builtin,
GlobalEnv(..),
+ setInstEnvs,
readGEnv, setGEnv, updGEnv,
LocalEnv(..),
, 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 = []
import Type
import TypeRep
import Coercion
+import FamInstEnv ( FamInst, mkLocalFamInst )
+import InstEnv ( Instance )
import OccName
import MkId
import BasicTypes ( StrictnessMark(..), boolToRecFlag )
type TyConGroup = ([TyCon], UniqSet TyCon)
-vectTypeEnv :: TypeEnv -> VM TypeEnv
+vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [Instance])
vectTypeEnv env
= do
cs <- readGEnv $ mk_map . global_tycons
parr_tcs1 <- mapM (\tc -> buildPArrayTyCon (tyConName tc) tc) keep_tcs
parr_tcs2 <- zipWithM (buildPArrayTyCon . tyConName) conv_tcs vect_tcs
let new_tcs = vect_tcs ++ parr_tcs1 ++ parr_tcs2
- return $ extendTypeEnvList env
- (map ATyCon new_tcs ++ [ADataCon dc | tc <- new_tcs
- , dc <- tyConDataCons tc])
+
+ let new_env = extendTypeEnvList env
+ (map ATyCon new_tcs
+ ++ [ADataCon dc | tc <- new_tcs
+ , dc <- tyConDataCons tc])
+
+ return (new_env, map mkLocalFamInst (parr_tcs1 ++ parr_tcs2), [])
where
tycons = typeEnvTyCons env
groups = tyConGroups tycons
import DataCon
import TyCon
import Type
+import FamInstEnv ( extendFamInstEnvList )
+import InstEnv ( extendInstEnvList )
import Var
import VarEnv
import VarSet
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
- types' <- vectTypeEnv (mg_types guts)
+ (types', fam_insts, insts) <- vectTypeEnv (mg_types guts)
+
+ let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
+ inst_env' = extendInstEnvList (mg_inst_env guts) insts
+ updGEnv (setInstEnvs inst_env' fam_inst_env')
+
binds' <- mapM vectTopBind (mg_binds guts)
- return $ guts { mg_types = types'
- , mg_binds = binds' }
+ return $ guts { mg_types = types'
+ , mg_binds = binds'
+ , mg_inst_env = inst_env'
+ , mg_fam_inst_env = fam_inst_env'
+ , mg_insts = mg_insts guts ++ insts
+ , mg_fam_insts = mg_fam_insts guts ++ fam_insts
+ }
vectTopBind :: CoreBind -> VM CoreBind
vectTopBind b@(NonRec var expr)