module FloatOut ( floatOutwards ) where import CoreSyn import CoreUtils import CoreArity ( etaExpand ) import CoreMonad ( 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 ) import UniqSupply ( UniqSupply ) import Bag import Util import Maybes import UniqFM import Outputable import FastString\end{code} ----------------- Overall game plan ----------------- The Big Main Idea is: To float out sub-expressions that can thereby get outside a non-one-shot value lambda, and hence may be shared. To achieve this we may need to do two thing: a) Let-bind the sub-expression: f (g x) ==> let lvl = f (g x) in lvl Now we can float the binding for 'lvl'. b) More than that, we may need to abstract wrt a type variable \x -> ... /\a -> let v = ...a... in .... Here the binding for v mentions 'a' but not 'x'. So we abstract wrt 'a', to give this binding for 'v': vp = /\a -> ...a... v = vp a Now the binding for vp can float out unimpeded. I can't remember why this case seemed important enough to deal with, but I certainly found cases where important floats didn't happen if we did not abstract wrt tyvars. With this in mind we can also achieve another goal: lambda lifting. We can make an arbitrary (function) binding float to top level by abstracting wrt *all* local variables, not just type variables, leaving a binding that can be floated right to top level. Whether or not this happens is controlled by a flag. Random comments ~~~~~~~~~~~~~~~ At the moment we never float a binding out to between two adjacent lambdas. For example: @ \x y -> let t = x+x in ... ===> \x -> let t = x+x in \y -> ... @ Reason: this is less efficient in the case where the original lambda is never partially applied. But there's a case I've seen where this might not be true. Consider: @ elEm2 x ys = elem' x ys where elem' _ [] = False elem' x (y:ys) = x==y || elem' x ys @ It turns out that this generates a subexpression of the form @ \deq x ys -> let eq = eqFromEqDict deq in ... @ vwhich might usefully be separated to @ \deq -> let eq = eqFromEqDict deq in \xy -> ... @ Well, maybe. We don't do this at the moment. %************************************************************************ %* * \subsection[floatOutwards]{@floatOutwards@: let-floating interface function} %* * %************************************************************************ \begin{code}

floatOutwards :: FloatOutSwitches -> DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] floatOutwards float_sws dflags us pgm = do { let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" (hcat [ int tlets, ptext (sLit " Lets floated to top level; "), int ntlets, ptext (sLit " Lets floated elsewhere; from "), int lams, ptext (sLit " Lambda groups")]); return (concat binds_s') } floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) floatTopBind bind = case (floatBind bind) of { (fs, floats) -> (fs, bagToList (flattenFloats floats)) }\end{code} %************************************************************************ %* * \subsection[FloatOut-Bind]{Floating in a binding (the business end)} %* * %************************************************************************ \begin{code}

floatBind :: LevelledBind -> (FloatStats, FloatBinds) floatBind (NonRec (TB var level) rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> -- A tiresome hack: -- see Note [Bottoming floats: eta expansion] in SetLevels let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' | otherwise = rhs' in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) } 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. In our example we make a Rec thus: -- v = ...f... -- f = ... b ... 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 (((TB _ dest_lvl), _) : _) = pairs do_pair (TB name level, rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, 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} %* * %************************************************************************ \begin{code}

floatExpr, floatRhs, floatCaseAlt :: Level -> LevelledExpr -> (FloatStats, FloatBinds, CoreExpr) floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss = case (floatExpr lvl arg) of { (fsa, floats, arg') -> case (partitionByMajorLevel lvl floats) of { (floats', heres) -> -- Dump bindings that aren't going to escape from a lambda; -- in particular, we must dump the ones that are bound by -- 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] = floatExpr lvl arg ----------------- floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) floatExpr lvl (App e a) = case (floatExpr lvl e) of { (fse, floats_e, e') -> 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 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 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')) }} floatExpr lvl (Note note@(SCC cc) expr) = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> let -- Annotate bindings floated outwards past an scc expression -- with the cc. We mark that cc as "duplicated", though. annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns in (fs, annotated_defns, Note note expr') } floatExpr lvl (Note note expr) -- Other than SCCs = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Note note expr') } floatExpr lvl (Cast expr co) = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Cast expr' co) } floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case -- I.e. floatExpr for rhs, floatCaseAlt for body = case floatExpr lvl rhs of { (_, rhs_floats, rhs') -> case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') -> (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }} floatExpr lvl (Let bind body) = case (floatBind bind) of { (fsb, bind_floats) -> case (floatExpr lvl body) of { (fse, 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') -> case floatList float_alt alts of { (fsa, fda, alts') -> (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where -- Use floatCaseAlt for the alternatives, so that we -- don't gratuitiously float bindings out of the RHSs float_alt (con, bs, rhs) = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') -> (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }\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

data FloatStats = FlS Int -- Number of top-floats * lambda groups they've been past Int -- Number of non-top-floats * lambda groups they've been past Int -- Number of lambda (groups) seen get_stats :: FloatStats -> (Int, Int, Int) get_stats (FlS a b c) = (a, b, c) zeroStats :: FloatStats zeroStats = FlS 0 0 0 sum_stats :: [FloatStats] -> FloatStats sum_stats xs = foldr add_stats zeroStats xs add_stats :: FloatStats -> FloatStats -> FloatStats add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) = FlS (a1 + a2) (b1 + b2) (c1 + c2) add_to_stats :: FloatStats -> FloatBinds -> FloatStats add_to_stats (FlS a b c) (FB tops others) = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)\end{code} %************************************************************************ %* * \subsection{Utility bits for floating} %* * %************************************************************************ Note [Representation of FloatBinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The FloatBinds types is somewhat important. We can get very large numbers of floating bindings, often all destined for the top level. A typical example is x = [4,2,5,2,5, .... ] Then we get lots of small expressions like (fromInteger 4), which all get lifted to top level. The trouble is that (a) we partition these floating bindings *at every binding site* (b) SetLevels introduces a new bindings site for every float So we had better not look at each binding at each binding site! That is why MajorEnv is represented as a finite map. We keep the bindings destined for the *top* level separate, because we float them out even if they don't escape a *value* lambda; see partitionByMajorLevel. \begin{code}

type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted 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 flattenFloats :: FloatBinds -> Bag FloatBind flattenFloats (FB tops others) = tops `unionBags` flattenMajor others flattenMajor :: MajorEnv -> Bag FloatBind flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag flattenMinor :: MinorEnv -> Bag FloatBind flattenMinor = foldUFM unionBags emptyBag emptyFloats :: FloatBinds emptyFloats = FB emptyBag emptyUFM 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))) 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 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv plusMinor = plusUFM_C unionBags floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] floatsToBindPairs floats binds = foldrBag add binds floats where add (Rec pairs) binds = pairs ++ binds add (NonRec binder rhs) binds = (binder,rhs) : binds install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr = foldrBag install_group expr defn_groups where install_group defns body = Let defns body partitionByMajorLevel, partitionByLevel :: Level -- Partitioning level -> FloatBinds -- Defns to be divided into 2 piles... -> (FloatBinds, -- Defns with level strictly < partition level, Bag FloatBind) -- The rest -- ---- partitionByMajorLevel ---- -- Float it if we escape a value lambda, *or* if we get to the top level -- If we can get to the top level, say "yes" anyway. This means that -- x = f e -- transforms to -- lvl = e -- x = f lvl -- which is as it should be partitionByMajorLevel (Level major _) (FB tops defns) = (FB tops outer, heres `unionBags` flattenMajor inner) where (outer, mb_heres, inner) = splitUFM defns major 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), here_min `unionBags` flattenMinor inner_min `unionBags` flattenMajor inner_maj) where (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major (outer_min, mb_here_min, inner_min) = case mb_here_maj of Nothing -> (emptyUFM, Nothing, emptyUFM) Just min_defns -> splitUFM min_defns minor 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) 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}