Commit 29df68c2 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Move code

parent ce39c447
......@@ -8,7 +8,8 @@ module VectUtils (
polyAbstract, polyApply, polyVApply,
lookupPArrayFamInst,
hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures
buildClosure, buildClosures,
mkClosureApp
) where
#include "HsVersions.h"
......@@ -239,7 +240,6 @@ takeHoisted
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do
......@@ -249,6 +249,16 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],
Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
mkClosureApp :: VExpr -> VExpr -> VM VExpr
mkClosureApp (vclo, lclo) (varg, larg)
= do
vapply <- builtin applyClosureVar
lapply <- builtin applyClosurePVar
return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg])
where
(arg_ty, res_ty) = splitClosureTy (exprType vclo)
buildClosures :: [TyVar] -> Var -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
buildClosures tvs lc vars [arg_ty] res_ty mk_body
= buildClosure tvs lc vars arg_ty res_ty mk_body
......
......@@ -150,17 +150,6 @@ vectBndrsIn vs p
-- ----------------------------------------------------------------------------
-- Expressions
capply :: VExpr -> VExpr -> VM VExpr
capply (vfn, lfn) (varg, larg)
= do
apply <- builtin applyClosureVar
applyP <- builtin applyClosurePVar
return (mkApps (Var apply) [Type arg_ty, Type res_ty, vfn, varg],
mkApps (Var applyP) [Type arg_ty, Type res_ty, lfn, larg])
where
fn_ty = exprType vfn
(arg_ty, res_ty) = splitClosureTy fn_ty
vectVar :: Var -> Var -> VM VExpr
vectVar lc v
= do
......@@ -222,7 +211,7 @@ vectExpr lc (_, AnnApp fn arg)
= do
fn' <- vectExpr lc fn
arg' <- vectExpr lc arg
capply fn' arg'
mkClosureApp fn' arg'
vectExpr lc (_, AnnCase expr bndr ty alts)
= panic "vectExpr: case"
......@@ -272,7 +261,7 @@ vectLam lc fvs bs body
(vectExpr new_lc body)
return $ vLams new_lc vbndrs vbody
vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM VExpr
vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
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