From: benl@ouroborus.net Date: Wed, 8 Sep 2010 07:20:40 +0000 (+0000) Subject: Break out closure utils into own module X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=170a6564229788618fb86fbb3be6662bf8e566a0 Break out closure utils into own module --- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index bd432a9..57b7467 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -463,6 +463,7 @@ Library Vectorise.Type.Type Vectorise.Type.TyConDecl Vectorise.Type.Classify + Vectorise.Utils.Closure Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 4b7cc47..960028c 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -14,6 +14,7 @@ import Vectorise.Builtins import Vectorise.Type.Type import Vectorise.Type.TyConDecl import Vectorise.Type.Classify +import Vectorise.Utils.Closure import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import BasicTypes diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index d823690..8c82fb0 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -7,6 +7,7 @@ module VectUtils ( mkBuiltinCo, voidType, mkWrapType, mkPADictType, mkPArrayType, mkPDataType, mkPReprType, mkPArray, + mkBuiltinTyConApps, mkClosureTypes, pdataReprTyCon, pdataReprDataCon, mkVScrut, prDictOfType, prDFunOfTyCon, @@ -18,15 +19,14 @@ module VectUtils ( polyAbstract, polyApply, polyVApply, polyArity, Inline(..), addInlineArity, inlineMe, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, - buildClosure, buildClosures, - mkClosureApp ) where + + import Vectorise.Monad import Vectorise.Env import Vectorise.Vect import Vectorise.Builtins -import MkCore ( mkCoreTup, mkWildCase ) import CoreSyn import CoreUtils import CoreUnfold ( mkInlineRule ) @@ -38,8 +38,7 @@ import DataCon import Var import MkId ( unwrapFamInstScrut ) import Id ( setIdUnfolding ) -import TysWiredIn -import BasicTypes ( Boxity(..), Arity ) +import BasicTypes import Literal ( Literal, mkMachInt ) @@ -107,6 +106,7 @@ voidType = mkBuiltinTyConApp voidTyCon [] mkWrapType :: Type -> VM Type mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] + mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon @@ -434,106 +434,4 @@ boxExpr ty (vexpr, lexpr) Nothing -> return (vexpr, lexpr) -} --- Closures ------------------------------------------------------------------- -mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr -mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) - = do Just dict <- paDictOfType env_ty - mkv <- builtin closureVar - mkl <- builtin liftedClosureVar - 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 applyVar - lapply <- builtin liftedApplyVar - lc <- builtin liftingContext - return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], - Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, 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 - = -- liftM vInlineMe $ - 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 - -- liftM vInlineMe - buildClosure tvs vars arg_ty res_ty' - . hoistPolyVExpr tvs (Inline (length vars + 1)) - $ do - lc <- builtin liftingContext - clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body - return $ vLams lc (vars ++ [arg]) clo - --- (clo , aclo (Arr lc xs1 ... xsn) ) --- where --- f = \env v -> case env of -> 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 (Inline 2) - $ do - lc <- builtin liftingContext - body <- mk_body - return -- . vInlineMe - . vLams lc [env_bndr, arg_bndr] - $ bind (vVar env_bndr) - (vVarApps lc body (vars ++ [arg_bndr])) - - mkClosure arg_ty res_ty env_ty fn env - - --- Environments --------------------------------------------------------------- -buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) -buildEnv [] = do - ty <- voidType - void <- builtin voidVar - pvoid <- builtin pvoidVar - return (ty, vVar (void, pvoid), \_ body -> body) - -buildEnv [v] = return (vVarType v, vVar v, - \env body -> vLet (vNonRec v env) body) - -buildEnv vs - = do - - (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - - let venv_con = tupleCon Boxed (length vs) - [lenv_con] = tyConDataCons lenv_tc - - venv = mkCoreTup (map Var vvs) - lenv = Var (dataConWrapId lenv_con) - `mkTyApps` lenv_tyargs - `mkApps` map Var lvs - - vbind env body = mkWildCase env ty (exprType body) - [(DataAlt venv_con, vvs, body)] - - lbind env body = - let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env - in - mkWildCase scrut (exprType scrut) (exprType body) - [(DataAlt lenv_con, lvs, body)] - - bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, - lbind lenv lbody) - - return (ty, (venv, lenv), bind) - where - (vvs, lvs) = unzip vs - tys = map vVarType vs - ty = mkBoxedTupleTy tys diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index da783a9..5597e2f 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -5,6 +5,7 @@ module Vectorise.Exp where import VectUtils import VectType +import Vectorise.Utils.Closure import Vectorise.Var import Vectorise.Vect import Vectorise.Env diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs new file mode 100644 index 0000000..685c82b --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -0,0 +1,129 @@ + +module Vectorise.Utils.Closure ( + mkClosure, + mkClosureApp, + buildClosure, + buildClosures, + buildEnv +) +where +import VectUtils +import Vectorise.Builtins +import Vectorise.Vect +import Vectorise.Monad + +import CoreSyn +import Type +import Var +import MkCore +import CoreUtils +import TyCon +import DataCon +import MkId +import TysWiredIn +import BasicTypes +import FastString + + +mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr +mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) + = do Just dict <- paDictOfType env_ty + mkv <- builtin closureVar + mkl <- builtin liftedClosureVar + 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 applyVar + lapply <- builtin liftedApplyVar + lc <- builtin liftingContext + return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], + Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, 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 + = -- liftM vInlineMe $ + 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 + -- liftM vInlineMe + buildClosure tvs vars arg_ty res_ty' + . hoistPolyVExpr tvs (Inline (length vars + 1)) + $ do + lc <- builtin liftingContext + clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body + return $ vLams lc (vars ++ [arg]) clo + + +-- (clo , aclo (Arr lc xs1 ... xsn) ) +-- where +-- f = \env v -> case env of -> 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 (Inline 2) + $ do + lc <- builtin liftingContext + body <- mk_body + return -- . vInlineMe + . vLams lc [env_bndr, arg_bndr] + $ bind (vVar env_bndr) + (vVarApps lc body (vars ++ [arg_bndr])) + + mkClosure arg_ty res_ty env_ty fn env + + +-- Environments --------------------------------------------------------------- +buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) +buildEnv [] = do + ty <- voidType + void <- builtin voidVar + pvoid <- builtin pvoidVar + return (ty, vVar (void, pvoid), \_ body -> body) + +buildEnv [v] = return (vVarType v, vVar v, + \env body -> vLet (vNonRec v env) body) + +buildEnv vs + = do + + (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty + + let venv_con = tupleCon Boxed (length vs) + [lenv_con] = tyConDataCons lenv_tc + + venv = mkCoreTup (map Var vvs) + lenv = Var (dataConWrapId lenv_con) + `mkTyApps` lenv_tyargs + `mkApps` map Var lvs + + vbind env body = mkWildCase env ty (exprType body) + [(DataAlt venv_con, vvs, body)] + + lbind env body = + let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env + in + mkWildCase scrut (exprType scrut) (exprType body) + [(DataAlt lenv_con, lvs, body)] + + bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, + lbind lenv lbody) + + return (ty, (venv, lenv), bind) + where + (vvs, lvs) = unzip vs + tys = map vVarType vs + ty = mkBoxedTupleTy tys