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
14 import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
15 import ErrUtils ( dumpIfSet_dyn )
16 import CostCentre ( dupifyCC, CostCentre )
17 import Id ( Id, idType )
18 import Type ( isUnLiftedType )
19 import SetLevels ( Level(..), LevelledExpr, LevelledBind,
20 setLevels, isTopLvl, tOP_LEVEL )
21 import UniqSupply ( UniqSupply )
36 To float out sub-expressions that can thereby get outside
37 a non-one-shot value lambda, and hence may be shared.
40 To achieve this we may need to do two thing:
42 a) Let-bind the sub-expression:
44 f (g x) ==> let lvl = f (g x) in lvl
46 Now we can float the binding for 'lvl'.
48 b) More than that, we may need to abstract wrt a type variable
50 \x -> ... /\a -> let v = ...a... in ....
52 Here the binding for v mentions 'a' but not 'x'. So we
53 abstract wrt 'a', to give this binding for 'v':
58 Now the binding for vp can float out unimpeded.
59 I can't remember why this case seemed important enough to
60 deal with, but I certainly found cases where important floats
61 didn't happen if we did not abstract wrt tyvars.
63 With this in mind we can also achieve another goal: lambda lifting.
64 We can make an arbitrary (function) binding float to top level by
65 abstracting wrt *all* local variables, not just type variables, leaving
66 a binding that can be floated right to top level. Whether or not this
67 happens is controlled by a flag.
73 At the moment we never float a binding out to between two adjacent
77 \x y -> let t = x+x in ...
79 \x -> let t = x+x in \y -> ...
81 Reason: this is less efficient in the case where the original lambda
82 is never partially applied.
84 But there's a case I've seen where this might not be true. Consider:
90 elem' x (y:ys) = x==y || elem' x ys
92 It turns out that this generates a subexpression of the form
94 \deq x ys -> let eq = eqFromEqDict deq in ...
96 vwhich might usefully be separated to
98 \deq -> let eq = eqFromEqDict deq in \xy -> ...
100 Well, maybe. We don't do this at the moment.
103 %************************************************************************
105 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
107 %************************************************************************
110 floatOutwards :: FloatOutSwitches
113 -> [CoreBind] -> IO [CoreBind]
115 floatOutwards float_sws dflags us pgm
117 let { annotated_w_levels = setLevels float_sws pgm us ;
118 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
121 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
122 (vcat (map ppr annotated_w_levels));
124 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
126 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
127 (hcat [ int tlets, ptext (sLit " Lets floated to top level; "),
128 int ntlets, ptext (sLit " Lets floated elsewhere; from "),
129 int lams, ptext (sLit " Lambda groups")]);
131 return (concat binds_s')
134 floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
136 = case (floatBind bind) of { (fs, floats) ->
137 (fs, bagToList (flattenFloats floats))
141 %************************************************************************
143 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
145 %************************************************************************
149 floatBind :: LevelledBind -> (FloatStats, FloatBinds)
151 floatBind (NonRec (TB name level) rhs)
152 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
153 (fs, rhs_floats `plusFloats` unitFloat level (NonRec name rhs')) }
155 floatBind bind@(Rec pairs)
156 = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
157 let rhs_floats = foldr1 plusFloats rhss_floats in
159 if not (isTopLvl bind_dest_lvl) then
160 -- Find which bindings float out at least one lambda beyond this one
161 -- These ones can't mention the binders, because they couldn't
162 -- be escaping a major level if so.
163 -- The ones that are not going further can join the letrec;
164 -- they may not be mutually recursive but the occurrence analyser will
166 case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) ->
168 floats' `plusFloats` unitFloat bind_dest_lvl
169 (Rec (floatsToBindPairs heres new_pairs))) }
171 -- In a recursive binding, *destined for* the top level
172 -- (only), the rhs floats may contain references to the
173 -- bound things. For example
174 -- f = ...(let v = ...f... in b) ...
175 -- might get floated to
178 -- and hence we must (pessimistically) make all the floats recursive
179 -- with the top binding. Later dependency analysis will unravel it.
181 -- This can only happen for bindings destined for the top level,
182 -- because only then will partitionByMajorLevel allow through a binding
183 -- that only differs in its minor level
184 (sum_stats fss, unitFloat tOP_LEVEL
185 (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs)))
188 bind_dest_lvl = getBindLevel bind
190 do_pair (TB name level, rhs)
191 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
192 (fs, rhs_floats, (name, rhs'))
196 %************************************************************************
198 \subsection[FloatOut-Expr]{Floating in expressions}
200 %************************************************************************
203 floatExpr, floatRhs, floatCaseAlt
206 -> (FloatStats, FloatBinds, CoreExpr)
208 floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss
209 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
210 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
211 -- Dump bindings that aren't going to escape from a lambda;
212 -- in particular, we must dump the ones that are bound by
213 -- the rec or case alternative
214 (fsa, floats', install heres arg') }}
216 floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
217 -- See Note [Floating out of RHS]
218 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
219 if exprIsCheap arg' then
222 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
223 (fsa, floats', install heres arg') }}
225 -- Note [Floating out of RHSs]
226 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
227 -- Dump bindings that aren't going to escape from a lambda
228 -- This isn't a scoping issue (the binder isn't in scope in the RHS
229 -- of a non-rec binding)
230 -- Rather, it is to avoid floating the x binding out of
231 -- f (let x = e in b)
232 -- unnecessarily. But we first test for values or trival rhss,
233 -- because (in particular) we don't want to insert new bindings between
234 -- the "=" and the "\". E.g.
235 -- f = \x -> let <bind> in <body>
237 -- f = let <bind> in \x -> <body>
238 -- (a) The simplifier will immediately float it further out, so we may
239 -- as well do so right now; in general, keeping rhss as manifest
241 -- (b) If a float-in pass follows immediately, it might add yet more
242 -- bindings just after the '='. And some of them might (correctly)
243 -- be strict even though the 'let f' is lazy, because f, being a value,
244 -- gets its demand-info zapped by the simplifier.
246 -- We use exprIsCheap because that is also what's used by the simplifier
247 -- to decide whether to float a let out of a let
249 floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
250 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
251 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
253 floatExpr lvl (App e a)
254 = case (floatExpr lvl e) of { (fse, floats_e, e') ->
255 case (floatRhs lvl a) of { (fsa, floats_a, a') ->
256 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
258 floatExpr _ lam@(Lam _ _)
260 (bndrs_w_lvls, body) = collectBinders lam
261 bndrs = [b | TB b _ <- bndrs_w_lvls]
262 lvls = [l | TB _ l <- bndrs_w_lvls]
264 -- For the all-tyvar case we are prepared to pull
265 -- the lets out, to implement the float-out-of-big-lambda
266 -- transform; but otherwise we only float bindings that are
267 -- going to escape a value lambda.
268 -- In particular, for one-shot lambdas we don't float things
269 -- out; we get no saving by so doing.
270 partition_fn | all isTyVar bndrs = partitionByLevel
271 | otherwise = partitionByMajorLevel
273 case (floatExpr (last lvls) body) of { (fs, floats, body') ->
275 -- Dump any bindings which absolutely cannot go any further
276 case (partition_fn (head lvls) floats) of { (floats', heres) ->
278 (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
281 floatExpr lvl (Note note@(SCC cc) expr)
282 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
284 -- Annotate bindings floated outwards past an scc expression
285 -- with the cc. We mark that cc as "duplicated", though.
287 annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns
289 (fs, annotated_defns, Note note expr') }
291 floatExpr lvl (Note note expr) -- Other than SCCs
292 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
293 (fs, floating_defns, Note note expr') }
295 floatExpr lvl (Cast expr co)
296 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
297 (fs, floating_defns, Cast expr' co) }
299 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
300 | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
301 -- I.e. floatExpr for rhs, floatCaseAlt for body
302 = case floatExpr lvl rhs of { (_, rhs_floats, rhs') ->
303 case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
304 (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}
306 floatExpr lvl (Let bind body)
307 = case (floatBind bind) of { (fsb, bind_floats) ->
308 case (floatExpr lvl body) of { (fse, body_floats, body') ->
310 bind_floats `plusFloats` body_floats,
313 floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
314 = case floatExpr lvl scrut of { (fse, fde, scrut') ->
315 case floatList float_alt alts of { (fsa, fda, alts') ->
316 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
319 -- Use floatCaseAlt for the alternatives, so that we
320 -- don't gratuitiously float bindings out of the RHSs
321 float_alt (con, bs, rhs)
322 = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
323 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
326 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
327 floatList _ [] = (zeroStats, emptyFloats, [])
328 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
329 case floatList f as of { (fs_as, binds_as, bs) ->
330 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
332 getBindLevel :: Bind (TaggedBndr Level) -> Level
333 getBindLevel (NonRec (TB _ lvl) _) = lvl
334 getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
335 getBindLevel (Rec []) = panic "getBindLevel Rec []"
338 %************************************************************************
340 \subsection{Utility bits for floating stats}
342 %************************************************************************
344 I didn't implement this with unboxed numbers. I don't want to be too
345 strict in this stuff, as it is rarely turned on. (WDP 95/09)
349 = FlS Int -- Number of top-floats * lambda groups they've been past
350 Int -- Number of non-top-floats * lambda groups they've been past
351 Int -- Number of lambda (groups) seen
353 get_stats :: FloatStats -> (Int, Int, Int)
354 get_stats (FlS a b c) = (a, b, c)
356 zeroStats :: FloatStats
357 zeroStats = FlS 0 0 0
359 sum_stats :: [FloatStats] -> FloatStats
360 sum_stats xs = foldr add_stats zeroStats xs
362 add_stats :: FloatStats -> FloatStats -> FloatStats
363 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
364 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
366 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
367 add_to_stats (FlS a b c) (FB tops others)
368 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
372 %************************************************************************
374 \subsection{Utility bits for floating}
376 %************************************************************************
378 Note [Representation of FloatBinds]
379 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
380 The FloatBinds types is somewhat important. We can get very large numbers
381 of floating bindings, often all destined for the top level. A typical example
382 is x = [4,2,5,2,5, .... ]
383 Then we get lots of small expressions like (fromInteger 4), which all get
387 (a) we partition these floating bindings *at every binding site*
388 (b) SetLevels introduces a new bindings site for every float
389 So we had better not look at each binding at each binding site!
391 That is why MajorEnv is represented as a finite map.
393 We keep the bindings destined for the *top* level separate, because
394 we float them out even if they don't escape a *value* lambda; see
395 partitionByMajorLevel.
399 type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted
401 data FloatBinds = FB !(Bag FloatBind) -- Destined for top level
402 !MajorEnv -- Levels other than top
403 -- See Note [Representation of FloatBinds]
405 type MajorEnv = UniqFM MinorEnv -- Keyed by major level
406 type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level
408 flattenFloats :: FloatBinds -> Bag FloatBind
409 flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
411 flattenMajor :: MajorEnv -> Bag FloatBind
412 flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag
414 flattenMinor :: MinorEnv -> Bag FloatBind
415 flattenMinor = foldUFM unionBags emptyBag
417 emptyFloats :: FloatBinds
418 emptyFloats = FB emptyBag emptyUFM
420 unitFloat :: Level -> FloatBind -> FloatBinds
421 unitFloat lvl@(Level major minor) b
422 | isTopLvl lvl = FB (unitBag b) emptyUFM
423 | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b)))
425 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
426 plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
428 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
429 plusMajor = plusUFM_C plusMinor
431 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
432 plusMinor = plusUFM_C unionBags
434 floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
435 floatsToBindPairs floats binds = foldrBag add binds floats
437 add (Rec pairs) binds = pairs ++ binds
438 add (NonRec binder rhs) binds = (binder,rhs) : binds
440 install :: Bag FloatBind -> CoreExpr -> CoreExpr
441 install defn_groups expr
442 = foldrBag install_group expr defn_groups
444 install_group defns body = Let defns body
446 partitionByMajorLevel, partitionByLevel
447 :: Level -- Partitioning level
448 -> FloatBinds -- Defns to be divided into 2 piles...
449 -> (FloatBinds, -- Defns with level strictly < partition level,
450 Bag FloatBind) -- The rest
452 -- ---- partitionByMajorLevel ----
453 -- Float it if we escape a value lambda, *or* if we get to the top level
454 -- If we can get to the top level, say "yes" anyway. This means that
459 -- which is as it should be
461 partitionByMajorLevel (Level major _) (FB tops defns)
462 = (FB tops outer, heres `unionBags` flattenMajor inner)
464 (outer, mb_heres, inner) = splitUFM defns major
465 heres = case mb_heres of
467 Just h -> flattenMinor h
469 partitionByLevel (Level major minor) (FB tops defns)
470 = (FB tops (outer_maj `plusMajor` unitUFM major outer_min),
471 here_min `unionBags` flattenMinor inner_min
472 `unionBags` flattenMajor inner_maj)
475 (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major
476 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
477 Nothing -> (emptyUFM, Nothing, emptyUFM)
478 Just min_defns -> splitUFM min_defns minor
479 here_min = mb_here_min `orElse` emptyBag
481 wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
482 wrapCostCentre cc (FB tops defns)
483 = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns)
485 wrap_defns = mapBag wrap_one
486 wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)
487 wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs)