projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Teach vectorisation about Bool
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
738ae6f
..
27f90f6
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-2,7
+2,7
@@
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module VectMonad (
-- for details
module VectMonad (
@@
-11,10
+11,10
@@
module VectMonad (
noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
liftDs,
noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
liftDs,
- cloneName, cloneId,
+ cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon,
+ Builtins(..), sumTyCon, prodTyCon, combinePAVar,
builtin, builtins,
GlobalEnv(..),
builtin, builtins,
GlobalEnv(..),
@@
-31,6
+31,7
@@
module VectMonad (
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
+ lookupBoxedTyCon,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
@@
-102,6
+103,9
@@
data GlobalEnv = GlobalEnv {
-- Mapping from TyCons to their PR dfuns
, global_pr_funs :: NameEnv Var
-- Mapping from TyCons to their PR dfuns
, global_pr_funs :: NameEnv Var
+ -- Mapping from unboxed TyCons to their boxed versions
+ , global_boxed_tycons :: NameEnv TyCon
+
-- External package inst-env & home-package inst-env for class
-- instances
--
-- External package inst-env & home-package inst-env for class
-- instances
--
@@
-141,7
+145,8
@@
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_pr_funs = emptyNameEnv
+ , global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
@@
-165,6
+170,10
@@
setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
+setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+setBoxedTyConsEnv ps genv
+ = genv { global_boxed_tycons = mkNameEnv ps }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
@@
-301,6
+310,9
@@
cloneId mk_occ id ty
| otherwise = Id.mkLocalId name ty
return id'
| otherwise = Id.mkLocalId name ty
return id'
+cloneVar :: Var -> VM Var
+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
+
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
@@
-386,6
+398,10
@@
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)
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
+lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
+ (tyConName tc)
+
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
env { local_tyvars = tv : local_tyvars env
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
env { local_tyvars = tv : local_tyvars env
@@
-472,6
+488,7
@@
initV hsc_env guts info p
let builtin_tycons = initBuiltinTyCons builtins
builtin_pas <- initBuiltinPAs builtins
builtin_prs <- initBuiltinPRs builtins
let builtin_tycons = initBuiltinTyCons builtins
builtin_pas <- initBuiltinPAs builtins
builtin_prs <- initBuiltinPRs builtins
+ builtin_boxed <- initBuiltinBoxedTyCons builtins
eps <- ioToIOEnv $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
eps <- ioToIOEnv $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
@@
-480,6
+497,7
@@
initV hsc_env guts info p
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
let genv = extendTyConsEnv builtin_tycons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv