Report bindings that cannot be vectorised
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Sat, 10 Sep 2011 06:55:21 +0000 (16:55 +1000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Sat, 10 Sep 2011 06:59:44 +0000 (16:59 +1000)
- Toplevel bindings that cannot be vectorised are reported as a warning
- '-ddump-vt-trace' has even more information about unvectorised code
- Fixed some documentation

compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Convert.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Monad.hs
compiler/vectorise/Vectorise/Monad/Base.hs
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Utils/PADict.hs

index c699441..649f33f 100644 (file)
@@ -146,8 +146,10 @@ vectTopBind b@(NonRec var expr)
          ; hs <- takeHoisted
          ; return . Rec $ (var, cexpr) : (var', expr') : hs
          }
-     `orElseV`
-       return b
+     `orElseErrV`
+     do { emitVt "  Could NOT vectorise top-level binding" $ ppr var
+        ; return b
+        }
   where
     unlessNoVectDecl vectorise
       = do { hasNoVectDecl <- noVectDecl var
@@ -184,7 +186,7 @@ vectTopBind b@(Rec bs)
          ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs
          ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs
          }
-     `orElseV`
+     `orElseErrV`
        return b    
   where
     (vars, exprs) = unzip bs
@@ -309,8 +311,8 @@ vectTopRhs recFs var expr
     info False vectDecl | isJust vectDecl = " [VECTORISE]"
                         | otherwise       = " (no pragma)"
 
--- | Project out the vectorised version of a binding from some closure,
---   or return the original body if that doesn't work or the binding is scalar. 
+-- |Project out the vectorised version of a binding from some closure,
+-- or return the original body if that doesn't work or the binding is scalar. 
 --
 tryConvert :: Var       -- ^ Name of the original binding (eg @foo@)
            -> Var       -- ^ Name of vectorised version of binding (eg @$vfoo@)
@@ -322,5 +324,9 @@ tryConvert var vect_var rhs
          then
            return rhs
          else
-           fromVect (idType var) (Var vect_var) `orElseV` return rhs
+           fromVect (idType var) (Var vect_var) 
+           `orElseErrV` 
+           do { emitVt "  Could NOT call vectorised from original version" $ ppr var
+              ; return rhs
+              }
        }
index 6e0c5a1..4e17fa7 100644 (file)
@@ -1,7 +1,8 @@
-
 module Vectorise.Convert
-       (fromVect)
+  ( fromVect
+  )
 where
+
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Type.Type
@@ -11,30 +12,32 @@ import TyCon
 import Type
 import TypeRep
 import FastString
+import Outputable
 
 
--- | Build an expression that calls the vectorised version of some 
---   function from a `Closure`.
+-- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its
+-- value.
 --
---   For example
---   @   
---      \(x :: Double) -> 
---      \(y :: Double) -> 
---      ($v_foo $: x) $: y
---   @
+-- For functions, we eta expand the function and convert the arguments and result:
+
+-- For example
+-- @   
+--    \(x :: Double) -> 
+--    \(y :: Double) -> 
+--    ($v_foo $: x) $: y
+-- @
 --
---   We use the type of the original binding to work out how many
---   outer lambdas to add.
+-- We use the type of the original binding to work out how many outer lambdas to add.
 --
-fromVect 
-       :: Type         -- ^ The type of the original binding.
-       -> CoreExpr     -- ^ Expression giving the closure to use, eg @$v_foo@.
-       -> VM CoreExpr
-       
+fromVect :: Type        -- ^ The type of the original binding.
+         -> CoreExpr    -- ^ Expression giving the closure to use, eg @$v_foo@.
+         -> VM CoreExpr
+  
 -- Convert the type to the core view if it isn't already.
+--
 fromVect ty expr 
-       | Just ty' <- coreView ty 
-       = fromVect ty' expr
+  | Just ty' <- coreView ty 
+  = fromVect ty' expr
 
 -- For each function constructor in the original type we add an outer 
 -- lambda to bind the parameter variable, and an inner application of it.
@@ -49,35 +52,48 @@ fromVect (FunTy arg_ty res_ty) expr
                $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
       return $ Lam arg body
 
--- If the type isn't a function then it's time to call on the closure.
+-- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e.,
+-- is identical to the non-vectorised version).
+--
 fromVect ty expr
   = identityConv ty >> return expr
 
-
--- TODO: What is this really doing?
+-- Convert an expression such that it evaluates to the vectorised equivalent of the value of the
+-- original expression.
+--
+-- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the
+--          original one.
+--
 toVect :: Type -> CoreExpr -> VM CoreExpr
 toVect ty expr = identityConv ty >> return expr
 
-
--- | Check that we have the vectorised versions of all the
---   type constructors in this type.
+-- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor
+-- are not altered by vectorisation as they contain no parallel arrays.
+--
 identityConv :: Type -> VM ()
 identityConv ty 
   | Just ty' <- coreView ty 
   = identityConv ty'
-
 identityConv (TyConApp tycon tys)
- = do mapM_ identityConv tys
-      identityConvTyCon tycon
+  = do { mapM_ identityConv tys
+       ; identityConvTyCon tycon
+       }
+identityConv (TyVarTy _)    = noV $ text "identityConv: type variable changes under vectorisation"
+identityConv (AppTy   _ _)  = noV $ text "identityConv: type appl. changes under vectorisation"
+identityConv (FunTy    _ _) = noV $ text "identityConv: function type changes under vectorisation"
+identityConv (ForAllTy _ _) = noV $ text "identityConv: quantified type changes under vectorisation"
+identityConv (PredTy   _)   = noV $ text "identityConv: predicate type changes under vectorisation"
 
-identityConv _ = noV
-
-
--- | Check that we have the vectorised version of this type constructor.
+-- |Check that this type constructor is neutral under type vectorisation — i.e., it is not altered
+-- by vectorisation as they contain no parallel arrays.
+--
 identityConvTyCon :: TyCon -> VM ()
 identityConvTyCon tc
   | isBoxedTupleTyCon tc = return ()
   | isUnLiftedTyCon tc   = return ()
   | otherwise 
-  = do tc' <- maybeV (lookupTyCon tc)
-       if tc == tc' then return () else noV
+  = do tc' <- maybeV notVectErr (lookupTyCon tc)
+       if tc == tc' then return () else noV idErr
+  where
+    notVectErr = text "identityConvTyCon: no vectorised version for type constructor" <+> ppr tc
+    idErr      = text "identityConvTyCon: type constructor contains parallel arrays"   <+> ppr tc
index 2b7accc..ee3dfdf 100644 (file)
@@ -200,7 +200,8 @@ vectScalarFun forceScalar recFns expr
       ; let scalarVars = gscalarVars `extendVarSetList` recFns
             (arg_tys, res_ty) = splitFunTys (exprType expr)
       ; MASSERT( not $ null arg_tys )
-      ; onlyIfV (forceScalar                              -- user asserts the functions is scalar
+      ; onlyIfV empty
+                (forceScalar                              -- user asserts the functions is scalar
                  ||
                  all (is_scalar_ty scalarTyCons) arg_tys  -- check whether the function is scalar
                   && is_scalar_ty scalarTyCons res_ty
@@ -389,7 +390,7 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
           $ vectExpr body
       let (vect_bndrs, lift_bndrs) = unzip vbndrs
       (vscrut, lscrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr)
-      vect_dc <- maybeV (lookupDataCon dc)
+      vect_dc <- maybeV dataConErr (lookupDataCon dc)
       let [pdata_dc] = tyConDataCons pdata_tc
 
       let vcase = mk_wild_case vscrut vty vect_dc  vect_bndrs vect_body
@@ -402,10 +403,12 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
 
     mk_wild_case expr ty dc bndrs body
       = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)]
+      
+    dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)
 
 vectAlgCase tycon _ty_args scrut bndr ty alts
   = do
-      vect_tc     <- maybeV (lookupTyCon tycon)
+      vect_tc     <- maybeV tyConErr (lookupTyCon tycon)
       (vty, lty)  <- vectAndLiftType ty
 
       let arity = length (tyConDataCons vect_tc)
@@ -437,6 +440,8 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
       return . vLet (vNonRec vbndr vexpr)
              $ (vect_case, lift_case)
   where
+    tyConErr = (text "vectAlgCase: type constructor not vectorised" <+> ppr tycon)
+
     vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
                     | otherwise         = vectBndrIn bndr
 
@@ -450,7 +455,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
 
     proc_alt arity sel _ lty (DataAlt dc, bndrs, body)
       = do
-          vect_dc <- maybeV (lookupDataCon dc)
+          vect_dc <- maybeV dataConErr (lookupDataCon dc)
           let ntag = dataConTagZ vect_dc
               tag  = mkDataConTag vect_dc
               fvs  = freeVarsOf body `delVarSetList` bndrs
@@ -476,6 +481,9 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
                  --               (LitAlt (mkMachInt 0), [], empty)])
           let (vect_bndrs, lift_bndrs) = unzip vbndrs
           return (vect_dc, vect_bndrs, lift_bndrs, vbody)
+      where
+        dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)
+
 
     proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt"
 
index dd21762..9a61c6d 100644 (file)
@@ -45,6 +45,7 @@ import Outputable
 import FastString
 
 import Control.Monad
+import System.IO
 
 -- |Run a vectorisation computation.
 --
@@ -101,7 +102,12 @@ initV hsc_env guts info thing_inside
            ; r <- runVM thing_inside' builtins genv emptyLocalEnv
            ; case r of
                Yes genv _ x -> return $ Just (new_info genv, x)
-               No           -> return Nothing
+               No reason    -> do { unqual <- mkPrintUnqualifiedDs
+                                  ; liftIO $ 
+                                      printForUser stderr unqual $ 
+                                        mkDumpDoc "Warning: vectorisation failure:" reason
+                                  ; return Nothing
+                                  }
            } }
 
     new_info genv = modVectInfo genv (mg_types guts) (mg_vect_decls guts) info
index aa73e25..01fb6a5 100644 (file)
@@ -1,29 +1,29 @@
+-- |The Vectorisation monad.
 
--- | The Vectorisation monad.
 module Vectorise.Monad.Base (
-       -- * The Vectorisation Monad
-       VResult(..),
-       VM(..),
-
-       -- * Lifting
-       liftDs,
-
-       -- * Error Handling
-       cantVectorise,
-       maybeCantVectorise,
-       maybeCantVectoriseM,
-       
-       -- * Debugging
-       traceVt, dumpOptVt, dumpVt,
-       
-       -- * Control
-       noV,     traceNoV,
-       ensureV, traceEnsureV,
-       onlyIfV,
-       tryV,
-       maybeV,  traceMaybeV,
-       orElseV,
-       fixV,
+  -- * The Vectorisation Monad
+  VResult(..),
+  VM(..),
+
+  -- * Lifting
+  liftDs,
+
+  -- * Error Handling
+  cantVectorise,
+  maybeCantVectorise,
+  maybeCantVectoriseM,
+  
+  -- * Debugging
+  emitVt, traceVt, dumpOptVt, dumpVt,
+  
+  -- * Control
+  noV, traceNoV,
+  ensureV, traceEnsureV,
+  onlyIfV,
+  tryV, tryErrV,
+  maybeV,  traceMaybeV,
+  orElseV, orElseErrV,
+  fixV,
 ) where
 
 import Vectorise.Builtins
@@ -42,21 +42,23 @@ import System.IO (stderr)
 
 -- The Vectorisation Monad ----------------------------------------------------
 
--- | Vectorisation can either succeed with new envionment and a value,
---   or return with failure.
+-- |Vectorisation can either succeed with new envionment and a value, or return with failure
+-- (including a description of the reason for failure).
+--
 data VResult a 
-       = Yes GlobalEnv LocalEnv a | No
+  = Yes GlobalEnv LocalEnv a 
+  | No  SDoc
 
 newtype VM a 
-       = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
+  = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
 
 instance Monad VM where
   return x   = VM $ \_  genv lenv -> return (Yes genv lenv x)
   VM p >>= f = VM $ \bi genv lenv -> do
-                                      r <- p bi genv lenv
-                                      case r of
-                                        Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
-                                        No                -> return No
+                                       r <- p bi genv lenv
+                                       case r of
+                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
+                                         No reason         -> return $ No reason
 
 instance Functor VM where
   fmap = liftM
@@ -66,27 +68,31 @@ instance MonadIO VM where
 
 
 -- Lifting --------------------------------------------------------------------
--- | Lift a desugaring computation into the vectorisation monad.
+
+-- |Lift a desugaring computation into the vectorisation monad.
+--
 liftDs :: DsM a -> VM a
 liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
 
 
 -- Error Handling -------------------------------------------------------------
--- | Throw a `pgmError` saying we can't vectorise something.
+
+-- |Throw a `pgmError` saying we can't vectorise something.
+--
 cantVectorise :: String -> SDoc -> a
 cantVectorise s d = pgmError
-                  . showSDocDump
+                  . showSDoc
                   $ vcat [text "*** Vectorisation error ***",
                           nest 4 $ sep [text s, nest 4 d]]
 
-
--- | Like `fromJust`, but `pgmError` on Nothing.
+-- |Like `fromJust`, but `pgmError` on Nothing.
+--
 maybeCantVectorise :: String -> SDoc -> Maybe a -> a
 maybeCantVectorise s d Nothing  = cantVectorise s d
 maybeCantVectorise _ _ (Just x) = x
 
-
--- | Like `maybeCantVectorise` but in a `Monad`.
+-- |Like `maybeCantVectorise` but in a `Monad`.
+--
 maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
 maybeCantVectoriseM s d p
   = do
@@ -100,6 +106,14 @@ maybeCantVectoriseM s d p
 
 -- |Output a trace message if -ddump-vt-trace is active.
 --
+emitVt :: String -> SDoc -> VM () 
+emitVt herald doc
+  = liftDs $
+      liftIO . printForUser stderr alwaysQualify $
+        hang (text herald) 2 doc
+
+-- |Output a trace message if -ddump-vt-trace is active.
+--
 traceVt :: String -> SDoc -> VM () 
 traceVt herald doc
   | 1 <= opt_TraceLevel = liftDs $
@@ -125,69 +139,99 @@ dumpVt header doc
        ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc)
        }
 
+
 -- Control --------------------------------------------------------------------
--- | Return some result saying we've failed.
-noV :: VM a
-noV    = VM $ \_ _ _ -> return No
 
+-- |Return some result saying we've failed.
+--
+noV :: SDoc -> VM a
+noV reason = VM $ \_ _ _ -> return $ No reason
 
--- | Like `traceNoV` but also emit some trace message to stderr.
+-- |Like `traceNoV` but also emit some trace message to stderr.
+--
 traceNoV :: String -> SDoc -> VM a
-traceNoV s d  = pprTrace s d noV
-
-
--- | If `True` then carry on, otherwise fail.
-ensureV :: Bool -> VM ()
-ensureV False = noV
-ensureV True  = return ()
+traceNoV s d = pprTrace s d $ noV d
 
+-- |If `True` then carry on, otherwise fail.
+--
+ensureV :: SDoc -> Bool -> VM ()
+ensureV reason  False = noV reason
+ensureV _reason True  = return ()
 
--- | Like `ensureV` but if we fail then emit some trace message to stderr.
+-- |Like `ensureV` but if we fail then emit some trace message to stderr.
+--
 traceEnsureV :: String -> SDoc -> Bool -> VM ()
 traceEnsureV s d False = traceNoV s d
 traceEnsureV _ _ True  = return ()
 
+-- |If `True` then return the first argument, otherwise fail.
+--
+onlyIfV :: SDoc -> Bool -> VM a -> VM a
+onlyIfV reason b p = ensureV reason b >> p
 
--- | If `True` then return the first argument, otherwise fail.
-onlyIfV :: Bool -> VM a -> VM a
-onlyIfV b p = ensureV b >> p
-
-
--- | Try some vectorisation computaton.
---     If it succeeds then return `Just` the result,
---     otherwise return `Nothing`.
+-- |Try some vectorisation computaton.
+--
+-- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a
+-- failure message.
+--
+tryErrV :: VM a -> VM (Maybe a)
+tryErrV (VM p) = VM $ \bi genv lenv ->
+  do
+    r <- p bi genv lenv
+    case r of
+      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
+      No reason         -> do { unqual <- mkPrintUnqualifiedDs
+                              ; liftIO $ 
+                                  printForUser stderr unqual $ 
+                                    text "Warning: vectorisation failure:" <+> reason
+                              ; return (Yes genv  lenv  Nothing)
+                              }
+
+-- |Try some vectorisation computaton.
+--
+-- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a
+-- failure message.
+--
 tryV :: VM a -> VM (Maybe a)
 tryV (VM p) = VM $ \bi genv lenv ->
   do
     r <- p bi genv lenv
     case r of
       Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
-      No                -> return (Yes genv  lenv  Nothing)
-
-
--- | If `Just` then return the value, otherwise fail.
-maybeV :: VM (Maybe a) -> VM a
-maybeV p = maybe noV return =<< p
+      No _reason        -> return (Yes genv  lenv  Nothing)
 
+-- |If `Just` then return the value, otherwise fail.
+--
+maybeV :: SDoc -> VM (Maybe a) -> VM a
+maybeV reason p = maybe (noV reason) return =<< p
 
--- | Like `maybeV` but emit a message to stderr if we fail.
+-- |Like `maybeV` but emit a message to stderr if we fail.
+--
 traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
 traceMaybeV s d p = maybe (traceNoV s d) return =<< p
 
+-- |Try the first computation,
+--
+--   * if it succeeds then take the returned value,
+--   * if it fails then run the second computation instead while emitting a failure message.
+--
+orElseErrV :: VM a -> VM a -> VM a
+orElseErrV p q = maybe q return =<< tryErrV p
 
--- | Try the first computation,
---     if it succeeds then take the returned value,
---     if it fails then run the second computation instead.
+-- |Try the first computation,
+--
+--   * if it succeeds then take the returned value,
+--   * if it fails then run the second computation instead without emitting a failure message.
+--
 orElseV :: VM a -> VM a -> VM a
 orElseV p q = maybe q return =<< tryV p
 
-
--- | Fixpoint in the vectorisation monad.
+-- |Fixpoint in the vectorisation monad.
+--
 fixV :: (a -> VM a) -> VM a
 fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
   where
     -- NOTE: It is essential that we are lazy in r above so do not replace
     --       calls to this function by an explicit case.
     unYes (Yes _ _ x) = x
-    unYes No          = panic "Vectorise.Monad.Base.fixV: no result"
-
+    unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason
index 9492f10..be149af 100644 (file)
@@ -1,8 +1,9 @@
+module Vectorise.Monad.InstEnv 
+  ( lookupInst
+  , lookupFamInst
+  ) 
+where
 
-module Vectorise.Monad.InstEnv (
-       lookupInst,
-       lookupFamInst
-) where
 import Vectorise.Monad.Global
 import Vectorise.Monad.Base
 import Vectorise.Env
@@ -38,15 +39,15 @@ lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 lookupInst cls tys
   = do { instEnv <- getInstEnv
        ; case lookupInstEnv instEnv cls tys of
-          ([(inst, inst_tys)], _, _) 
+           ([(inst, inst_tys)], _, _) 
              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
-             | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: " 
-                                      (ppr $ mkTyConApp (classTyCon cls) tys)
+             | otherwise  -> cantVectorise "VectMonad.lookupInst: flexi var: " 
+                                           (ppr $ mkTyConApp (classTyCon cls) tys)
              where
                inst_tys'  = [ty | Right ty <- inst_tys]
                noFlexiVar = all isRight inst_tys
-          _other         ->
-             pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
+           _other         ->
+             cantVectorise "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
        }
   where
     isRight (Left  _) = False
@@ -73,8 +74,8 @@ lookupFamInst tycon tys
   = ASSERT( isFamilyTyCon tycon )
     do { instEnv <- getFamInstEnv
        ; case lookupFamInstEnv instEnv tycon tys of
-          [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
-          _other                -> 
-             pprPanic "VectMonad.lookupFamInst: not found: " 
-                      (ppr $ mkTyConApp tycon tys)
+           [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+           _other                -> 
+             cantVectorise "VectMonad.lookupFamInst: not found: " 
+                           (ppr $ mkTyConApp tycon tys)
        }
index 33418d4..740a647 100644 (file)
@@ -128,8 +128,9 @@ prDictOfPReprInstTyCon ty prepr_tc prepr_args
 
   | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
 
--- | Get the PR dictionary for a type. The argument must be a representation
+-- |Get the PR dictionary for a type. The argument must be a representation
 -- type.
+--
 prDictOfReprType :: Type -> VM CoreExpr
 prDictOfReprType ty
   | Just (tycon, tyargs) <- splitTyConApp_maybe ty
@@ -143,7 +144,8 @@ prDictOfReprType ty
                  return $ Var sel `App` Type ty' `App` pa
           else do 
                  -- a representation tycon must have a PR instance
-                 dfun <- maybeV $ lookupTyConPR tycon
+                 dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ 
+                           lookupTyConPR tycon
                  prDFunApply dfun tyargs
 
   | otherwise