From: benl@ouroborus.net Date: Wed, 8 Sep 2010 07:41:02 +0000 (+0000) Subject: Break out hoisting utils into their own module X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d5744ef51a8b8b1e063daa98026a9f803bfc88b4 Break out hoisting utils into their own module --- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 57b7467..06d7e28 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -464,6 +464,7 @@ Library Vectorise.Type.TyConDecl Vectorise.Type.Classify Vectorise.Utils.Closure + Vectorise.Utils.Hoisting Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 960028c..046acb9 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -15,6 +15,7 @@ import Vectorise.Type.Type import Vectorise.Type.TyConDecl import Vectorise.Type.Classify import Vectorise.Utils.Closure +import Vectorise.Utils.Hoisting import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import BasicTypes diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 8c82fb0..9c50d4a 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -16,37 +16,27 @@ module VectUtils ( combinePD, liftPD, zipScalars, scalarClosure, - polyAbstract, polyApply, polyVApply, polyArity, - Inline(..), addInlineArity, inlineMe, - hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, + polyAbstract, polyApply, polyVApply, polyArity ) where - - import Vectorise.Monad -import Vectorise.Env import Vectorise.Vect import Vectorise.Builtins import CoreSyn import CoreUtils -import CoreUnfold ( mkInlineRule ) import Coercion import Type import TypeRep import TyCon import DataCon import Var -import MkId ( unwrapFamInstScrut ) -import Id ( setIdUnfolding ) -import BasicTypes -import Literal ( Literal, mkMachInt ) - - +import MkId +import Literal import Outputable import FastString - import Control.Monad + collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) collectAnnTypeArgs expr = go expr [] where @@ -363,62 +353,6 @@ polyVApply expr tys = do Just dicts <- liftM sequence $ mapM paDictOfType tys return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr --- Inline --------------------------------------------------------------------- --- | Records whether we should inline a particular binding. -data Inline - = Inline Arity - | DontInline - --- | Add to the arity contained within an `Inline`, if any. -addInlineArity :: Inline -> Int -> Inline -addInlineArity (Inline m) n = Inline (m+n) -addInlineArity DontInline _ = DontInline - --- | Says to always inline a binding. -inlineMe :: Inline -inlineMe = Inline 0 - - --- Hoising -------------------------------------------------------------------- -hoistBinding :: Var -> CoreExpr -> VM () -hoistBinding v e = updGEnv $ \env -> - env { global_bindings = (v,e) : global_bindings env } - -hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var -hoistExpr fs expr inl - = do - var <- mk_inline `liftM` newLocalVar fs (exprType expr) - hoistBinding var expr - return var - where - mk_inline var = case inl of - Inline arity -> var `setIdUnfolding` - mkInlineRule expr (Just arity) - DontInline -> var - -hoistVExpr :: VExpr -> Inline -> VM VVar -hoistVExpr (ve, le) inl - = do - fs <- getBindName - vv <- hoistExpr ('v' `consFS` fs) ve inl - lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) - return (vv, lv) - -hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr -hoistPolyVExpr tvs inline p - = do - inline' <- liftM (addInlineArity inline) (polyArity tvs) - expr <- closedV . polyAbstract tvs $ \args -> - liftM (mapVect (mkLams $ tvs ++ args)) p - fn <- hoistVExpr expr inline' - polyVApply (vVar fn) (mkTyVarTys tvs) - -takeHoisted :: VM [(Var, CoreExpr)] -takeHoisted - = do - env <- readGEnv id - setGEnv $ env { global_bindings = [] } - return $ global_bindings env {- boxExpr :: Type -> VExpr -> VM VExpr diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 34ca5ab..22cba53 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -3,8 +3,8 @@ module Vectorise( vectorise ) where -import VectUtils import VectType +import Vectorise.Utils.Hoisting import Vectorise.Exp import Vectorise.Vect import Vectorise.Env diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 5597e2f..1c2ee4c 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -6,6 +6,7 @@ where import VectUtils import VectType import Vectorise.Utils.Closure +import Vectorise.Utils.Hoisting 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 index 685c82b..47cb837 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -8,6 +8,7 @@ module Vectorise.Utils.Closure ( ) where import VectUtils +import Vectorise.Utils.Hoisting import Vectorise.Builtins import Vectorise.Vect import Vectorise.Monad diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs new file mode 100644 index 0000000..a604927 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -0,0 +1,89 @@ + +module Vectorise.Utils.Hoisting ( + Inline(..), + addInlineArity, + inlineMe, + + hoistBinding, + hoistExpr, + hoistVExpr, + hoistPolyVExpr, + takeHoisted +) +where +import VectUtils +import Vectorise.Monad +import Vectorise.Env +import Vectorise.Vect + +import CoreSyn +import CoreUtils +import CoreUnfold +import Type +import Var +import Id +import BasicTypes +import FastString +import Control.Monad + + +-- Inline --------------------------------------------------------------------- +-- | Records whether we should inline a particular binding. +data Inline + = Inline Arity + | DontInline + +-- | Add to the arity contained within an `Inline`, if any. +addInlineArity :: Inline -> Int -> Inline +addInlineArity (Inline m) n = Inline (m+n) +addInlineArity DontInline _ = DontInline + +-- | Says to always inline a binding. +inlineMe :: Inline +inlineMe = Inline 0 + + +-- Hoising -------------------------------------------------------------------- +hoistBinding :: Var -> CoreExpr -> VM () +hoistBinding v e = updGEnv $ \env -> + env { global_bindings = (v,e) : global_bindings env } + + +hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var +hoistExpr fs expr inl + = do + var <- mk_inline `liftM` newLocalVar fs (exprType expr) + hoistBinding var expr + return var + where + mk_inline var = case inl of + Inline arity -> var `setIdUnfolding` + mkInlineRule expr (Just arity) + DontInline -> var + + +hoistVExpr :: VExpr -> Inline -> VM VVar +hoistVExpr (ve, le) inl + = do + fs <- getBindName + vv <- hoistExpr ('v' `consFS` fs) ve inl + lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) + return (vv, lv) + + +hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr +hoistPolyVExpr tvs inline p + = do + inline' <- liftM (addInlineArity inline) (polyArity tvs) + expr <- closedV . polyAbstract tvs $ \args -> + liftM (mapVect (mkLams $ tvs ++ args)) p + fn <- hoistVExpr expr inline' + polyVApply (vVar fn) (mkTyVarTys tvs) + + +takeHoisted :: VM [(Var, CoreExpr)] +takeHoisted + = do + env <- readGEnv id + setGEnv $ env { global_bindings = [] } + return $ global_bindings env