compiler: make sure we reject -O + HscInterpreted
[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 {-# OPTIONS_GHC -fno-warn-orphans #-}
11
12 module FloatOut ( floatOutwards ) where
13
14 import CoreSyn
15 import CoreUtils
16 import MkCore
17 import CoreArity ( etaExpand )
18 import CoreMonad ( FloatOutSwitches(..) )
19
20 import DynFlags
21 import ErrUtils ( dumpIfSet_dyn )
22 import Id ( Id, idArity, isBottomingId )
23 import Var ( Var )
24 import SetLevels
25 import UniqSupply ( UniqSupply )
26 import Bag
27 import Util
28 import Maybes
29 import Outputable
30 import FastString
31 import qualified Data.IntMap as M
32
33 #include "HsVersions.h"
34
35 {-
36 -----------------
37 Overall game plan
38 -----------------
39
40 The Big Main Idea is:
41
42 To float out sub-expressions that can thereby get outside
43 a non-one-shot value lambda, and hence may be shared.
44
45
46 To achieve this we may need to do two thing:
47
48 a) Let-bind the sub-expression:
49
50 f (g x) ==> let lvl = f (g x) in lvl
51
52 Now we can float the binding for 'lvl'.
53
54 b) More than that, we may need to abstract wrt a type variable
55
56 \x -> ... /\a -> let v = ...a... in ....
57
58 Here the binding for v mentions 'a' but not 'x'. So we
59 abstract wrt 'a', to give this binding for 'v':
60
61 vp = /\a -> ...a...
62 v = vp a
63
64 Now the binding for vp can float out unimpeded.
65 I can't remember why this case seemed important enough to
66 deal with, but I certainly found cases where important floats
67 didn't happen if we did not abstract wrt tyvars.
68
69 With this in mind we can also achieve another goal: lambda lifting.
70 We can make an arbitrary (function) binding float to top level by
71 abstracting wrt *all* local variables, not just type variables, leaving
72 a binding that can be floated right to top level. Whether or not this
73 happens is controlled by a flag.
74
75
76 Random comments
77 ~~~~~~~~~~~~~~~
78
79 At the moment we never float a binding out to between two adjacent
80 lambdas. For example:
81
82 @
83 \x y -> let t = x+x in ...
84 ===>
85 \x -> let t = x+x in \y -> ...
86 @
87 Reason: this is less efficient in the case where the original lambda
88 is never partially applied.
89
90 But there's a case I've seen where this might not be true. Consider:
91 @
92 elEm2 x ys
93 = elem' x ys
94 where
95 elem' _ [] = False
96 elem' x (y:ys) = x==y || elem' x ys
97 @
98 It turns out that this generates a subexpression of the form
99 @
100 \deq x ys -> let eq = eqFromEqDict deq in ...
101 @
102 vwhich might usefully be separated to
103 @
104 \deq -> let eq = eqFromEqDict deq in \xy -> ...
105 @
106 Well, maybe. We don't do this at the moment.
107
108
109 ************************************************************************
110 * *
111 \subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
112 * *
113 ************************************************************************
114 -}
115
116 floatOutwards :: FloatOutSwitches
117 -> DynFlags
118 -> UniqSupply
119 -> CoreProgram -> IO CoreProgram
120
121 floatOutwards float_sws dflags us pgm
122 = do {
123 let { annotated_w_levels = setLevels float_sws pgm us ;
124 (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
125 } ;
126
127 dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
128 (vcat (map ppr annotated_w_levels));
129
130 let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
131
132 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
133 (hcat [ int tlets, ptext (sLit " Lets floated to top level; "),
134 int ntlets, ptext (sLit " Lets floated elsewhere; from "),
135 int lams, ptext (sLit " Lambda groups")]);
136
137 return (bagToList (unionManyBags binds_s'))
138 }
139
140 floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
141 floatTopBind bind
142 = case (floatBind bind) of { (fs, floats, bind') ->
143 let float_bag = flattenTopFloats floats
144 in case bind' of
145 Rec prs -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
146 NonRec {} -> (fs, float_bag `snocBag` bind') }
147
148 {-
149 ************************************************************************
150 * *
151 \subsection[FloatOut-Bind]{Floating in a binding (the business end)}
152 * *
153 ************************************************************************
154 -}
155
156 floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind)
157 floatBind (NonRec (TB var _) rhs)
158 = case (floatExpr rhs) of { (fs, rhs_floats, rhs') ->
159
160 -- A tiresome hack:
161 -- see Note [Bottoming floats: eta expansion] in SetLevels
162 let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
163 | otherwise = rhs'
164
165 in (fs, rhs_floats, NonRec var rhs'') }
166
167 floatBind (Rec pairs)
168 = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
169 (fs, rhs_floats, Rec (concat new_pairs)) }
170 where
171 do_pair (TB name spec, rhs)
172 | isTopLvl dest_lvl -- See Note [floatBind for top level]
173 = case (floatExpr rhs) of { (fs, rhs_floats, rhs') ->
174 (fs, emptyFloats, addTopFloatPairs (flattenTopFloats rhs_floats) [(name, rhs')])}
175 | otherwise -- Note [Floating out of Rec rhss]
176 = case (floatExpr rhs) of { (fs, rhs_floats, rhs') ->
177 case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
178 case (splitRecFloats heres) of { (pairs, case_heres) ->
179 (fs, rhs_floats', (name, installUnderLambdas case_heres rhs') : pairs) }}}
180 where
181 dest_lvl = floatSpecLevel spec
182
183 splitRecFloats :: Bag FloatBind -> ([(Id,CoreExpr)], Bag FloatBind)
184 -- The "tail" begins with a case
185 -- See Note [Floating out of Rec rhss]
186 splitRecFloats fs
187 = go [] (bagToList fs)
188 where
189 go prs (FloatLet (NonRec b r) : fs) = go ((b,r):prs) fs
190 go prs (FloatLet (Rec prs') : fs) = go (prs' ++ prs) fs
191 go prs fs = (prs, listToBag fs)
192
193 installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
194 -- Note [Floating out of Rec rhss]
195 installUnderLambdas floats e
196 | isEmptyBag floats = e
197 | otherwise = go e
198 where
199 go (Lam b e) = Lam b (go e)
200 go e = install floats e
201
202 ---------------
203 floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
204 floatList _ [] = (zeroStats, emptyFloats, [])
205 floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
206 case floatList f as of { (fs_as, binds_as, bs) ->
207 (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
208
209 {-
210 Note [Floating out of Rec rhss]
211 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
212 Consider Rec { f<1,0> = \xy. body }
213 From the body we may get some floats. The ones with level <1,0> must
214 stay here, since they may mention f. Ideally we'd like to make them
215 part of the Rec block pairs -- but we can't if there are any
216 FloatCases involved.
217
218 Nor is it a good idea to dump them in the rhs, but outside the lambda
219 f = case x of I# y -> \xy. body
220 because now f's arity might get worse, which is Not Good. (And if
221 there's an SCC around the RHS it might not get better again.
222 See Trac #5342.)
223
224 So, gruesomely, we split the floats into
225 * the outer FloatLets, which can join the Rec, and
226 * an inner batch starting in a FloatCase, which are then
227 pushed *inside* the lambdas.
228 This loses full-laziness the rare situation where there is a
229 FloatCase and a Rec interacting.
230
231 Note [floatBind for top level]
232 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
233 We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
234 letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
235 The binding for bar will be in the "tops" part of the floating binds,
236 and thus not partioned by floatBody.
237
238 We could perhaps get rid of the 'tops' component of the floating binds,
239 but this case works just as well.
240
241
242 ************************************************************************
243
244 \subsection[FloatOut-Expr]{Floating in expressions}
245 * *
246 ************************************************************************
247 -}
248
249 floatBody :: Level
250 -> LevelledExpr
251 -> (FloatStats, FloatBinds, CoreExpr)
252
253 floatBody lvl arg -- Used rec rhss, and case-alternative rhss
254 = case (floatExpr arg) of { (fsa, floats, arg') ->
255 case (partitionByLevel lvl floats) of { (floats', heres) ->
256 -- Dump bindings are bound here
257 (fsa, floats', install heres arg') }}
258
259 -----------------
260
261 {- Note [Floating past breakpoints]
262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
263
264 Notes from Peter Wortmann (re: #10052)
265
266 "This case clearly means we're trying to float past a breakpoint..."
267
268 Further:
269
270 "Breakpoints as they currently exist are the only Tikish that is not
271 scoped, counting, and not splittable.
272
273 This means that we can't:
274 - Simply float code out of it, because the payload must still be covered (scoped)
275 - Copy the tick, because it would change entry counts (here: duplicate breakpoints)"
276
277 While this seems like an odd case, it can apparently occur in real
278 life: through the combination of optimizations + GHCi usage. For an
279 example, see #10052 as mentioned above. So not only does the
280 interpreter not like some compiler-generated things (like unboxed
281 tuples), the compiler doesn't like interpreter-introduced things!
282
283 Also see Note [GHCi and -O] in GHC.hs.
284 -}
285
286 floatExpr :: LevelledExpr
287 -> (FloatStats, FloatBinds, CoreExpr)
288 floatExpr (Var v) = (zeroStats, emptyFloats, Var v)
289 floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
290 floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
291 floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
292
293 floatExpr (App e a)
294 = case (floatExpr e) of { (fse, floats_e, e') ->
295 case (floatExpr a) of { (fsa, floats_a, a') ->
296 (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
297
298 floatExpr lam@(Lam (TB _ lam_spec) _)
299 = let (bndrs_w_lvls, body) = collectBinders lam
300 bndrs = [b | TB b _ <- bndrs_w_lvls]
301 bndr_lvl = floatSpecLevel lam_spec
302 -- All the binders have the same level
303 -- See SetLevels.lvlLamBndrs
304 in
305 case (floatBody bndr_lvl body) of { (fs, floats, body') ->
306 (add_to_stats fs floats, floats, mkLams bndrs body') }
307
308 floatExpr (Tick tickish expr)
309 | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
310 = case (floatExpr expr) of { (fs, floating_defns, expr') ->
311 (fs, floating_defns, Tick tickish expr') }
312
313 | not (tickishCounts tickish) || tickishCanSplit tickish
314 = case (floatExpr expr) of { (fs, floating_defns, expr') ->
315 let -- Annotate bindings floated outwards past an scc expression
316 -- with the cc. We mark that cc as "duplicated", though.
317 annotated_defns = wrapTick (mkNoCount tickish) floating_defns
318 in
319 (fs, annotated_defns, Tick tickish expr') }
320
321 -- Note [Floating past breakpoints]
322 | otherwise
323 = pprPanic "floatExpr tick" (ppr tickish)
324
325 floatExpr (Cast expr co)
326 = case (floatExpr expr) of { (fs, floating_defns, expr') ->
327 (fs, floating_defns, Cast expr' co) }
328
329 floatExpr (Let bind body)
330 = case bind_spec of
331 FloatMe dest_lvl
332 -> case (floatBind bind) of { (fsb, bind_floats, bind') ->
333 case (floatExpr body) of { (fse, body_floats, body') ->
334 ( add_stats fsb fse
335 , bind_floats `plusFloats` unitLetFloat dest_lvl bind'
336 `plusFloats` body_floats
337 , body') }}
338
339 StayPut bind_lvl -- See Note [Avoiding unnecessary floating]
340 -> case (floatBind bind) of { (fsb, bind_floats, bind') ->
341 case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
342 ( add_stats fsb fse
343 , bind_floats `plusFloats` body_floats
344 , Let bind' body') }}
345 where
346 bind_spec = case bind of
347 NonRec (TB _ s) _ -> s
348 Rec ((TB _ s, _) : _) -> s
349 Rec [] -> panic "floatExpr:rec"
350
351 floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
352 = case case_spec of
353 FloatMe dest_lvl -- Case expression moves
354 | [(con@(DataAlt {}), bndrs, rhs)] <- alts
355 -> case floatExpr scrut of { (fse, fde, scrut') ->
356 case floatExpr rhs of { (fsb, fdb, rhs') ->
357 let
358 float = unitCaseFloat dest_lvl scrut'
359 case_bndr con [b | TB b _ <- bndrs]
360 in
361 (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
362 | otherwise
363 -> pprPanic "Floating multi-case" (ppr alts)
364
365 StayPut bind_lvl -- Case expression stays put
366 -> case floatExpr scrut of { (fse, fde, scrut') ->
367 case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') ->
368 (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
369 }}
370 where
371 float_alt bind_lvl (con, bs, rhs)
372 = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
373 (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
374
375 {-
376 Note [Avoiding unnecessary floating]
377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
378 In general we want to avoid floating a let unnecessarily, because
379 it might worsen strictness:
380 let
381 x = ...(let y = e in y+y)....
382 Here y is demanded. If we float it outside the lazy 'x=..' then
383 we'd have to zap its demand info, and it may never be restored.
384
385 So at a 'let' we leave the binding right where the are unless
386 the binding will escape a value lambda, e.g.
387
388 (\x -> let y = fac 100 in y)
389
390 That's what the partitionByMajorLevel does in the floatExpr (Let ...)
391 case.
392
393 Notice, though, that we must take care to drop any bindings
394 from the body of the let that depend on the staying-put bindings.
395
396 We used instead to do the partitionByMajorLevel on the RHS of an '=',
397 in floatRhs. But that was quite tiresome. We needed to test for
398 values or trival rhss, because (in particular) we don't want to insert
399 new bindings between the "=" and the "\". E.g.
400 f = \x -> let <bind> in <body>
401 We do not want
402 f = let <bind> in \x -> <body>
403 (a) The simplifier will immediately float it further out, so we may
404 as well do so right now; in general, keeping rhss as manifest
405 values is good
406 (b) If a float-in pass follows immediately, it might add yet more
407 bindings just after the '='. And some of them might (correctly)
408 be strict even though the 'let f' is lazy, because f, being a value,
409 gets its demand-info zapped by the simplifier.
410 And even all that turned out to be very fragile, and broke
411 altogether when profiling got in the way.
412
413 So now we do the partition right at the (Let..) itself.
414
415 ************************************************************************
416 * *
417 \subsection{Utility bits for floating stats}
418 * *
419 ************************************************************************
420
421 I didn't implement this with unboxed numbers. I don't want to be too
422 strict in this stuff, as it is rarely turned on. (WDP 95/09)
423 -}
424
425 data FloatStats
426 = FlS Int -- Number of top-floats * lambda groups they've been past
427 Int -- Number of non-top-floats * lambda groups they've been past
428 Int -- Number of lambda (groups) seen
429
430 get_stats :: FloatStats -> (Int, Int, Int)
431 get_stats (FlS a b c) = (a, b, c)
432
433 zeroStats :: FloatStats
434 zeroStats = FlS 0 0 0
435
436 sum_stats :: [FloatStats] -> FloatStats
437 sum_stats xs = foldr add_stats zeroStats xs
438
439 add_stats :: FloatStats -> FloatStats -> FloatStats
440 add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
441 = FlS (a1 + a2) (b1 + b2) (c1 + c2)
442
443 add_to_stats :: FloatStats -> FloatBinds -> FloatStats
444 add_to_stats (FlS a b c) (FB tops others)
445 = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
446
447 {-
448 ************************************************************************
449 * *
450 \subsection{Utility bits for floating}
451 * *
452 ************************************************************************
453
454 Note [Representation of FloatBinds]
455 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 The FloatBinds types is somewhat important. We can get very large numbers
457 of floating bindings, often all destined for the top level. A typical example
458 is x = [4,2,5,2,5, .... ]
459 Then we get lots of small expressions like (fromInteger 4), which all get
460 lifted to top level.
461
462 The trouble is that
463 (a) we partition these floating bindings *at every binding site*
464 (b) SetLevels introduces a new bindings site for every float
465 So we had better not look at each binding at each binding site!
466
467 That is why MajorEnv is represented as a finite map.
468
469 We keep the bindings destined for the *top* level separate, because
470 we float them out even if they don't escape a *value* lambda; see
471 partitionByMajorLevel.
472 -}
473
474 type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted
475 type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
476 type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
477
478 data FloatBinds = FB !(Bag FloatLet) -- Destined for top level
479 !MajorEnv -- Levels other than top
480 -- See Note [Representation of FloatBinds]
481
482 instance Outputable FloatBinds where
483 ppr (FB fbs defs)
484 = ptext (sLit "FB") <+> (braces $ vcat
485 [ ptext (sLit "tops =") <+> ppr fbs
486 , ptext (sLit "non-tops =") <+> ppr defs ])
487
488 flattenTopFloats :: FloatBinds -> Bag CoreBind
489 flattenTopFloats (FB tops defs)
490 = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )
491 tops
492
493 addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
494 addTopFloatPairs float_bag prs
495 = foldrBag add prs float_bag
496 where
497 add (NonRec b r) prs = (b,r):prs
498 add (Rec prs1) prs2 = prs1 ++ prs2
499
500 flattenMajor :: MajorEnv -> Bag FloatBind
501 flattenMajor = M.fold (unionBags . flattenMinor) emptyBag
502
503 flattenMinor :: MinorEnv -> Bag FloatBind
504 flattenMinor = M.fold unionBags emptyBag
505
506 emptyFloats :: FloatBinds
507 emptyFloats = FB emptyBag M.empty
508
509 unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
510 unitCaseFloat (Level major minor) e b con bs
511 = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs))))
512
513 unitLetFloat :: Level -> FloatLet -> FloatBinds
514 unitLetFloat lvl@(Level major minor) b
515 | isTopLvl lvl = FB (unitBag b) M.empty
516 | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats))
517 where
518 floats = unitBag (FloatLet b)
519
520 plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
521 plusFloats (FB t1 l1) (FB t2 l2)
522 = FB (t1 `unionBags` t2) (l1 `plusMajor` l2)
523
524 plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
525 plusMajor = M.unionWith plusMinor
526
527 plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
528 plusMinor = M.unionWith unionBags
529
530 install :: Bag FloatBind -> CoreExpr -> CoreExpr
531 install defn_groups expr
532 = foldrBag wrapFloat expr defn_groups
533
534 partitionByLevel
535 :: Level -- Partitioning level
536 -> FloatBinds -- Defns to be divided into 2 piles...
537 -> (FloatBinds, -- Defns with level strictly < partition level,
538 Bag FloatBind) -- The rest
539
540 {-
541 -- ---- partitionByMajorLevel ----
542 -- Float it if we escape a value lambda,
543 -- *or* if we get to the top level
544 -- *or* if it's a case-float and its minor level is < current
545 --
546 -- If we can get to the top level, say "yes" anyway. This means that
547 -- x = f e
548 -- transforms to
549 -- lvl = e
550 -- x = f lvl
551 -- which is as it should be
552
553 partitionByMajorLevel (Level major _) (FB tops defns)
554 = (FB tops outer, heres `unionBags` flattenMajor inner)
555 where
556 (outer, mb_heres, inner) = M.splitLookup major defns
557 heres = case mb_heres of
558 Nothing -> emptyBag
559 Just h -> flattenMinor h
560 -}
561
562 partitionByLevel (Level major minor) (FB tops defns)
563 = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),
564 here_min `unionBags` flattenMinor inner_min
565 `unionBags` flattenMajor inner_maj)
566
567 where
568 (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
569 (outer_min, mb_here_min, inner_min) = case mb_here_maj of
570 Nothing -> (M.empty, Nothing, M.empty)
571 Just min_defns -> M.splitLookup minor min_defns
572 here_min = mb_here_min `orElse` emptyBag
573
574 wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
575 wrapTick t (FB tops defns)
576 = FB (mapBag wrap_bind tops) (M.map (M.map wrap_defns) defns)
577 where
578 wrap_defns = mapBag wrap_one
579
580 wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
581 wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs)
582
583 wrap_one (FloatLet bind) = FloatLet (wrap_bind bind)
584 wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
585
586 maybe_tick e | exprIsHNF e = tickHNFArgs t e
587 | otherwise = mkTick t e
588 -- we don't need to wrap a tick around an HNF when we float it
589 -- outside a tick: that is an invariant of the tick semantics
590 -- Conversely, inlining of HNFs inside an SCC is allowed, and
591 -- indeed the HNF we're floating here might well be inlined back
592 -- again, and we don't want to end up with duplicate ticks.