X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatOut.lhs;h=e5db7d93cefaa538b2e4ccad3aa47aa7d56840b9;hp=f5f894648af86776ff78e88326020b7df53ddf47;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=b84ba676034763b3082bbd9405794a4fde499d14 diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index f5f8946..e5db7d9 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -11,21 +11,24 @@ module FloatOut ( floatOutwards ) where import CoreSyn import CoreUtils import CoreArity ( etaExpand ) +import CoreMonad ( FloatOutSwitches(..) ) -import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id, idType, idArity, isBottomingId ) import Type ( isUnLiftedType ) import SetLevels ( Level(..), LevelledExpr, LevelledBind, - setLevels, isTopLvl, tOP_LEVEL ) + setLevels, isTopLvl ) 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} ----------------- @@ -135,8 +138,7 @@ floatOutwards float_sws dflags us pgm floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) floatTopBind bind = case (floatBind bind) of { (fs, floats) -> - (fs, bagToList (flattenFloats floats)) - } + (fs, bagToList (flattenFloats floats)) } \end{code} %************************************************************************ @@ -147,7 +149,6 @@ floatTopBind bind \begin{code} floatBind :: LevelledBind -> (FloatStats, FloatBinds) - floatBind (NonRec (TB var level) rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> @@ -158,47 +159,44 @@ floatBind (NonRec (TB var level) rhs) in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) } -floatBind bind@(Rec pairs) - = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) -> - let rhs_floats = foldr1 plusFloats rhss_floats in - - if not (isTopLvl bind_dest_lvl) then +floatBind (Rec pairs) + = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> + -- NB: the rhs floats may contain references to the + -- bound things. For example + -- f = ...(let v = ...f... in b) ... + if not (isTopLvl dest_lvl) then -- Find which bindings float out at least one lambda beyond this one -- These ones can't mention the binders, because they couldn't -- be escaping a major level if so. -- The ones that are not going further can join the letrec; -- they may not be mutually recursive but the occurrence analyser will - -- find that out. - case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) -> - (sum_stats fss, - floats' `plusFloats` unitFloat bind_dest_lvl - (Rec (floatsToBindPairs heres new_pairs))) } - else - -- In a recursive binding, *destined for* the top level - -- (only), the rhs floats may contain references to the - -- bound things. For example - -- f = ...(let v = ...f... in b) ... - -- might get floated to + -- find that out. In our example we make a Rec thus: -- v = ...f... -- f = ... b ... - -- and hence we must (pessimistically) make all the floats recursive - -- with the top binding. Later dependency analysis will unravel it. - -- - -- This can only happen for bindings destined for the top level, - -- because only then will partitionByMajorLevel allow through a binding - -- that only differs in its minor level - (sum_stats fss, unitFloat tOP_LEVEL - (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) - } + case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) -> + (fs, floats' `plusFloats` unitFloat dest_lvl + (Rec (floatsToBindPairs heres new_pairs))) } + else + -- For top level, no need to partition; just make them all recursive + -- (And the partition wouldn't work because they'd all end up in floats') + (fs, unitFloat dest_lvl + (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) } where - bind_dest_lvl = getBindLevel bind + (((TB _ dest_lvl), _) : _) = pairs do_pair (TB name level, rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (name, rhs')) - } + (fs, rhs_floats, (name, rhs')) } + +--------------- +floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList _ [] = (zeroStats, emptyFloats, []) +floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> + case floatList f as of { (fs_as, binds_as, bs) -> + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} \end{code} + %************************************************************************ \subsection[FloatOut-Expr]{Floating in expressions} @@ -219,41 +217,15 @@ floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss -- the rec or case alternative (fsa, floats', install heres arg') }} +----------------- floatRhs lvl arg -- Used for nested non-rec rhss, and fn args -- See Note [Floating out of RHS] - = case (floatExpr lvl arg) of { (fsa, floats, arg') -> - if exprIsCheap arg' then - (fsa, floats, arg') - else - case (partitionByMajorLevel lvl floats) of { (floats', heres) -> - (fsa, floats', install heres arg') }} - --- Note [Floating out of RHSs] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Dump bindings that aren't going to escape from a lambda --- This isn't a scoping issue (the binder isn't in scope in the RHS --- of a non-rec binding) --- Rather, it is to avoid floating the x binding out of --- f (let x = e in b) --- unnecessarily. But we first test for values or trival rhss, --- because (in particular) we don't want to insert new bindings between --- the "=" and the "\". E.g. --- f = \x -> let in --- We do not want --- f = let in \x -> --- (a) The simplifier will immediately float it further out, so we may --- as well do so right now; in general, keeping rhss as manifest --- values is good --- (b) If a float-in pass follows immediately, it might add yet more --- bindings just after the '='. And some of them might (correctly) --- be strict even though the 'let f' is lazy, because f, being a value, --- gets its demand-info zapped by the simplifier. --- --- We use exprIsCheap because that is also what's used by the simplifier --- to decide whether to float a let out of a let + = floatExpr lvl arg +----------------- floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co) floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) floatExpr lvl (App e a) @@ -261,27 +233,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 isTyVar 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) @@ -312,9 +277,10 @@ floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) floatExpr lvl (Let bind body) = case (floatBind bind) of { (fsb, bind_floats) -> case (floatExpr lvl body) of { (fse, body_floats, body') -> - (add_stats fsb fse, - bind_floats `plusFloats` body_floats, - body') }} + case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats) + of { (floats, heres) -> + -- See Note [Avoiding unnecessary floating] + (add_stats fsb fse, floats, install heres body') } } } floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) = case floatExpr lvl scrut of { (fse, fde, scrut') -> @@ -327,20 +293,43 @@ floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) float_alt (con, bs, rhs) = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') -> (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } - - -floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList _ [] = (zeroStats, emptyFloats, []) -floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> - case floatList f as of { (fs_as, binds_as, bs) -> - (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} - -getBindLevel :: Bind (TaggedBndr Level) -> Level -getBindLevel (NonRec (TB _ lvl) _) = lvl -getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl -getBindLevel (Rec []) = panic "getBindLevel Rec []" \end{code} +Note [Avoiding unnecessary floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to avoid floating a let unnecessarily, because +it might worsen strictness: + let + x = ...(let y = e in y+y).... +Here y is demanded. If we float it outside the lazy 'x=..' then +we'd have to zap its demand info, and it may never be restored. + +So at a 'let' we leave the binding right where the are unless +the binding will escape a value lambda. That's what the +partitionByMajorLevel does in the floatExpr (Let ...) case. + +Notice, though, that we must take care to drop any bindings +from the body of the let that depend on the staying-put bindings. + +We used instead to do the partitionByMajorLevel on the RHS of an '=', +in floatRhs. But that was quite tiresome. We needed to test for +values or trival rhss, because (in particular) we don't want to insert +new bindings between the "=" and the "\". E.g. + f = \x -> let in +We do not want + f = let in \x -> +(a) The simplifier will immediately float it further out, so we may + as well do so right now; in general, keeping rhss as manifest + values is good +(b) If a float-in pass follows immediately, it might add yet more + bindings just after the '='. And some of them might (correctly) + be strict even though the 'let f' is lazy, because f, being a value, + gets its demand-info zapped by the simplifier. +And even all that turned out to be very fragile, and broke +altogether when profiling got in the way. + +So now we do the partition right at the (Let..) itself. + %************************************************************************ %* * \subsection{Utility bits for floating stats} @@ -408,34 +397,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 @@ -467,29 +461,28 @@ 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) wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) \end{code} -