% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[FloatOut]{Float bindings outwards (towards the top level)} ``Long-distance'' floating of bindings towards the top level. \begin{code}

    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 <bind> in
We do not want f = let <bind> 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} %* * %************************************************************************ I didn't implement this with unboxed numbers. I don't want to be too strict in this stuff, as it is rarely turned on. (WDP 95/09) \begin{code}

    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}