builtin,
GlobalEnv(..),
+ setInstEnvs,
readGEnv, setGEnv, updGEnv,
LocalEnv(..),
readLEnv, setLEnv, updLEnv,
- defGlobalVar, lookupVar,
- lookupTyCon,
+ lookupVar, defGlobalVar,
+ lookupTyCon, defTyCon,
+ lookupDataCon, defDataCon,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupInst, lookupFamInst
, applyClosurePVar :: Var
, lengthPAVar :: Var
, replicatePAVar :: Var
+ , emptyPAVar :: Var
}
paDictTyCon :: Builtins -> TyCon
applyClosurePVar <- dsLookupGlobalId applyClosurePName
lengthPAVar <- dsLookupGlobalId lengthPAName
replicatePAVar <- dsLookupGlobalId replicatePAName
+ emptyPAVar <- dsLookupGlobalId emptyPAName
return $ Builtins {
parrayTyCon = parrayTyCon
, applyClosurePVar = applyClosurePVar
, lengthPAVar = lengthPAVar
, replicatePAVar = replicatePAVar
+ , emptyPAVar = emptyPAVar
}
data GlobalEnv = GlobalEnv {
}
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs bi
= GlobalEnv {
global_vars = mapVarEnv (Var . snd) $ vectInfoVar info
, global_exported_vars = emptyVarEnv
- , global_tycons = mapNameEnv snd $ vectInfoTyCon info
+ , global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
+ (tyConName funTyCon) (closureTyCon bi)
+
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
}
+setInstEnvs :: InstEnv -> FamInstEnv -> GlobalEnv -> GlobalEnv
+setInstEnvs l_inst l_fam_inst genv
+ | (g_inst, _) <- global_inst_env genv
+ , (g_fam_inst, _) <- global_fam_inst_env genv
+ = genv { global_inst_env = (g_inst, l_inst)
+ , global_fam_inst_env = (g_fam_inst, l_fam_inst) }
+
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
$ maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
lookupTyCon :: TyCon -> VM (Maybe TyCon)
-lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+lookupTyCon tc
+ | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
+
+ | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+
+defTyCon :: TyCon -> TyCon -> VM ()
+defTyCon tc tc' = updGEnv $ \env ->
+ env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+
+lookupDataCon :: DataCon -> VM (Maybe DataCon)
+lookupDataCon dc = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
+
+defDataCon :: DataCon -> DataCon -> VM ()
+defDataCon dc dc' = updGEnv $ \env ->
+ env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
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)
+ r <- runVM p builtins (initGlobalEnv info instEnvs famInstEnvs builtins)
emptyLocalEnv
case r of
Yes genv _ x -> return $ Just (new_info genv, x)