never executed always true always false
1
2 {-# LANGUAGE PatternSynonyms #-}
3
4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
5
6 {-
7 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
8
9 \section{GHC.Core.Opt.SetLevels}
10
11 ***************************
12 Overview
13 ***************************
14
15 1. We attach binding levels to Core bindings, in preparation for floating
16 outwards (@FloatOut@).
17
18 2. We also let-ify many expressions (notably case scrutinees), so they
19 will have a fighting chance of being floated sensible.
20
21 3. Note [Need for cloning during float-out]
22 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
23 We clone the binders of any floatable let-binding, so that when it is
24 floated out it will be unique. Example
25 (let x=2 in x) + (let x=3 in x)
26 we must clone before floating so we get
27 let x1=2 in
28 let x2=3 in
29 x1+x2
30
31 NOTE: this can't be done using the uniqAway idea, because the variable
32 must be unique in the whole program, not just its current scope,
33 because two variables in different scopes may float out to the
34 same top level place
35
36 NOTE: Very tiresomely, we must apply this substitution to
37 the rules stored inside a variable too.
38
39 We do *not* clone top-level bindings, because some of them must not change,
40 but we *do* clone bindings that are heading for the top level
41
42 4. Note [Binder-swap during float-out]
43 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
44 In the expression
45 case x of wild { p -> ...wild... }
46 we substitute x for wild in the RHS of the case alternatives:
47 case x of wild { p -> ...x... }
48 This means that a sub-expression involving x is not "trapped" inside the RHS.
49 And it's not inconvenient because we already have a substitution.
50
51 Note that this is EXACTLY BACKWARDS from the what the simplifier does.
52 The simplifier tries to get rid of occurrences of x, in favour of wild,
53 in the hope that there will only be one remaining occurrence of x, namely
54 the scrutinee of the case, and we can inline it.
55
56 This can only work if @wild@ is an unrestricted binder. Indeed, even with the
57 extended typing rule (in the linter) for case expressions, if
58 case x of wild # 1 { p -> e}
59 is well-typed, then
60 case x of wild # 1 { p -> e[wild\x] }
61 is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@
62 at all). In which case, it is, of course, pointless to do the substitution
63 anyway. So for a linear binder (and really anything which isn't unrestricted),
64 doing this substitution would either produce ill-typed terms or be the
65 identity.
66 -}
67
68 module GHC.Core.Opt.SetLevels (
69 setLevels,
70
71 Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
72 LevelledBind, LevelledExpr, LevelledBndr,
73 FloatSpec(..), floatSpecLevel,
74
75 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
76 ) where
77
78 import GHC.Prelude
79
80 import GHC.Core
81 import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
82 import GHC.Core.Utils ( exprType, exprIsHNF
83 , exprOkForSpeculation
84 , exprIsTopLevelBindable
85 , collectMakeStaticArgs
86 , mkLamTypes
87 )
88 import GHC.Core.Opt.Arity ( exprBotStrictness_maybe )
89 import GHC.Core.FVs -- all of it
90 import GHC.Core.Subst
91 import GHC.Core.Make ( sortQuantVars )
92 import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType
93 , mightBeUnliftedType, closeOverKindsDSet
94 , typeHasFixedRuntimeRep
95 )
96 import GHC.Core.Multiplicity ( pattern Many )
97 import GHC.Core.DataCon ( dataConOrigResTy )
98
99 import GHC.Types.Id
100 import GHC.Types.Id.Info
101 import GHC.Types.Var
102 import GHC.Types.Var.Set
103 import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet )
104 import GHC.Types.Unique.DSet ( getUniqDSet )
105 import GHC.Types.Var.Env
106 import GHC.Types.Literal ( litIsTrivial )
107 import GHC.Types.Demand ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig )
108 import GHC.Types.Cpr ( mkCprSig, botCpr )
109 import GHC.Types.Name ( getOccName, mkSystemVarName )
110 import GHC.Types.Name.Occurrence ( occNameString )
111 import GHC.Types.Unique ( hasKey )
112 import GHC.Types.Tickish ( tickishIsCode )
113 import GHC.Types.Unique.Supply
114 import GHC.Types.Unique.DFM
115 import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
116
117 import GHC.Builtin.Types
118 import GHC.Builtin.Names ( runRWKey )
119
120 import GHC.Data.FastString
121
122 import GHC.Utils.FV
123 import GHC.Utils.Monad ( mapAccumLM )
124 import GHC.Utils.Misc
125 import GHC.Utils.Outputable
126 import GHC.Utils.Panic
127 import GHC.Utils.Panic.Plain
128 import GHC.Utils.Trace
129
130 import Data.Maybe
131
132 {-
133 ************************************************************************
134 * *
135 \subsection{Level numbers}
136 * *
137 ************************************************************************
138 -}
139
140 type LevelledExpr = TaggedExpr FloatSpec
141 type LevelledBind = TaggedBind FloatSpec
142 type LevelledBndr = TaggedBndr FloatSpec
143
144 data Level = Level Int -- Level number of enclosing lambdas
145 Int -- Number of big-lambda and/or case expressions and/or
146 -- context boundaries between
147 -- here and the nearest enclosing lambda
148 LevelType -- Binder or join ceiling?
149 data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)
150
151 data FloatSpec
152 = FloatMe Level -- Float to just inside the binding
153 -- tagged with this level
154 | StayPut Level -- Stay where it is; binding is
155 -- tagged with this level
156
157 floatSpecLevel :: FloatSpec -> Level
158 floatSpecLevel (FloatMe l) = l
159 floatSpecLevel (StayPut l) = l
160
161 {-
162 The {\em level number} on a (type-)lambda-bound variable is the
163 nesting depth of the (type-)lambda which binds it. The outermost lambda
164 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
165
166 On an expression, it's the maximum level number of its free
167 (type-)variables. On a let(rec)-bound variable, it's the level of its
168 RHS. On a case-bound variable, it's the number of enclosing lambdas.
169
170 Top-level variables: level~0. Those bound on the RHS of a top-level
171 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
172 as ``subscripts'')...
173 \begin{verbatim}
174 a_0 = let b_? = ... in
175 x_1 = ... b ... in ...
176 \end{verbatim}
177
178 The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).
179 That's meant to be the level number of the enclosing binder in the
180 final (floated) program. If the level number of a sub-expression is
181 less than that of the context, then it might be worth let-binding the
182 sub-expression so that it will indeed float.
183
184 If you can float to level @Level 0 0@ worth doing so because then your
185 allocation becomes static instead of dynamic. We always start with
186 context @Level 0 0@.
187
188
189 Note [FloatOut inside INLINE]
190 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
191 @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
192 to say "don't float anything out of here". That's exactly what we
193 want for the body of an INLINE, where we don't want to float anything
194 out at all. See notes with lvlMFE below.
195
196 But, check this out:
197
198 -- At one time I tried the effect of not floating anything out of an InlineMe,
199 -- but it sometimes works badly. For example, consider PrelArr.done. It
200 -- has the form __inline (\d. e)
201 -- where e doesn't mention d. If we float this to
202 -- __inline (let x = e in \d. x)
203 -- things are bad. The inliner doesn't even inline it because it doesn't look
204 -- like a head-normal form. So it seems a lesser evil to let things float.
205 -- In GHC.Core.Opt.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
206 -- which discourages floating out.
207
208 So the conclusion is: don't do any floating at all inside an InlineMe.
209 (In the above example, don't float the {x=e} out of the \d.)
210
211 One particular case is that of workers: we don't want to float the
212 call to the worker outside the wrapper, otherwise the worker might get
213 inlined into the floated expression, and an importing module won't see
214 the worker at all.
215
216 Note [Join ceiling]
217 ~~~~~~~~~~~~~~~~~~~
218 Join points can't float very far; too far, and they can't remain join points
219 So, suppose we have:
220
221 f x = (joinrec j y = ... x ... in jump j x) + 1
222
223 One may be tempted to float j out to the top of f's RHS, but then the jump
224 would not be a tail call. Thus we keep track of a level called the *join
225 ceiling* past which join points are not allowed to float.
226
227 The troublesome thing is that, unlike most levels to which something might
228 float, there is not necessarily an identifier to which the join ceiling is
229 attached. Fortunately, if something is to be floated to a join ceiling, it must
230 be dropped at the *nearest* join ceiling. Thus each level is marked as to
231 whether it is a join ceiling, so that FloatOut can tell which binders are being
232 floated to the nearest join ceiling and which to a particular binder (or set of
233 binders).
234 -}
235
236 instance Outputable FloatSpec where
237 ppr (FloatMe l) = char 'F' <> ppr l
238 ppr (StayPut l) = ppr l
239
240 tOP_LEVEL :: Level
241 tOP_LEVEL = Level 0 0 BndrLvl
242
243 incMajorLvl :: Level -> Level
244 incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
245
246 incMinorLvl :: Level -> Level
247 incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
248
249 asJoinCeilLvl :: Level -> Level
250 asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
251
252 maxLvl :: Level -> Level -> Level
253 maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)
254 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
255 | otherwise = l2
256
257 ltLvl :: Level -> Level -> Bool
258 ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
259 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
260
261 ltMajLvl :: Level -> Level -> Bool
262 -- Tells if one level belongs to a difft *lambda* level to another
263 ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2
264
265 isTopLvl :: Level -> Bool
266 isTopLvl (Level 0 0 _) = True
267 isTopLvl _ = False
268
269 isJoinCeilLvl :: Level -> Bool
270 isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
271
272 instance Outputable Level where
273 ppr (Level maj min typ)
274 = hcat [ char '<', int maj, char ',', int min, char '>'
275 , ppWhen (typ == JoinCeilLvl) (char 'C') ]
276
277 instance Eq Level where
278 (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
279
280 {-
281 ************************************************************************
282 * *
283 \subsection{Main level-setting code}
284 * *
285 ************************************************************************
286 -}
287
288 setLevels :: FloatOutSwitches
289 -> CoreProgram
290 -> UniqSupply
291 -> [LevelledBind]
292
293 setLevels float_lams binds us
294 = initLvl us (do_them binds)
295 where
296 env = initialEnv float_lams binds
297
298 do_them :: [CoreBind] -> LvlM [LevelledBind]
299 do_them [] = return []
300 do_them (b:bs)
301 = do { lvld_bind <- lvlTopBind env b
302 ; lvld_binds <- do_them bs
303 ; return (lvld_bind : lvld_binds) }
304
305 lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind
306 lvlTopBind env (NonRec bndr rhs)
307 = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs
308 ; return (NonRec bndr' rhs') }
309
310 lvlTopBind env (Rec pairs)
311 = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs
312 ; return (Rec prs') }
313
314 lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr
315 -> LvlM (LevelledBndr, LevelledExpr)
316 -- NB: 'env' has all the top-level binders in scope, so
317 -- there is no need call substAndLvlBndrs here
318 lvl_top env is_rec bndr rhs
319 = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)
320 Nothing -- Not a join point
321 (freeVars rhs)
322 ; return (stayPut tOP_LEVEL bndr, rhs') }
323
324 {-
325 ************************************************************************
326 * *
327 \subsection{Setting expression levels}
328 * *
329 ************************************************************************
330
331 Note [Floating over-saturated applications]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 If we see (f x y), and (f x) is a redex (ie f's arity is 1),
334 we call (f x) an "over-saturated application"
335
336 Should we float out an over-sat app, if can escape a value lambda?
337 It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
338 But we don't want to do it for class selectors, because the work saved
339 is minimal, and the extra local thunks allocated cost money.
340
341 Arguably we could float even class-op applications if they were going to
342 top level -- but then they must be applied to a constant dictionary and
343 will almost certainly be optimised away anyway.
344 -}
345
346 lvlExpr :: LevelEnv -- Context
347 -> CoreExprWithFVs -- Input expression
348 -> LvlM LevelledExpr -- Result expression
349
350 {-
351 The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
352 binder. Here's an example
353
354 v = \x -> ...\y -> let r = case (..x..) of
355 ..x..
356 in ..
357
358 When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's
359 the level of @r@, even though it's inside a level-2 @\y@. It's
360 important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
361 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
362 --- because it isn't a *maximal* free expression.
363
364 If there were another lambda in @r@'s rhs, it would get level-2 as well.
365 -}
366
367 lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))
368 lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
369 lvlExpr env (_, AnnVar v) = return (lookupVar env v)
370 lvlExpr _ (_, AnnLit lit) = return (Lit lit)
371
372 lvlExpr env (_, AnnCast expr (_, co)) = do
373 expr' <- lvlNonTailExpr env expr
374 return (Cast expr' (substCo (le_subst env) co))
375
376 lvlExpr env (_, AnnTick tickish expr) = do
377 expr' <- lvlNonTailExpr env expr
378 let tickish' = substTickish (le_subst env) tickish
379 return (Tick tickish' expr')
380
381 lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
382
383 -- We don't split adjacent lambdas. That is, given
384 -- \x y -> (x+1,y)
385 -- we don't float to give
386 -- \x -> let v = x+1 in \y -> (v,y)
387 -- Why not? Because partial applications are fairly rare, and splitting
388 -- lambdas makes them more expensive.
389
390 lvlExpr env expr@(_, AnnLam {})
391 = do { new_body <- lvlNonTailMFE new_env True body
392 ; return (mkLams new_bndrs new_body) }
393 where
394 (bndrs, body) = collectAnnBndrs expr
395 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
396 (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
397 -- At one time we called a special version of collectBinders,
398 -- which ignored coercions, because we don't want to split
399 -- a lambda like this (\x -> coerce t (\s -> ...))
400 -- This used to happen quite a bit in state-transformer programs,
401 -- but not nearly so much now non-recursive newtypes are transparent.
402 -- [See GHC.Core.Opt.SetLevels rev 1.50 for a version with this approach.]
403
404 lvlExpr env (_, AnnLet bind body)
405 = do { (bind', new_env) <- lvlBind env bind
406 ; body' <- lvlExpr new_env body
407 -- No point in going via lvlMFE here. If the binding is alive
408 -- (mentioned in body), and the whole let-expression doesn't
409 -- float, then neither will the body
410 ; return (Let bind' body') }
411
412 lvlExpr env (_, AnnCase scrut case_bndr ty alts)
413 = do { scrut' <- lvlNonTailMFE env True scrut
414 ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
415
416 lvlNonTailExpr :: LevelEnv -- Context
417 -> CoreExprWithFVs -- Input expression
418 -> LvlM LevelledExpr -- Result expression
419 lvlNonTailExpr env expr
420 = lvlExpr (placeJoinCeiling env) expr
421
422 -------------------------------------------
423 lvlApp :: LevelEnv
424 -> CoreExprWithFVs
425 -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
426 -> LvlM LevelledExpr -- Result expression
427 lvlApp env orig_expr ((_,AnnVar fn), args)
428 -- Try to ensure that runRW#'s continuation isn't floated out.
429 -- See Note [Simplification of runRW#].
430 | fn `hasKey` runRWKey
431 = do { args' <- mapM (lvlExpr env) args
432 ; return (foldl' App (lookupVar env fn) args') }
433
434 | floatOverSat env -- See Note [Floating over-saturated applications]
435 , arity > 0
436 , arity < n_val_args
437 , Nothing <- isClassOpId_maybe fn
438 = do { rargs' <- mapM (lvlNonTailMFE env False) rargs
439 ; lapp' <- lvlNonTailMFE env False lapp
440 ; return (foldl' App lapp' rargs') }
441
442 | otherwise
443 = do { (_, args') <- mapAccumLM lvl_arg stricts args
444 -- Take account of argument strictness; see
445 -- Note [Floating to the top]
446 ; return (foldl' App (lookupVar env fn) args') }
447 where
448 n_val_args = count (isValArg . deAnnotate) args
449 arity = idArity fn
450
451 stricts :: [Demand] -- True for strict /value/ arguments
452 stricts = case splitDmdSig (idDmdSig fn) of
453 (arg_ds, _) | arg_ds `lengthExceeds` n_val_args
454 -> []
455 | otherwise
456 -> arg_ds
457
458 -- Separate out the PAP that we are floating from the extra
459 -- arguments, by traversing the spine until we have collected
460 -- (n_val_args - arity) value arguments.
461 (lapp, rargs) = left (n_val_args - arity) orig_expr []
462
463 left 0 e rargs = (e, rargs)
464 left n (_, AnnApp f a) rargs
465 | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
466 | otherwise = left n f (a:rargs)
467 left _ _ _ = panic "GHC.Core.Opt.SetLevels.lvlExpr.left"
468
469 is_val_arg :: CoreExprWithFVs -> Bool
470 is_val_arg (_, AnnType {}) = False
471 is_val_arg _ = True
472
473 lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
474 lvl_arg strs arg | (str1 : strs') <- strs
475 , is_val_arg arg
476 = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg
477 ; return (strs', arg') }
478 | otherwise
479 = do { arg' <- lvlMFE env False arg
480 ; return (strs, arg') }
481
482 lvlApp env _ (fun, args)
483 = -- No PAPs that we can float: just carry on with the
484 -- arguments and the function.
485 do { args' <- mapM (lvlNonTailMFE env False) args
486 ; fun' <- lvlNonTailExpr env fun
487 ; return (foldl' App fun' args') }
488
489 -------------------------------------------
490 lvlCase :: LevelEnv -- Level of in-scope names/tyvars
491 -> DVarSet -- Free vars of input scrutinee
492 -> LevelledExpr -- Processed scrutinee
493 -> Id -> Type -- Case binder and result type
494 -> [CoreAltWithFVs] -- Input alternatives
495 -> LvlM LevelledExpr -- Result expression
496 lvlCase env scrut_fvs scrut' case_bndr ty alts
497 -- See Note [Floating single-alternative cases]
498 | [AnnAlt con@(DataAlt {}) bs body] <- alts
499 , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF]
500 , not (isTopLvl dest_lvl) -- Can't have top-level cases
501 , not (floatTopLvlOnly env) -- Can float anywhere
502 , Many <- idMult case_bndr -- See Note [Floating linear case]
503 = -- Always float the case if possible
504 -- Unlike lets we don't insist that it escapes a value lambda
505 do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
506 ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
507 ; body' <- lvlMFE rhs_env True body
508 ; let alt' = Alt con (map (stayPut dest_lvl) bs') body'
509 ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
510
511 | otherwise -- Stays put
512 = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
513 alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
514 ; alts' <- mapM (lvl_alt alts_env) alts
515 ; return (Case scrut' case_bndr' ty' alts') }
516 where
517 ty' = substTy (le_subst env) ty
518
519 incd_lvl = incMinorLvl (le_ctxt_lvl env)
520 dest_lvl = maxFvLevel (const True) env scrut_fvs
521 -- Don't abstract over type variables, hence const True
522
523 lvl_alt alts_env (AnnAlt con bs rhs)
524 = do { rhs' <- lvlMFE new_env True rhs
525 ; return (Alt con bs' rhs') }
526 where
527 (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
528
529 {- Note [Floating single-alternative cases]
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
531 Consider this:
532 data T a = MkT !a
533 f :: T Int -> blah
534 f x vs = case x of { MkT y ->
535 let f vs = ...(case y of I# w -> e)...f..
536 in f vs
537
538 Here we can float the (case y ...) out, because y is sure
539 to be evaluated, to give
540 f x vs = case x of { MkT y ->
541 case y of I# w ->
542 let f vs = ...(e)...f..
543 in f vs
544
545 That saves unboxing it every time round the loop. It's important in
546 some DPH stuff where we really want to avoid that repeated unboxing in
547 the inner loop.
548
549 Things to note:
550
551 * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
552
553 - exrpIsHNF catches the key case of an evaluated variable
554
555 - exprOkForSpeculation is /false/ of an evaluated variable;
556 See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils
557 So we'd actually miss the key case!
558
559 - Nothing is gained from the extra generality of exprOkForSpeculation
560 since we only consider floating a case whose single alternative
561 is a DataAlt K a b -> rhs
562
563 * We can't float a case to top level
564
565 * It's worth doing this float even if we don't float
566 the case outside a value lambda. Example
567 case x of {
568 MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
569 If we floated the cases out we could eliminate one of them.
570
571 * We only do this with a single-alternative case
572
573
574 Note [Floating linear case]
575 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
576 Linear case can't be floated past case branches:
577 case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... }
578 Is well typed, but
579 case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }}
580 Will not be, because of how `x` is used in one alternative but not the other.
581
582 It is not easy to float this linear cases precisely, so, instead, we elect, for
583 the moment, to simply not float linear case.
584
585
586 Note [Setting levels when floating single-alternative cases]
587 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
588 Handling level-setting when floating a single-alternative case binding
589 is a bit subtle, as evidenced by #16978. In particular, we must keep
590 in mind that we are merely moving the case and its binders, not the
591 body. For example, suppose 'a' is known to be evaluated and we have
592
593 \z -> case a of
594 (x,_) -> <body involving x and z>
595
596 After floating we may have:
597
598 case a of
599 (x,_) -> \z -> <body involving x and z>
600 {- some expression involving x and z -}
601
602 When analysing <body involving...> we want to use the /ambient/ level,
603 and /not/ the destination level of the 'case a of (x,-) ->' binding.
604
605 #16978 was caused by us setting the context level to the destination
606 level of `x` when analysing <body>. This led us to conclude that we
607 needed to quantify over some of its free variables (e.g. z), resulting
608 in shadowing and very confusing Core Lint failures.
609
610
611 Note [Check the output scrutinee for exprIsHNF]
612 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
613 Consider this:
614 case x of y {
615 A -> ....(case y of alts)....
616 }
617
618 Because of the binder-swap, the inner case will get substituted to
619 (case x of ..). So when testing whether the scrutinee is in HNF we
620 must be careful to test the *result* scrutinee ('x' in this case), not
621 the *input* one 'y'. The latter *is* in HNF here (because y is
622 evaluated), but the former is not -- and indeed we can't float the
623 inner case out, at least not unless x is also evaluated at its binding
624 site. See #5453.
625
626 That's why we apply exprIsHNF to scrut' and not to scrut.
627
628 See Note [Floating single-alternative cases] for why
629 we use exprIsHNF in the first place.
630 -}
631
632 lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars
633 -> Bool -- True <=> strict context [body of case
634 -- or let]
635 -> CoreExprWithFVs -- input expression
636 -> LvlM LevelledExpr -- Result expression
637 lvlNonTailMFE env strict_ctxt ann_expr
638 = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
639
640 lvlMFE :: LevelEnv -- Level of in-scope names/tyvars
641 -> Bool -- True <=> strict context [body of case or let]
642 -> CoreExprWithFVs -- input expression
643 -> LvlM LevelledExpr -- Result expression
644 -- lvlMFE is just like lvlExpr, except that it might let-bind
645 -- the expression, so that it can itself be floated.
646
647 lvlMFE env _ (_, AnnType ty)
648 = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))
649
650 -- No point in floating out an expression wrapped in a coercion or note
651 -- If we do we'll transform lvl = e |> co
652 -- to lvl' = e; lvl = lvl' |> co
653 -- and then inline lvl. Better just to float out the payload.
654 lvlMFE env strict_ctxt (_, AnnTick t e)
655 = do { e' <- lvlMFE env strict_ctxt e
656 ; let t' = substTickish (le_subst env) t
657 ; return (Tick t' e') }
658
659 lvlMFE env strict_ctxt (_, AnnCast e (_, co))
660 = do { e' <- lvlMFE env strict_ctxt e
661 ; return (Cast e' (substCo (le_subst env) co)) }
662
663 lvlMFE env strict_ctxt e@(_, AnnCase {})
664 | strict_ctxt -- Don't share cases in a strict context
665 = lvlExpr env e -- See Note [Case MFEs]
666
667 lvlMFE env strict_ctxt ann_expr
668 | floatTopLvlOnly env && not (isTopLvl dest_lvl)
669 -- Only floating to the top level is allowed.
670 || hasFreeJoin env fvs -- If there is a free join, don't float
671 -- See Note [Free join points]
672 || not (typeHasFixedRuntimeRep (exprType expr))
673 -- We can't let-bind an expression if we don't know
674 -- how it will be represented at runtime.
675 -- See Note [Representation polymorphism invariants] in GHC.Core
676 || notWorthFloating expr abs_vars
677 || not float_me
678 = -- Don't float it out
679 lvlExpr env ann_expr
680
681 | float_is_new_lam || exprIsTopLevelBindable expr expr_ty
682 -- No wrapping needed if the type is lifted, or is a literal string
683 -- or if we are wrapping it in one or more value lambdas
684 = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
685 (isJust mb_bot_str)
686 join_arity_maybe
687 ann_expr
688 -- Treat the expr just like a right-hand side
689 ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
690 ; let var2 = annotateBotStr var float_n_lams mb_bot_str
691 ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
692 (mkVarApps (Var var2) abs_vars)) }
693
694 -- OK, so the float has an unlifted type (not top-level bindable)
695 -- and no new value lambdas (float_is_new_lam is False)
696 -- Try for the boxing strategy
697 -- See Note [Floating MFEs of unlifted type]
698 | escapes_value_lam
699 , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
700 -- See Note [Test cheapness with exprOkForSpeculation]
701 , Just (tc, _) <- splitTyConApp_maybe expr_ty
702 , Just dc <- boxingDataCon_maybe tc
703 , let dc_res_ty = dataConOrigResTy dc -- No free type variables
704 [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]
705 = do { expr1 <- lvlExpr rhs_env ann_expr
706 ; let l1r = incMinorLvlFrom rhs_env
707 float_rhs = mkLams abs_vars_w_lvls $
708 Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
709 [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])]
710
711 ; var <- newLvlVar float_rhs Nothing is_mk_static
712 ; let l1u = incMinorLvlFrom env
713 use_expr = Case (mkVarApps (Var var) abs_vars)
714 (stayPut l1u bx_bndr) expr_ty
715 [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]
716 ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
717 use_expr) }
718
719 | otherwise -- e.g. do not float unboxed tuples
720 = lvlExpr env ann_expr
721
722 where
723 expr = deAnnotate ann_expr
724 expr_ty = exprType expr
725 fvs = freeVarsOf ann_expr
726 fvs_ty = tyCoVarsOfType expr_ty
727 is_bot = isBottomThunk mb_bot_str
728 is_function = isFunction ann_expr
729 mb_bot_str = exprBotStrictness_maybe expr
730 -- See Note [Bottoming floats]
731 -- esp Bottoming floats (2)
732 expr_ok_for_spec = exprOkForSpeculation expr
733 dest_lvl = destLevel env fvs fvs_ty is_function is_bot False
734 abs_vars = abstractVars dest_lvl env fvs
735
736 -- float_is_new_lam: the floated thing will be a new value lambda
737 -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is
738 -- allocation saved. The benefit is to get it to the top level
739 -- and hence out of the body of this function altogether, making
740 -- it smaller and more inlinable
741 float_is_new_lam = float_n_lams > 0
742 float_n_lams = count isId abs_vars
743
744 (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
745
746 join_arity_maybe = Nothing
747
748 is_mk_static = isJust (collectMakeStaticArgs expr)
749 -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
750
751 -- A decision to float entails let-binding this thing, and we only do
752 -- that if we'll escape a value lambda, or will go to the top level.
753 float_me = saves_work || saves_alloc || is_mk_static
754
755 -- We can save work if we can move a redex outside a value lambda
756 -- But if float_is_new_lam is True, then the redex is wrapped in a
757 -- a new lambda, so no work is saved
758 saves_work = escapes_value_lam && not float_is_new_lam
759
760 escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
761 -- See Note [Escaping a value lambda]
762
763 -- See Note [Floating to the top]
764 saves_alloc = isTopLvl dest_lvl
765 && floatConsts env
766 && (not strict_ctxt || is_bot || exprIsHNF expr)
767
768 hasFreeJoin :: LevelEnv -> DVarSet -> Bool
769 -- Has a free join point which is not being floated to top level.
770 -- (In the latter case it won't be a join point any more.)
771 -- Not treating top-level ones specially had a massive effect
772 -- on nofib/minimax/Prog.prog
773 hasFreeJoin env fvs
774 = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
775
776 isBottomThunk :: Maybe (Arity, s) -> Bool
777 -- See Note [Bottoming floats] (2)
778 isBottomThunk (Just (0, _)) = True -- Zero arity
779 isBottomThunk _ = False
780
781 {- Note [Floating to the top]
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783 We are keen to float something to the top level, even if it does not
784 escape a value lambda (and hence save work), for two reasons:
785
786 * Doing so makes the function smaller, by floating out
787 bottoming expressions, or integer or string literals. That in
788 turn makes it easier to inline, with less duplication.
789
790 * (Minor) Doing so may turn a dynamic allocation (done by machine
791 instructions) into a static one. Minor because we are assuming
792 we are not escaping a value lambda.
793
794 But do not so if:
795 - the context is a strict, and
796 - the expression is not a HNF, and
797 - the expression is not bottoming
798
799 Exammples:
800
801 * Bottoming
802 f x = case x of
803 0 -> error <big thing>
804 _ -> x+1
805 Here we want to float (error <big thing>) to top level, abstracting
806 over 'x', so as to make f's RHS smaller.
807
808 * HNF
809 f = case y of
810 True -> p:q
811 False -> blah
812 We may as well float the (p:q) so it becomes a static data structure.
813
814 * Case scrutinee
815 f = case g True of ....
816 Don't float (g True) to top level; then we have the admin of a
817 top-level thunk to worry about, with zero gain.
818
819 * Case alternative
820 h = case y of
821 True -> g True
822 False -> False
823 Don't float (g True) to the top level
824
825 * Arguments
826 t = f (g True)
827 If f is lazy, we /do/ float (g True) because then we can allocate
828 the thunk statically rather than dynamically. But if f is strict
829 we don't (see the use of idDmdSig in lvlApp). It's not clear
830 if this test is worth the bother: it's only about CAFs!
831
832 It's controlled by a flag (floatConsts), because doing this too
833 early loses opportunities for RULES which (needless to say) are
834 important in some nofib programs (gcd is an example). [SPJ note:
835 I think this is obsolete; the flag seems always on.]
836
837 Note [Floating join point bindings]
838 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
839 Mostly we only float a join point if it can /stay/ a join point. But
840 there is one exception: if it can go to the top level (#13286).
841 Consider
842 f x = joinrec j y n = <...j y' n'...>
843 in jump j x 0
844
845 Here we may just as well produce
846 j y n = <....j y' n'...>
847 f x = j x 0
848
849 and now there is a chance that 'f' will be inlined at its call sites.
850 It shouldn't make a lot of difference, but these tests
851 perf/should_run/MethSharing
852 simplCore/should_compile/spec-inline
853 and one nofib program, all improve if you do float to top, because
854 of the resulting inlining of f. So ok, let's do it.
855
856 Note [Free join points]
857 ~~~~~~~~~~~~~~~~~~~~~~~
858 We never float a MFE that has a free join-point variable. You might think
859 this can never occur. After all, consider
860 join j x = ...
861 in ....(jump j x)....
862 How might we ever want to float that (jump j x)?
863 * If it would escape a value lambda, thus
864 join j x = ... in (\y. ...(jump j x)... )
865 then 'j' isn't a valid join point in the first place.
866
867 But consider
868 join j x = .... in
869 joinrec j2 y = ...(jump j x)...(a+b)....
870
871 Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.
872 But it is emphatically /not/ good to float the (jump j x) out:
873 (a) 'j' will stop being a join point
874 (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no
875 work would be saved by floating it out of the \y.
876
877 Even if we floated 'j' to top level, (b) would still hold.
878
879 Bottom line: never float a MFE that has a free JoinId.
880
881 Note [Floating MFEs of unlifted type]
882 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
883 Suppose we have
884 case f x of (r::Int#) -> blah
885 we'd like to float (f x). But it's not trivial because it has type
886 Int#, and we don't want to evaluate it too early. But we can instead
887 float a boxed version
888 y = case f x of r -> I# r
889 and replace the original (f x) with
890 case (case y of I# r -> r) of r -> blah
891
892 Being able to float unboxed expressions is sometimes important; see #12603.
893 I'm not sure how /often/ it is important, but it's not hard to achieve.
894
895 We only do it for a fixed collection of types for which we have a
896 convenient boxing constructor (see boxingDataCon_maybe). In
897 particular we /don't/ do it for unboxed tuples; it's better to float
898 the components of the tuple individually.
899
900 I did experiment with a form of boxing that works for any type, namely
901 wrapping in a function. In our example
902
903 let y = case f x of r -> \v. f x
904 in case y void of r -> blah
905
906 It works fine, but it's 50% slower (based on some crude benchmarking).
907 I suppose we could do it for types not covered by boxingDataCon_maybe,
908 but it's more code and I'll wait to see if anyone wants it.
909
910 Note [Test cheapness with exprOkForSpeculation]
911 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
912 We don't want to float very cheap expressions by boxing and unboxing.
913 But we use exprOkForSpeculation for the test, not exprIsCheap.
914 Why? Because it's important /not/ to transform
915 f (a /# 3)
916 to
917 f (case bx of I# a -> a /# 3)
918 and float bx = I# (a /# 3), because the application of f no
919 longer obeys the let/app invariant. But (a /# 3) is ok-for-spec
920 due to a special hack that says division operators can't fail
921 when the denominator is definitely non-zero. And yet that
922 same expression says False to exprIsCheap. Simplest way to
923 guarantee the let/app invariant is to use the same function!
924
925 If an expression is okay for speculation, we could also float it out
926 *without* boxing and unboxing, since evaluating it early is okay.
927 However, it turned out to usually be better not to float such expressions,
928 since they tend to be extremely cheap things like (x +# 1#). Even the
929 cost of spilling the let-bound variable to the stack across a call may
930 exceed the cost of recomputing such an expression. (And we can't float
931 unlifted bindings to top-level.)
932
933 We could try to do something smarter here, and float out expensive yet
934 okay-for-speculation things, such as division by non-zero constants.
935 But I suspect it's a narrow target.
936
937 Note [Bottoming floats]
938 ~~~~~~~~~~~~~~~~~~~~~~~
939 If we see
940 f = \x. g (error "urk")
941 we'd like to float the call to error, to get
942 lvl = error "urk"
943 f = \x. g lvl
944
945 But, as ever, we need to be careful:
946
947 (1) We want to float a bottoming
948 expression even if it has free variables:
949 f = \x. g (let v = h x in error ("urk" ++ v))
950 Then we'd like to abstract over 'x' can float the whole arg of g:
951 lvl = \x. let v = h x in error ("urk" ++ v)
952 f = \x. g (lvl x)
953 To achieve this we pass is_bot to destLevel
954
955 (2) We do not do this for lambdas that return
956 bottom. Instead we treat the /body/ of such a function specially,
957 via point (1). For example:
958 f = \x. ....(\y z. if x then error y else error z)....
959 ===>
960 lvl = \x z y. if b then error y else error z
961 f = \x. ...(\y z. lvl x z y)...
962 (There is no guarantee that we'll choose the perfect argument order.)
963
964 (3) If we have a /binding/ that returns bottom, we want to float it to top
965 level, even if it has free vars (point (1)), and even it has lambdas.
966 Example:
967 ... let { v = \y. error (show x ++ show y) } in ...
968 We want to abstract over x and float the whole thing to top:
969 lvl = \xy. errror (show x ++ show y)
970 ...let {v = lvl x} in ...
971
972 Then of course we don't want to separately float the body (error ...)
973 as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
974 argument.
975
976 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
977 of functional programs" (unpublished I think).
978
979 When we do this, we set the strictness and arity of the new bottoming
980 Id, *immediately*, for three reasons:
981
982 * To prevent the abstracted thing being immediately inlined back in again
983 via preInlineUnconditionally. The latter has a test for bottoming Ids
984 to stop inlining them, so we'd better make sure it *is* a bottoming Id!
985
986 * So that it's properly exposed as such in the interface file, even if
987 this is all happening after strictness analysis.
988
989 * In case we do CSE with the same expression that *is* marked bottom
990 lvl = error "urk"
991 x{str=bot) = error "urk"
992 Here we don't want to replace 'x' with 'lvl', else we may get Lint
993 errors, e.g. via a case with empty alternatives: (case x of {})
994 Lint complains unless the scrutinee of such a case is clearly bottom.
995
996 This was reported in #11290. But since the whole bottoming-float
997 thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure
998 that it'll nail all such cases.
999
1000 Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
1001 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1002 Tiresomely, though, the simplifier has an invariant that the manifest
1003 arity of the RHS should be the same as the arity; but we can't call
1004 etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of
1005 CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut.
1006 But we should only eta-expand if the RHS doesn't already have the right
1007 exprArity, otherwise we get unnecessary top-level bindings if the RHS was
1008 trivial after the next run of the Simplifier.
1009
1010 Note [Case MFEs]
1011 ~~~~~~~~~~~~~~~~
1012 We don't float a case expression as an MFE from a strict context. Why not?
1013 Because in doing so we share a tiny bit of computation (the switch) but
1014 in exchange we build a thunk, which is bad. This case reduces allocation
1015 by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
1016 Doesn't change any other allocation at all.
1017
1018 We will make a separate decision for the scrutinee and alternatives.
1019
1020 However this can have a knock-on effect for fusion: consider
1021 \v -> foldr k z (case x of I# y -> build ..y..)
1022 Perhaps we can float the entire (case x of ...) out of the \v. Then
1023 fusion will not happen, but we will get more sharing. But if we don't
1024 float the case (as advocated here) we won't float the (build ...y..)
1025 either, so fusion will happen. It can be a big effect, esp in some
1026 artificial benchmarks (e.g. integer, queens), but there is no perfect
1027 answer.
1028
1029 -}
1030
1031 annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id
1032 -- See Note [Bottoming floats] for why we want to add
1033 -- bottoming information right now
1034 --
1035 -- n_extra are the number of extra value arguments added during floating
1036 annotateBotStr id n_extra mb_str
1037 = case mb_str of
1038 Nothing -> id
1039 Just (arity, sig) -> id `setIdArity` (arity + n_extra)
1040 `setIdDmdSig` (prependArgsDmdSig n_extra sig)
1041 `setIdCprSig` mkCprSig (arity + n_extra) botCpr
1042
1043 notWorthFloating :: CoreExpr -> [Var] -> Bool
1044 -- Returns True if the expression would be replaced by
1045 -- something bigger than it is now. For example:
1046 -- abs_vars = tvars only: return True if e is trivial,
1047 -- but False for anything bigger
1048 -- abs_vars = [x] (an Id): return True for trivial, or an application (f x)
1049 -- but False for (f x x)
1050 --
1051 -- One big goal is that floating should be idempotent. Eg if
1052 -- we replace e with (lvl79 x y) and then run FloatOut again, don't want
1053 -- to replace (lvl79 x y) with (lvl83 x y)!
1054
1055 notWorthFloating e abs_vars
1056 = go e (count isId abs_vars)
1057 where
1058 go (Var {}) n = n >= 0
1059 go (Lit lit) n = assert (n==0) $
1060 litIsTrivial lit -- Note [Floating literals]
1061 go (Tick t e) n = not (tickishIsCode t) && go e n
1062 go (Cast e _) n = go e n
1063 go (App e arg) n
1064 -- See Note [Floating applications to coercions]
1065 | Type {} <- arg = go e n
1066 | n==0 = False
1067 | is_triv arg = go e (n-1)
1068 | otherwise = False
1069 go _ _ = False
1070
1071 is_triv (Lit {}) = True -- Treat all literals as trivial
1072 is_triv (Var {}) = True -- (ie not worth floating)
1073 is_triv (Cast e _) = is_triv e
1074 is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions]
1075 is_triv (Tick t e) = not (tickishIsCode t) && is_triv e
1076 is_triv _ = False
1077
1078 {-
1079 Note [Floating literals]
1080 ~~~~~~~~~~~~~~~~~~~~~~~~
1081 It's important to float Integer literals, so that they get shared,
1082 rather than being allocated every time round the loop.
1083 Hence the litIsTrivial.
1084
1085 Ditto literal strings (LitString), which we'd like to float to top
1086 level, which is now possible.
1087
1088 Note [Floating applications to coercions]
1089 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1090 We don’t float out variables applied only to type arguments, since the
1091 extra binding would be pointless: type arguments are completely erased.
1092 But *coercion* arguments aren’t (see Note [Coercion tokens] in
1093 "GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in
1094 "GHC.Core.Unfold"), so we still want to float out variables applied only to
1095 coercion arguments.
1096
1097 Note [Escaping a value lambda]
1098 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1099 We want to float even cheap expressions out of value lambdas,
1100 because that saves allocation. Consider
1101 f = \x. .. (\y.e) ...
1102 Then we'd like to avoid allocating the (\y.e) every time we call f,
1103 (assuming e does not mention x). An example where this really makes a
1104 difference is simplrun009.
1105
1106 Another reason it's good is because it makes SpecContr fire on functions.
1107 Consider
1108 f = \x. ....(f (\y.e))....
1109 After floating we get
1110 lvl = \y.e
1111 f = \x. ....(f lvl)...
1112 and that is much easier for SpecConstr to generate a robust
1113 specialisation for.
1114
1115 However, if we are wrapping the thing in extra value lambdas (in
1116 abs_vars), then nothing is saved. E.g.
1117 f = \xyz. ...(e1[y],e2)....
1118 If we float
1119 lvl = \y. (e1[y],e2)
1120 f = \xyz. ...(lvl y)...
1121 we have saved nothing: one pair will still be allocated for each
1122 call of 'f'. Hence the (not float_is_lam) in float_me.
1123
1124
1125 ************************************************************************
1126 * *
1127 \subsection{Bindings}
1128 * *
1129 ************************************************************************
1130
1131 The binding stuff works for top level too.
1132 -}
1133
1134 lvlBind :: LevelEnv
1135 -> CoreBindWithFVs
1136 -> LvlM (LevelledBind, LevelEnv)
1137
1138 lvlBind env (AnnNonRec bndr rhs)
1139 | isTyVar bndr -- Don't do anything for TyVar binders
1140 -- (simplifier gets rid of them pronto)
1141 || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
1142 -- so we will ignore this case for now
1143 || not (profitableFloat env dest_lvl)
1144 || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
1145 -- We can't float an unlifted binding to top level (except
1146 -- literal strings), so we don't float it at all. It's a
1147 -- bit brutal, but unlifted bindings aren't expensive either
1148
1149 = -- No float
1150 do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs
1151 ; let bind_lvl = incMinorLvl (le_ctxt_lvl env)
1152 (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
1153 ; return (NonRec bndr' rhs', env') }
1154
1155 -- Otherwise we are going to float
1156 | null abs_vars
1157 = do { -- No type abstraction; clone existing binder
1158 rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
1159 is_bot mb_join_arity rhs
1160 ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
1161 ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
1162 ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
1163
1164 | otherwise
1165 = do { -- Yes, type abstraction; create a new binder, extend substitution, etc
1166 rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
1167 is_bot mb_join_arity rhs
1168 ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
1169 ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
1170 ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
1171
1172 where
1173 bndr_ty = idType bndr
1174 ty_fvs = tyCoVarsOfType bndr_ty
1175 rhs_fvs = freeVarsOf rhs
1176 bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr
1177 abs_vars = abstractVars dest_lvl env bind_fvs
1178 dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
1179
1180 deann_rhs = deAnnotate rhs
1181 mb_bot_str = exprBotStrictness_maybe deann_rhs
1182 is_bot = isJust mb_bot_str
1183 -- NB: not isBottomThunk! See Note [Bottoming floats] point (3)
1184
1185 n_extra = count isId abs_vars
1186 mb_join_arity = isJoinId_maybe bndr
1187 is_join = isJust mb_join_arity
1188
1189 lvlBind env (AnnRec pairs)
1190 | floatTopLvlOnly env && not (isTopLvl dest_lvl)
1191 -- Only floating to the top level is allowed.
1192 || not (profitableFloat env dest_lvl)
1193 || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)
1194 -- This mightBeUnliftedType stuff is the same test as in the non-rec case
1195 -- You might wonder whether we can have a recursive binding for
1196 -- an unlifted value -- but we can if it's a /join binding/ (#16978)
1197 -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to
1198 -- float join bindings at all, but that's another story.)
1199 = -- No float
1200 do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
1201 (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
1202 lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
1203 ; rhss' <- mapM lvl_rhs pairs
1204 ; return (Rec (bndrs' `zip` rhss'), env') }
1205
1206 -- Otherwise we are going to float
1207 | null abs_vars
1208 = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
1209 ; new_rhss <- mapM (do_rhs new_env) pairs
1210 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
1211 , new_env) }
1212
1213 -- ToDo: when enabling the floatLambda stuff,
1214 -- I think we want to stop doing this
1215 | [(bndr,rhs)] <- pairs
1216 , count isId abs_vars > 1
1217 = do -- Special case for self recursion where there are
1218 -- several variables carried around: build a local loop:
1219 -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
1220 -- This just makes the closures a bit smaller. If we don't do
1221 -- this, allocation rises significantly on some programs
1222 --
1223 -- We could elaborate it for the case where there are several
1224 -- mutually recursive functions, but it's quite a bit more complicated
1225 --
1226 -- This all seems a bit ad hoc -- sigh
1227 let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
1228 rhs_lvl = le_ctxt_lvl rhs_env
1229
1230 (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
1231 let
1232 (lam_bndrs, rhs_body) = collectAnnBndrs rhs
1233 (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
1234 (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
1235 new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body
1236 (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
1237 return (Rec [(TB poly_bndr (FloatMe dest_lvl)
1238 , mkLams abs_vars_w_lvls $
1239 mkLams lam_bndrs2 $
1240 Let (Rec [( TB new_bndr (StayPut rhs_lvl)
1241 , mkLams lam_bndrs2 new_rhs_body)])
1242 (mkVarApps (Var new_bndr) lam_bndrs1))]
1243 , poly_env)
1244
1245 | otherwise -- Non-null abs_vars
1246 = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
1247 ; new_rhss <- mapM (do_rhs new_env) pairs
1248 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
1249 , new_env) }
1250
1251 where
1252 (bndrs,rhss) = unzip pairs
1253 is_join = isJoinId (head bndrs)
1254 -- bndrs is always non-empty and if one is a join they all are
1255 -- Both are checked by Lint
1256 is_fun = all isFunction rhss
1257 is_bot = False -- It's odd to have an unconditionally divergent
1258 -- function in a Rec, and we don't much care what
1259 -- happens to it. False is simple!
1260
1261 do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
1262 is_bot (get_join bndr)
1263 rhs
1264
1265 get_join bndr | need_zap = Nothing
1266 | otherwise = isJoinId_maybe bndr
1267 need_zap = dest_lvl `ltLvl` joinCeilingLevel env
1268
1269 -- Finding the free vars of the binding group is annoying
1270 bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
1271 `unionDVarSet`
1272 (fvDVarSet $ unionsFV [ idFVs bndr
1273 | (bndr, (_,_)) <- pairs]))
1274 `delDVarSetList`
1275 bndrs
1276
1277 ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
1278 dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
1279 abs_vars = abstractVars dest_lvl env bind_fvs
1280
1281 profitableFloat :: LevelEnv -> Level -> Bool
1282 profitableFloat env dest_lvl
1283 = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda
1284 || isTopLvl dest_lvl -- Going all the way to top level
1285
1286
1287 ----------------------------------------------------
1288 -- Three help functions for the type-abstraction case
1289
1290 lvlRhs :: LevelEnv
1291 -> RecFlag
1292 -> Bool -- Is this a bottoming function
1293 -> Maybe JoinArity
1294 -> CoreExprWithFVs
1295 -> LvlM LevelledExpr
1296 lvlRhs env rec_flag is_bot mb_join_arity expr
1297 = lvlFloatRhs [] (le_ctxt_lvl env) env
1298 rec_flag is_bot mb_join_arity expr
1299
1300 lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
1301 -> Bool -- Binding is for a bottoming function
1302 -> Maybe JoinArity
1303 -> CoreExprWithFVs
1304 -> LvlM (Expr LevelledBndr)
1305 -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
1306 lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
1307 = do { body' <- if not is_bot -- See Note [Floating from a RHS]
1308 && any isId bndrs
1309 then lvlMFE body_env True body
1310 else lvlExpr body_env body
1311 ; return (mkLams bndrs' body') }
1312 where
1313 (bndrs, body) | Just join_arity <- mb_join_arity
1314 = collectNAnnBndrs join_arity rhs
1315 | otherwise
1316 = collectAnnBndrs rhs
1317 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
1318 all_bndrs = abs_vars ++ bndrs1
1319 (body_env, bndrs') | Just _ <- mb_join_arity
1320 = lvlJoinBndrs env1 dest_lvl rec all_bndrs
1321 | otherwise
1322 = case lvlLamBndrs env1 dest_lvl all_bndrs of
1323 (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
1324 -- The important thing here is that we call lvlLamBndrs on
1325 -- all these binders at once (abs_vars and bndrs), so they
1326 -- all get the same major level. Otherwise we create stupid
1327 -- let-bindings inside, joyfully thinking they can float; but
1328 -- in the end they don't because we never float bindings in
1329 -- between lambdas
1330
1331 {- Note [Floating from a RHS]
1332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1333 When floating the RHS of a let-binding, we don't always want to apply
1334 lvlMFE to the body of a lambda, as we usually do, because the entire
1335 binding body is already going to the right place (dest_lvl).
1336
1337 A particular example is the top level. Consider
1338 concat = /\ a -> foldr ..a.. (++) []
1339 We don't want to float the body of the lambda to get
1340 lvl = /\ a -> foldr ..a.. (++) []
1341 concat = /\ a -> lvl a
1342 That would be stupid.
1343
1344 Previously this was avoided in a much nastier way, by testing strict_ctxt
1345 in float_me in lvlMFE. But that wasn't even right because it would fail
1346 to float out the error sub-expression in
1347 f = \x. case x of
1348 True -> error ("blah" ++ show x)
1349 False -> ...
1350
1351 But we must be careful:
1352
1353 * If we had
1354 f = \x -> factorial 20
1355 we /would/ want to float that (factorial 20) out! Functions are treated
1356 differently: see the use of isFunction in the calls to destLevel. If
1357 there are only type lambdas, then destLevel will say "go to top, and
1358 abstract over the free tyvars" and we don't want that here.
1359
1360 * But if we had
1361 f = \x -> error (...x....)
1362 we would NOT want to float the bottoming expression out to give
1363 lvl = \x -> error (...x...)
1364 f = \x -> lvl x
1365
1366 Conclusion: use lvlMFE if there are
1367 * any value lambdas in the original function, and
1368 * this is not a bottoming function (the is_bot argument)
1369 Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice
1370 (e.g. #13369).
1371 -}
1372
1373 {-
1374 ************************************************************************
1375 * *
1376 \subsection{Deciding floatability}
1377 * *
1378 ************************************************************************
1379 -}
1380
1381 substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
1382 substAndLvlBndrs is_rec env lvl bndrs
1383 = lvlBndrs subst_env lvl subst_bndrs
1384 where
1385 (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
1386
1387 substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
1388 -- So named only to avoid the name clash with GHC.Core.Subst.substBndrs
1389 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
1390 = ( env { le_subst = subst'
1391 , le_env = foldl' add_id id_env (bndrs `zip` bndrs') }
1392 , bndrs')
1393 where
1394 (subst', bndrs') = case is_rec of
1395 NonRecursive -> substBndrs subst bndrs
1396 Recursive -> substRecBndrs subst bndrs
1397
1398 lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
1399 -- Compute the levels for the binders of a lambda group
1400 lvlLamBndrs env lvl bndrs
1401 = lvlBndrs env new_lvl bndrs
1402 where
1403 new_lvl | any is_major bndrs = incMajorLvl lvl
1404 | otherwise = incMinorLvl lvl
1405
1406 is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)
1407 -- The "probably" part says "don't float things out of a
1408 -- probable one-shot lambda"
1409 -- See Note [Computing one-shot info] in GHC.Types.Demand
1410
1411 lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
1412 -> (LevelEnv, [LevelledBndr])
1413 lvlJoinBndrs env lvl rec bndrs
1414 = lvlBndrs env new_lvl bndrs
1415 where
1416 new_lvl | isRec rec = incMajorLvl lvl
1417 | otherwise = incMinorLvl lvl
1418 -- Non-recursive join points are one-shot; recursive ones are not
1419
1420 lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
1421 -- The binders returned are exactly the same as the ones passed,
1422 -- apart from applying the substitution, but they are now paired
1423 -- with a (StayPut level)
1424 --
1425 -- The returned envt has le_ctxt_lvl updated to the new_lvl
1426 --
1427 -- All the new binders get the same level, because
1428 -- any floating binding is either going to float past
1429 -- all or none. We never separate binders.
1430 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
1431 = ( env { le_ctxt_lvl = new_lvl
1432 , le_join_ceil = new_lvl
1433 , le_lvl_env = addLvls new_lvl lvl_env bndrs }
1434 , map (stayPut new_lvl) bndrs)
1435
1436 stayPut :: Level -> OutVar -> LevelledBndr
1437 stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
1438
1439 -- Destination level is the max Id level of the expression
1440 -- (We'll abstract the type variables, if any.)
1441 destLevel :: LevelEnv
1442 -> DVarSet -- Free vars of the term
1443 -> TyCoVarSet -- Free in the /type/ of the term
1444 -- (a subset of the previous argument)
1445 -> Bool -- True <=> is function
1446 -> Bool -- True <=> is bottom
1447 -> Bool -- True <=> is a join point
1448 -> Level
1449 -- INVARIANT: if is_join=True then result >= join_ceiling
1450 destLevel env fvs fvs_ty is_function is_bot is_join
1451 | isTopLvl max_fv_id_level -- Float even joins if they get to top level
1452 -- See Note [Floating join point bindings]
1453 = tOP_LEVEL
1454
1455 | is_join -- Never float a join point past the join ceiling
1456 -- See Note [Join points] in GHC.Core.Opt.FloatOut
1457 = if max_fv_id_level `ltLvl` join_ceiling
1458 then join_ceiling
1459 else max_fv_id_level
1460
1461 | is_bot -- Send bottoming bindings to the top
1462 = as_far_as_poss -- regardless; see Note [Bottoming floats]
1463 -- Esp Bottoming floats (1)
1464
1465 | Just n_args <- floatLams env
1466 , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case
1467 , is_function
1468 , countFreeIds fvs <= n_args
1469 = as_far_as_poss -- Send functions to top level; see
1470 -- the comments with isFunction
1471
1472 | otherwise = max_fv_id_level
1473 where
1474 join_ceiling = joinCeilingLevel env
1475 max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
1476 -- tyvars will be abstracted
1477
1478 as_far_as_poss = maxFvLevel' isId env fvs_ty
1479 -- See Note [Floating and kind casts]
1480
1481 {- Note [Floating and kind casts]
1482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1483 Consider this
1484 case x of
1485 K (co :: * ~# k) -> let v :: Int |> co
1486 v = e
1487 in blah
1488
1489 Then, even if we are abstracting over Ids, or if e is bottom, we can't
1490 float v outside the 'co' binding. Reason: if we did we'd get
1491 v' :: forall k. (Int ~# Age) => Int |> co
1492 and now 'co' isn't in scope in that type. The underlying reason is
1493 that 'co' is a value-level thing and we can't abstract over that in a
1494 type (else we'd get a dependent type). So if v's /type/ mentions 'co'
1495 we can't float it out beyond the binding site of 'co'.
1496
1497 That's why we have this as_far_as_poss stuff. Usually as_far_as_poss
1498 is just tOP_LEVEL; but occasionally a coercion variable (which is an
1499 Id) mentioned in type prevents this.
1500
1501 Example #14270 comment:15.
1502 -}
1503
1504
1505 isFunction :: CoreExprWithFVs -> Bool
1506 -- The idea here is that we want to float *functions* to
1507 -- the top level. This saves no work, but
1508 -- (a) it can make the host function body a lot smaller,
1509 -- and hence inlinable.
1510 -- (b) it can also save allocation when the function is recursive:
1511 -- h = \x -> letrec f = \y -> ...f...y...x...
1512 -- in f x
1513 -- becomes
1514 -- f = \x y -> ...(f x)...y...x...
1515 -- h = \x -> f x x
1516 -- No allocation for f now.
1517 -- We may only want to do this if there are sufficiently few free
1518 -- variables. We certainly only want to do it for values, and not for
1519 -- constructors. So the simple thing is just to look for lambdas
1520 isFunction (_, AnnLam b e) | isId b = True
1521 | otherwise = isFunction e
1522 -- isFunction (_, AnnTick _ e) = isFunction e -- dubious
1523 isFunction _ = False
1524
1525 countFreeIds :: DVarSet -> Int
1526 countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet
1527 -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things.
1528 where
1529 add :: Var -> Int -> Int
1530 add v n | isId v = n+1
1531 | otherwise = n
1532
1533 {-
1534 ************************************************************************
1535 * *
1536 \subsection{Free-To-Level Monad}
1537 * *
1538 ************************************************************************
1539 -}
1540
1541 data LevelEnv
1542 = LE { le_switches :: FloatOutSwitches
1543 , le_ctxt_lvl :: Level -- The current level
1544 , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids
1545 , le_join_ceil:: Level -- Highest level to which joins float
1546 -- Invariant: always >= le_ctxt_lvl
1547
1548 -- See Note [le_subst and le_env]
1549 , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids
1550 -- The Id -> CoreExpr in the Subst is ignored
1551 -- (since we want to substitute a LevelledExpr for
1552 -- an Id via le_env) but we do use the Co/TyVar substs
1553 , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids
1554 }
1555
1556 {- Note [le_subst and le_env]
1557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1558 We clone nested let- and case-bound variables so that they are still
1559 distinct when floated out; hence the le_subst/le_env. (see point 3 of
1560 the module overview comment). We also use these envs when making a
1561 variable polymorphic because we want to float it out past a big
1562 lambda.
1563
1564 The le_subst and le_env always implement the same mapping,
1565 in_x :-> out_x a b
1566 where out_x is an OutVar, and a,b are its arguments (when
1567 we perform abstraction at the same time as floating).
1568
1569 le_subst maps to CoreExpr
1570 le_env maps to LevelledExpr
1571
1572 Since the range is always a variable or application, there is never
1573 any difference between the two, but sadly the types differ. The
1574 le_subst is used when substituting in a variable's IdInfo; the le_env
1575 when we find a Var.
1576
1577 In addition the le_env records a [OutVar] of variables free in the
1578 OutExpr/LevelledExpr, just so we don't have to call freeVars
1579 repeatedly. This list is always non-empty, and the first element is
1580 out_x
1581
1582 The domain of the both envs is *pre-cloned* Ids, though
1583
1584 The domain of the le_lvl_env is the *post-cloned* Ids
1585 -}
1586
1587 initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
1588 initialEnv float_lams binds
1589 = LE { le_switches = float_lams
1590 , le_ctxt_lvl = tOP_LEVEL
1591 , le_join_ceil = panic "initialEnv"
1592 , le_lvl_env = emptyVarEnv
1593 , le_subst = mkEmptySubst in_scope_toplvl
1594 , le_env = emptyVarEnv }
1595 where
1596 in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
1597 -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.Occuranal) and
1598 -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise)
1599 -- may both produce top-level bindings where an early binding refers
1600 -- to a later one. So here we put all the top-level binders in scope before
1601 -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)
1602
1603 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
1604 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
1605
1606 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
1607 addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
1608
1609 floatLams :: LevelEnv -> Maybe Int
1610 floatLams le = floatOutLambdas (le_switches le)
1611
1612 floatConsts :: LevelEnv -> Bool
1613 floatConsts le = floatOutConstants (le_switches le)
1614
1615 floatOverSat :: LevelEnv -> Bool
1616 floatOverSat le = floatOutOverSatApps (le_switches le)
1617
1618 floatTopLvlOnly :: LevelEnv -> Bool
1619 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
1620
1621 incMinorLvlFrom :: LevelEnv -> Level
1622 incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
1623
1624 -- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
1625 -- See Note [Binder-swap during float-out]
1626 extendCaseBndrEnv :: LevelEnv
1627 -> Id -- Pre-cloned case binder
1628 -> Expr LevelledBndr -- Post-cloned scrutinee
1629 -> LevelEnv
1630 extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
1631 case_bndr (Var scrut_var)
1632 | Many <- varMult case_bndr
1633 = le { le_subst = extendSubstWithVar subst case_bndr scrut_var
1634 , le_env = add_id id_env (case_bndr, scrut_var) }
1635 extendCaseBndrEnv env _ _ = env
1636
1637 -- See Note [Join ceiling]
1638 placeJoinCeiling :: LevelEnv -> LevelEnv
1639 placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
1640 = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }
1641 where
1642 lvl' = asJoinCeilLvl (incMinorLvl lvl)
1643
1644 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
1645 maxFvLevel max_me env var_set
1646 = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
1647 -- It's OK to use a non-deterministic fold here because maxIn commutes.
1648
1649 maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
1650 -- Same but for TyCoVarSet
1651 maxFvLevel' max_me env var_set
1652 = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
1653 -- It's OK to use a non-deterministic fold here because maxIn commutes.
1654
1655 maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
1656 maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
1657 = case lookupVarEnv id_env in_var of
1658 Just (abs_vars, _) -> foldr max_out lvl abs_vars
1659 Nothing -> max_out in_var lvl
1660 where
1661 max_out out_var lvl
1662 | max_me out_var = case lookupVarEnv lvl_env out_var of
1663 Just lvl' -> maxLvl lvl' lvl
1664 Nothing -> lvl
1665 | otherwise = lvl -- Ignore some vars depending on max_me
1666
1667 lookupVar :: LevelEnv -> Id -> LevelledExpr
1668 lookupVar le v = case lookupVarEnv (le_env le) v of
1669 Just (_, expr) -> expr
1670 _ -> Var v
1671
1672 -- Level to which join points are allowed to float (boundary of current tail
1673 -- context). See Note [Join ceiling]
1674 joinCeilingLevel :: LevelEnv -> Level
1675 joinCeilingLevel = le_join_ceil
1676
1677 abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
1678 -- Find the variables in fvs, free vars of the target expression,
1679 -- whose level is greater than the destination level
1680 -- These are the ones we are going to abstract out
1681 --
1682 -- Note that to get reproducible builds, the variables need to be
1683 -- abstracted in deterministic order, not dependent on the values of
1684 -- Uniques. This is achieved by using DVarSets, deterministic free
1685 -- variable computation and deterministic sort.
1686 -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why
1687 -- Uniques are not deterministic.
1688 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
1689 = -- NB: sortQuantVars might not put duplicates next to each other
1690 map zap $ sortQuantVars $
1691 filter abstract_me $
1692 dVarSetElems $
1693 closeOverKindsDSet $
1694 substDVarSet subst in_fvs
1695 -- NB: it's important to call abstract_me only on the OutIds the
1696 -- come from substDVarSet (not on fv, which is an InId)
1697 where
1698 abstract_me v = case lookupVarEnv lvl_env v of
1699 Just lvl -> dest_lvl `ltLvl` lvl
1700 Nothing -> False
1701
1702 -- We are going to lambda-abstract, so nuke any IdInfo,
1703 -- and add the tyvars of the Id (if necessary)
1704 zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||
1705 not (isEmptyRuleInfo (idSpecialisation v)))
1706 (text "absVarsOf: discarding info on" <+> ppr v) $
1707 setIdInfo v vanillaIdInfo
1708 | otherwise = v
1709
1710 type LvlM result = UniqSM result
1711
1712 initLvl :: UniqSupply -> UniqSM a -> a
1713 initLvl = initUs_
1714
1715 newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
1716 -> LvlM (LevelEnv, [OutId])
1717 -- The envt is extended to bind the new bndrs to dest_lvl, but
1718 -- the le_ctxt_lvl is unaffected
1719 newPolyBndrs dest_lvl
1720 env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
1721 abs_vars bndrs
1722 = assert (all (not . isCoVar) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer.
1723 do { uniqs <- getUniquesM
1724 ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
1725 bndr_prs = bndrs `zip` new_bndrs
1726 env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
1727 , le_subst = foldl' add_subst subst bndr_prs
1728 , le_env = foldl' add_id id_env bndr_prs }
1729 ; return (env', new_bndrs) }
1730 where
1731 add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
1732 add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
1733
1734 mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id
1735 transfer_join_info bndr $
1736 mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty
1737 where
1738 str = "poly_" ++ occNameString (getOccName bndr)
1739 poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr))
1740
1741 -- If we are floating a join point to top level, it stops being
1742 -- a join point. Otherwise it continues to be a join point,
1743 -- but we may need to adjust its arity
1744 dest_is_top = isTopLvl dest_lvl
1745 transfer_join_info bndr new_bndr
1746 | Just join_arity <- isJoinId_maybe bndr
1747 , not dest_is_top
1748 = new_bndr `asJoinId` join_arity + length abs_vars
1749 | otherwise
1750 = new_bndr
1751
1752 newLvlVar :: LevelledExpr -- The RHS of the new binding
1753 -> Maybe JoinArity -- Its join arity, if it is a join point
1754 -> Bool -- True <=> the RHS looks like (makeStatic ...)
1755 -> LvlM Id
1756 newLvlVar lvld_rhs join_arity_maybe is_mk_static
1757 = do { uniq <- getUniqueM
1758 ; return (add_join_info (mk_id uniq rhs_ty))
1759 }
1760 where
1761 add_join_info var = var `asJoinId_maybe` join_arity_maybe
1762 de_tagged_rhs = deTagExpr lvld_rhs
1763 rhs_ty = exprType de_tagged_rhs
1764
1765 mk_id uniq rhs_ty
1766 -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
1767 | is_mk_static
1768 = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
1769 rhs_ty
1770 | otherwise
1771 = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty
1772
1773 -- | Clone the binders bound by a single-alternative case.
1774 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1775 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1776 new_lvl vs
1777 = do { us <- getUniqueSupplyM
1778 ; let (subst', vs') = cloneBndrs subst us vs
1779 -- N.B. We are not moving the body of the case, merely its case
1780 -- binders. Consequently we should *not* set le_ctxt_lvl and
1781 -- le_join_ceil. See Note [Setting levels when floating
1782 -- single-alternative cases].
1783 env' = env { le_lvl_env = addLvls new_lvl lvl_env vs'
1784 , le_subst = subst'
1785 , le_env = foldl' add_id id_env (vs `zip` vs') }
1786
1787 ; return (env', vs') }
1788
1789 cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
1790 -> LvlM (LevelEnv, [OutVar])
1791 -- See Note [Need for cloning during float-out]
1792 -- Works for Ids bound by let(rec)
1793 -- The dest_lvl is attributed to the binders in the new env,
1794 -- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env
1795 cloneLetVars is_rec
1796 env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1797 dest_lvl vs
1798 = do { us <- getUniqueSupplyM
1799 ; let vs1 = map zap vs
1800 -- See Note [Zapping the demand info]
1801 (subst', vs2) = case is_rec of
1802 NonRecursive -> cloneBndrs subst us vs1
1803 Recursive -> cloneRecIdBndrs subst us vs1
1804 prs = vs `zip` vs2
1805 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
1806 , le_subst = subst'
1807 , le_env = foldl' add_id id_env prs }
1808
1809 ; return (env', vs2) }
1810 where
1811 zap :: Var -> Var
1812 zap v | isId v = zap_join (zapIdDemandInfo v)
1813 | otherwise = v
1814
1815 zap_join | isTopLvl dest_lvl = zapJoinId
1816 | otherwise = id
1817
1818 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1819 add_id id_env (v, v1)
1820 | isTyVar v = delVarEnv id_env v
1821 | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
1822
1823 {-
1824 Note [Zapping the demand info]
1825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1826 VERY IMPORTANT: we must zap the demand info if the thing is going to
1827 float out, because it may be less demanded than at its original
1828 binding site. Eg
1829 f :: Int -> Int
1830 f x = let v = 3*4 in v+x
1831 Here v is strict; but if we float v to top level, it isn't any more.
1832
1833 Similarly, if we're floating a join point, it won't be one anymore, so we zap
1834 join point information as well.
1835 -}