- let (venv_ty, venv, bind_venv) = mkVectEnv tys vs
- (lenv, bind_lenv) <- mkLiftEnv (Var lv) tys ls
- lenv_ty <- mkPArrayType venv_ty
-
- venv_bndr <- newLocalVar FSLIT("env") venv_ty
- lenv_bndr <- newLocalVar FSLIT("env") lenv_ty
-
- let mono_vfn = mkLams [venv_bndr, varg]
- . bind_venv (Var venv_bndr)
- $ vbody `mkVarApps` vs `mkVarApps` [varg]
- mono_lfn = mkLams [lenv_bndr, larg]
- . bind_lenv (Var lenv_bndr) lv
- $ lbody `mkVarApps` (lv:ls) `mkVarApps` [larg]
-
- vfn <- hoistPolyExpr FSLIT("vfn") tvs mono_vfn
- lfn <- hoistPolyExpr FSLIT("lfn") tvs mono_lfn
-
- pa_dict <- paDictOfType venv_ty
-
- vclo <- mkClosure arg_ty res_ty venv_ty pa_dict vfn lfn venv
- lclo <- mkClosureP arg_ty res_ty venv_ty pa_dict vfn lfn lenv
-
- return (vclo, lclo)
-
+ (env_ty, env, bind) <- buildEnv vars
+ env_bndr <- newLocalVVar (fsLit "env") env_ty
+ arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
+
+ fn <- hoistPolyVExpr tvs
+ $ do
+ lc <- builtin liftingContext
+ body <- mk_body
+ body' <- bind (vVar env_bndr)
+ (vVarApps lc body (vars ++ [arg_bndr]))
+ return (vLamsWithoutLC [env_bndr, arg_bndr] body')
+
+ mkClosure arg_ty res_ty env_ty fn env
+
+buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VM VExpr)
+buildEnv vvs
+ = do
+ lc <- builtin liftingContext
+ let (ty, venv, vbind) = mkVectEnv tys vs
+ (lenv, lbind) <- mkLiftEnv lc tys ls
+ return (ty, (venv, lenv),
+ \(venv,lenv) (vbody,lbody) ->
+ do
+ let vbody' = vbind venv vbody
+ lbody' <- lbind lenv lbody
+ return (vbody', lbody'))