-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] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
-buildClosures tvs vars [] res_ty mk_body
- = mk_body
-buildClosures tvs vars [arg_ty] res_ty mk_body
- = buildClosure tvs vars arg_ty res_ty mk_body
-buildClosures tvs 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 vars arg_ty res_ty'
- . hoistPolyVExpr tvs
- $ do
- lc <- builtin liftingContext
- clo <- buildClosures tvs (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] -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr
-buildClosure tvs vars arg_ty res_ty mk_body
- = do
- (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'))
- where
- (vs,ls) = unzip vvs
- tys = map idType vs
-
-mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
-mkVectEnv [] [] = (unitTy, Var unitDataConId, \env body -> body)
-mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
-mkVectEnv tys vs = (ty, mkCoreTup (map Var vs),
- \env body -> Case env (mkWildId ty) (exprType body)
- [(DataAlt (tupleCon Boxed (length vs)), vs, body)])
- where
- ty = mkCoreTupTy tys
-
-mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM CoreExpr)
-mkLiftEnv lc [ty] [v]
- = return (Var v, \env body ->
- do
- len <- lengthPA (Var v)
- return . Let (NonRec v env)
- $ Case len lc (exprType body) [(DEFAULT, [], body)])
-
--- NOTE: this transparently deals with empty environments
-mkLiftEnv lc tys vs