X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FLambdaLift.lhs;h=1abccae8c2b9bcee3d5fc684834c421c0208c34e;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=b1c83ddba6c4d70b67d4abf1e978b53da82334d1;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index b1c83dd..1abccae 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -8,17 +8,18 @@ module LambdaLift ( liftProgram ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList ) -import Id ( idType, mkSysLocal, addIdArity, - mkIdSet, unitIdSet, minusIdSet, - unionManyIdSets, idSetToList, IdSet(..), - nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..) +import Id ( idType, mkSysLocal, addIdArity, + mkIdSet, unitIdSet, minusIdSet, setIdVisibility, + unionManyIdSets, idSetToList, SYN_IE(IdSet), + nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv) ) -import SrcLoc ( mkUnknownSrcLoc ) +import IdInfo ( ArityInfo, exactArity ) +import SrcLoc ( noSrcLoc ) import Type ( splitForAllTy, mkForAllTys, mkFunTys ) import UniqSupply ( getUnique, splitUniqSupply ) import Util ( zipEqual, panic, assertPanic ) @@ -86,11 +87,13 @@ supercombinators on a selective basis: recursive calls, which may now have lots of free vars. Recent Observations: + * 2 might be already ``too many'' variables to abstract. The problem is that the increase in the number of free variables of closures refering to the lifted function (which is always # of abstracted args - 1) may increase heap allocation a lot. Expeiments are being done to check this... + * We do not lambda lift if the function has at least one occurrence without any arguments. This caused lots of problems. Ex: h = \ x -> ... let y = ... @@ -119,8 +122,8 @@ Recent Observations: %************************************************************************ \begin{code} -liftProgram :: UniqSupply -> [StgBinding] -> [StgBinding] -liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog)) +liftProgram :: Module -> UniqSupply -> [StgBinding] -> [StgBinding] +liftProgram mod us prog = concat (runLM mod Nothing us (mapLM liftTopBind prog)) liftTopBind :: StgBinding -> LiftM [StgBinding] @@ -147,8 +150,9 @@ liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgApp (StgConArg con) args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgVarArg v) args lvs) - = lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to + = lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to -- poke these bindings too early! returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs, emptyLiftInfo) @@ -198,7 +202,7 @@ liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body) liftExpr (StgLetNoEscape _ _ (StgRec pairs) body) = liftExpr body `thenLM` \ (body', body_info) -> mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> - returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + returnLM (StgLet (StgRec (zipEqual "liftExpr" binders rhss')) body', foldr unionLiftInfo body_info rhs_infos) where (binders,rhss) = unzip pairs @@ -240,7 +244,7 @@ liftExpr (StgLet (StgRec pairs) body) | not (all isLiftableRec rhss) = liftExpr body `thenLM` \ (body', body_info) -> mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> - returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + returnLM (StgLet (StgRec (zipEqual "liftExpr2" binders rhss')) body', foldr unionLiftInfo body_info rhs_infos) | otherwise -- All rhss are liftable @@ -392,7 +396,8 @@ mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body) The monad is used only to distribute global stuff, and the unique supply. \begin{code} -type LiftM a = LiftFlags +type LiftM a = Module + -> LiftFlags -> UniqSupply -> (IdEnv -- Domain = candidates for lifting (Id, -- The supercombinator @@ -405,22 +410,22 @@ type LiftFlags = Maybe Int -- No of fvs reqd to float recursive -- binding; Nothing == infinity -runLM :: LiftFlags -> UniqSupply -> LiftM a -> a -runLM flags us m = m flags us nullIdEnv +runLM :: Module -> LiftFlags -> UniqSupply -> LiftM a -> a +runLM mod flags us m = m mod flags us nullIdEnv thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b -thenLM m k ci us idenv - = k (m ci us1 idenv) ci us2 idenv +thenLM m k mod ci us idenv + = k (m mod ci us1 idenv) mod ci us2 idenv where (us1, us2) = splitUniqSupply us returnLM :: a -> LiftM a -returnLM a ci us idenv = a +returnLM a mod ci us idenv = a fixLM :: (a -> LiftM a) -> LiftM a -fixLM k ci us idenv = r +fixLM k mod ci us idenv = r where - r = k r ci us idenv + r = k r mod ci us idenv mapLM :: (a -> LiftM b) -> [a] -> LiftM [b] mapLM f [] = returnLM [] @@ -440,22 +445,22 @@ newSupercombinator :: Type -> Int -- Arity -> LiftM Id -newSupercombinator ty arity ci us idenv - = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc) -- ToDo: improve location - `addIdArity` arity +newSupercombinator ty arity mod ci us idenv + = setIdVisibility mod (mkSysLocal SLIT("sc") uniq ty noSrcLoc) + `addIdArity` exactArity arity -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? where uniq = getUnique us -lookup :: Id -> LiftM (Id,[Id]) -lookup v ci us idenv +lookUp :: Id -> LiftM (Id,[Id]) +lookUp v mod ci us idenv = case (lookupIdEnv idenv v) of Just result -> result Nothing -> (v, []) addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a -addScInlines ids values m ci us idenv - = m ci us idenv' +addScInlines ids values m mod ci us idenv + = m mod ci us idenv' where idenv' = growIdEnvList idenv (ids `zip_lazy` values) @@ -485,7 +490,7 @@ addScInlines ids values m ci us idenv getFinalFreeVars :: IdSet -> LiftM IdSet -getFinalFreeVars free_vars ci us idenv +getFinalFreeVars free_vars mod ci us idenv = unionManyIdSets (map munge_it (idSetToList free_vars)) where munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"