Update Trac ticket URLs to point to GitLab
[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 hiding ( wrapFloats )
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) = wrapFloats to_drop (Lit lit)
146 -- See Note [Dead bindings]
147 fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
148 fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v)
149 fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
150 fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))
151 = wrapFloats (drop_here ++ co_drop) $
152 Cast (fiExpr dflags e_drop expr) co
153 where
154 [drop_here, e_drop, co_drop]
155 = sepBindsByDropPoint dflags False
156 [freeVarsOf expr, freeVarsOfAnn co_ann]
157 to_drop
158
159 {-
160 Applications: we do float inside applications, mainly because we
161 need to get at all the arguments. The next simplifier run will
162 pull out any silly ones.
163 -}
164
165 fiExpr dflags to_drop ann_expr@(_,AnnApp {})
166 = wrapFloats drop_here $ wrapFloats extra_drop $
167 mkTicks ticks $
168 mkApps (fiExpr dflags fun_drop ann_fun)
169 (zipWith (fiExpr dflags) arg_drops ann_args)
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 dflags 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 dflags 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 dflags [] body))
312
313 | otherwise -- Float inside
314 = mkLams bndrs (fiExpr dflags 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 dflags to_drop (_, AnnTick tickish expr)
327 | tickish `tickishScopesLike` SoftScope
328 = Tick tickish (fiExpr dflags to_drop expr)
329
330 | otherwise -- Wimp out for now - we could push values in
331 = wrapFloats to_drop (Tick tickish (fiExpr dflags [] 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 dflags to_drop (_,AnnLet bind body)
385 = fiExpr dflags (after ++ new_float : before) body
386 -- to_drop is in reverse dependency order
387 where
388 (before, new_float, after) = fiBind dflags 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? See PrimOp.hs
406 Note [PrimOp can_fail and has_side_effects] which explains:
407 - We can float-in can_fail primops, but we can't float them out.
408 - But we can float a has_side_effects primop, but NOT inside a lambda,
409 so for now we don't float them at all.
410 Hence exprOkForSideEffects
411
412 * Because we can float can-fail primops (array indexing, division) inwards
413 but not outwards, we must be careful not to transform
414 case a /# b of r -> f (F# r)
415 ===>
416 f (case a /# b of r -> F# r)
417 because that creates a new thunk that wasn't there before. And
418 because it can't be floated out (can_fail), the thunk will stay
419 there. Disaster! (This happened in nofib 'simple' and 'scs'.)
420
421 Solution: only float cases into the branches of other cases, and
422 not into the arguments of an application, or the RHS of a let. This
423 is somewhat conservative, but it's simple. And it still hits the
424 cases like #5658. This is implemented in sepBindsByJoinPoint;
425 if is_case is False we dump all floating cases right here.
426
427 * #14511 is another example of why we want to restrict float-in
428 of case-expressions. Consider
429 case indexArray# a n of (# r #) -> writeArray# ma i (f r)
430 Now, floating that indexing operation into the (f r) thunk will
431 not create any new thunks, but it will keep the array 'a' alive
432 for much longer than the programmer expected.
433
434 So again, not floating a case into a let or argument seems like
435 the Right Thing
436
437 For @Case@, the possible drop points for the 'to_drop'
438 bindings are:
439 (a) inside the scrutinee
440 (b) inside one of the alternatives/default (default FVs always /first/!).
441
442 -}
443
444 fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
445 | isUnliftedType (idType case_bndr)
446 , exprOkForSideEffects (deAnnotate scrut)
447 -- See Note [Floating primops]
448 = wrapFloats shared_binds $
449 fiExpr dflags (case_float : rhs_binds) rhs
450 where
451 case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
452 (FloatCase scrut' case_bndr con alt_bndrs)
453 scrut' = fiExpr dflags scrut_binds scrut
454 rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
455 scrut_fvs = freeVarsOf scrut
456
457 [shared_binds, scrut_binds, rhs_binds]
458 = sepBindsByDropPoint dflags False
459 [scrut_fvs, rhs_fvs]
460 to_drop
461
462 fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
463 = wrapFloats drop_here1 $
464 wrapFloats drop_here2 $
465 Case (fiExpr dflags scrut_drops scrut) case_bndr ty
466 (zipWith fi_alt alts_drops_s alts)
467 where
468 -- Float into the scrut and alts-considered-together just like App
469 [drop_here1, scrut_drops, alts_drops]
470 = sepBindsByDropPoint dflags False
471 [scrut_fvs, all_alts_fvs]
472 to_drop
473
474 -- Float into the alts with the is_case flag set
475 (drop_here2 : alts_drops_s)
476 | [ _ ] <- alts = [] : [alts_drops]
477 | otherwise = sepBindsByDropPoint dflags True alts_fvs alts_drops
478
479 scrut_fvs = freeVarsOf scrut
480 alts_fvs = map alt_fvs alts
481 all_alts_fvs = unionDVarSets alts_fvs
482 alt_fvs (_con, args, rhs)
483 = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
484 -- Delete case_bndr and args from free vars of rhs
485 -- to get free vars of alt
486
487 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)
488
489 ------------------
490 fiBind :: DynFlags
491 -> FloatInBinds -- Binds we're trying to drop
492 -- as far "inwards" as possible
493 -> CoreBindWithFVs -- Input binding
494 -> DVarSet -- Free in scope of binding
495 -> ( FloatInBinds -- Land these before
496 , FloatInBind -- The binding itself
497 , FloatInBinds) -- Land these after
498
499 fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
500 = ( extra_binds ++ shared_binds -- Land these before
501 -- See Note [extra_fvs (1,2)]
502 , FB (unitDVarSet id) rhs_fvs' -- The new binding itself
503 (FloatLet (NonRec id rhs'))
504 , body_binds ) -- Land these after
505
506 where
507 body_fvs2 = body_fvs `delDVarSet` id
508
509 rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules]
510 extra_fvs | noFloatIntoRhs NonRecursive id rhs
511 = rule_fvs `unionDVarSet` rhs_fvs
512 | otherwise
513 = rule_fvs
514 -- See Note [extra_fvs (1): avoid floating into RHS]
515 -- No point in floating in only to float straight out again
516 -- We *can't* float into ok-for-speculation unlifted RHSs
517 -- But do float into join points
518
519 [shared_binds, extra_binds, rhs_binds, body_binds]
520 = sepBindsByDropPoint dflags False
521 [extra_fvs, rhs_fvs, body_fvs2]
522 to_drop
523
524 -- Push rhs_binds into the right hand side of the binding
525 rhs' = fiRhs dflags rhs_binds id ann_rhs
526 rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
527 -- Don't forget the rule_fvs; the binding mentions them!
528
529 fiBind dflags to_drop (AnnRec bindings) body_fvs
530 = ( extra_binds ++ shared_binds
531 , FB (mkDVarSet ids) rhs_fvs'
532 (FloatLet (Rec (fi_bind rhss_binds bindings)))
533 , body_binds )
534 where
535 (ids, rhss) = unzip bindings
536 rhss_fvs = map freeVarsOf rhss
537
538 -- See Note [extra_fvs (1,2)]
539 rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
540 extra_fvs = rule_fvs `unionDVarSet`
541 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
542 , noFloatIntoRhs Recursive bndr rhs ]
543
544 (shared_binds:extra_binds:body_binds:rhss_binds)
545 = sepBindsByDropPoint dflags False
546 (extra_fvs:body_fvs:rhss_fvs)
547 to_drop
548
549 rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
550 unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
551 rule_fvs -- Don't forget the rule variables!
552
553 -- Push rhs_binds into the right hand side of the binding
554 fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
555 -> [(Id, CoreExprWithFVs)]
556 -> [(Id, CoreExpr)]
557
558 fi_bind to_drops pairs
559 = [ (binder, fiRhs dflags to_drop binder rhs)
560 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
561
562 ------------------
563 fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
564 fiRhs dflags to_drop bndr rhs
565 | Just join_arity <- isJoinId_maybe bndr
566 , let (bndrs, body) = collectNAnnBndrs join_arity rhs
567 = mkLams bndrs (fiExpr dflags to_drop body)
568 | otherwise
569 = fiExpr dflags to_drop rhs
570
571 ------------------
572 noFloatIntoLam :: [Var] -> Bool
573 noFloatIntoLam bndrs = any bad bndrs
574 where
575 bad b = isId b && not (isOneShotBndr b)
576 -- Don't float inside a non-one-shot lambda
577
578 noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
579 -- ^ True if it's a bad idea to float bindings into this RHS
580 noFloatIntoRhs is_rec bndr rhs
581 | isJoinId bndr
582 = isRec is_rec -- Joins are one-shot iff non-recursive
583
584 | otherwise
585 = noFloatIntoArg rhs (idType bndr)
586
587 noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
588 noFloatIntoArg expr expr_ty
589 | isUnliftedType expr_ty
590 = True -- See Note [Do not destroy the let/app invariant]
591
592 | AnnLam bndr e <- expr
593 , (bndrs, _) <- collectAnnBndrs e
594 = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a)
595 || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b)
596 -- See Note [noFloatInto considerations] wrinkle 2
597
598 | otherwise -- Note [noFloatInto considerations] wrinkle 2
599 = exprIsTrivial deann_expr || exprIsHNF deann_expr
600 where
601 deann_expr = deAnnotate' expr
602
603 {- Note [noFloatInto considerations]
604 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
605 When do we want to float bindings into
606 - noFloatIntoRHs: the RHS of a let-binding
607 - noFloatIntoArg: the argument of a function application
608
609 Definitely don't float in if it has unlifted type; that
610 would destroy the let/app invariant.
611
612 * Wrinkle 1: do not float in if
613 (a) any non-one-shot value lambdas
614 or (b) all type lambdas
615 In both cases we'll float straight back out again
616 NB: Must line up with fiExpr (AnnLam...); see #7088
617
618 (a) is important: we /must/ float into a one-shot lambda group
619 (which includes join points). This makes a big difference
620 for things like
621 f x# = let x = I# x#
622 in let j = \() -> ...x...
623 in if <condition> then normal-path else j ()
624 If x is used only in the error case join point, j, we must float the
625 boxing constructor into it, else we box it every time which is very
626 bad news indeed.
627
628 * Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
629 back out again... not tragic, but a waste of time.
630
631 For function arguments we will still end up with this
632 in-then-out stuff; consider
633 letrec x = e in f x
634 Here x is not a HNF, so we'll produce
635 f (letrec x = e in x)
636 which is OK... it's not that common, and we'll end up
637 floating out again, in CorePrep if not earlier.
638 Still, we use exprIsTrivial to catch this case (sigh)
639
640
641 ************************************************************************
642 * *
643 \subsection{@sepBindsByDropPoint@}
644 * *
645 ************************************************************************
646
647 This is the crucial function. The idea is: We have a wad of bindings
648 that we'd like to distribute inside a collection of {\em drop points};
649 insides the alternatives of a \tr{case} would be one example of some
650 drop points; the RHS and body of a non-recursive \tr{let} binding
651 would be another (2-element) collection.
652
653 So: We're given a list of sets-of-free-variables, one per drop point,
654 and a list of floating-inwards bindings. If a binding can go into
655 only one drop point (without suddenly making something out-of-scope),
656 in it goes. If a binding is used inside {\em multiple} drop points,
657 then it has to go in a you-must-drop-it-above-all-these-drop-points
658 point.
659
660 We have to maintain the order on these drop-point-related lists.
661 -}
662
663 -- pprFIB :: FloatInBinds -> SDoc
664 -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
665
666 sepBindsByDropPoint
667 :: DynFlags
668 -> Bool -- True <=> is case expression
669 -> [FreeVarSet] -- One set of FVs per drop point
670 -- Always at least two long!
671 -> FloatInBinds -- Candidate floaters
672 -> [FloatInBinds] -- FIRST one is bindings which must not be floated
673 -- inside any drop point; the rest correspond
674 -- one-to-one with the input list of FV sets
675
676 -- Every input floater is returned somewhere in the result;
677 -- none are dropped, not even ones which don't seem to be
678 -- free in *any* of the drop-point fvs. Why? Because, for example,
679 -- a binding (let x = E in B) might have a specialised version of
680 -- x (say x') stored inside x, but x' isn't free in E or B.
681
682 type DropBox = (FreeVarSet, FloatInBinds)
683
684 sepBindsByDropPoint dflags is_case drop_pts floaters
685 | null floaters -- Shortcut common case
686 = [] : [[] | _ <- drop_pts]
687
688 | otherwise
689 = ASSERT( drop_pts `lengthAtLeast` 2 )
690 go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
691 where
692 n_alts = length drop_pts
693
694 go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
695 -- The *first* one in the argument list is the drop_here set
696 -- The FloatInBinds in the lists are in the reverse of
697 -- the normal FloatInBinds order; that is, they are the right way round!
698
699 go [] drop_boxes = map (reverse . snd) drop_boxes
700
701 go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
702 = go binds new_boxes
703 where
704 -- "here" means the group of bindings dropped at the top of the fork
705
706 (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
707 | (fvs, _) <- drop_boxes]
708
709 drop_here = used_here || cant_push
710
711 n_used_alts = count id used_in_flags -- returns number of Trues in list.
712
713 cant_push
714 | is_case = n_used_alts == n_alts -- Used in all, don't push
715 -- Remember n_alts > 1
716 || (n_used_alts > 1 && not (floatIsDupable dflags bind))
717 -- floatIsDupable: see Note [Duplicating floats]
718
719 | otherwise = floatIsCase bind || n_used_alts > 1
720 -- floatIsCase: see Note [Floating primops]
721
722 new_boxes | drop_here = (insert here_box : fork_boxes)
723 | otherwise = (here_box : new_fork_boxes)
724
725 new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
726 fork_boxes used_in_flags
727
728 insert :: DropBox -> DropBox
729 insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
730
731 insert_maybe box True = insert box
732 insert_maybe box False = box
733
734 go _ _ = panic "sepBindsByDropPoint/go"
735
736
737 {- Note [Duplicating floats]
738 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
739
740 For case expressions we duplicate the binding if it is reasonably
741 small, and if it is not used in all the RHSs This is good for
742 situations like
743 let x = I# y in
744 case e of
745 C -> error x
746 D -> error x
747 E -> ...not mentioning x...
748
749 If the thing is used in all RHSs there is nothing gained,
750 so we don't duplicate then.
751 -}
752
753 floatedBindsFVs :: FloatInBinds -> FreeVarSet
754 floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
755
756 fbFVs :: FloatInBind -> DVarSet
757 fbFVs (FB _ fvs _) = fvs
758
759 wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
760 -- Remember FloatInBinds is in *reverse* dependency order
761 wrapFloats [] e = e
762 wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
763
764 floatIsDupable :: DynFlags -> FloatBind -> Bool
765 floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
766 floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs
767 floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
768
769 floatIsCase :: FloatBind -> Bool
770 floatIsCase (FloatCase {}) = True
771 floatIsCase (FloatLet {}) = False