Commit 24901afd authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Add generated PArray instances to instance environments

parent 6c63c674
......@@ -9,6 +9,7 @@ module VectMonad (
builtin,
GlobalEnv(..),
setInstEnvs,
readGEnv, setGEnv, updGEnv,
LocalEnv(..),
......@@ -157,6 +158,13 @@ initGlobalEnv info instEnvs famInstEnvs bi
, 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 = []
......
......@@ -12,6 +12,8 @@ import TyCon
import Type
import TypeRep
import Coercion
import FamInstEnv ( FamInst, mkLocalFamInst )
import InstEnv ( Instance )
import OccName
import MkId
import BasicTypes ( StrictnessMark(..), boolToRecFlag )
......@@ -66,7 +68,7 @@ vectType ty = pprPanic "vectType:" (ppr ty)
type TyConGroup = ([TyCon], UniqSet TyCon)
vectTypeEnv :: TypeEnv -> VM TypeEnv
vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [Instance])
vectTypeEnv env
= do
cs <- readGEnv $ mk_map . global_tycons
......@@ -78,9 +80,13 @@ vectTypeEnv env
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
......
......@@ -19,6 +19,8 @@ import Rules ( RuleBase )
import DataCon
import TyCon
import Type
import FamInstEnv ( extendFamInstEnvList )
import InstEnv ( extendInstEnvList )
import Var
import VarEnv
import VarSet
......@@ -56,10 +58,20 @@ vectorise hsc_env _ _ guts
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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment