-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 :: Type -> Type -> VExpr -> VExpr -> VM VExpr
-mkClosureApp arg_ty res_ty (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])
-
-buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
-buildClosures _ _ [] _ 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 varType vs
-
-mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
-mkVectEnv [] [] = (unitTy, Var unitDataConId, \_ 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 -> mkWildCase env 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 ty (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
- = do
- (env_tc, env_tyargs) <- parrayReprTyCon vty
-
- bndrs <- if null vs then do
- v <- newDummyVar unitTy
- return [v]
- else return vs
- let [env_con] = tyConDataCons env_tc
-
- env = Var (dataConWrapId env_con)
- `mkTyApps` env_tyargs
- `mkApps` (Var lc : args)
-
- bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
- in
- return $ mkWildCase scrut (exprType scrut)
- (exprType body)
- [(DataAlt env_con, lc : bndrs, body)]
- return (env, bind)
- where
- vty = mkCoreTupTy tys
-
- args | null vs = [Var unitDataConId]
- | otherwise = map Var vs