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