Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / simplCore / FloatOut.hs
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 {-# LANGUAGE CPP #-}
10
11 module FloatOut ( floatOutwards ) where
12
13 import GhcPrelude
14
15 import CoreSyn
16 import CoreUtils
17 import MkCore
18 import CoreArity ( etaExpand )
19 import CoreMonad ( FloatOutSwitches(..) )
20
21 import DynFlags
22 import ErrUtils ( dumpIfSet_dyn )
23 import Id ( Id, idArity, idType, isBottomingId,
24 isJoinId, isJoinId_maybe )
25 import SetLevels
26 import UniqSupply ( UniqSupply )
27 import Bag
28 import Util
29 import Maybes
30 import Outputable
31 import Type
32 import qualified Data.IntMap as M
33
34 import Data.List ( partition )
35
36 #include "HsVersions.h"
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 CoreSyn), 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 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 :: FloatOutSwitches
166 -> DynFlags
167 -> UniqSupply
168 -> CoreProgram -> IO CoreProgram
169
170 floatOutwards float_sws dflags 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 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
177 (vcat (map ppr annotated_w_levels));
178
179 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
180
181 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
182 (hcat [ int tlets, text " Lets floated to top level; ",
183 int ntlets, text " Lets floated elsewhere; from ",
184 int lams, text " Lambda groups"]);
185
186 return (bagToList (unionManyBags binds_s'))
187 }
188
189 floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
190 floatTopBind bind
191 = case (floatBind bind) of { (fs, floats, bind') ->
192 let float_bag = flattenTopFloats floats
193 in case bind' of
194 -- bind' can't have unlifted values or join points, so can only be one
195 -- value bind, rec or non-rec (see comment on floatBind)
196 [Rec prs] -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
197 [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)
198 _ -> pprPanic "floatTopBind" (ppr bind') }
199
200 {-
201 ************************************************************************
202 * *
203 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
204 * *
205 ************************************************************************
206 -}
207
208 floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])
209 -- Returns a list with either
210 -- * A single non-recursive binding (value or join point), or
211 -- * The following, in order:
212 -- * Zero or more non-rec unlifted bindings
213 -- * One or both of:
214 -- * A recursive group of join binds
215 -- * A recursive group of value binds
216 -- See Note [Floating out of Rec rhss] for why things get arranged this way.
217 floatBind (NonRec (TB var _) rhs)
218 = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->
219
220 -- A tiresome hack:
221 -- see Note [Bottoming floats: eta expansion] in SetLevels
222 let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
223 | otherwise = rhs'
224
225 in (fs, rhs_floats, [NonRec var rhs'']) }
226
227 floatBind (Rec pairs)
228 = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
229 let (new_ul_pairss, new_other_pairss) = unzip new_pairs
230 (new_join_pairs, new_l_pairs) = partition (isJoinId . fst)
231 (concat new_other_pairss)
232 -- Can't put the join points and the values in the same rec group
233 new_rec_binds | null new_join_pairs = [ Rec new_l_pairs ]
234 | null new_l_pairs = [ Rec new_join_pairs ]
235 | otherwise = [ Rec new_l_pairs
236 , Rec new_join_pairs ]
237 new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]
238 in
239 (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }
240 where
241 do_pair :: (LevelledBndr, LevelledExpr)
242 -> (FloatStats, FloatBinds,
243 ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
244 [(Id,CoreExpr)])) -- Join points and lifted value bindings
245 do_pair (TB name spec, rhs)
246 | isTopLvl dest_lvl -- See Note [floatBind for top level]
247 = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
248 (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)
249 [(name, rhs')]))}
250 | otherwise -- Note [Floating out of Rec rhss]
251 = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
252 case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
253 case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->
254 let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in
255 (fs, rhs_floats', (ul_pairs, pairs')) }}}
256 where
257 dest_lvl = floatSpecLevel spec
258
259 splitRecFloats :: Bag FloatBind
260 -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
261 [(Id,CoreExpr)], -- Join points and lifted value bindings
262 Bag FloatBind) -- A tail of further bindings
263 -- The "tail" begins with a case
264 -- See Note [Floating out of Rec rhss]
265 splitRecFloats fs
266 = go [] [] (bagToList fs)
267 where
268 go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)
269 , not (isJoinId b)
270 = go ((b,r):ul_prs) prs fs
271 | otherwise
272 = go ul_prs ((b,r):prs) fs
273 go ul_prs prs (FloatLet (Rec prs') : fs) = go ul_prs (prs' ++ prs) fs
274 go ul_prs prs fs = (reverse ul_prs, prs,
275 listToBag fs)
276 -- Order only matters for
277 -- non-rec
278
279 installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
280 -- Note [Floating out of Rec rhss]
281 installUnderLambdas floats e
282 | isEmptyBag floats = e
283 | otherwise = go e
284 where
285 go (Lam b e) = Lam b (go e)
286 go e = install floats e
287
288 ---------------
289 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
290 floatList _ [] = (zeroStats, emptyFloats, [])
291 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
292 case floatList f as of { (fs_as, binds_as, bs) ->
293 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
294
295 {-
296 Note [Floating out of Rec rhss]
297 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
298 Consider Rec { f<1,0> = \xy. body }
299 From the body we may get some floats. The ones with level <1,0> must
300 stay here, since they may mention f. Ideally we'd like to make them
301 part of the Rec block pairs -- but we can't if there are any
302 FloatCases involved.
303
304 Nor is it a good idea to dump them in the rhs, but outside the lambda
305 f = case x of I# y -> \xy. body
306 because now f's arity might get worse, which is Not Good. (And if
307 there's an SCC around the RHS it might not get better again.
308 See #5342.)
309
310 So, gruesomely, we split the floats into
311 * the outer FloatLets, which can join the Rec, and
312 * an inner batch starting in a FloatCase, which are then
313 pushed *inside* the lambdas.
314 This loses full-laziness the rare situation where there is a
315 FloatCase and a Rec interacting.
316
317 If there are unlifted FloatLets (that *aren't* join points) among the floats,
318 we can't add them to the recursive group without angering Core Lint, but since
319 they must be ok-for-speculation, they can't actually be making any recursive
320 calls, so we can safely pull them out and keep them non-recursive.
321
322 (Why is something getting floated to <1,0> that doesn't make a recursive call?
323 The case that came up in testing was that f *and* the unlifted binding were
324 getting floated *to the same place*:
325
326 \x<2,0> ->
327 ... <3,0>
328 letrec { f<F<2,0>> =
329 ... let x'<F<2,0>> = x +# 1# in ...
330 } in ...
331
332 Everything gets labeled "float to <2,0>" because it all depends on x, but this
333 makes f and x' look mutually recursive when they're not.
334
335 The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the
336 wip/join-points branch.
337
338 TODO: This can probably be solved somehow in SetLevels. The difference between
339 "this *is at* level <2,0>" and "this *depends on* level <2,0>" is very
340 important.)
341
342 Note [floatBind for top level]
343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
344 We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
345 letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
346 The binding for bar will be in the "tops" part of the floating binds,
347 and thus not partioned by floatBody.
348
349 We could perhaps get rid of the 'tops' component of the floating binds,
350 but this case works just as well.
351
352
353 ************************************************************************
354
355 \subsection[FloatOut-Expr]{Floating in expressions}
356 * *
357 ************************************************************************
358 -}
359
360 floatBody :: Level
361 -> LevelledExpr
362 -> (FloatStats, FloatBinds, CoreExpr)
363
364 floatBody lvl arg -- Used rec rhss, and case-alternative rhss
365 = case (floatExpr arg) of { (fsa, floats, arg') ->
366 case (partitionByLevel lvl floats) of { (floats', heres) ->
367 -- Dump bindings are bound here
368 (fsa, floats', install heres arg') }}
369
370 -----------------
371
372 {- Note [Floating past breakpoints]
373 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374
375 We used to disallow floating out of breakpoint ticks (see #10052). However, I
376 think this is too restrictive.
377
378 Consider the case of an expression scoped over by a breakpoint tick,
379
380 tick<...> (let x = ... in f x)
381
382 In this case it is completely legal to float out x, despite the fact that
383 breakpoint ticks are scoped,
384
385 let x = ... in (tick<...> f x)
386
387 The reason here is that we know that the breakpoint will still be hit when the
388 expression is entered since the tick still scopes over the RHS.
389
390 -}
391
392 floatExpr :: LevelledExpr
393 -> (FloatStats, FloatBinds, CoreExpr)
394 floatExpr (Var v) = (zeroStats, emptyFloats, Var v)
395 floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
396 floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
397 floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
398
399 floatExpr (App e a)
400 = case (atJoinCeiling $ floatExpr e) of { (fse, floats_e, e') ->
401 case (atJoinCeiling $ floatExpr a) of { (fsa, floats_a, a') ->
402 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
403
404 floatExpr lam@(Lam (TB _ lam_spec) _)
405 = let (bndrs_w_lvls, body) = collectBinders lam
406 bndrs = [b | TB b _ <- bndrs_w_lvls]
407 bndr_lvl = asJoinCeilLvl (floatSpecLevel lam_spec)
408 -- All the binders have the same level
409 -- See SetLevels.lvlLamBndrs
410 -- Use asJoinCeilLvl to make this the join ceiling
411 in
412 case (floatBody bndr_lvl body) of { (fs, floats, body') ->
413 (add_to_stats fs floats, floats, mkLams bndrs body') }
414
415 floatExpr (Tick tickish expr)
416 | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
417 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
418 (fs, floating_defns, Tick tickish expr') }
419
420 | not (tickishCounts tickish) || tickishCanSplit tickish
421 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
422 let -- Annotate bindings floated outwards past an scc expression
423 -- with the cc. We mark that cc as "duplicated", though.
424 annotated_defns = wrapTick (mkNoCount tickish) floating_defns
425 in
426 (fs, annotated_defns, Tick tickish expr') }
427
428 -- Note [Floating past breakpoints]
429 | Breakpoint{} <- tickish
430 = case (floatExpr expr) of { (fs, floating_defns, expr') ->
431 (fs, floating_defns, Tick tickish expr') }
432
433 | otherwise
434 = pprPanic "floatExpr tick" (ppr tickish)
435
436 floatExpr (Cast expr co)
437 = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
438 (fs, floating_defns, Cast expr' co) }
439
440 floatExpr (Let bind body)
441 = case bind_spec of
442 FloatMe dest_lvl
443 -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
444 case (floatExpr body) of { (fse, body_floats, body') ->
445 let new_bind_floats = foldr plusFloats emptyFloats
446 (map (unitLetFloat dest_lvl) binds') in
447 ( add_stats fsb fse
448 , bind_floats `plusFloats` new_bind_floats
449 `plusFloats` body_floats
450 , body') }}
451
452 StayPut bind_lvl -- See Note [Avoiding unnecessary floating]
453 -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
454 case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
455 ( add_stats fsb fse
456 , bind_floats `plusFloats` body_floats
457 , foldr Let body' binds' ) }}
458 where
459 bind_spec = case bind of
460 NonRec (TB _ s) _ -> s
461 Rec ((TB _ s, _) : _) -> s
462 Rec [] -> panic "floatExpr:rec"
463
464 floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
465 = case case_spec of
466 FloatMe dest_lvl -- Case expression moves
467 | [(con@(DataAlt {}), bndrs, rhs)] <- alts
468 -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
469 case floatExpr rhs of { (fsb, fdb, rhs') ->
470 let
471 float = unitCaseFloat dest_lvl scrut'
472 case_bndr con [b | TB b _ <- bndrs]
473 in
474 (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
475 | otherwise
476 -> pprPanic "Floating multi-case" (ppr alts)
477
478 StayPut bind_lvl -- Case expression stays put
479 -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
480 case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') ->
481 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
482 }}
483 where
484 float_alt bind_lvl (con, bs, rhs)
485 = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
486 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
487
488 floatRhs :: CoreBndr
489 -> LevelledExpr
490 -> (FloatStats, FloatBinds, CoreExpr)
491 floatRhs bndr rhs
492 | Just join_arity <- isJoinId_maybe bndr
493 , Just (bndrs, body) <- try_collect join_arity rhs []
494 = case bndrs of
495 [] -> floatExpr rhs
496 (TB _ lam_spec):_ ->
497 let lvl = floatSpecLevel lam_spec in
498 case floatBody lvl body of { (fs, floats, body') ->
499 (fs, floats, mkLams [b | TB b _ <- bndrs] body') }
500 | otherwise
501 = atJoinCeiling $ floatExpr rhs
502 where
503 try_collect 0 expr acc = Just (reverse acc, expr)
504 try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)
505 try_collect _ _ _ = Nothing
506
507 {-
508 Note [Avoiding unnecessary floating]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 In general we want to avoid floating a let unnecessarily, because
511 it might worsen strictness:
512 let
513 x = ...(let y = e in y+y)....
514 Here y is demanded. If we float it outside the lazy 'x=..' then
515 we'd have to zap its demand info, and it may never be restored.
516
517 So at a 'let' we leave the binding right where the are unless
518 the binding will escape a value lambda, e.g.
519
520 (\x -> let y = fac 100 in y)
521
522 That's what the partitionByMajorLevel does in the floatExpr (Let ...)
523 case.
524
525 Notice, though, that we must take care to drop any bindings
526 from the body of the let that depend on the staying-put bindings.
527
528 We used instead to do the partitionByMajorLevel on the RHS of an '=',
529 in floatRhs. But that was quite tiresome. We needed to test for
530 values or trival rhss, because (in particular) we don't want to insert
531 new bindings between the "=" and the "\". E.g.
532 f = \x -> let <bind> in <body>
533 We do not want
534 f = let <bind> in \x -> <body>
535 (a) The simplifier will immediately float it further out, so we may
536 as well do so right now; in general, keeping rhss as manifest
537 values is good
538 (b) If a float-in pass follows immediately, it might add yet more
539 bindings just after the '='. And some of them might (correctly)
540 be strict even though the 'let f' is lazy, because f, being a value,
541 gets its demand-info zapped by the simplifier.
542 And even all that turned out to be very fragile, and broke
543 altogether when profiling got in the way.
544
545 So now we do the partition right at the (Let..) itself.
546
547 ************************************************************************
548 * *
549 \subsection{Utility bits for floating stats}
550 * *
551 ************************************************************************
552
553 I didn't implement this with unboxed numbers. I don't want to be too
554 strict in this stuff, as it is rarely turned on. (WDP 95/09)
555 -}
556
557 data FloatStats
558 = FlS Int -- Number of top-floats * lambda groups they've been past
559 Int -- Number of non-top-floats * lambda groups they've been past
560 Int -- Number of lambda (groups) seen
561
562 get_stats :: FloatStats -> (Int, Int, Int)
563 get_stats (FlS a b c) = (a, b, c)
564
565 zeroStats :: FloatStats
566 zeroStats = FlS 0 0 0
567
568 sum_stats :: [FloatStats] -> FloatStats
569 sum_stats xs = foldr add_stats zeroStats xs
570
571 add_stats :: FloatStats -> FloatStats -> FloatStats
572 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
573 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
574
575 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
576 add_to_stats (FlS a b c) (FB tops ceils others)
577 = FlS (a + lengthBag tops)
578 (b + lengthBag ceils + lengthBag (flattenMajor others))
579 (c + 1)
580
581 {-
582 ************************************************************************
583 * *
584 \subsection{Utility bits for floating}
585 * *
586 ************************************************************************
587
588 Note [Representation of FloatBinds]
589 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
590 The FloatBinds types is somewhat important. We can get very large numbers
591 of floating bindings, often all destined for the top level. A typical example
592 is x = [4,2,5,2,5, .... ]
593 Then we get lots of small expressions like (fromInteger 4), which all get
594 lifted to top level.
595
596 The trouble is that
597 (a) we partition these floating bindings *at every binding site*
598 (b) SetLevels introduces a new bindings site for every float
599 So we had better not look at each binding at each binding site!
600
601 That is why MajorEnv is represented as a finite map.
602
603 We keep the bindings destined for the *top* level separate, because
604 we float them out even if they don't escape a *value* lambda; see
605 partitionByMajorLevel.
606 -}
607
608 type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted
609 type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
610 type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
611
612 data FloatBinds = FB !(Bag FloatLet) -- Destined for top level
613 !(Bag FloatBind) -- Destined for join ceiling
614 !MajorEnv -- Other levels
615 -- See Note [Representation of FloatBinds]
616
617 instance Outputable FloatBinds where
618 ppr (FB fbs ceils defs)
619 = text "FB" <+> (braces $ vcat
620 [ text "tops =" <+> ppr fbs
621 , text "ceils =" <+> ppr ceils
622 , text "non-tops =" <+> ppr defs ])
623
624 flattenTopFloats :: FloatBinds -> Bag CoreBind
625 flattenTopFloats (FB tops ceils defs)
626 = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )
627 ASSERT2( isEmptyBag ceils, ppr ceils )
628 tops
629
630 addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
631 addTopFloatPairs float_bag prs
632 = foldrBag add prs float_bag
633 where
634 add (NonRec b r) prs = (b,r):prs
635 add (Rec prs1) prs2 = prs1 ++ prs2
636
637 flattenMajor :: MajorEnv -> Bag FloatBind
638 flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag
639
640 flattenMinor :: MinorEnv -> Bag FloatBind
641 flattenMinor = M.foldr unionBags emptyBag
642
643 emptyFloats :: FloatBinds
644 emptyFloats = FB emptyBag emptyBag M.empty
645
646 unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
647 unitCaseFloat (Level major minor t) e b con bs
648 | t == JoinCeilLvl
649 = FB emptyBag floats M.empty
650 | otherwise
651 = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))
652 where
653 floats = unitBag (FloatCase e b con bs)
654
655 unitLetFloat :: Level -> FloatLet -> FloatBinds
656 unitLetFloat lvl@(Level major minor t) b
657 | isTopLvl lvl = FB (unitBag b) emptyBag M.empty
658 | t == JoinCeilLvl = FB emptyBag floats M.empty
659 | otherwise = FB emptyBag emptyBag (M.singleton major
660 (M.singleton minor floats))
661 where
662 floats = unitBag (FloatLet b)
663
664 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
665 plusFloats (FB t1 c1 l1) (FB t2 c2 l2)
666 = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)
667
668 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
669 plusMajor = M.unionWith plusMinor
670
671 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
672 plusMinor = M.unionWith unionBags
673
674 install :: Bag FloatBind -> CoreExpr -> CoreExpr
675 install defn_groups expr
676 = foldrBag wrapFloat expr defn_groups
677
678 partitionByLevel
679 :: Level -- Partitioning level
680 -> FloatBinds -- Defns to be divided into 2 piles...
681 -> (FloatBinds, -- Defns with level strictly < partition level,
682 Bag FloatBind) -- The rest
683
684 {-
685 -- ---- partitionByMajorLevel ----
686 -- Float it if we escape a value lambda,
687 -- *or* if we get to the top level
688 -- *or* if it's a case-float and its minor level is < current
689 --
690 -- If we can get to the top level, say "yes" anyway. This means that
691 -- x = f e
692 -- transforms to
693 -- lvl = e
694 -- x = f lvl
695 -- which is as it should be
696
697 partitionByMajorLevel (Level major _) (FB tops defns)
698 = (FB tops outer, heres `unionBags` flattenMajor inner)
699 where
700 (outer, mb_heres, inner) = M.splitLookup major defns
701 heres = case mb_heres of
702 Nothing -> emptyBag
703 Just h -> flattenMinor h
704 -}
705
706 partitionByLevel (Level major minor typ) (FB tops ceils defns)
707 = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),
708 here_min `unionBags` here_ceil
709 `unionBags` flattenMinor inner_min
710 `unionBags` flattenMajor inner_maj)
711
712 where
713 (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
714 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
715 Nothing -> (M.empty, Nothing, M.empty)
716 Just min_defns -> M.splitLookup minor min_defns
717 here_min = mb_here_min `orElse` emptyBag
718 (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)
719 | otherwise = (emptyBag, ceils)
720
721 -- Like partitionByLevel, but instead split out the bindings that are marked
722 -- to float to the nearest join ceiling (see Note [Join points])
723 partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)
724 partitionAtJoinCeiling (FB tops ceils defs)
725 = (FB tops emptyBag defs, ceils)
726
727 -- Perform some action at a join ceiling, i.e., don't let join points float out
728 -- (see Note [Join points])
729 atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)
730 -> (FloatStats, FloatBinds, CoreExpr)
731 atJoinCeiling (fs, floats, expr')
732 = (fs, floats', install ceils expr')
733 where
734 (floats', ceils) = partitionAtJoinCeiling floats
735
736 wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
737 wrapTick t (FB tops ceils defns)
738 = FB (mapBag wrap_bind tops) (wrap_defns ceils)
739 (M.map (M.map wrap_defns) defns)
740 where
741 wrap_defns = mapBag wrap_one
742
743 wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
744 wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs)
745
746 wrap_one (FloatLet bind) = FloatLet (wrap_bind bind)
747 wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
748
749 maybe_tick e | exprIsHNF e = tickHNFArgs t e
750 | otherwise = mkTick t e
751 -- we don't need to wrap a tick around an HNF when we float it
752 -- outside a tick: that is an invariant of the tick semantics
753 -- Conversely, inlining of HNFs inside an SCC is allowed, and
754 -- indeed the HNF we're floating here might well be inlined back
755 -- again, and we don't want to end up with duplicate ticks.