Commit 76fb3390 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au

Move code

parent 020f8546
......@@ -4,6 +4,7 @@ module VectUtils (
mkPADictType, mkPArrayType,
paDictArgType, paDictOfType,
paMethod, lengthPA, replicatePA, emptyPA,
abstractOverTyVars, applyToTypes,
lookupPArrayFamInst,
hoistExpr, takeHoisted
) where
......@@ -23,7 +24,7 @@ import PrelNames
import Outputable
import FastString
import Control.Monad ( liftM )
import Control.Monad ( liftM, zipWithM_ )
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
......@@ -126,6 +127,27 @@ replicatePA len x = liftM (`mkApps` [len,x])
emptyPA :: Type -> VM CoreExpr
emptyPA = paMethod emptyPAVar
abstractOverTyVars :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
abstractOverTyVars tvs p
= do
mdicts <- mapM mk_dict_var tvs
zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts
p (mk_lams mdicts)
where
mk_dict_var tv = do
r <- paDictArgType tv
case r of
Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
Nothing -> return Nothing
mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
applyToTypes :: CoreExpr -> [Type] -> VM CoreExpr
applyToTypes expr tys
= do
dicts <- mapM paDictOfType tys
return $ expr `mkTyApps` tys `mkApps` dicts
lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
......
......@@ -40,7 +40,7 @@ import BasicTypes ( Boxity(..) )
import Outputable
import FastString
import Control.Monad ( liftM, liftM2, mapAndUnzipM, zipWithM_ )
import Control.Monad ( liftM, liftM2, mapAndUnzipM )
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
......@@ -175,27 +175,6 @@ vectPolyVar lc v tys
where
mk_app e = applyToTypes e =<< mapM vectType tys
abstractOverTyVars :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
abstractOverTyVars tvs p
= do
mdicts <- mapM mk_dict_var tvs
zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts
p (mk_lams mdicts)
where
mk_dict_var tv = do
r <- paDictArgType tv
case r of
Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
Nothing -> return Nothing
mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
applyToTypes :: CoreExpr -> [Type] -> VM CoreExpr
applyToTypes expr tys
= do
dicts <- mapM paDictOfType tys
return $ expr `mkTyApps` tys `mkApps` dicts
vectPolyExpr :: CoreExpr -> CoreExprWithFVs -> VM (CoreExpr, CoreExpr)
vectPolyExpr lc expr
= localV
......
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