LocalEnv(..),
readLEnv, setLEnv, updLEnv,
- defGlobalVar, lookupVar,
- lookupTyCon,
+ lookupVar, defGlobalVar,
+ lookupTyCon, defTyCon,
+ lookupDataCon, defDataCon,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupInst, lookupFamInst
}
-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
$ 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)