2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[FloatOut]{Float bindings outwards (towards the top level)}
6 ``Long-distance'' floating of bindings towards the top level.
9 module FloatOut ( floatOutwards ) where
13 import CoreArity ( etaExpand )
15 import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
16 import ErrUtils ( dumpIfSet_dyn )
17 import CostCentre ( dupifyCC, CostCentre )
18 import Id ( Id, idType, idArity, isBottomingId )
19 import Type ( isUnLiftedType )
20 import SetLevels ( Level(..), LevelledExpr, LevelledBind,
21 setLevels, isTopLvl, tOP_LEVEL )
22 import UniqSupply ( UniqSupply )
37 To float out sub-expressions that can thereby get outside
38 a non-one-shot value lambda, and hence may be shared.
41 To achieve this we may need to do two thing:
43 a) Let-bind the sub-expression:
45 f (g x) ==> let lvl = f (g x) in lvl
47 Now we can float the binding for 'lvl'.
49 b) More than that, we may need to abstract wrt a type variable
51 \x -> ... /\a -> let v = ...a... in ....
53 Here the binding for v mentions 'a' but not 'x'. So we
54 abstract wrt 'a', to give this binding for 'v':
59 Now the binding for vp can float out unimpeded.
60 I can't remember why this case seemed important enough to
61 deal with, but I certainly found cases where important floats
62 didn't happen if we did not abstract wrt tyvars.
64 With this in mind we can also achieve another goal: lambda lifting.
65 We can make an arbitrary (function) binding float to top level by
66 abstracting wrt *all* local variables, not just type variables, leaving
67 a binding that can be floated right to top level. Whether or not this
68 happens is controlled by a flag.
74 At the moment we never float a binding out to between two adjacent
78 \x y -> let t = x+x in ...
80 \x -> let t = x+x in \y -> ...
82 Reason: this is less efficient in the case where the original lambda
83 is never partially applied.
85 But there's a case I've seen where this might not be true. Consider:
91 elem' x (y:ys) = x==y || elem' x ys
93 It turns out that this generates a subexpression of the form
95 \deq x ys -> let eq = eqFromEqDict deq in ...
97 vwhich might usefully be separated to
99 \deq -> let eq = eqFromEqDict deq in \xy -> ...
101 Well, maybe. We don't do this at the moment.
104 %************************************************************************
106 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
108 %************************************************************************
111 floatOutwards :: FloatOutSwitches
114 -> [CoreBind] -> IO [CoreBind]
116 floatOutwards float_sws dflags us pgm
118 let { annotated_w_levels = setLevels float_sws pgm us ;
119 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
122 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
123 (vcat (map ppr annotated_w_levels));
125 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
127 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
128 (hcat [ int tlets, ptext (sLit " Lets floated to top level; "),
129 int ntlets, ptext (sLit " Lets floated elsewhere; from "),
130 int lams, ptext (sLit " Lambda groups")]);
132 return (concat binds_s')
135 floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
137 = case (floatBind bind) of { (fs, floats) ->
138 (fs, bagToList (flattenFloats floats))
142 %************************************************************************
144 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
146 %************************************************************************
149 floatBind :: LevelledBind -> (FloatStats, FloatBinds)
151 floatBind (NonRec (TB var level) rhs)
152 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
155 -- see Note [Bottoming floats: eta expansion] in SetLevels
156 let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
159 in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) }
161 floatBind bind@(Rec pairs)
162 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
163 let rhs_floats = foldr1 plusFloats rhss_floats in
165 if not (isTopLvl bind_dest_lvl) then
166 -- Find which bindings float out at least one lambda beyond this one
167 -- These ones can't mention the binders, because they couldn't
168 -- be escaping a major level if so.
169 -- The ones that are not going further can join the letrec;
170 -- they may not be mutually recursive but the occurrence analyser will
172 case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) ->
174 floats' `plusFloats` unitFloat bind_dest_lvl
175 (Rec (floatsToBindPairs heres new_pairs))) }
177 -- In a recursive binding, *destined for* the top level
178 -- (only), the rhs floats may contain references to the
179 -- bound things. For example
180 -- f = ...(let v = ...f... in b) ...
181 -- might get floated to
184 -- and hence we must (pessimistically) make all the floats recursive
185 -- with the top binding. Later dependency analysis will unravel it.
187 -- This can only happen for bindings destined for the top level,
188 -- because only then will partitionByMajorLevel allow through a binding
189 -- that only differs in its minor level
190 (sum_stats fss, unitFloat tOP_LEVEL
191 (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs)))
194 bind_dest_lvl = getBindLevel bind
196 do_pair (TB name level, rhs)
197 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
198 (fs, rhs_floats, (name, rhs'))
202 %************************************************************************
204 \subsection[FloatOut-Expr]{Floating in expressions}
206 %************************************************************************
209 floatExpr, floatRhs, floatCaseAlt
212 -> (FloatStats, FloatBinds, CoreExpr)
214 floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss
215 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
216 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
217 -- Dump bindings that aren't going to escape from a lambda;
218 -- in particular, we must dump the ones that are bound by
219 -- the rec or case alternative
220 (fsa, floats', install heres arg') }}
222 floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
223 -- See Note [Floating out of RHS]
224 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
225 if exprIsCheap arg' then
228 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
229 (fsa, floats', install heres arg') }}
231 -- Note [Floating out of RHSs]
232 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
233 -- Dump bindings that aren't going to escape from a lambda
234 -- This isn't a scoping issue (the binder isn't in scope in the RHS
235 -- of a non-rec binding)
236 -- Rather, it is to avoid floating the x binding out of
237 -- f (let x = e in b)
238 -- unnecessarily. But we first test for values or trival rhss,
239 -- because (in particular) we don't want to insert new bindings between
240 -- the "=" and the "\". E.g.
241 -- f = \x -> let <bind> in <body>
243 -- f = let <bind> in \x -> <body>
244 -- (a) The simplifier will immediately float it further out, so we may
245 -- as well do so right now; in general, keeping rhss as manifest
247 -- (b) If a float-in pass follows immediately, it might add yet more
248 -- bindings just after the '='. And some of them might (correctly)
249 -- be strict even though the 'let f' is lazy, because f, being a value,
250 -- gets its demand-info zapped by the simplifier.
252 -- We use exprIsCheap because that is also what's used by the simplifier
253 -- to decide whether to float a let out of a let
255 floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
256 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
257 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
259 floatExpr lvl (App e a)
260 = case (floatExpr lvl e) of { (fse, floats_e, e') ->
261 case (floatRhs lvl a) of { (fsa, floats_a, a') ->
262 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
264 floatExpr _ lam@(Lam _ _)
266 (bndrs_w_lvls, body) = collectBinders lam
267 bndrs = [b | TB b _ <- bndrs_w_lvls]
268 lvls = [l | TB _ l <- bndrs_w_lvls]
270 -- For the all-tyvar case we are prepared to pull
271 -- the lets out, to implement the float-out-of-big-lambda
272 -- transform; but otherwise we only float bindings that are
273 -- going to escape a value lambda.
274 -- In particular, for one-shot lambdas we don't float things
275 -- out; we get no saving by so doing.
276 partition_fn | all isTyVar bndrs = partitionByLevel
277 | otherwise = partitionByMajorLevel
279 case (floatExpr (last lvls) body) of { (fs, floats, body') ->
281 -- Dump any bindings which absolutely cannot go any further
282 case (partition_fn (head lvls) floats) of { (floats', heres) ->
284 (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
287 floatExpr lvl (Note note@(SCC cc) expr)
288 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
290 -- Annotate bindings floated outwards past an scc expression
291 -- with the cc. We mark that cc as "duplicated", though.
293 annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns
295 (fs, annotated_defns, Note note expr') }
297 floatExpr lvl (Note note expr) -- Other than SCCs
298 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
299 (fs, floating_defns, Note note expr') }
301 floatExpr lvl (Cast expr co)
302 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
303 (fs, floating_defns, Cast expr' co) }
305 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
306 | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
307 -- I.e. floatExpr for rhs, floatCaseAlt for body
308 = case floatExpr lvl rhs of { (_, rhs_floats, rhs') ->
309 case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
310 (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}
312 floatExpr lvl (Let bind body)
313 = case (floatBind bind) of { (fsb, bind_floats) ->
314 case (floatExpr lvl body) of { (fse, body_floats, body') ->
316 bind_floats `plusFloats` body_floats,
319 floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
320 = case floatExpr lvl scrut of { (fse, fde, scrut') ->
321 case floatList float_alt alts of { (fsa, fda, alts') ->
322 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
325 -- Use floatCaseAlt for the alternatives, so that we
326 -- don't gratuitiously float bindings out of the RHSs
327 float_alt (con, bs, rhs)
328 = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
329 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
332 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
333 floatList _ [] = (zeroStats, emptyFloats, [])
334 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
335 case floatList f as of { (fs_as, binds_as, bs) ->
336 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
338 getBindLevel :: Bind (TaggedBndr Level) -> Level
339 getBindLevel (NonRec (TB _ lvl) _) = lvl
340 getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
341 getBindLevel (Rec []) = panic "getBindLevel Rec []"
344 %************************************************************************
346 \subsection{Utility bits for floating stats}
348 %************************************************************************
350 I didn't implement this with unboxed numbers. I don't want to be too
351 strict in this stuff, as it is rarely turned on. (WDP 95/09)
355 = FlS Int -- Number of top-floats * lambda groups they've been past
356 Int -- Number of non-top-floats * lambda groups they've been past
357 Int -- Number of lambda (groups) seen
359 get_stats :: FloatStats -> (Int, Int, Int)
360 get_stats (FlS a b c) = (a, b, c)
362 zeroStats :: FloatStats
363 zeroStats = FlS 0 0 0
365 sum_stats :: [FloatStats] -> FloatStats
366 sum_stats xs = foldr add_stats zeroStats xs
368 add_stats :: FloatStats -> FloatStats -> FloatStats
369 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
370 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
372 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
373 add_to_stats (FlS a b c) (FB tops others)
374 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
378 %************************************************************************
380 \subsection{Utility bits for floating}
382 %************************************************************************
384 Note [Representation of FloatBinds]
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386 The FloatBinds types is somewhat important. We can get very large numbers
387 of floating bindings, often all destined for the top level. A typical example
388 is x = [4,2,5,2,5, .... ]
389 Then we get lots of small expressions like (fromInteger 4), which all get
393 (a) we partition these floating bindings *at every binding site*
394 (b) SetLevels introduces a new bindings site for every float
395 So we had better not look at each binding at each binding site!
397 That is why MajorEnv is represented as a finite map.
399 We keep the bindings destined for the *top* level separate, because
400 we float them out even if they don't escape a *value* lambda; see
401 partitionByMajorLevel.
405 type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted
407 data FloatBinds = FB !(Bag FloatBind) -- Destined for top level
408 !MajorEnv -- Levels other than top
409 -- See Note [Representation of FloatBinds]
411 type MajorEnv = UniqFM MinorEnv -- Keyed by major level
412 type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level
414 flattenFloats :: FloatBinds -> Bag FloatBind
415 flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
417 flattenMajor :: MajorEnv -> Bag FloatBind
418 flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag
420 flattenMinor :: MinorEnv -> Bag FloatBind
421 flattenMinor = foldUFM unionBags emptyBag
423 emptyFloats :: FloatBinds
424 emptyFloats = FB emptyBag emptyUFM
426 unitFloat :: Level -> FloatBind -> FloatBinds
427 unitFloat lvl@(Level major minor) b
428 | isTopLvl lvl = FB (unitBag b) emptyUFM
429 | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b)))
431 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
432 plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
434 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
435 plusMajor = plusUFM_C plusMinor
437 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
438 plusMinor = plusUFM_C unionBags
440 floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
441 floatsToBindPairs floats binds = foldrBag add binds floats
443 add (Rec pairs) binds = pairs ++ binds
444 add (NonRec binder rhs) binds = (binder,rhs) : binds
446 install :: Bag FloatBind -> CoreExpr -> CoreExpr
447 install defn_groups expr
448 = foldrBag install_group expr defn_groups
450 install_group defns body = Let defns body
452 partitionByMajorLevel, partitionByLevel
453 :: Level -- Partitioning level
454 -> FloatBinds -- Defns to be divided into 2 piles...
455 -> (FloatBinds, -- Defns with level strictly < partition level,
456 Bag FloatBind) -- The rest
458 -- ---- partitionByMajorLevel ----
459 -- Float it if we escape a value lambda, *or* if we get to the top level
460 -- If we can get to the top level, say "yes" anyway. This means that
465 -- which is as it should be
467 partitionByMajorLevel (Level major _) (FB tops defns)
468 = (FB tops outer, heres `unionBags` flattenMajor inner)
470 (outer, mb_heres, inner) = splitUFM defns major
471 heres = case mb_heres of
473 Just h -> flattenMinor h
475 partitionByLevel (Level major minor) (FB tops defns)
476 = (FB tops (outer_maj `plusMajor` unitUFM major outer_min),
477 here_min `unionBags` flattenMinor inner_min
478 `unionBags` flattenMajor inner_maj)
481 (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major
482 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
483 Nothing -> (emptyUFM, Nothing, emptyUFM)
484 Just min_defns -> splitUFM min_defns minor
485 here_min = mb_here_min `orElse` emptyBag
487 wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
488 wrapCostCentre cc (FB tops defns)
489 = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns)
491 wrap_defns = mapBag wrap_one
492 wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)
493 wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs)