projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Track changes to dph
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
836a020
..
ecbc7d9
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-2,12
+2,13
@@
module VectMonad (
Scope(..),
VM,
Scope(..),
VM,
- noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
+ noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV,
+ initV,
liftDs,
cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
liftDs,
cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon, uarrTy, intPrimArrayTy,
+ Builtins(..), sumTyCon, prodTyCon,
combinePAVar,
builtin, builtins,
combinePAVar,
builtin, builtins,
@@
-36,7
+37,8
@@
module VectMonad (
import VectBuiltIn
import VectBuiltIn
-import HscTypes
+import HscTypes hiding ( MonadThings(..) )
+import Module ( PackageId )
import CoreSyn
import TyCon
import DataCon
import CoreSyn
import TyCon
import DataCon
@@
-174,7
+176,7
@@
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
- , local_bind_name = FSLIT("fn")
+ , local_bind_name = fsLit "fn"
}
-- FIXME
}
-- FIXME
@@
-228,10
+230,12
@@
orElseV :: VM a -> VM a -> VM a
orElseV p q = maybe q return =<< tryV p
fixV :: (a -> VM a) -> VM a
orElseV p q = maybe q return =<< tryV p
fixV :: (a -> VM a) -> VM a
-fixV f = VM $ \bi genv lenv -> fixDs $
- \r -> case r of
- Yes _ _ x -> runVM (f x) bi genv lenv
- No -> return No
+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 "VectMonad.fixV: no result"
localV :: VM a -> VM a
localV p = do
localV :: VM a -> VM a
localV p = do
@@
-251,6
+255,9
@@
closedV p = do
liftDs :: DsM a -> VM a
liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
liftDs :: DsM a -> VM a
liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
+liftBuiltinDs :: (Builtins -> DsM a) -> VM a
+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
+
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
@@
-329,7
+336,7
@@
newLocalVar fs ty
return $ mkSysLocal fs u ty
newDummyVar :: Type -> VM Var
return $ mkSysLocal fs u ty
newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar FSLIT("ds")
+newDummyVar = newLocalVar (fsLit "ds")
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
@@
-376,10
+383,10
@@
defDataCon dc dc' = updGEnv $ \env ->
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftDs . primPArray
+lookupPrimPArray = liftBuiltinDs . primPArray
lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftDs . primMethod tycon
+lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
@@
-473,10
+480,12
@@
lookupFamInst tycon tys
(ppr $ mkTyConApp 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
= 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
(mg_rdr_env guts)
(mg_types guts)
go
@@
-485,7
+494,7
@@
initV hsc_env guts info p
go =
do
go =
do
- builtins <- initBuiltins
+ builtins <- initBuiltins pkg
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins