module VectBuiltIn (
- Builtins(..), initBuiltins
+ Builtins(..),
+ initBuiltins, initBuiltinTyCons, initBuiltinPAs
) where
#include "HsVersions.h"
import DsMonad
+import IfaceEnv ( lookupOrig )
+import Module ( Module )
import DataCon ( DataCon )
-import TyCon ( TyCon, tyConDataCons )
+import TyCon ( TyCon, tyConName, tyConDataCons )
import Var ( Var )
import Id ( mkSysLocal )
+import Name ( Name )
+import OccName ( mkVarOccFS )
+import TypeRep ( funTyCon )
import TysPrim ( intPrimTy )
+import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
import PrelNames
+import BasicTypes ( Boxity(..) )
-import Control.Monad ( liftM )
+import FastString
+
+import Control.Monad ( liftM, zipWithM )
data Builtins = Builtins {
parrayTyCon :: TyCon
, liftingContext = liftingContext
}
+initBuiltinTyCons :: DsM [(Name, TyCon)]
+initBuiltinTyCons
+ = do
+ vects <- sequence vs
+ return (zip origs vects)
+ where
+ (origs, vs) = unzip builtinTyCons
+
+builtinTyCons :: [(Name, DsM TyCon)]
+builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)]
+
+initBuiltinPAs :: DsM [(Name, Var)]
+initBuiltinPAs
+ = do
+ pas <- zipWithM lookupExternalVar mods fss
+ return $ zip tcs pas
+ where
+ (tcs, mods, fss) = unzip3 builtinPAs
+
+builtinPAs :: [(Name, Module, FastString)]
+builtinPAs = [
+ mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo")
+ , mk (tyConName unitTyCon) nDP_PARRAY FSLIT("dPA_Unit")
+
+ , temporary intTyConName FSLIT("dPA_Int")
+ ]
+ ++ tups
+ where
+ mk name mod fs = (name, mod, fs)
+
+ temporary name fs = (name, nDP_INSTANCES, fs)
+
+ tups = map mk_tup [2..3]
+ mk_tup n = temporary (tyConName $ tupleTyCon Boxed n)
+ (mkFastString $ "dPA_" ++ show n)
+
+lookupExternalVar :: Module -> FastString -> DsM Var
+lookupExternalVar mod fs
+ = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
lookupVar, defGlobalVar,
lookupTyCon, defTyCon,
lookupDataCon, defDataCon,
- lookupTyConPA, defTyConPA, defTyConPAs, defTyConBuiltinPAs,
+ lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
-- Local binding name
, local_bind_name :: FastString
}
-
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins
- -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs bi
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs
= GlobalEnv {
global_vars = mapVarEnv snd $ vectInfoVar info
, global_exported_vars = emptyVarEnv
- , global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
- (tyConName funTyCon) (closureTyCon bi)
-
+ , global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_inst_env = instEnvs
where
(g_fam_inst, _) = global_fam_inst_env genv
+extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+extendTyConsEnv ps genv
+ = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+
+extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+extendPAFunsEnv ps genv
+ = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
= do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
p
-lookupExternalVar :: Module -> FastString -> VM Var
-lookupExternalVar mod fs
- = liftDs
- $ dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
-
cloneName :: (OccName -> OccName) -> Name -> VM Name
cloneName mk_occ name = liftM make (liftDs newUnique)
where
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
[(tyConName tc, pa) | (tc, pa) <- ps] }
-defTyConBuiltinPAs :: [(Name, Module, FastString)] -> VM ()
-defTyConBuiltinPAs ps
- = do
- pas <- zipWithM lookupExternalVar mods fss
- updGEnv $ \env ->
- env { global_pa_funs = extendNameEnvList (global_pa_funs env)
- (zip tcs pas) }
- where
- (tcs, mods, fss) = unzip3 ps
-
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
go instEnvs famInstEnvs =
do
builtins <- initBuiltins
- r <- runVM p builtins (initGlobalEnv info
- instEnvs
- famInstEnvs
- builtins)
- emptyLocalEnv
+ builtin_tycons <- initBuiltinTyCons
+ builtin_pas <- initBuiltinPAs
+
+ let genv = extendTyConsEnv builtin_tycons
+ . extendPAFunsEnv builtin_pas
+ $ initGlobalEnv info instEnvs famInstEnvs
+
+ r <- runVM p builtins genv emptyLocalEnv
case r of
Yes genv _ x -> return $ Just (new_info genv, x)
No -> return Nothing
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
-builtin_PAs :: [(Name, Module, FastString)]
-builtin_PAs = [
- (closureTyConName, nDP_CLOSURE, FSLIT("dPA_Clo"))
- , mk intTyConName FSLIT("dPA_Int")
- ]
- ++ tups
- where
- mk name fs = (name, nDP_INSTANCES, fs)
-
- tups = mk_tup 0 : map mk_tup [2..3]
- mk_tup n = (getName $ tupleTyCon Boxed n, nDP_INSTANCES,
- mkFastString $ "dPA_" ++ show n)
-
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
- defTyConBuiltinPAs builtin_PAs
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts