never executed always true always false
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[FloatOut]{Float bindings outwards (towards the top level)}
5
6 ``Long-distance'' floating of bindings towards the top level.
7 -}
8
9
10
11 module GHC.Core.Opt.FloatOut ( floatOutwards ) where
12
13 import GHC.Prelude
14
15 import GHC.Core
16 import GHC.Core.Utils
17 import GHC.Core.Make
18 import GHC.Core.Opt.Arity ( exprArity, etaExpand )
19 import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
20
21 import GHC.Driver.Session
22 import GHC.Utils.Logger
23 import GHC.Types.Id ( Id, idArity, idType, isDeadEndId,
24 isJoinId, isJoinId_maybe )
25 import GHC.Types.Tickish
26 import GHC.Core.Opt.SetLevels
27 import GHC.Types.Unique.Supply ( UniqSupply )
28 import GHC.Data.Bag
29 import GHC.Utils.Misc
30 import GHC.Data.Maybe
31 import GHC.Utils.Outputable
32 import GHC.Utils.Panic
33 import GHC.Core.Type
34 import qualified Data.IntMap as M
35
36 import Data.List ( partition )
37
38 {-
39 -----------------
40 Overall game plan
41 -----------------
42
43 The Big Main Idea is:
44
45 To float out sub-expressions that can thereby get outside
46 a non-one-shot value lambda, and hence may be shared.
47
48
49 To achieve this we may need to do two things:
50
51 a) Let-bind the sub-expression:
52
53 f (g x) ==> let lvl = f (g x) in lvl
54
55 Now we can float the binding for 'lvl'.
56
57 b) More than that, we may need to abstract wrt a type variable
58
59 \x -> ... /\a -> let v = ...a... in ....
60
61 Here the binding for v mentions 'a' but not 'x'. So we
62 abstract wrt 'a', to give this binding for 'v':
63
64 vp = /\a -> ...a...
65 v = vp a
66
67 Now the binding for vp can float out unimpeded.
68 I can't remember why this case seemed important enough to
69 deal with, but I certainly found cases where important floats
70 didn't happen if we did not abstract wrt tyvars.
71
72 With this in mind we can also achieve another goal: lambda lifting.
73 We can make an arbitrary (function) binding float to top level by
74 abstracting wrt *all* local variables, not just type variables, leaving
75 a binding that can be floated right to top level. Whether or not this
76 happens is controlled by a flag.
77
78
79 Random comments
80 ~~~~~~~~~~~~~~~
81
82 At the moment we never float a binding out to between two adjacent
83 lambdas. For example:
84
85 @
86 \x y -> let t = x+x in ...
87 ===>
88 \x -> let t = x+x in \y -> ...
89 @
90 Reason: this is less efficient in the case where the original lambda
91 is never partially applied.
92
93 But there's a case I've seen where this might not be true. Consider:
94 @
95 elEm2 x ys
96 = elem' x ys
97 where
98 elem' _ [] = False
99 elem' x (y:ys) = x==y || elem' x ys
100 @
101 It turns out that this generates a subexpression of the form
102 @
103 \deq x ys -> let eq = eqFromEqDict deq in ...
104 @
105 which might usefully be separated to
106 @
107 \deq -> let eq = eqFromEqDict deq in \xy -> ...
108 @
109 Well, maybe. We don't do this at the moment.
110
111 Note [Join points]
112 ~~~~~~~~~~~~~~~~~~
113 Every occurrence of a join point must be a tail call (see Note [Invariants on
114 join points] in GHC.Core), so we must be careful with how far we float them. The
115 mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]
116 in GHC.Core.Opt.SetLevels. For us, the significance is that a binder might be marked to be
117 dropped at the nearest boundary between tail calls and non-tail calls. For
118 example:
119
120 (< join j = ... in
121 let x = < ... > in
122 case < ... > of
123 A -> ...
124 B -> ...
125 >) < ... > < ... >
126
127 Here the join ceilings are marked with angle brackets. Either side of an
128 application is a join ceiling, as is the scrutinee position of a case
129 expression or the RHS of a let binding (but not a join point).
130
131 Why do we *want* do float join points at all? After all, they're never
132 allocated, so there's no sharing to be gained by floating them. However, the
133 other benefit of floating is making RHSes small, and this can have a significant
134 impact. In particular, stream fusion has been known to produce nested loops like
135 this:
136
137 joinrec j1 x1 =
138 joinrec j2 x2 =
139 joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
140 in jump j3 x2
141 in jump j2 x1
142 in jump j1 x
143
144 (Assume x1 and x2 do *not* occur free in j3.)
145
146 Here j1 and j2 are wholly superfluous---each of them merely forwards its
147 argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make
148 everything one big mutual recursion:
149
150 joinrec j1 x1 = jump j2 x1
151 j2 x2 = jump j3 x2
152 j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
153 in jump j1 x
154
155 Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.
156 Without floating, we're stuck with three loops instead of one.
157
158 ************************************************************************
159 * *
160 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
161 * *
162 ************************************************************************
163 -}
164
165 floatOutwards :: Logger
166 -> FloatOutSwitches
167 -> UniqSupply
168 -> CoreProgram -> IO CoreProgram
169
170 floatOutwards logger float_sws us pgm
171 = do {
172 let { annotated_w_levels = setLevels float_sws pgm us ;
173 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
174 } ;
175
176 putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:"
177 FormatCore
178 (vcat (map ppr annotated_w_levels));
179
180 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
181
182 putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:"
183 FormatText
184 (hcat [ int tlets, text " Lets floated to top level; ",
185 int ntlets, text " Lets floated elsewhere; from ",
186 int lams, text " Lambda groups"]);
187
188 return (bagToList (unionManyBags binds_s'))
189 }
190
191 floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
192 floatTopBind bind
193 = case (floatBind bind) of { (fs, floats, bind') ->
194 let float_bag = flattenTopFloats floats
195 in case bind' of
196 -- bind' can't have unlifted values or join points, so can only be one
197 -- value bind, rec or non-rec (see comment on floatBind)
198 [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
199 [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)
200 _ -> pprPanic "floatTopBind" (ppr bind') }
201
202 {-
203 ************************************************************************
204 * *
205 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
206 * *
207 ************************************************************************
208 -}
209
210 floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])
211 -- Returns a list with either
212 -- * A single non-recursive binding (value or join point), or
213 -- * The following, in order:
214 -- * Zero or more non-rec unlifted bindings
215 -- * One or both of:
216 -- * A recursive group of join binds
217 -- * A recursive group of value binds
218 -- See Note [Floating out of Rec rhss] for why things get arranged this way.
219 floatBind (NonRec (TB var _) rhs)
220 = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->
221
222 -- A tiresome hack:
223 -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels
224 let rhs'' | isDeadEndId var
225 , exprArity rhs' < idArity var = etaExpand (idArity var) rhs'
226 | otherwise = rhs'
227
228 in (fs, rhs_floats, [NonRec var rhs'']) }
229
230 floatBind (Rec pairs)
231 = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
232 let (new_ul_pairss, new_other_pairss) = unzip new_pairs
233 (new_join_pairs, new_l_pairs) = partition (isJoinId . fst)
234 (concat new_other_pairss)
235 -- Can't put the join points and the values in the same rec group
236 new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ]
237 | null new_l_pairs = [ Rec new_join_pairs ]
238 | otherwise = [ Rec new_l_pairs
239 , Rec new_join_pairs ]
240 new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]
241 in
242 (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }
243 where
244 do_pair :: (LevelledBndr, LevelledExpr)
245 -> (FloatStats, FloatBinds,
246 ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
247 [(Id,CoreExpr)])) -- Join points and lifted value bindings
248 do_pair (TB name spec, rhs)
249 | isTopLvl dest_lvl -- See Note [floatBind for top level]
250 = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
251 (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)
252 [(name, rhs')]))}
253 | otherwise -- Note [Floating out of Rec rhss]
254 = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
255 case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
256 case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->
257 let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in
258 (fs, rhs_floats', (ul_pairs, pairs')) }}}
259 where
260 dest_lvl = floatSpecLevel spec
261
262 splitRecFloats :: Bag FloatBind
263 -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
264 [(Id,CoreExpr)], -- Join points and lifted value bindings
265 Bag FloatBind) -- A tail of further bindings
266 -- The "tail" begins with a case
267 -- See Note [Floating out of Rec rhss]
268 splitRecFloats fs
269 = go [] [] (bagToList fs)
270 where
271 go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)
272 , not (isJoinId b)
273 = go ((b,r):ul_prs) prs fs
274 | otherwise
275 = go ul_prs ((b,r):prs) fs
276 go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs
277 go ul_prs prs fs = (reverse ul_prs, prs,
278 listToBag fs)
279 -- Order only matters for
280 -- non-rec
281
282 installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
283 -- Note [Floating out of Rec rhss]
284 installUnderLambdas floats e
285 | isEmptyBag floats = e
286 | otherwise = go e
287 where
288 go (Lam b e) = Lam b (go e)
289 go e = install floats e
290
291 ---------------
292 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
293 floatList _ [] = (zeroStats, emptyFloats, [])
294 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
295 case floatList f as of { (fs_as, binds_as, bs) ->
296 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
297
298 {-
299 Note [Floating out of Rec rhss]
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
301 Consider Rec { f<1,0> = \xy. body }
302 From the body we may get some floats. The ones with level <1,0> must
303 stay here, since they may mention f. Ideally we'd like to make them
304 part of the Rec block pairs -- but we can't if there are any
305 FloatCases involved.
306
307 Nor is it a good idea to dump them in the rhs, but outside the lambda
308 f = case x of I# y -> \xy. body
309 because now f's arity might get worse, which is Not Good. (And if
310 there's an SCC around the RHS it might not get better again.
311 See #5342.)
312
313 So, gruesomely, we split the floats into
314 * the outer FloatLets, which can join the Rec, and
315 * an inner batch starting in a FloatCase, which are then
316 pushed *inside* the lambdas.
317 This loses full-laziness the rare situation where there is a
318 FloatCase and a Rec interacting.
319
320 If there are unlifted FloatLets (that *aren't* join points) among the floats,
321 we can't add them to the recursive group without angering Core Lint, but since
322 they must be ok-for-speculation, they can't actually be making any recursive
323 calls, so we can safely pull them out and keep them non-recursive.
324
325 (Why is something getting floated to <1,0> that doesn't make a recursive call?
326 The case that came up in testing was that f *and* the unlifted binding were
327 getting floated *to the same place*:
328
329 \x<2,0> ->
330 ... <3,0>
331 letrec { f<F<2,0>> =
332 ... let x'<F<2,0>> = x +# 1# in ...
333 } in ...
334
335 Everything gets labeled "float to <2,0>" because it all depends on x, but this
336 makes f and x' look mutually recursive when they're not.
337
338 The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the
339 wip/join-points branch.
340
341 TODO: This can probably be solved somehow in GHC.Core.Opt.SetLevels. The difference between
342 "this *is at* level <2,0>" and "this *depends on* level <2,0>" is very
343 important.)
344
345 Note [floatBind for top level]
346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
347 We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
348 letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
349 The binding for bar will be in the "tops" part of the floating binds,
350 and thus not partioned by floatBody.
351
352 We could perhaps get rid of the 'tops' component of the floating binds,
353 but this case works just as well.
354
355
356 ************************************************************************
357
358 \subsection[FloatOut-Expr]{Floating in expressions}
359 * *
360 ************************************************************************
361 -}
362
363 floatBody :: Level
364 -> LevelledExpr
365 -> (FloatStats, FloatBinds, CoreExpr)
366
367 floatBody lvl arg -- Used rec rhss, and case-alternative rhss
368 = case (floatExpr arg) of { (fsa, floats, arg') ->
369 case (partitionByLevel lvl floats) of { (floats', heres) ->
370 -- Dump bindings are bound here
371 (fsa, floats', install heres arg') }}
372
373 -----------------
374
375 {- Note [Floating past breakpoints]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377
378 We used to disallow floating out of breakpoint ticks (see #10052). However, I
379 think this is too restrictive.
380
381 Consider the case of an expression scoped over by a breakpoint tick,
382
383 tick<...> (let x = ... in f x)
384
385 In this case it is completely legal to float out x, despite the fact that
386 breakpoint ticks are scoped,
387
388 let x = ... in (tick<...> f x)
389
390 The reason here is that we know that the breakpoint will still be hit when the
391 expression is entered since the tick still scopes over the RHS.
392
393 -}
394
395 floatExpr :: LevelledExpr
396 -> (FloatStats, FloatBinds, CoreExpr)
397 floatExpr (Var v) = (zeroStats, emptyFloats, Var v)
398 floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
399 floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
400 floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
401
402 floatExpr (App e a)
403 = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') ->
404 case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') ->
405 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
406
407 floatExpr lam@(Lam (TB _ lam_spec) _)
408 = let (bndrs_w_lvls, body) = collectBinders lam
409 bndrs = [b | TB b _ <- bndrs_w_lvls]
410 bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec)
411 -- All the binders have the same level
412 -- See GHC.Core.Opt.SetLevels.lvlLamBndrs
413 -- Use asJoinCeilLvl to make this the join ceiling
414 in
415 case (floatBody bndr_lvl body) of { (fs, floats, body') ->
416 (add_to_stats fs floats, floats, mkLams bndrs body') }
417
418 floatExpr (Tick tickish expr)
419 | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
420 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
421 (fs, floating_defns, Tick tickish expr') }
422
423 | not (tickishCounts tickish) || tickishCanSplit tickish
424 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
425 let -- Annotate bindings floated outwards past an scc expression
426 -- with the cc. We mark that cc as "duplicated", though.
427 annotated_defns = wrapTick (mkNoCount tickish) floating_defns
428 in
429 (fs, annotated_defns, Tick tickish expr') }
430
431 -- Note [Floating past breakpoints]
432 | Breakpoint{} <- tickish
433 = case (floatExpr expr) of { (fs, floating_defns, expr') ->
434 (fs, floating_defns, Tick tickish expr') }
435
436 | otherwise
437 = pprPanic "floatExpr tick" (ppr tickish)
438
439 floatExpr (Cast expr co)
440 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
441 (fs, floating_defns, Cast expr' co) }
442
443 floatExpr (Let bind body)
444 = case bind_spec of
445 FloatMe dest_lvl
446 -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
447 case (floatExpr body) of { (fse, body_floats, body') ->
448 let new_bind_floats = foldr plusFloats emptyFloats
449 (map (unitLetFloat dest_lvl) binds') in
450 ( add_stats fsb fse
451 , bind_floats `plusFloats` new_bind_floats
452 `plusFloats` body_floats
453 , body') }}
454
455 StayPut bind_lvl -- See Note [Avoiding unnecessary floating]
456 -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
457 case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
458 ( add_stats fsb fse
459 , bind_floats `plusFloats` body_floats
460 , foldr Let body' binds' ) }}
461 where
462 bind_spec = case bind of
463 NonRec (TB _ s) _ -> s
464 Rec ((TB _ s, _) : _) -> s
465 Rec [] -> panic "floatExpr:rec"
466
467 floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
468 = case case_spec of
469 FloatMe dest_lvl -- Case expression moves
470 | [Alt con@(DataAlt {}) bndrs rhs] <- alts
471 -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
472 case floatExpr rhs of { (fsb, fdb, rhs') ->
473 let
474 float = unitCaseFloat dest_lvl scrut'
475 case_bndr con [b | TB b _ <- bndrs]
476 in
477 (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
478 | otherwise
479 -> pprPanic "Floating multi-case" (ppr alts)
480
481 StayPut bind_lvl -- Case expression stays put
482 -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
483 case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') ->
484 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
485 }}
486 where
487 float_alt bind_lvl (Alt con bs rhs)
488 = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
489 (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') }
490
491 floatRhs :: CoreBndr
492 -> LevelledExpr
493 -> (FloatStats, FloatBinds, CoreExpr)
494 floatRhs bndr rhs
495 | Just join_arity <- isJoinId_maybe bndr
496 , Just (bndrs, body) <- try_collect join_arity rhs []
497 = case bndrs of
498 [] -> floatExpr rhs
499 (TB _ lam_spec):_ ->
500 let lvl = floatSpecLevel lam_spec in
501 case floatBody lvl body of { (fs, floats, body') ->
502 (fs, floats, mkLams [b | TB b _ <- bndrs] body') }
503 | otherwise
504 = atJoinCeiling $ floatExpr rhs
505 where
506 try_collect 0 expr acc = Just (reverse acc, expr)
507 try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)
508 try_collect _ _ _ = Nothing
509
510 {-
511 Note [Avoiding unnecessary floating]
512 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
513 In general we want to avoid floating a let unnecessarily, because
514 it might worsen strictness:
515 let
516 x = ...(let y = e in y+y)....
517 Here y is demanded. If we float it outside the lazy 'x=..' then
518 we'd have to zap its demand info, and it may never be restored.
519
520 So at a 'let' we leave the binding right where the are unless
521 the binding will escape a value lambda, e.g.
522
523 (\x -> let y = fac 100 in y)
524
525 That's what the partitionByMajorLevel does in the floatExpr (Let ...)
526 case.
527
528 Notice, though, that we must take care to drop any bindings
529 from the body of the let that depend on the staying-put bindings.
530
531 We used instead to do the partitionByMajorLevel on the RHS of an '=',
532 in floatRhs. But that was quite tiresome. We needed to test for
533 values or trivial rhss, because (in particular) we don't want to insert
534 new bindings between the "=" and the "\". E.g.
535 f = \x -> let <bind> in <body>
536 We do not want
537 f = let <bind> in \x -> <body>
538 (a) The simplifier will immediately float it further out, so we may
539 as well do so right now; in general, keeping rhss as manifest
540 values is good
541 (b) If a float-in pass follows immediately, it might add yet more
542 bindings just after the '='. And some of them might (correctly)
543 be strict even though the 'let f' is lazy, because f, being a value,
544 gets its demand-info zapped by the simplifier.
545 And even all that turned out to be very fragile, and broke
546 altogether when profiling got in the way.
547
548 So now we do the partition right at the (Let..) itself.
549
550 ************************************************************************
551 * *
552 \subsection{Utility bits for floating stats}
553 * *
554 ************************************************************************
555
556 I didn't implement this with unboxed numbers. I don't want to be too
557 strict in this stuff, as it is rarely turned on. (WDP 95/09)
558 -}
559
560 data FloatStats
561 = FlS Int -- Number of top-floats * lambda groups they've been past
562 Int -- Number of non-top-floats * lambda groups they've been past
563 Int -- Number of lambda (groups) seen
564
565 get_stats :: FloatStats -> (Int, Int, Int)
566 get_stats (FlS a b c) = (a, b, c)
567
568 zeroStats :: FloatStats
569 zeroStats = FlS 0 0 0
570
571 sum_stats :: [FloatStats] -> FloatStats
572 sum_stats xs = foldr add_stats zeroStats xs
573
574 add_stats :: FloatStats -> FloatStats -> FloatStats
575 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
576 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
577
578 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
579 add_to_stats (FlS a b c) (FB tops ceils others)
580 = FlS (a + lengthBag tops)
581 (b + lengthBag ceils + lengthBag (flattenMajor others))
582 (c + 1)
583
584 {-
585 ************************************************************************
586 * *
587 \subsection{Utility bits for floating}
588 * *
589 ************************************************************************
590
591 Note [Representation of FloatBinds]
592 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
593 The FloatBinds types is somewhat important. We can get very large numbers
594 of floating bindings, often all destined for the top level. A typical example
595 is x = [4,2,5,2,5, .... ]
596 Then we get lots of small expressions like (fromInteger 4), which all get
597 lifted to top level.
598
599 The trouble is that
600 (a) we partition these floating bindings *at every binding site*
601 (b) GHC.Core.Opt.SetLevels introduces a new bindings site for every float
602 So we had better not look at each binding at each binding site!
603
604 That is why MajorEnv is represented as a finite map.
605
606 We keep the bindings destined for the *top* level separate, because
607 we float them out even if they don't escape a *value* lambda; see
608 partitionByMajorLevel.
609 -}
610
611 type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted
612 type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
613 type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
614
615 data FloatBinds = FB !(Bag FloatLet) -- Destined for top level
616 !(Bag FloatBind) -- Destined for join ceiling
617 !MajorEnv -- Other levels
618 -- See Note [Representation of FloatBinds]
619
620 instance Outputable FloatBinds where
621 ppr (FB fbs ceils defs)
622 = text "FB" <+> (braces $ vcat
623 [ text "tops =" <+> ppr fbs
624 , text "ceils =" <+> ppr ceils
625 , text "non-tops =" <+> ppr defs ])
626
627 flattenTopFloats :: FloatBinds -> Bag CoreBind
628 flattenTopFloats (FB tops ceils defs)
629 = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $
630 assertPpr (isEmptyBag ceils) (ppr ceils)
631 tops
632
633 addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
634 addTopFloatPairs float_bag prs
635 = foldr add prs float_bag
636 where
637 add (NonRec b r) prs = (b,r):prs
638 add (Rec prs1) prs2 = prs1 ++ prs2
639
640 flattenMajor :: MajorEnv -> Bag FloatBind
641 flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag
642
643 flattenMinor :: MinorEnv -> Bag FloatBind
644 flattenMinor = M.foldr unionBags emptyBag
645
646 emptyFloats :: FloatBinds
647 emptyFloats = FB emptyBag emptyBag M.empty
648
649 unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
650 unitCaseFloat (Level major minor t) e b con bs
651 | t == JoinCeilLvl
652 = FB emptyBag floats M.empty
653 | otherwise
654 = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))
655 where
656 floats = unitBag (FloatCase e b con bs)
657
658 unitLetFloat :: Level -> FloatLet -> FloatBinds
659 unitLetFloat lvl@(Level major minor t) b
660 | isTopLvl lvl = FB (unitBag b) emptyBag M.empty
661 | t == JoinCeilLvl = FB emptyBag floats M.empty
662 | otherwise = FB emptyBag emptyBag (M.singleton major
663 (M.singleton minor floats))
664 where
665 floats = unitBag (FloatLet b)
666
667 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
668 plusFloats (FB t1 c1 l1) (FB t2 c2 l2)
669 = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)
670
671 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
672 plusMajor = M.unionWith plusMinor
673
674 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
675 plusMinor = M.unionWith unionBags
676
677 install :: Bag FloatBind -> CoreExpr -> CoreExpr
678 install defn_groups expr
679 = foldr wrapFloat expr defn_groups
680
681 partitionByLevel
682 :: Level -- Partitioning level
683 -> FloatBinds -- Defns to be divided into 2 piles...
684 -> (FloatBinds, -- Defns with level strictly < partition level,
685 Bag FloatBind) -- The rest
686
687 {-
688 -- ---- partitionByMajorLevel ----
689 -- Float it if we escape a value lambda,
690 -- *or* if we get to the top level
691 -- *or* if it's a case-float and its minor level is < current
692 --
693 -- If we can get to the top level, say "yes" anyway. This means that
694 -- x = f e
695 -- transforms to
696 -- lvl = e
697 -- x = f lvl
698 -- which is as it should be
699
700 partitionByMajorLevel (Level major _) (FB tops defns)
701 = (FB tops outer, heres `unionBags` flattenMajor inner)
702 where
703 (outer, mb_heres, inner) = M.splitLookup major defns
704 heres = case mb_heres of
705 Nothing -> emptyBag
706 Just h -> flattenMinor h
707 -}
708
709 partitionByLevel (Level major minor typ) (FB tops ceils defns)
710 = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),
711 here_min `unionBags` here_ceil
712 `unionBags` flattenMinor inner_min
713 `unionBags` flattenMajor inner_maj)
714
715 where
716 (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
717 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
718 Nothing -> (M.empty, Nothing, M.empty)
719 Just min_defns -> M.splitLookup minor min_defns
720 here_min = mb_here_min `orElse` emptyBag
721 (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)
722 | otherwise = (emptyBag, ceils)
723
724 -- Like partitionByLevel, but instead split out the bindings that are marked
725 -- to float to the nearest join ceiling (see Note [Join points])
726 partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)
727 partitionAtJoinCeiling (FB tops ceils defs)
728 = (FB tops emptyBag defs, ceils)
729
730 -- Perform some action at a join ceiling, i.e., don't let join points float out
731 -- (see Note [Join points])
732 atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)
733 -> (FloatStats, FloatBinds, CoreExpr)
734 atJoinCeiling (fs, floats, expr')
735 = (fs, floats', install ceils expr')
736 where
737 (floats', ceils) = partitionAtJoinCeiling floats
738
739 wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
740 wrapTick t (FB tops ceils defns)
741 = FB (mapBag wrap_bind tops) (wrap_defns ceils)
742 (M.map (M.map wrap_defns) defns)
743 where
744 wrap_defns = mapBag wrap_one
745
746 wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
747 wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs)
748
749 wrap_one (FloatLet bind) = FloatLet (wrap_bind bind)
750 wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
751
752 maybe_tick e | exprIsHNF e = tickHNFArgs t e
753 | otherwise = mkTick t e
754 -- we don't need to wrap a tick around an HNF when we float it
755 -- outside a tick: that is an invariant of the tick semantics
756 -- Conversely, inlining of HNFs inside an SCC is allowed, and
757 -- indeed the HNF we're floating here might well be inlined back
758 -- again, and we don't want to end up with duplicate ticks.