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 )
14 import CoreMonad ( FloatOutSwitches(..) )
16 import DynFlags ( DynFlags, DynFlag(..) )
17 import ErrUtils ( dumpIfSet_dyn )
18 import CostCentre ( dupifyCC, CostCentre )
19 import Id ( Id, idType, idArity, isBottomingId )
20 import Type ( isUnLiftedType )
21 import SetLevels ( Level(..), LevelledExpr, LevelledBind,
22 setLevels, isTopLvl, tOP_LEVEL )
23 import UniqSupply ( UniqSupply )
38 To float out sub-expressions that can thereby get outside
39 a non-one-shot value lambda, and hence may be shared.
42 To achieve this we may need to do two thing:
44 a) Let-bind the sub-expression:
46 f (g x) ==> let lvl = f (g x) in lvl
48 Now we can float the binding for 'lvl'.
50 b) More than that, we may need to abstract wrt a type variable
52 \x -> ... /\a -> let v = ...a... in ....
54 Here the binding for v mentions 'a' but not 'x'. So we
55 abstract wrt 'a', to give this binding for 'v':
60 Now the binding for vp can float out unimpeded.
61 I can't remember why this case seemed important enough to
62 deal with, but I certainly found cases where important floats
63 didn't happen if we did not abstract wrt tyvars.
65 With this in mind we can also achieve another goal: lambda lifting.
66 We can make an arbitrary (function) binding float to top level by
67 abstracting wrt *all* local variables, not just type variables, leaving
68 a binding that can be floated right to top level. Whether or not this
69 happens is controlled by a flag.
75 At the moment we never float a binding out to between two adjacent
79 \x y -> let t = x+x in ...
81 \x -> let t = x+x in \y -> ...
83 Reason: this is less efficient in the case where the original lambda
84 is never partially applied.
86 But there's a case I've seen where this might not be true. Consider:
92 elem' x (y:ys) = x==y || elem' x ys
94 It turns out that this generates a subexpression of the form
96 \deq x ys -> let eq = eqFromEqDict deq in ...
98 vwhich might usefully be separated to
100 \deq -> let eq = eqFromEqDict deq in \xy -> ...
102 Well, maybe. We don't do this at the moment.
105 %************************************************************************
107 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
109 %************************************************************************
112 floatOutwards :: FloatOutSwitches
115 -> [CoreBind] -> IO [CoreBind]
117 floatOutwards float_sws dflags us pgm
119 let { annotated_w_levels = setLevels float_sws pgm us ;
120 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
123 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
124 (vcat (map ppr annotated_w_levels));
126 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
128 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
129 (hcat [ int tlets, ptext (sLit " Lets floated to top level; "),
130 int ntlets, ptext (sLit " Lets floated elsewhere; from "),
131 int lams, ptext (sLit " Lambda groups")]);
133 return (concat binds_s')
136 floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
138 = case (floatBind bind) of { (fs, floats) ->
139 (fs, bagToList (flattenFloats floats))
143 %************************************************************************
145 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
147 %************************************************************************
150 floatBind :: LevelledBind -> (FloatStats, FloatBinds)
152 floatBind (NonRec (TB var level) rhs)
153 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
156 -- see Note [Bottoming floats: eta expansion] in SetLevels
157 let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
160 in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) }
162 floatBind bind@(Rec pairs)
163 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
164 let rhs_floats = foldr1 plusFloats rhss_floats in
166 if not (isTopLvl bind_dest_lvl) then
167 -- Find which bindings float out at least one lambda beyond this one
168 -- These ones can't mention the binders, because they couldn't
169 -- be escaping a major level if so.
170 -- The ones that are not going further can join the letrec;
171 -- they may not be mutually recursive but the occurrence analyser will
173 case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) ->
175 floats' `plusFloats` unitFloat bind_dest_lvl
176 (Rec (floatsToBindPairs heres new_pairs))) }
178 -- In a recursive binding, *destined for* the top level
179 -- (only), the rhs floats may contain references to the
180 -- bound things. For example
181 -- f = ...(let v = ...f... in b) ...
182 -- might get floated to
185 -- and hence we must (pessimistically) make all the floats recursive
186 -- with the top binding. Later dependency analysis will unravel it.
188 -- This can only happen for bindings destined for the top level,
189 -- because only then will partitionByMajorLevel allow through a binding
190 -- that only differs in its minor level
191 (sum_stats fss, unitFloat tOP_LEVEL
192 (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs)))
195 bind_dest_lvl = getBindLevel bind
197 do_pair (TB name level, rhs)
198 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
199 (fs, rhs_floats, (name, rhs'))
203 %************************************************************************
205 \subsection[FloatOut-Expr]{Floating in expressions}
207 %************************************************************************
210 floatExpr, floatRhs, floatCaseAlt
213 -> (FloatStats, FloatBinds, CoreExpr)
215 floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss
216 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
217 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
218 -- Dump bindings that aren't going to escape from a lambda;
219 -- in particular, we must dump the ones that are bound by
220 -- the rec or case alternative
221 (fsa, floats', install heres arg') }}
223 floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
224 -- See Note [Floating out of RHS]
225 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
226 if exprIsCheap arg' then
229 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
230 (fsa, floats', install heres arg') }}
232 -- Note [Floating out of RHSs]
233 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
234 -- Dump bindings that aren't going to escape from a lambda
235 -- This isn't a scoping issue (the binder isn't in scope in the RHS
236 -- of a non-rec binding)
237 -- Rather, it is to avoid floating the x binding out of
238 -- f (let x = e in b)
239 -- unnecessarily. But we first test for values or trival rhss,
240 -- because (in particular) we don't want to insert new bindings between
241 -- the "=" and the "\". E.g.
242 -- f = \x -> let <bind> in <body>
244 -- f = let <bind> in \x -> <body>
245 -- (a) The simplifier will immediately float it further out, so we may
246 -- as well do so right now; in general, keeping rhss as manifest
248 -- (b) If a float-in pass follows immediately, it might add yet more
249 -- bindings just after the '='. And some of them might (correctly)
250 -- be strict even though the 'let f' is lazy, because f, being a value,
251 -- gets its demand-info zapped by the simplifier.
253 -- We use exprIsCheap because that is also what's used by the simplifier
254 -- to decide whether to float a let out of a let
256 floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
257 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
258 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
260 floatExpr lvl (App e a)
261 = case (floatExpr lvl e) of { (fse, floats_e, e') ->
262 case (floatRhs lvl a) of { (fsa, floats_a, a') ->
263 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
265 floatExpr _ lam@(Lam _ _)
267 (bndrs_w_lvls, body) = collectBinders lam
268 bndrs = [b | TB b _ <- bndrs_w_lvls]
269 lvls = [l | TB _ l <- bndrs_w_lvls]
271 -- For the all-tyvar case we are prepared to pull
272 -- the lets out, to implement the float-out-of-big-lambda
273 -- transform; but otherwise we only float bindings that are
274 -- going to escape a value lambda.
275 -- In particular, for one-shot lambdas we don't float things
276 -- out; we get no saving by so doing.
277 partition_fn | all isTyVar bndrs = partitionByLevel
278 | otherwise = partitionByMajorLevel
280 case (floatExpr (last lvls) body) of { (fs, floats, body') ->
282 -- Dump any bindings which absolutely cannot go any further
283 case (partition_fn (head lvls) floats) of { (floats', heres) ->
285 (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
288 floatExpr lvl (Note note@(SCC cc) expr)
289 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
291 -- Annotate bindings floated outwards past an scc expression
292 -- with the cc. We mark that cc as "duplicated", though.
294 annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns
296 (fs, annotated_defns, Note note expr') }
298 floatExpr lvl (Note note expr) -- Other than SCCs
299 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
300 (fs, floating_defns, Note note expr') }
302 floatExpr lvl (Cast expr co)
303 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
304 (fs, floating_defns, Cast expr' co) }
306 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
307 | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
308 -- I.e. floatExpr for rhs, floatCaseAlt for body
309 = case floatExpr lvl rhs of { (_, rhs_floats, rhs') ->
310 case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
311 (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}
313 floatExpr lvl (Let bind body)
314 = case (floatBind bind) of { (fsb, bind_floats) ->
315 case (floatExpr lvl body) of { (fse, body_floats, body') ->
317 bind_floats `plusFloats` body_floats,
320 floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
321 = case floatExpr lvl scrut of { (fse, fde, scrut') ->
322 case floatList float_alt alts of { (fsa, fda, alts') ->
323 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
326 -- Use floatCaseAlt for the alternatives, so that we
327 -- don't gratuitiously float bindings out of the RHSs
328 float_alt (con, bs, rhs)
329 = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
330 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
333 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
334 floatList _ [] = (zeroStats, emptyFloats, [])
335 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
336 case floatList f as of { (fs_as, binds_as, bs) ->
337 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
339 getBindLevel :: Bind (TaggedBndr Level) -> Level
340 getBindLevel (NonRec (TB _ lvl) _) = lvl
341 getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
342 getBindLevel (Rec []) = panic "getBindLevel Rec []"
345 %************************************************************************
347 \subsection{Utility bits for floating stats}
349 %************************************************************************
351 I didn't implement this with unboxed numbers. I don't want to be too
352 strict in this stuff, as it is rarely turned on. (WDP 95/09)
356 = FlS Int -- Number of top-floats * lambda groups they've been past
357 Int -- Number of non-top-floats * lambda groups they've been past
358 Int -- Number of lambda (groups) seen
360 get_stats :: FloatStats -> (Int, Int, Int)
361 get_stats (FlS a b c) = (a, b, c)
363 zeroStats :: FloatStats
364 zeroStats = FlS 0 0 0
366 sum_stats :: [FloatStats] -> FloatStats
367 sum_stats xs = foldr add_stats zeroStats xs
369 add_stats :: FloatStats -> FloatStats -> FloatStats
370 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
371 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
373 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
374 add_to_stats (FlS a b c) (FB tops others)
375 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
379 %************************************************************************
381 \subsection{Utility bits for floating}
383 %************************************************************************
385 Note [Representation of FloatBinds]
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
387 The FloatBinds types is somewhat important. We can get very large numbers
388 of floating bindings, often all destined for the top level. A typical example
389 is x = [4,2,5,2,5, .... ]
390 Then we get lots of small expressions like (fromInteger 4), which all get
394 (a) we partition these floating bindings *at every binding site*
395 (b) SetLevels introduces a new bindings site for every float
396 So we had better not look at each binding at each binding site!
398 That is why MajorEnv is represented as a finite map.
400 We keep the bindings destined for the *top* level separate, because
401 we float them out even if they don't escape a *value* lambda; see
402 partitionByMajorLevel.
406 type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted
408 data FloatBinds = FB !(Bag FloatBind) -- Destined for top level
409 !MajorEnv -- Levels other than top
410 -- See Note [Representation of FloatBinds]
412 type MajorEnv = UniqFM MinorEnv -- Keyed by major level
413 type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level
415 flattenFloats :: FloatBinds -> Bag FloatBind
416 flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
418 flattenMajor :: MajorEnv -> Bag FloatBind
419 flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag
421 flattenMinor :: MinorEnv -> Bag FloatBind
422 flattenMinor = foldUFM unionBags emptyBag
424 emptyFloats :: FloatBinds
425 emptyFloats = FB emptyBag emptyUFM
427 unitFloat :: Level -> FloatBind -> FloatBinds
428 unitFloat lvl@(Level major minor) b
429 | isTopLvl lvl = FB (unitBag b) emptyUFM
430 | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b)))
432 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
433 plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
435 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
436 plusMajor = plusUFM_C plusMinor
438 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
439 plusMinor = plusUFM_C unionBags
441 floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
442 floatsToBindPairs floats binds = foldrBag add binds floats
444 add (Rec pairs) binds = pairs ++ binds
445 add (NonRec binder rhs) binds = (binder,rhs) : binds
447 install :: Bag FloatBind -> CoreExpr -> CoreExpr
448 install defn_groups expr
449 = foldrBag install_group expr defn_groups
451 install_group defns body = Let defns body
453 partitionByMajorLevel, partitionByLevel
454 :: Level -- Partitioning level
455 -> FloatBinds -- Defns to be divided into 2 piles...
456 -> (FloatBinds, -- Defns with level strictly < partition level,
457 Bag FloatBind) -- The rest
459 -- ---- partitionByMajorLevel ----
460 -- Float it if we escape a value lambda, *or* if we get to the top level
461 -- If we can get to the top level, say "yes" anyway. This means that
466 -- which is as it should be
468 partitionByMajorLevel (Level major _) (FB tops defns)
469 = (FB tops outer, heres `unionBags` flattenMajor inner)
471 (outer, mb_heres, inner) = splitUFM defns major
472 heres = case mb_heres of
474 Just h -> flattenMinor h
476 partitionByLevel (Level major minor) (FB tops defns)
477 = (FB tops (outer_maj `plusMajor` unitUFM major outer_min),
478 here_min `unionBags` flattenMinor inner_min
479 `unionBags` flattenMajor inner_maj)
482 (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major
483 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
484 Nothing -> (emptyUFM, Nothing, emptyUFM)
485 Just min_defns -> splitUFM min_defns minor
486 here_min = mb_here_min `orElse` emptyBag
488 wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
489 wrapCostCentre cc (FB tops defns)
490 = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns)
492 wrap_defns = mapBag wrap_one
493 wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)
494 wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs)