Update Hadrian
[ghc.git] / compiler / simplCore / FloatIn.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 ************************************************************************
5 * *
6 \section[FloatIn]{Floating Inwards pass}
7 * *
8 ************************************************************************
9
10 The main purpose of @floatInwards@ is floating into branches of a
11 case, so that we don't allocate things, save them on the stack, and
12 then discover that they aren't needed in the chosen branch.
13 -}
14
15 {-# LANGUAGE CPP #-}
16 {-# OPTIONS_GHC -fprof-auto #-}
17
18 module FloatIn ( floatInwards ) where
19
20 #include "HsVersions.h"
21
22 import GhcPrelude
23
24 import CoreSyn
25 import MkCore
26 import HscTypes ( ModGuts(..) )
27 import CoreUtils
28 import CoreFVs
29 import CoreMonad ( CoreM )
30 import Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )
31 import Var
32 import Type
33 import VarSet
34 import Util
35 import DynFlags
36 import Outputable
37 -- import Data.List ( mapAccumL )
38 import BasicTypes ( RecFlag(..), isRec )
39
40 {-
41 Top-level interface function, @floatInwards@. Note that we do not
42 actually float any bindings downwards from the top-level.
43 -}
44
45 floatInwards :: ModGuts -> CoreM ModGuts
46 floatInwards pgm@(ModGuts { mg_binds = binds })
47 = do { dflags <- getDynFlags
48 ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }
49 where
50 fi_top_bind dflags (NonRec binder rhs)
51 = NonRec binder (fiExpr dflags [] (freeVars rhs))
52 fi_top_bind dflags (Rec pairs)
53 = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
54
55
56 {-
57 ************************************************************************
58 * *
59 \subsection{Mail from Andr\'e [edited]}
60 * *
61 ************************************************************************
62
63 {\em Will wrote: What??? I thought the idea was to float as far
64 inwards as possible, no matter what. This is dropping all bindings
65 every time it sees a lambda of any kind. Help! }
66
67 You are assuming we DO DO full laziness AFTER floating inwards! We
68 have to [not float inside lambdas] if we don't.
69
70 If we indeed do full laziness after the floating inwards (we could
71 check the compilation flags for that) then I agree we could be more
72 aggressive and do float inwards past lambdas.
73
74 Actually we are not doing a proper full laziness (see below), which
75 was another reason for not floating inwards past a lambda.
76
77 This can easily be fixed. The problem is that we float lets outwards,
78 but there are a few expressions which are not let bound, like case
79 scrutinees and case alternatives. After floating inwards the
80 simplifier could decide to inline the let and the laziness would be
81 lost, e.g.
82
83 \begin{verbatim}
84 let a = expensive ==> \b -> case expensive of ...
85 in \ b -> case a of ...
86 \end{verbatim}
87 The fix is
88 \begin{enumerate}
89 \item
90 to let bind the algebraic case scrutinees (done, I think) and
91 the case alternatives (except the ones with an
92 unboxed type)(not done, I think). This is best done in the
93 SetLevels.hs module, which tags things with their level numbers.
94 \item
95 do the full laziness pass (floating lets outwards).
96 \item
97 simplify. The simplifier inlines the (trivial) lets that were
98 created but were not floated outwards.
99 \end{enumerate}
100
101 With the fix I think Will's suggestion that we can gain even more from
102 strictness by floating inwards past lambdas makes sense.
103
104 We still gain even without going past lambdas, as things may be
105 strict in the (new) context of a branch (where it was floated to) or
106 of a let rhs, e.g.
107 \begin{verbatim}
108 let a = something case x of
109 in case x of alt1 -> case something of a -> a + a
110 alt1 -> a + a ==> alt2 -> b
111 alt2 -> b
112
113 let a = something let b = case something of a -> a + a
114 in let b = a + a ==> in (b,b)
115 in (b,b)
116 \end{verbatim}
117 Also, even if a is not found to be strict in the new context and is
118 still left as a let, if the branch is not taken (or b is not entered)
119 the closure for a is not built.
120
121 ************************************************************************
122 * *
123 \subsection{Main floating-inwards code}
124 * *
125 ************************************************************************
126 -}
127
128 type FreeVarSet = DIdSet
129 type BoundVarSet = DIdSet
130
131 data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
132 -- The FreeVarSet is the free variables of the binding. In the case
133 -- of recursive bindings, the set doesn't include the bound
134 -- variables.
135
136 type FloatInBinds = [FloatInBind]
137 -- In reverse dependency order (innermost binder first)
138
139 fiExpr :: DynFlags
140 -> FloatInBinds -- Binds we're trying to drop
141 -- as far "inwards" as possible
142 -> CoreExprWithFVs -- Input expr
143 -> CoreExpr -- Result
144
145 fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit
146 fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
147 fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
148 fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
149 fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))
150 = wrapFloats (drop_here ++ co_drop) $
151 Cast (fiExpr dflags e_drop expr) co
152 where
153 [drop_here, e_drop, co_drop]
154 = sepBindsByDropPoint dflags False
155 [freeVarsOf expr, freeVarsOfAnn co_ann]
156 to_drop
157
158 {-
159 Applications: we do float inside applications, mainly because we
160 need to get at all the arguments. The next simplifier run will
161 pull out any silly ones.
162 -}
163
164 fiExpr dflags to_drop ann_expr@(_,AnnApp {})
165 = wrapFloats drop_here $ wrapFloats extra_drop $
166 mkTicks ticks $
167 mkApps (fiExpr dflags fun_drop ann_fun)
168 (zipWith (fiExpr dflags) arg_drops ann_args)
169 where
170 (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
171 fun_ty = exprType (deAnnotate ann_fun)
172 fun_fvs = freeVarsOf ann_fun
173 arg_fvs = map freeVarsOf ann_args
174
175 (drop_here : extra_drop : fun_drop : arg_drops)
176 = sepBindsByDropPoint dflags False
177 (extra_fvs : fun_fvs : arg_fvs)
178 to_drop
179 -- Shortcut behaviour: if to_drop is empty,
180 -- sepBindsByDropPoint returns a suitable bunch of empty
181 -- lists without evaluating extra_fvs, and hence without
182 -- peering into each argument
183
184 (_, extra_fvs) = foldl add_arg (fun_ty, extra_fvs0) ann_args
185 extra_fvs0 = case ann_fun of
186 (_, AnnVar _) -> fun_fvs
187 _ -> emptyDVarSet
188 -- Don't float the binding for f into f x y z; see Note [Join points]
189 -- for why we *can't* do it when f is a join point. (If f isn't a
190 -- join point, floating it in isn't especially harmful but it's
191 -- useless since the simplifier will immediately float it back out.)
192
193 add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
194 add_arg (fun_ty, extra_fvs) (_, AnnType ty)
195 = (piResultTy fun_ty ty, extra_fvs)
196
197 add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
198 | noFloatIntoArg arg arg_ty
199 = (res_ty, extra_fvs `unionDVarSet` arg_fvs)
200 | otherwise
201 = (res_ty, extra_fvs)
202 where
203 (arg_ty, res_ty) = splitFunTy fun_ty
204
205 {-
206 Note [Do not destroy the let/app invariant]
207 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
208 Watch out for
209 f (x +# y)
210 We don't want to float bindings into here
211 f (case ... of { x -> x +# y })
212 because that might destroy the let/app invariant, which requires
213 unlifted function arguments to be ok-for-speculation.
214
215 Note [Join points]
216 ~~~~~~~~~~~~~~~~~~
217 Generally, we don't need to worry about join points - there are places we're
218 not allowed to float them, but since they can't have occurrences in those
219 places, we're not tempted.
220
221 We do need to be careful about jumps, however:
222
223 joinrec j x y z = ... in
224 jump j a b c
225
226 Previous versions often floated the definition of a recursive function into its
227 only non-recursive occurrence. But for a join point, this is a disaster:
228
229 (joinrec j x y z = ... in
230 jump j) a b c -- wrong!
231
232 Every jump must be exact, so the jump to j must have three arguments. Hence
233 we're careful not to float into the target of a jump (though we can float into
234 the arguments just fine).
235
236 Note [Floating in past a lambda group]
237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
238 * We must be careful about floating inside a value lambda.
239 That risks losing laziness.
240 The float-out pass might rescue us, but then again it might not.
241
242 * We must be careful about type lambdas too. At one time we did, and
243 there is no risk of duplicating work thereby, but we do need to be
244 careful. In particular, here is a bad case (it happened in the
245 cichelli benchmark:
246 let v = ...
247 in let f = /\t -> \a -> ...
248 ==>
249 let f = /\t -> let v = ... in \a -> ...
250 This is bad as now f is an updatable closure (update PAP)
251 and has arity 0.
252
253 * Hack alert! We only float in through one-shot lambdas,
254 not (as you might guess) through lone big lambdas.
255 Reason: we float *out* past big lambdas (see the test in the Lam
256 case of FloatOut.floatExpr) and we don't want to float straight
257 back in again.
258
259 It *is* important to float into one-shot lambdas, however;
260 see the remarks with noFloatIntoRhs.
261
262 So we treat lambda in groups, using the following rule:
263
264 Float in if (a) there is at least one Id,
265 and (b) there are no non-one-shot Ids
266
267 Otherwise drop all the bindings outside the group.
268
269 This is what the 'go' function in the AnnLam case is doing.
270
271 (Join points are handled similarly: a join point is considered one-shot iff
272 it's non-recursive, so we float only into non-recursive join points.)
273
274 Urk! if all are tyvars, and we don't float in, we may miss an
275 opportunity to float inside a nested case branch
276
277
278 Note [Floating coercions]
279 ~~~~~~~~~~~~~~~~~~~~~~~~~
280 We could, in principle, have a coercion binding like
281 case f x of co { DEFAULT -> e1 e2 }
282 It's not common to have a function that returns a coercion, but nothing
283 in Core prohibits it. If so, 'co' might be mentioned in e1 or e2
284 /only in a type/. E.g. suppose e1 was
285 let (x :: Int |> co) = blah in blah2
286
287
288 But, with coercions appearing in types, there is a complication: we
289 might be floating in a "strict let" -- that is, a case. Case expressions
290 mention their return type. We absolutely can't float a coercion binding
291 inward to the point that the type of the expression it's about to wrap
292 mentions the coercion. So we include the union of the sets of free variables
293 of the types of all the drop points involved. If any of the floaters
294 bind a coercion variable mentioned in any of the types, that binder must
295 be dropped right away.
296
297 -}
298
299 fiExpr dflags to_drop lam@(_, AnnLam _ _)
300 | noFloatIntoLam bndrs -- Dump it all here
301 -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088
302 = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))
303
304 | otherwise -- Float inside
305 = mkLams bndrs (fiExpr dflags to_drop body)
306
307 where
308 (bndrs, body) = collectAnnBndrs lam
309
310 {-
311 We don't float lets inwards past an SCC.
312 ToDo: keep info on current cc, and when passing
313 one, if it is not the same, annotate all lets in binds with current
314 cc, change current cc to the new one and float binds into expr.
315 -}
316
317 fiExpr dflags to_drop (_, AnnTick tickish expr)
318 | tickish `tickishScopesLike` SoftScope
319 = Tick tickish (fiExpr dflags to_drop expr)
320
321 | otherwise -- Wimp out for now - we could push values in
322 = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
323
324 {-
325 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
326 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
327 or~(b2), in each of the RHSs of the pairs of a @Rec@.
328
329 Note that we do {\em weird things} with this let's binding. Consider:
330 \begin{verbatim}
331 let
332 w = ...
333 in {
334 let v = ... w ...
335 in ... v .. w ...
336 }
337 \end{verbatim}
338 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
339 body of the inner let, we could panic and leave \tr{w}'s binding where
340 it is. But \tr{v} is floatable further into the body of the inner let, and
341 {\em then} \tr{w} will also be only in the body of that inner let.
342
343 So: rather than drop \tr{w}'s binding here, we add it onto the list of
344 things to drop in the outer let's body, and let nature take its
345 course.
346
347 Note [extra_fvs (1): avoid floating into RHS]
348 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349 Consider let x=\y....t... in body. We do not necessarily want to float
350 a binding for t into the RHS, because it'll immediately be floated out
351 again. (It won't go inside the lambda else we risk losing work.)
352 In letrec, we need to be more careful still. We don't want to transform
353 let x# = y# +# 1#
354 in
355 letrec f = \z. ...x#...f...
356 in ...
357 into
358 letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
359 because now we can't float the let out again, because a letrec
360 can't have unboxed bindings.
361
362 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
363 arrange to dump bindings that bind extra_fvs before the entire let.
364
365 Note [extra_fvs (2): free variables of rules]
366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367 Consider
368 let x{rule mentioning y} = rhs in body
369 Here y is not free in rhs or body; but we still want to dump bindings
370 that bind y outside the let. So we augment extra_fvs with the
371 idRuleAndUnfoldingVars of x. No need for type variables, hence not using
372 idFreeVars.
373 -}
374
375 fiExpr dflags to_drop (_,AnnLet bind body)
376 = fiExpr dflags (after ++ new_float : before) body
377 -- to_drop is in reverse dependency order
378 where
379 (before, new_float, after) = fiBind dflags to_drop bind body_fvs
380 body_fvs = freeVarsOf body
381
382 {- Note [Floating primops]
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~
384 We try to float-in a case expression over an unlifted type. The
385 motivating example was Trac #5658: in particular, this change allows
386 array indexing operations, which have a single DEFAULT alternative
387 without any binders, to be floated inward.
388
389 SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
390 scalars also need to be floated inward, but unpacks have a single non-DEFAULT
391 alternative that binds the elements of the tuple. We now therefore also support
392 floating in cases with a single alternative that may bind values.
393
394 But there are wrinkles
395
396 * Which unlifted cases do we float? See PrimOp.hs
397 Note [PrimOp can_fail and has_side_effects] which explains:
398 - We can float-in can_fail primops, but we can't float them out.
399 - But we can float a has_side_effects primop, but NOT inside a lambda,
400 so for now we don't float them at all.
401 Hence exprOkForSideEffects
402
403 * Because we can float can-fail primops (array indexing, division) inwards
404 but not outwards, we must be careful not to transform
405 case a /# b of r -> f (F# r)
406 ===>
407 f (case a /# b of r -> F# r)
408 because that creates a new thunk that wasn't there before. And
409 because it can't be floated out (can_fail), the thunk will stay
410 there. Disaster! (This happened in nofib 'simple' and 'scs'.)
411
412 Solution: only float cases into the branches of other cases, and
413 not into the arguments of an application, or the RHS of a let. This
414 is somewhat conservative, but it's simple. And it still hits the
415 cases like Trac #5658. This is implemented in sepBindsByJoinPoint;
416 if is_case is False we dump all floating cases right here.
417
418 For @Case@, the possible drop points for the 'to_drop'
419 bindings are:
420 (a) inside the scrutinee
421 (b) inside one of the alternatives/default (default FVs always /first/!).
422
423 -}
424
425 fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
426 | isUnliftedType (idType case_bndr)
427 , exprOkForSideEffects (deAnnotate scrut)
428 -- See Note [Floating primops]
429 = wrapFloats shared_binds $
430 fiExpr dflags (case_float : rhs_binds) rhs
431 where
432 case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
433 (FloatCase scrut' case_bndr con alt_bndrs)
434 scrut' = fiExpr dflags scrut_binds scrut
435 rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
436 scrut_fvs = freeVarsOf scrut
437
438 [shared_binds, scrut_binds, rhs_binds]
439 = sepBindsByDropPoint dflags False
440 [scrut_fvs, rhs_fvs]
441 to_drop
442
443 fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
444 = wrapFloats drop_here1 $
445 wrapFloats drop_here2 $
446 Case (fiExpr dflags scrut_drops scrut) case_bndr ty
447 (zipWith fi_alt alts_drops_s alts)
448 where
449 -- Float into the scrut and alts-considered-together just like App
450 [drop_here1, scrut_drops, alts_drops]
451 = sepBindsByDropPoint dflags False
452 [scrut_fvs, all_alts_fvs]
453 to_drop
454
455 -- Float into the alts with the is_case flag set
456 (drop_here2 : alts_drops_s)
457 | [ _ ] <- alts = [] : [alts_drops]
458 | otherwise = sepBindsByDropPoint dflags True alts_fvs alts_drops
459
460 scrut_fvs = freeVarsOf scrut
461 alts_fvs = map alt_fvs alts
462 all_alts_fvs = unionDVarSets alts_fvs
463 alt_fvs (_con, args, rhs)
464 = foldl delDVarSet (freeVarsOf rhs) (case_bndr:args)
465 -- Delete case_bndr and args from free vars of rhs
466 -- to get free vars of alt
467
468 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)
469
470 ------------------
471 fiBind :: DynFlags
472 -> FloatInBinds -- Binds we're trying to drop
473 -- as far "inwards" as possible
474 -> CoreBindWithFVs -- Input binding
475 -> DVarSet -- Free in scope of binding
476 -> ( FloatInBinds -- Land these before
477 , FloatInBind -- The binding itself
478 , FloatInBinds) -- Land these after
479
480 fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
481 = ( extra_binds ++ shared_binds -- Land these before
482 -- See Note [extra_fvs (1,2)]
483 , FB (unitDVarSet id) rhs_fvs' -- The new binding itself
484 (FloatLet (NonRec id rhs'))
485 , body_binds ) -- Land these after
486
487 where
488 body_fvs2 = body_fvs `delDVarSet` id
489
490 rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules]
491 extra_fvs | noFloatIntoRhs NonRecursive id rhs
492 = rule_fvs `unionDVarSet` rhs_fvs
493 | otherwise
494 = rule_fvs
495 -- See Note [extra_fvs (1): avoid floating into RHS]
496 -- No point in floating in only to float straight out again
497 -- We *can't* float into ok-for-speculation unlifted RHSs
498 -- But do float into join points
499
500 [shared_binds, extra_binds, rhs_binds, body_binds]
501 = sepBindsByDropPoint dflags False
502 [extra_fvs, rhs_fvs, body_fvs2]
503 to_drop
504
505 -- Push rhs_binds into the right hand side of the binding
506 rhs' = fiRhs dflags rhs_binds id ann_rhs
507 rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
508 -- Don't forget the rule_fvs; the binding mentions them!
509
510 fiBind dflags to_drop (AnnRec bindings) body_fvs
511 = ( extra_binds ++ shared_binds
512 , FB (mkDVarSet ids) rhs_fvs'
513 (FloatLet (Rec (fi_bind rhss_binds bindings)))
514 , body_binds )
515 where
516 (ids, rhss) = unzip bindings
517 rhss_fvs = map freeVarsOf rhss
518
519 -- See Note [extra_fvs (1,2)]
520 rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
521 extra_fvs = rule_fvs `unionDVarSet`
522 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
523 , noFloatIntoRhs Recursive bndr rhs ]
524
525 (shared_binds:extra_binds:body_binds:rhss_binds)
526 = sepBindsByDropPoint dflags False
527 (extra_fvs:body_fvs:rhss_fvs)
528 to_drop
529
530 rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
531 unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
532 rule_fvs -- Don't forget the rule variables!
533
534 -- Push rhs_binds into the right hand side of the binding
535 fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
536 -> [(Id, CoreExprWithFVs)]
537 -> [(Id, CoreExpr)]
538
539 fi_bind to_drops pairs
540 = [ (binder, fiRhs dflags to_drop binder rhs)
541 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
542
543 ------------------
544 fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
545 fiRhs dflags to_drop bndr rhs
546 | Just join_arity <- isJoinId_maybe bndr
547 , let (bndrs, body) = collectNAnnBndrs join_arity rhs
548 = mkLams bndrs (fiExpr dflags to_drop body)
549 | otherwise
550 = fiExpr dflags to_drop rhs
551
552 ------------------
553 noFloatIntoLam :: [Var] -> Bool
554 noFloatIntoLam bndrs = any bad bndrs
555 where
556 bad b = isId b && not (isOneShotBndr b)
557 -- Don't float inside a non-one-shot lambda
558
559 noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
560 -- ^ True if it's a bad idea to float bindings into this RHS
561 noFloatIntoRhs is_rec bndr rhs
562 | isJoinId bndr
563 = isRec is_rec -- Joins are one-shot iff non-recursive
564
565 | otherwise
566 = noFloatIntoArg rhs (idType bndr)
567
568 noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
569 noFloatIntoArg expr expr_ty
570 | isUnliftedType expr_ty
571 = True -- See Note [Do not destroy the let/app invariant]
572
573 | AnnLam bndr e <- expr
574 , (bndrs, _) <- collectAnnBndrs e
575 = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a)
576 || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b)
577 -- See Note [noFloatInto considerations] wrinkle 2
578
579 | otherwise -- Note [noFloatInto considerations] wrinkle 2
580 = exprIsTrivial deann_expr || exprIsHNF deann_expr
581 where
582 deann_expr = deAnnotate' expr
583
584 {- Note [noFloatInto considerations]
585 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
586 When do we want to float bindings into
587 - noFloatIntoRHs: the RHS of a let-binding
588 - noFloatIntoArg: the argument of a function application
589
590 Definitely don't float in if it has unlifted type; that
591 would destroy the let/app invariant.
592
593 * Wrinkle 1: do not float in if
594 (a) any non-one-shot value lambdas
595 or (b) all type lambdas
596 In both cases we'll float straight back out again
597 NB: Must line up with fiExpr (AnnLam...); see Trac #7088
598
599 (a) is important: we /must/ float into a one-shot lambda group
600 (which includes join points). This makes a big difference
601 for things like
602 f x# = let x = I# x#
603 in let j = \() -> ...x...
604 in if <condition> then normal-path else j ()
605 If x is used only in the error case join point, j, we must float the
606 boxing constructor into it, else we box it every time which is very
607 bad news indeed.
608
609 * Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
610 back out again... not tragic, but a waste of time.
611
612 For function arguments we will still end up with this
613 in-then-out stuff; consider
614 letrec x = e in f x
615 Here x is not a HNF, so we'll produce
616 f (letrec x = e in x)
617 which is OK... it's not that common, and we'll end up
618 floating out again, in CorePrep if not earlier.
619 Still, we use exprIsTrivial to catch this case (sigh)
620
621
622 ************************************************************************
623 * *
624 \subsection{@sepBindsByDropPoint@}
625 * *
626 ************************************************************************
627
628 This is the crucial function. The idea is: We have a wad of bindings
629 that we'd like to distribute inside a collection of {\em drop points};
630 insides the alternatives of a \tr{case} would be one example of some
631 drop points; the RHS and body of a non-recursive \tr{let} binding
632 would be another (2-element) collection.
633
634 So: We're given a list of sets-of-free-variables, one per drop point,
635 and a list of floating-inwards bindings. If a binding can go into
636 only one drop point (without suddenly making something out-of-scope),
637 in it goes. If a binding is used inside {\em multiple} drop points,
638 then it has to go in a you-must-drop-it-above-all-these-drop-points
639 point.
640
641 We have to maintain the order on these drop-point-related lists.
642 -}
643
644 -- pprFIB :: FloatInBinds -> SDoc
645 -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
646
647 sepBindsByDropPoint
648 :: DynFlags
649 -> Bool -- True <=> is case expression
650 -> [FreeVarSet] -- One set of FVs per drop point
651 -- Always at least two long!
652 -> FloatInBinds -- Candidate floaters
653 -> [FloatInBinds] -- FIRST one is bindings which must not be floated
654 -- inside any drop point; the rest correspond
655 -- one-to-one with the input list of FV sets
656
657 -- Every input floater is returned somewhere in the result;
658 -- none are dropped, not even ones which don't seem to be
659 -- free in *any* of the drop-point fvs. Why? Because, for example,
660 -- a binding (let x = E in B) might have a specialised version of
661 -- x (say x') stored inside x, but x' isn't free in E or B.
662
663 type DropBox = (FreeVarSet, FloatInBinds)
664
665 sepBindsByDropPoint dflags is_case drop_pts floaters
666 | null floaters -- Shortcut common case
667 = [] : [[] | _ <- drop_pts]
668
669 | otherwise
670 = ASSERT( drop_pts `lengthAtLeast` 2 )
671 go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
672 where
673 n_alts = length drop_pts
674
675 go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
676 -- The *first* one in the argument list is the drop_here set
677 -- The FloatInBinds in the lists are in the reverse of
678 -- the normal FloatInBinds order; that is, they are the right way round!
679
680 go [] drop_boxes = map (reverse . snd) drop_boxes
681
682 go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
683 = go binds new_boxes
684 where
685 -- "here" means the group of bindings dropped at the top of the fork
686
687 (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
688 | (fvs, _) <- drop_boxes]
689
690 drop_here = used_here || cant_push
691
692 n_used_alts = count id used_in_flags -- returns number of Trues in list.
693
694 cant_push
695 | is_case = n_used_alts == n_alts -- Used in all, don't push
696 -- Remember n_alts > 1
697 || (n_used_alts > 1 && not (floatIsDupable dflags bind))
698 -- floatIsDupable: see Note [Duplicating floats]
699
700 | otherwise = floatIsCase bind || n_used_alts > 1
701 -- floatIsCase: see Note [Floating primops]
702
703 new_boxes | drop_here = (insert here_box : fork_boxes)
704 | otherwise = (here_box : new_fork_boxes)
705
706 new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
707 fork_boxes used_in_flags
708
709 insert :: DropBox -> DropBox
710 insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
711
712 insert_maybe box True = insert box
713 insert_maybe box False = box
714
715 go _ _ = panic "sepBindsByDropPoint/go"
716
717
718 {- Note [Duplicating floats]
719 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
720
721 For case expressions we duplicate the binding if it is reasonably
722 small, and if it is not used in all the RHSs This is good for
723 situations like
724 let x = I# y in
725 case e of
726 C -> error x
727 D -> error x
728 E -> ...not mentioning x...
729
730 If the thing is used in all RHSs there is nothing gained,
731 so we don't duplicate then.
732 -}
733
734 floatedBindsFVs :: FloatInBinds -> FreeVarSet
735 floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
736
737 fbFVs :: FloatInBind -> DVarSet
738 fbFVs (FB _ fvs _) = fvs
739
740 wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
741 -- Remember FloatInBinds is in *reverse* dependency order
742 wrapFloats [] e = e
743 wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
744
745 floatIsDupable :: DynFlags -> FloatBind -> Bool
746 floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
747 floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs
748 floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
749
750 floatIsCase :: FloatBind -> Bool
751 floatIsCase (FloatCase {}) = True
752 floatIsCase (FloatLet {}) = False