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 )
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)) }
142 %************************************************************************
144 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
146 %************************************************************************
149 floatBind :: LevelledBind -> (FloatStats, FloatBinds)
150 floatBind (NonRec (TB var level) rhs)
151 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
154 -- see Note [Bottoming floats: eta expansion] in SetLevels
155 let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
158 in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) }
160 floatBind (Rec pairs)
161 = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
162 -- NB: the rhs floats may contain references to the
163 -- bound things. For example
164 -- f = ...(let v = ...f... in b) ...
165 if not (isTopLvl 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
171 -- find that out. In our example we make a Rec thus:
174 case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) ->
175 (fs, floats' `plusFloats` unitFloat dest_lvl
176 (Rec (floatsToBindPairs heres new_pairs))) }
178 -- For top level, no need to partition; just make them all recursive
179 -- (And the partition wouldn't work because they'd all end up in floats')
180 (fs, unitFloat dest_lvl
181 (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) }
183 (((TB _ dest_lvl), _) : _) = pairs
185 do_pair (TB name level, rhs)
186 = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
187 (fs, rhs_floats, (name, rhs')) }
190 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
191 floatList _ [] = (zeroStats, emptyFloats, [])
192 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
193 case floatList f as of { (fs_as, binds_as, bs) ->
194 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
198 %************************************************************************
200 \subsection[FloatOut-Expr]{Floating in expressions}
202 %************************************************************************
205 floatExpr, floatRhs, floatCaseAlt
208 -> (FloatStats, FloatBinds, CoreExpr)
210 floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss
211 = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
212 case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
213 -- Dump bindings that aren't going to escape from a lambda;
214 -- in particular, we must dump the ones that are bound by
215 -- the rec or case alternative
216 (fsa, floats', install heres arg') }}
219 floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
220 -- See Note [Floating out of RHS]
224 floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
225 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
226 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
228 floatExpr lvl (App e a)
229 = case (floatExpr lvl e) of { (fse, floats_e, e') ->
230 case (floatRhs lvl a) of { (fsa, floats_a, a') ->
231 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
233 floatExpr _ lam@(Lam _ _)
235 (bndrs_w_lvls, body) = collectBinders lam
236 bndrs = [b | TB b _ <- bndrs_w_lvls]
237 lvls = [l | TB _ l <- bndrs_w_lvls]
239 -- For the all-tyvar case we are prepared to pull
240 -- the lets out, to implement the float-out-of-big-lambda
241 -- transform; but otherwise we only float bindings that are
242 -- going to escape a value lambda.
243 -- In particular, for one-shot lambdas we don't float things
244 -- out; we get no saving by so doing.
245 partition_fn | all isTyVar bndrs = partitionByLevel
246 | otherwise = partitionByMajorLevel
248 case (floatExpr (last lvls) body) of { (fs, floats, body') ->
250 -- Dump any bindings which absolutely cannot go any further
251 case (partition_fn (head lvls) floats) of { (floats', heres) ->
253 (add_to_stats fs floats', floats', mkLams bndrs (install heres body'))
256 floatExpr lvl (Note note@(SCC cc) expr)
257 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
259 -- Annotate bindings floated outwards past an scc expression
260 -- with the cc. We mark that cc as "duplicated", though.
262 annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns
264 (fs, annotated_defns, Note note expr') }
266 floatExpr lvl (Note note expr) -- Other than SCCs
267 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
268 (fs, floating_defns, Note note expr') }
270 floatExpr lvl (Cast expr co)
271 = case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
272 (fs, floating_defns, Cast expr' co) }
274 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
275 | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case
276 -- I.e. floatExpr for rhs, floatCaseAlt for body
277 = case floatExpr lvl rhs of { (_, rhs_floats, rhs') ->
278 case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
279 (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}
281 floatExpr lvl (Let bind body)
282 = case (floatBind bind) of { (fsb, bind_floats) ->
283 case (floatExpr lvl body) of { (fse, body_floats, body') ->
284 case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats)
285 of { (floats, heres) ->
286 -- See Note [Avoiding unnecessary floating]
287 (add_stats fsb fse, floats, install heres body') } } }
289 floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
290 = case floatExpr lvl scrut of { (fse, fde, scrut') ->
291 case floatList float_alt alts of { (fsa, fda, alts') ->
292 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
295 -- Use floatCaseAlt for the alternatives, so that we
296 -- don't gratuitiously float bindings out of the RHSs
297 float_alt (con, bs, rhs)
298 = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') ->
299 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
302 Note [Avoiding unnecessary floating]
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
304 In general we want to avoid floating a let unnecessarily, because
305 it might worsen strictness:
307 x = ...(let y = e in y+y)....
308 Here y is demanded. If we float it outside the lazy 'x=..' then
309 we'd have to zap its demand info, and it may never be restored.
311 So at a 'let' we leave the binding right where the are unless
312 the binding will escape a value lambda. That's what the
313 partitionByMajorLevel does in the floatExpr (Let ...) case.
315 Notice, though, that we must take care to drop any bindings
316 from the body of the let that depend on the staying-put bindings.
318 We used instead to do the partitionByMajorLevel on the RHS of an '=',
319 in floatRhs. But that was quite tiresome. We needed to test for
320 values or trival rhss, because (in particular) we don't want to insert
321 new bindings between the "=" and the "\". E.g.
322 f = \x -> let <bind> in <body>
324 f = let <bind> in \x -> <body>
325 (a) The simplifier will immediately float it further out, so we may
326 as well do so right now; in general, keeping rhss as manifest
328 (b) If a float-in pass follows immediately, it might add yet more
329 bindings just after the '='. And some of them might (correctly)
330 be strict even though the 'let f' is lazy, because f, being a value,
331 gets its demand-info zapped by the simplifier.
332 And even all that turned out to be very fragile, and broke
333 altogether when profiling got in the way.
335 So now we do the partition right at the (Let..) itself.
337 %************************************************************************
339 \subsection{Utility bits for floating stats}
341 %************************************************************************
343 I didn't implement this with unboxed numbers. I don't want to be too
344 strict in this stuff, as it is rarely turned on. (WDP 95/09)
348 = FlS Int -- Number of top-floats * lambda groups they've been past
349 Int -- Number of non-top-floats * lambda groups they've been past
350 Int -- Number of lambda (groups) seen
352 get_stats :: FloatStats -> (Int, Int, Int)
353 get_stats (FlS a b c) = (a, b, c)
355 zeroStats :: FloatStats
356 zeroStats = FlS 0 0 0
358 sum_stats :: [FloatStats] -> FloatStats
359 sum_stats xs = foldr add_stats zeroStats xs
361 add_stats :: FloatStats -> FloatStats -> FloatStats
362 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
363 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
365 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
366 add_to_stats (FlS a b c) (FB tops others)
367 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
371 %************************************************************************
373 \subsection{Utility bits for floating}
375 %************************************************************************
377 Note [Representation of FloatBinds]
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 The FloatBinds types is somewhat important. We can get very large numbers
380 of floating bindings, often all destined for the top level. A typical example
381 is x = [4,2,5,2,5, .... ]
382 Then we get lots of small expressions like (fromInteger 4), which all get
386 (a) we partition these floating bindings *at every binding site*
387 (b) SetLevels introduces a new bindings site for every float
388 So we had better not look at each binding at each binding site!
390 That is why MajorEnv is represented as a finite map.
392 We keep the bindings destined for the *top* level separate, because
393 we float them out even if they don't escape a *value* lambda; see
394 partitionByMajorLevel.
398 type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted
400 data FloatBinds = FB !(Bag FloatBind) -- Destined for top level
401 !MajorEnv -- Levels other than top
402 -- See Note [Representation of FloatBinds]
404 type MajorEnv = UniqFM MinorEnv -- Keyed by major level
405 type MinorEnv = UniqFM (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 = foldUFM (unionBags . flattenMinor) emptyBag
413 flattenMinor :: MinorEnv -> Bag FloatBind
414 flattenMinor = foldUFM unionBags emptyBag
416 emptyFloats :: FloatBinds
417 emptyFloats = FB emptyBag emptyUFM
419 unitFloat :: Level -> FloatBind -> FloatBinds
420 unitFloat lvl@(Level major minor) b
421 | isTopLvl lvl = FB (unitBag b) emptyUFM
422 | otherwise = FB emptyBag (unitUFM major (unitUFM 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 = plusUFM_C plusMinor
430 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
431 plusMinor = plusUFM_C 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) = splitUFM defns major
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` unitUFM major outer_min),
470 here_min `unionBags` flattenMinor inner_min
471 `unionBags` flattenMajor inner_maj)
474 (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major
475 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
476 Nothing -> (emptyUFM, Nothing, emptyUFM)
477 Just min_defns -> splitUFM min_defns minor
478 here_min = mb_here_min `orElse` emptyBag
480 wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds
481 wrapCostCentre cc (FB tops defns)
482 = FB (wrap_defns tops) (mapUFM (mapUFM 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)