diff options
| -rw-r--r-- | compiler/vectorise/Vectorise.hs | 18 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Convert.hs | 84 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Exp.hs | 16 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad.hs | 8 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/Base.hs | 190 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/InstEnv.hs | 27 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Utils/PADict.hs | 6 |
7 files changed, 216 insertions, 133 deletions
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index c699441bb9..649f33f2db 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -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 + } } diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index 6e0c5a1fb8..4e17fa7032 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 2b7accc646..ee3dfdfefa 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -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" diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index dd21762df7..9a61c6d013 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index aa73e25264..01fb6a5847 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index 9492f1010f..be149af9d7 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -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) } diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 33418d45e3..740a647180 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -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 |