From b284d3709e846c2dcdceb48901fe42ec75efb090 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 26 Oct 2010 11:15:47 +0000 Subject: [PATCH] Fix a long-standing bug the float-out pass We were failing to float out a binding that could be floated, because of a confusion in the Lam case of floatExpr. In investigating this I also discoverd that there is really no point at all in giving a different level to variables in a binding group, so I've now given them all the same (in SetLevels.lvlLamBndrs The overall difference is quite minor in a nofib run: Program Size Allocs Runtime Elapsed ------------------------------------------------------------- Min +0.0% -8.5% -28.4% -28.7% Max +0.0% +0.7% -0.7% -1.1% Geometric Mean +0.0% -0.0% -11.6% -11.8% I don't trust those runtimes, but smaller is good! The 8.5% improvement in allocation in fulsom, and seems real. The 0.7% allocation increase only happens in programs with very small allocation. I tracked one down to a call of this form GHC.IO.Handle.Internals.mkDuplexHandle5 = \ args -> GHC.IO.Handle.Internals.openTextEncoding1 mb_codec ha_type (\mb_encoder mb_decoder -> blah) With the new floater the argument of openTextEncoding1 becomes (let lvl = .. in \mb_encoder mb_decoder -> blah) And rightly so. However in fact this argument is a continuation and hence is called once, so the floating is fruitless. Roll on one-shot-function analysis (which I know how to do but fail to get to!). --- compiler/simplCore/FloatOut.lhs | 70 +++++++++++++++++++------------------- compiler/simplCore/SetLevels.lhs | 25 ++++---------- 2 files changed, 42 insertions(+), 53 deletions(-) diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index fba88e7..2a51a21 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -24,9 +24,11 @@ import UniqSupply ( UniqSupply ) import Bag import Util import Maybes -import UniqFM import Outputable import FastString +import qualified Data.IntMap as M + +#include "HsVersions.h" \end{code} ----------------- @@ -230,27 +232,20 @@ floatExpr lvl (App e a) case (floatRhs lvl a) of { (fsa, floats_a, a') -> (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} -floatExpr _ lam@(Lam _ _) - = let - (bndrs_w_lvls, body) = collectBinders lam +floatExpr _ lam@(Lam (TB _ lam_lvl) _) + = let (bndrs_w_lvls, body) = collectBinders lam bndrs = [b | TB b _ <- bndrs_w_lvls] - lvls = [l | TB _ l <- bndrs_w_lvls] - - -- For the all-tyvar case we are prepared to pull - -- the lets out, to implement the float-out-of-big-lambda - -- transform; but otherwise we only float bindings that are - -- going to escape a value lambda. - -- In particular, for one-shot lambdas we don't float things - -- out; we get no saving by so doing. - partition_fn | all isTyCoVar bndrs = partitionByLevel - | otherwise = partitionByMajorLevel + -- All the binders have the same level + -- See SetLevels.lvlLamBndrs in - case (floatExpr (last lvls) body) of { (fs, floats, body') -> - - -- Dump any bindings which absolutely cannot go any further - case (partition_fn (head lvls) floats) of { (floats', heres) -> - - (add_to_stats fs floats', floats', mkLams bndrs (install heres body')) + case (floatExpr lam_lvl body) of { (fs, floats, body1) -> + + -- Dump anything that is captured by this lambda + -- Eg \x -> ...(\y -> let v = in ...)... + -- We'll have the binding (v = ) in the floats, + -- but must dump it at the lambda-x + case (partitionByLevel lam_lvl floats) of { (floats1, heres) -> + (add_to_stats fs floats1, floats1, mkLams bndrs (install heres body1)) }} floatExpr lvl (Note note@(SCC cc) expr) @@ -401,34 +396,39 @@ data FloatBinds = FB !(Bag FloatBind) -- Destined for top level !MajorEnv -- Levels other than top -- See Note [Representation of FloatBinds] -type MajorEnv = UniqFM MinorEnv -- Keyed by major level -type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level +instance Outputable FloatBinds where + ppr (FB fbs env) = ptext (sLit "FB") <+> (braces $ vcat + [ ptext (sLit "binds =") <+> ppr fbs + , ptext (sLit "env =") <+> ppr env ]) + +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level flattenFloats :: FloatBinds -> Bag FloatBind flattenFloats (FB tops others) = tops `unionBags` flattenMajor others flattenMajor :: MajorEnv -> Bag FloatBind -flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag +flattenMajor = M.fold (unionBags . flattenMinor) emptyBag flattenMinor :: MinorEnv -> Bag FloatBind -flattenMinor = foldUFM unionBags emptyBag +flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds -emptyFloats = FB emptyBag emptyUFM +emptyFloats = FB emptyBag M.empty unitFloat :: Level -> FloatBind -> FloatBinds unitFloat lvl@(Level major minor) b - | isTopLvl lvl = FB (unitBag b) emptyUFM - | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b))) + | isTopLvl lvl = FB (unitBag b) M.empty + | otherwise = FB emptyBag (M.singleton major (M.singleton minor (unitBag b))) plusFloats :: FloatBinds -> FloatBinds -> FloatBinds plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2) plusMajor :: MajorEnv -> MajorEnv -> MajorEnv -plusMajor = plusUFM_C plusMinor +plusMajor = M.unionWith plusMinor plusMinor :: MinorEnv -> MinorEnv -> MinorEnv -plusMinor = plusUFM_C unionBags +plusMinor = M.unionWith unionBags floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] floatsToBindPairs floats binds = foldrBag add binds floats @@ -460,26 +460,26 @@ partitionByMajorLevel, partitionByLevel partitionByMajorLevel (Level major _) (FB tops defns) = (FB tops outer, heres `unionBags` flattenMajor inner) where - (outer, mb_heres, inner) = splitUFM defns major + (outer, mb_heres, inner) = M.splitLookup major defns heres = case mb_heres of Nothing -> emptyBag Just h -> flattenMinor h partitionByLevel (Level major minor) (FB tops defns) - = (FB tops (outer_maj `plusMajor` unitUFM major outer_min), + = (FB tops (outer_maj `plusMajor` M.singleton major outer_min), here_min `unionBags` flattenMinor inner_min `unionBags` flattenMajor inner_maj) where - (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns (outer_min, mb_here_min, inner_min) = case mb_here_maj of - Nothing -> (emptyUFM, Nothing, emptyUFM) - Just min_defns -> splitUFM min_defns minor + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns here_min = mb_here_min `orElse` emptyBag wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds wrapCostCentre cc (FB tops defns) - = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns) + = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns) where wrap_defns = mapBag wrap_one wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index ebfc27e..c684e7d 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -671,26 +671,15 @@ lvlLamBndrs lvl [] = (lvl, []) lvlLamBndrs lvl bndrs - = go (incMinorLvl lvl) - False -- Havn't bumped major level in this group - [] bndrs + = (new_lvl, [TB bndr new_lvl | bndr <- bndrs]) + -- All the new binders get the same level, because + -- any floating binding is either going to float past + -- all or none. We never separate binders where - go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) - | isId bndr && -- Go to the next major level if this is a value binder, - not bumped_major && -- and we havn't already gone to the next level (one jump per group) - not (isOneShotLambda bndr) -- and it isn't a one-shot lambda - = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl - | otherwise - = go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs - - where - new_lvl = incMajorLvl old_lvl - - go old_lvl _ rev_lvld_bndrs [] - = (old_lvl, reverse rev_lvld_bndrs) - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This happens quite a bit in state-transformer programs + is_major bndr = isId bndr && not (isOneShotLambda bndr) \end{code} \begin{code} -- 1.7.10.4