X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=56f5b8fa90db095b8acb0a046c5564fb95e64c8e;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hp=1299683b9f3206dca2be5cb11ebef7687f2d5ba9;hpb=13af4e5da214fb0b9be6a536048fe7a905af3b16;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 1299683..56f5b8f 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -2,7 +2,8 @@ module VectMonad ( Scope(..), VM, - noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV, + noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, + initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM, liftDs, cloneName, cloneId, cloneVar, newExportedVar, newLocalVar, newDummyVar, newTyVar, @@ -36,8 +37,8 @@ module VectMonad ( import VectBuiltIn -import HscTypes -import Module ( dphSeqPackageId ) +import HscTypes hiding ( MonadThings(..) ) +import Module ( PackageId ) import CoreSyn import TyCon import DataCon @@ -205,6 +206,25 @@ instance Monad VM where Yes genv' lenv' x -> runVM (f x) bi genv' lenv' No -> return No + +cantVectorise :: String -> SDoc -> a +cantVectorise s d = pgmError + . showSDocDump + $ vcat [text "*** Vectorisation error ***", + nest 4 $ sep [text s, nest 4 d]] + +maybeCantVectorise :: String -> SDoc -> Maybe a -> a +maybeCantVectorise s d Nothing = cantVectorise s d +maybeCantVectorise _ _ (Just x) = x + +maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a +maybeCantVectoriseM s d p + = do + r <- p + case r of + Just x -> return x + Nothing -> cantVectorise s d + noV :: VM a noV = VM $ \_ _ _ -> return No @@ -335,7 +355,7 @@ newLocalVar fs ty return $ mkSysLocal fs u ty newDummyVar :: Type -> VM Var -newDummyVar = newLocalVar (fsLit "ds") +newDummyVar = newLocalVar (fsLit "vv") newTyVar :: FastString -> Kind -> VM Var newTyVar fs k @@ -359,8 +379,8 @@ lookupVar v case r of Just e -> return (Local e) Nothing -> liftM Global - $ traceMaybeV "lookupVar" (ppr v) - (readGEnv $ \env -> lookupVarEnv (global_vars env) v) + . maybeCantVectoriseM "Variable not vectorised:" (ppr v) + . readGEnv $ \env -> lookupVarEnv (global_vars env) v lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc @@ -479,10 +499,12 @@ lookupFamInst tycon tys (ppr $ mkTyConApp tycon tys) } -initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a)) -initV hsc_env guts info p +initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a)) +initV pkg hsc_env guts info p = do - Just r <- initDs hsc_env (mg_module guts) + -- XXX: ignores error messages and warnings, check that this is + -- indeed ok (the use of "Just r" suggests so) + (_,Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go @@ -491,7 +513,7 @@ initV hsc_env guts info p go = do - builtins <- initBuiltins dphSeqPackageId + builtins <- initBuiltins pkg builtin_vars <- initBuiltinVars builtins builtin_tycons <- initBuiltinTyCons builtins let builtin_datacons = initBuiltinDataCons builtins