Commit 5eec4625 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Utility functions for accessing parallel array representations

parent 263a30f1
...@@ -4,10 +4,10 @@ module VectUtils ( ...@@ -4,10 +4,10 @@ module VectUtils (
mkDataConTag, mkDataConTag,
splitClosureTy, splitClosureTy,
mkPADictType, mkPArrayType, mkPADictType, mkPArrayType,
parrayReprTyCon, parrayReprDataCon,
paDictArgType, paDictOfType, paDFunType, paDictArgType, paDictOfType, paDFunType,
paMethod, lengthPA, replicatePA, emptyPA, liftPA, paMethod, lengthPA, replicatePA, emptyPA, liftPA,
polyAbstract, polyApply, polyVApply, polyAbstract, polyApply, polyVApply,
lookupPArrayFamInst,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures, buildClosure, buildClosures,
mkClosureApp mkClosureApp
...@@ -110,6 +110,16 @@ mkPArrayType ty ...@@ -110,6 +110,16 @@ mkPArrayType ty
tc <- builtin parrayTyCon tc <- builtin parrayTyCon
return $ TyConApp tc [ty] return $ TyConApp tc [ty]
parrayReprTyCon :: Type -> VM (TyCon, [Type])
parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
parrayReprDataCon :: Type -> VM (DataCon, [Type])
parrayReprDataCon ty
= do
(tc, arg_tys) <- parrayReprTyCon ty
let [dc] = tyConDataCons tc
return (dc, arg_tys)
paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
where where
...@@ -226,9 +236,6 @@ polyVApply expr tys ...@@ -226,9 +236,6 @@ polyVApply expr tys
dicts <- mapM paDictOfType tys dicts <- mapM paDictOfType tys
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
hoistBinding :: Var -> CoreExpr -> VM () hoistBinding :: Var -> CoreExpr -> VM ()
hoistBinding v e = updGEnv $ \env -> hoistBinding v e = updGEnv $ \env ->
env { global_bindings = (v,e) : global_bindings env } env { global_bindings = (v,e) : global_bindings env }
...@@ -354,7 +361,7 @@ mkLiftEnv lc [ty] [v] ...@@ -354,7 +361,7 @@ mkLiftEnv lc [ty] [v]
-- NOTE: this transparently deals with empty environments -- NOTE: this transparently deals with empty environments
mkLiftEnv lc tys vs mkLiftEnv lc tys vs
= do = do
(env_tc, env_tyargs) <- lookupPArrayFamInst vty (env_tc, env_tyargs) <- parrayReprTyCon vty
let [env_con] = tyConDataCons env_tc let [env_con] = tyConDataCons env_tc
env = Var (dataConWrapId env_con) env = Var (dataConWrapId env_con)
......
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