Commit 4d7033df authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Report bindings that cannot be vectorised

- Toplevel bindings that cannot be vectorised are reported as a warning
- '-ddump-vt-trace' has even more information about unvectorised code
- Fixed some documentation
parent b3bc5f4f
......@@ -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
}
}
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
......@@ -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"
......
......@@ -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
......
-- |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
......@@ -98,6 +104,14 @@ maybeCantVectoriseM s d p
-- Debugging ------------------------------------------------------------------
-- |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 ()
......@@ -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
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)
}
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment