-mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
-mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
- = do
- dict <- paDictOfType env_ty
- mkv <- builtin mkClosureVar
- mkl <- builtin mkClosurePVar
- 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
-buildClosures tvs lc vars (arg_ty : arg_tys) res_ty mk_body
- = do
- res_ty' <- mkClosureTypes arg_tys res_ty
- arg <- newLocalVVar FSLIT("x") arg_ty
- buildClosure tvs lc vars arg_ty res_ty'
- . hoistPolyVExpr tvs
- $ do
- clo <- buildClosures tvs lc (vars ++ [arg]) arg_tys res_ty mk_body
- return $ vLams lc (vars ++ [arg]) clo
-
--- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)
--- where
--- f = \env v -> case env of <x1,...,xn> -> e x1 ... xn v
--- f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v
---
-buildClosure :: [TyVar] -> Var -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr
-buildClosure tvs lv vars arg_ty res_ty mk_body
- = do
- (env_ty, env, bind) <- buildEnv lv vars
- env_bndr <- newLocalVVar FSLIT("env") env_ty
- arg_bndr <- newLocalVVar FSLIT("arg") arg_ty
-
- fn <- hoistPolyVExpr tvs
- $ do
- body <- mk_body
- body' <- bind (vVar env_bndr)
- (vVarApps lv body (vars ++ [arg_bndr]))
- return (vLamsWithoutLC [env_bndr, arg_bndr] body')
-
- mkClosure arg_ty res_ty env_ty fn env
-
-buildEnv :: Var -> [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VM VExpr)
-buildEnv lv vvs