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,
import VectBuiltIn
-import HscTypes
-import Module ( dphSeqPackageId )
+import HscTypes hiding ( MonadThings(..) )
+import Module ( PackageId )
import CoreSyn
import TyCon
import DataCon
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
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
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
(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
go =
do
- builtins <- initBuiltins dphSeqPackageId
+ builtins <- initBuiltins pkg
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins