polyAbstract, polyApply, polyVApply,
lookupPArrayFamInst,
hoistExpr, hoistPolyVExpr, takeHoisted,
- buildClosure, buildClosures
+ buildClosure, buildClosures,
+ mkClosureApp
) where
#include "HsVersions.h"
env { global_bindings = (var, expr) : global_bindings env }
return var
-hoistVExpr :: FastString -> VExpr -> VM VVar
-hoistVExpr fs (ve, le)
+hoistVExpr :: VExpr -> VM VVar
+hoistVExpr (ve, le)
= do
+ fs <- getBindName
vv <- hoistExpr ('v' `consFS` fs) ve
lv <- hoistExpr ('l' `consFS` fs) le
return (vv, lv)
-hoistPolyVExpr :: FastString -> [TyVar] -> VM VExpr -> VM VExpr
-hoistPolyVExpr fs tvs p
+hoistPolyVExpr :: [TyVar] -> VM VExpr -> VM VExpr
+hoistPolyVExpr tvs p
= do
expr <- closedV . polyAbstract tvs $ \abstract ->
liftM (mapVect abstract) p
- fn <- hoistVExpr fs expr
+ fn <- hoistVExpr expr
polyVApply (vVar fn) (mkTyVarTys tvs)
takeHoisted :: VM [(Var, CoreExpr)]
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
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
res_ty' <- mkClosureTypes arg_tys res_ty
arg <- newLocalVVar FSLIT("x") arg_ty
buildClosure tvs lc vars arg_ty res_ty'
- . hoistPolyVExpr FSLIT("fn") tvs
+ . hoistPolyVExpr tvs
$ do
clo <- buildClosures tvs lc (vars ++ [arg]) arg_tys res_ty mk_body
return $ vLams lc (vars ++ [arg]) clo
env_bndr <- newLocalVVar FSLIT("env") env_ty
arg_bndr <- newLocalVVar FSLIT("arg") arg_ty
- fn <- hoistPolyVExpr FSLIT("fn") tvs
+ fn <- hoistPolyVExpr tvs
$ do
body <- mk_body
body' <- bind (vVar env_bndr)