projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Remove dead code
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
6cb1679
..
320d192
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-7,8
+7,8
@@
module VectMonad (
cloneName, cloneId,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
cloneName, cloneId,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..),
- builtin,
+ Builtins(..), sumTyCon, prodTyCon,
+ builtin, builtins,
GlobalEnv(..),
setFamInstEnv,
GlobalEnv(..),
setFamInstEnv,
@@
-23,6
+23,7
@@
module VectMonad (
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
+ lookupTyConPR,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
@@
-47,6
+48,7
@@
import NameEnv
import TysPrim ( intPrimTy )
import Module
import IfaceEnv
import TysPrim ( intPrimTy )
import Module
import IfaceEnv
+import IOEnv ( ioToIOEnv )
import DsMonad
import PrelNames
import DsMonad
import PrelNames
@@
-89,6
+91,9
@@
data GlobalEnv = GlobalEnv {
--
, global_pa_funs :: NameEnv Var
--
, global_pa_funs :: NameEnv Var
+ -- Mapping from TyCons to their PR dfuns
+ , global_pr_funs :: NameEnv Var
+
-- External package inst-env & home-package inst-env for class
-- instances
--
-- External package inst-env & home-package inst-env for class
-- instances
--
@@
-128,6
+133,7
@@
initGlobalEnv info instEnvs famInstEnvs
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
+ , global_pr_funs = emptyVarEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
@@
-147,6
+153,10
@@
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPRFunsEnv ps genv
+ = genv { global_pr_funs = mkNameEnv ps }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
@@
-230,6
+240,9
@@
liftDs p = VM $ \bi genv lenv -> do { x <- p; 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))
+builtins :: (a -> Builtins -> b) -> VM (a -> b)
+builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
+
readGEnv :: (GlobalEnv -> a) -> VM a
readGEnv f = VM $ \bi genv lenv -> return (Yes genv lenv (f genv))
readGEnv :: (GlobalEnv -> a) -> VM a
readGEnv f = VM $ \bi genv lenv -> return (Yes genv lenv (f genv))
@@
-354,7
+367,10
@@
defTyConPAs ps = updGEnv $ \env ->
[(tyConName tc, pa) | (tc, pa) <- ps] }
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
[(tyConName tc, pa) | (tc, pa) <- ps] }
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
-lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+
+lookupTyConPR :: TyCon -> VM (Maybe Var)
+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
@@
-429,25
+445,27
@@
lookupFamInst tycon tys
initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
initV hsc_env guts info p
= do
initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
initV hsc_env guts info p
= do
- eps <- hscEPS hsc_env
- let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
- let instEnvs = (eps_inst_env eps, mg_inst_env guts)
-
Just r <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts)
(mg_types guts)
Just r <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts)
(mg_types guts)
- (go instEnvs famInstEnvs)
+ go
return r
where
return r
where
- go instEnvs famInstEnvs =
+ go =
do
do
- builtins <- initBuiltins
+ builtins <- initBuiltins
builtin_tycons <- initBuiltinTyCons
builtin_pas <- initBuiltinPAs
builtin_tycons <- initBuiltinTyCons
builtin_pas <- initBuiltinPAs
+ builtin_prs <- initBuiltinPRs builtins
+
+ eps <- ioToIOEnv $ hscEPS hsc_env
+ let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+ instEnvs = (eps_inst_env eps, mg_inst_env guts)
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
+ . setPRFunsEnv builtin_prs
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv