-import Control.Monad ( liftM )
-
-data Scope a b = Global a | Local b
-
--- ----------------------------------------------------------------------------
--- Vectorisation monad
-
-data Builtins = Builtins {
- parrayTyCon :: TyCon
- , paTyCon :: TyCon
- , paDataCon :: DataCon
- , closureTyCon :: TyCon
- , mkClosureVar :: Var
- , applyClosureVar :: Var
- , mkClosurePVar :: Var
- , applyClosurePVar :: Var
- , lengthPAVar :: Var
- , replicatePAVar :: Var
- , emptyPAVar :: Var
- , liftingContext :: Var
- }
-
-initBuiltins :: DsM Builtins
-initBuiltins
- = do
- parrayTyCon <- dsLookupTyCon parrayTyConName
- paTyCon <- dsLookupTyCon paTyConName
- let paDataCon = case tyConDataCons paTyCon of [dc] -> dc
- closureTyCon <- dsLookupTyCon closureTyConName
-
- mkClosureVar <- dsLookupGlobalId mkClosureName
- applyClosureVar <- dsLookupGlobalId applyClosureName
- mkClosurePVar <- dsLookupGlobalId mkClosurePName
- applyClosurePVar <- dsLookupGlobalId applyClosurePName
- lengthPAVar <- dsLookupGlobalId lengthPAName
- replicatePAVar <- dsLookupGlobalId replicatePAName
- emptyPAVar <- dsLookupGlobalId emptyPAName
-
- liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
- newUnique
-
- return $ Builtins {
- parrayTyCon = parrayTyCon
- , paTyCon = paTyCon
- , paDataCon = paDataCon
- , closureTyCon = closureTyCon
- , mkClosureVar = mkClosureVar
- , applyClosureVar = applyClosureVar
- , mkClosurePVar = mkClosurePVar
- , applyClosurePVar = applyClosurePVar
- , lengthPAVar = lengthPAVar
- , replicatePAVar = replicatePAVar
- , emptyPAVar = emptyPAVar
- , liftingContext = liftingContext
- }
-
-data GlobalEnv = GlobalEnv {
- -- Mapping from global variables to their vectorised versions.
- --
- global_vars :: VarEnv Var
-
- -- Exported variables which have a vectorised version
- --
- , global_exported_vars :: VarEnv (Var, Var)
-
- -- Mapping from TyCons to their vectorised versions.
- -- TyCons which do not have to be vectorised are mapped to
- -- themselves.
- --
- , global_tycons :: NameEnv TyCon
-
- -- Mapping from DataCons to their vectorised versions
- --
- , global_datacons :: NameEnv DataCon
-
- -- Mapping from TyCons to their PA dfuns
- --
- , global_pa_funs :: NameEnv Var
-
- -- External package inst-env & home-package inst-env for class
- -- instances
- --
- , global_inst_env :: (InstEnv, InstEnv)
-
- -- External package inst-env & home-package inst-env for family
- -- instances
- --
- , global_fam_inst_env :: FamInstEnvs
-
- -- Hoisted bindings
- , global_bindings :: [(Var, CoreExpr)]
-
- -- Global Rdr environment (from ModGuts)
- --
- , global_rdr_env :: GlobalRdrEnv
- }
-
-data LocalEnv = LocalEnv {
- -- Mapping from local variables to their vectorised and
- -- lifted versions
- --
- local_vars :: VarEnv (Var, Var)
-
- -- In-scope type variables
- --
- , local_tyvars :: [TyVar]
-
- -- Mapping from tyvars to their PA dictionaries
- , local_tyvar_pa :: VarEnv CoreExpr
-
- -- Local binding name
- , local_bind_name :: FastString
- }
-
-
-initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalRdrEnv
- -> GlobalEnv
-initGlobalEnv info instEnvs famInstEnvs bi rdr_env
- = GlobalEnv {
- global_vars = mapVarEnv snd $ vectInfoVar info
- , global_exported_vars = emptyVarEnv
- , global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info))
- (tyConName funTyCon) (closureTyCon bi)
-
- , global_datacons = mapNameEnv snd $ vectInfoDataCon info
- , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
- , global_inst_env = instEnvs
- , global_fam_inst_env = famInstEnvs
- , global_bindings = []
- , global_rdr_env = rdr_env
- }
-
-setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
-setFamInstEnv l_fam_inst genv
- = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
- where
- (g_fam_inst, _) = global_fam_inst_env genv
-
-emptyLocalEnv = LocalEnv {
- local_vars = emptyVarEnv
- , local_tyvars = []
- , local_tyvar_pa = emptyVarEnv
- , local_bind_name = FSLIT("fn")
- }
-
--- FIXME
-updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
-updVectInfo env tyenv info
- = info {
- vectInfoVar = global_exported_vars env
- , vectInfoTyCon = mk_env typeEnvTyCons global_tycons
- , vectInfoDataCon = mk_env typeEnvDataCons global_datacons
- , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs
- }
- where
- mk_env from_tyenv from_env = mkNameEnv [(name, (from,to))
- | from <- from_tyenv tyenv
- , let name = getName from
- , Just to <- [lookupNameEnv (from_env env) name]]