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,
23 import UniqSupply ( UniqSupply )
29 import qualified Data.IntMap as M
31 #include "HsVersions.h"
40 To float out sub-expressions that can thereby get outside
41 a non-one-shot value lambda, and hence may be shared.
44 To achieve this we may need to do two thing:
46 a) Let-bind the sub-expression:
48 f (g x) ==> let lvl = f (g x) in lvl
50 Now we can float the binding for 'lvl'.
52 b) More than that, we may need to abstract wrt a type variable
54 \x -> ... /\a -> let v = ...a... in ....
56 Here the binding for v mentions 'a' but not 'x'. So we
57 abstract wrt 'a', to give this binding for 'v':
62 Now the binding for vp can float out unimpeded.
63 I can't remember why this case seemed important enough to
64 deal with, but I certainly found cases where important floats
65 didn't happen if we did not abstract wrt tyvars.
67 With this in mind we can also achieve another goal: lambda lifting.
68 We can make an arbitrary (function) binding float to top level by
69 abstracting wrt *all* local variables, not just type variables, leaving
70 a binding that can be floated right to top level. Whether or not this
71 happens is controlled by a flag.
77 At the moment we never float a binding out to between two adjacent
81 \x y -> let t = x+x in ...
83 \x -> let t = x+x in \y -> ...
85 Reason: this is less efficient in the case where the original lambda
86 is never partially applied.
88 But there's a case I've seen where this might not be true. Consider:
94 elem' x (y:ys) = x==y || elem' x ys
96 It turns out that this generates a subexpression of the form
98 \deq x ys -> let eq = eqFromEqDict deq in ...
100 vwhich might usefully be separated to
102 \deq -> let eq = eqFromEqDict deq in \xy -> ...
104 Well, maybe. We don't do this at the moment.
107 %************************************************************************
109 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
111 %************************************************************************
114 floatOutwards :: FloatOutSwitches
117 -> [CoreBind] -> IO [CoreBind]
119 floatOutwards float_sws dflags us pgm
121 let { annotated_w_levels = setLevels float_sws pgm us ;
122 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
125 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
126 (vcat (map ppr annotated_w_levels));
128 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
130 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
131 (hcat [ int tlets, ptext (sLit " Lets floated to top level; "),
132 int ntlets, ptext (sLit " Lets floated elsewhere; from "),
133 int lams, ptext (sLit " Lambda groups")]);
135 return (concat binds_s')
138 floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
140 = case (floatBind bind) of { (fs, floats) ->
141 (fs, bagToList (flattenFloats floats)) }
144 %************************************************************************
146 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
148 %************************************************************************
151 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 (Rec pairs)
163 = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
164 -- NB: the rhs floats may contain references to the
165 -- bound things. For example
166 -- f = ...(let v = ...f... in b) ...
167 if not (isTopLvl dest_lvl) then
168 -- Find which bindings float out at least one lambda beyond this one
169 -- These ones can't mention the binders, because they couldn't
170 -- be escaping a major level if so.
171 -- The ones that are not going further can join the letrec;
172 -- they may not be mutually recursive but the occurrence analyser will
173 -- find that out. In our example we make a Rec thus:
176 case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) ->
177 (fs, floats' `plusFloats` unitFloat dest_lvl
178 (Rec (floatsToBindPairs heres new_pairs))) }
180 -- For top level, no need to partition; just make them all recursive
181 -- (And the partition wouldn't work because they'd all end up in floats')
182 (fs, unitFloat dest_lvl
183 (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) }
185 (((TB _ dest_lvl), _) : _) = pairs
187 do_pair (TB name level, rhs)
188 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
189 (fs, rhs_floats, (name, rhs')) }
192 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
193 floatList _ [] = (zeroStats, emptyFloats, [])
194 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
195 case floatList f as of { (fs_as, binds_as, bs) ->
196 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
200 %************************************************************************
202 \subsection[FloatOut-Expr]{Floating in expressions}
204 %************************************************************************
207 floatExpr, floatRhs, floatCaseAlt
210 -> (FloatStats, FloatBinds, CoreExpr)
212 floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss
213 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
214 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
215 -- Dump bindings that aren't going to escape from a lambda;
216 -- in particular, we must dump the ones that are bound by
217 -- the rec or case alternative
218 (fsa, floats', install heres arg') }}
221 floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
222 -- See Note [Floating out of RHS]
226 floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
227 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
228 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
230 floatExpr lvl (App e a)
231 = case (floatExpr lvl e) of { (fse, floats_e, e') ->
232 case (floatRhs lvl a) of { (fsa, floats_a, a') ->
233 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
235 floatExpr _ lam@(Lam (TB _ lam_lvl) _)
236 = let (bndrs_w_lvls, body) = collectBinders lam
237 bndrs = [b | TB b _ <- bndrs_w_lvls]
238 -- All the binders have the same level
239 -- See SetLevels.lvlLamBndrs
241 case (floatExpr lam_lvl body) of { (fs, floats, body1) ->
243 -- Dump anything that is captured by this lambda
244 -- Eg \x -> ...(\y -> let v = <blah> in ...)...
245 -- We'll have the binding (v = <blah>) in the floats,
246 -- but must dump it at the lambda-x
247 case (partitionByLevel lam_lvl floats) of { (floats1, heres) ->
248 (add_to_stats fs floats1, floats1, mkLams bndrs (install heres body1))
251 floatExpr lvl (Note note@(SCC cc) expr)
252 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
254 -- Annotate bindings floated outwards past an scc expression
255 -- with the cc. We mark that cc as "duplicated", though.
257 annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns
259 (fs, annotated_defns, Note note expr') }
261 floatExpr lvl (Note note expr) -- Other than SCCs
262 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
263 (fs, floating_defns, Note note expr') }
265 floatExpr lvl (Cast expr co)
266 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
267 (fs, floating_defns, Cast expr' co) }
269 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
270 | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
271 -- I.e. floatExpr for rhs, floatCaseAlt for body
272 = case floatExpr lvl rhs of { (_, rhs_floats, rhs') ->
273 case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
274 (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}
276 floatExpr lvl (Let bind body)
277 = case (floatBind bind) of { (fsb, bind_floats) ->
278 case (floatExpr lvl body) of { (fse, body_floats, body') ->
279 case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats)
280 of { (floats, heres) ->
281 -- See Note [Avoiding unnecessary floating]
282 (add_stats fsb fse, floats, install heres body') } } }
284 floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
285 = case floatExpr lvl scrut of { (fse, fde, scrut') ->
286 case floatList float_alt alts of { (fsa, fda, alts') ->
287 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
290 -- Use floatCaseAlt for the alternatives, so that we
291 -- don't gratuitiously float bindings out of the RHSs
292 float_alt (con, bs, rhs)
293 = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
294 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
297 Note [Avoiding unnecessary floating]
298 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
299 In general we want to avoid floating a let unnecessarily, because
300 it might worsen strictness:
302 x = ...(let y = e in y+y)....
303 Here y is demanded. If we float it outside the lazy 'x=..' then
304 we'd have to zap its demand info, and it may never be restored.
306 So at a 'let' we leave the binding right where the are unless
307 the binding will escape a value lambda. That's what the
308 partitionByMajorLevel does in the floatExpr (Let ...) case.
310 Notice, though, that we must take care to drop any bindings
311 from the body of the let that depend on the staying-put bindings.
313 We used instead to do the partitionByMajorLevel on the RHS of an '=',
314 in floatRhs. But that was quite tiresome. We needed to test for
315 values or trival rhss, because (in particular) we don't want to insert
316 new bindings between the "=" and the "\". E.g.
317 f = \x -> let <bind> in <body>
319 f = let <bind> in \x -> <body>
320 (a) The simplifier will immediately float it further out, so we may
321 as well do so right now; in general, keeping rhss as manifest
323 (b) If a float-in pass follows immediately, it might add yet more
324 bindings just after the '='. And some of them might (correctly)
325 be strict even though the 'let f' is lazy, because f, being a value,
326 gets its demand-info zapped by the simplifier.
327 And even all that turned out to be very fragile, and broke
328 altogether when profiling got in the way.
330 So now we do the partition right at the (Let..) itself.
332 %************************************************************************
334 \subsection{Utility bits for floating stats}
336 %************************************************************************
338 I didn't implement this with unboxed numbers. I don't want to be too
339 strict in this stuff, as it is rarely turned on. (WDP 95/09)
343 = FlS Int -- Number of top-floats * lambda groups they've been past
344 Int -- Number of non-top-floats * lambda groups they've been past
345 Int -- Number of lambda (groups) seen
347 get_stats :: FloatStats -> (Int, Int, Int)
348 get_stats (FlS a b c) = (a, b, c)
350 zeroStats :: FloatStats
351 zeroStats = FlS 0 0 0
353 sum_stats :: [FloatStats] -> FloatStats
354 sum_stats xs = foldr add_stats zeroStats xs
356 add_stats :: FloatStats -> FloatStats -> FloatStats
357 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
358 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
360 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
361 add_to_stats (FlS a b c) (FB tops others)
362 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
366 %************************************************************************
368 \subsection{Utility bits for floating}
370 %************************************************************************
372 Note [Representation of FloatBinds]
373 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 The FloatBinds types is somewhat important. We can get very large numbers
375 of floating bindings, often all destined for the top level. A typical example
376 is x = [4,2,5,2,5, .... ]
377 Then we get lots of small expressions like (fromInteger 4), which all get
381 (a) we partition these floating bindings *at every binding site*
382 (b) SetLevels introduces a new bindings site for every float
383 So we had better not look at each binding at each binding site!
385 That is why MajorEnv is represented as a finite map.
387 We keep the bindings destined for the *top* level separate, because
388 we float them out even if they don't escape a *value* lambda; see
389 partitionByMajorLevel.
393 type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted
395 data FloatBinds = FB !(Bag FloatBind) -- Destined for top level
396 !MajorEnv -- Levels other than top
397 -- See Note [Representation of FloatBinds]
399 instance Outputable FloatBinds where
400 ppr (FB fbs env) = ptext (sLit "FB") <+> (braces $ vcat
401 [ ptext (sLit "binds =") <+> ppr fbs
402 , ptext (sLit "env =") <+> ppr env ])
404 type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
405 type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
407 flattenFloats :: FloatBinds -> Bag FloatBind
408 flattenFloats (FB tops others) = tops `unionBags` flattenMajor others
410 flattenMajor :: MajorEnv -> Bag FloatBind
411 flattenMajor = M.fold (unionBags . flattenMinor) emptyBag
413 flattenMinor :: MinorEnv -> Bag FloatBind
414 flattenMinor = M.fold unionBags emptyBag
416 emptyFloats :: FloatBinds
417 emptyFloats = FB emptyBag M.empty
419 unitFloat :: Level -> FloatBind -> FloatBinds
420 unitFloat lvl@(Level major minor) b
421 | isTopLvl lvl = FB (unitBag b) M.empty
422 | otherwise = FB emptyBag (M.singleton major (M.singleton minor (unitBag b)))
424 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
425 plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2)
427 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
428 plusMajor = M.unionWith plusMinor
430 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
431 plusMinor = M.unionWith unionBags
433 floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
434 floatsToBindPairs floats binds = foldrBag add binds floats
436 add (Rec pairs) binds = pairs ++ binds
437 add (NonRec binder rhs) binds = (binder,rhs) : binds
439 install :: Bag FloatBind -> CoreExpr -> CoreExpr
440 install defn_groups expr
441 = foldrBag install_group expr defn_groups
443 install_group defns body = Let defns body
445 partitionByMajorLevel, partitionByLevel
446 :: Level -- Partitioning level
447 -> FloatBinds -- Defns to be divided into 2 piles...
448 -> (FloatBinds, -- Defns with level strictly < partition level,
449 Bag FloatBind) -- The rest
451 -- ---- partitionByMajorLevel ----
452 -- Float it if we escape a value lambda, *or* if we get to the top level
453 -- If we can get to the top level, say "yes" anyway. This means that
458 -- which is as it should be
460 partitionByMajorLevel (Level major _) (FB tops defns)
461 = (FB tops outer, heres `unionBags` flattenMajor inner)
463 (outer, mb_heres, inner) = M.splitLookup major defns
464 heres = case mb_heres of
466 Just h -> flattenMinor h
468 partitionByLevel (Level major minor) (FB tops defns)
469 = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),
470 here_min `unionBags` flattenMinor inner_min
471 `unionBags` flattenMajor inner_maj)
474 (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
475 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
476 Nothing -> (M.empty, Nothing, M.empty)
477 Just min_defns -> M.splitLookup minor min_defns
478 here_min = mb_here_min `orElse` emptyBag
480 wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
481 wrapCostCentre cc (FB tops defns)
482 = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns)
484 wrap_defns = mapBag wrap_one
485 wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs)
486 wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs)