Rename FV related functions
[ghc.git] / compiler / simplCore / SetLevels.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section{SetLevels}
5
6 ***************************
7 Overview
8 ***************************
9
10 1. We attach binding levels to Core bindings, in preparation for floating
11 outwards (@FloatOut@).
12
13 2. We also let-ify many expressions (notably case scrutinees), so they
14 will have a fighting chance of being floated sensible.
15
16 3. Note [Need for cloning during float-out]
17 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
18 We clone the binders of any floatable let-binding, so that when it is
19 floated out it will be unique. Example
20 (let x=2 in x) + (let x=3 in x)
21 we must clone before floating so we get
22 let x1=2 in
23 let x2=3 in
24 x1+x2
25
26 NOTE: this can't be done using the uniqAway idea, because the variable
27 must be unique in the whole program, not just its current scope,
28 because two variables in different scopes may float out to the
29 same top level place
30
31 NOTE: Very tiresomely, we must apply this substitution to
32 the rules stored inside a variable too.
33
34 We do *not* clone top-level bindings, because some of them must not change,
35 but we *do* clone bindings that are heading for the top level
36
37 4. Note [Binder-swap during float-out]
38 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
39 In the expression
40 case x of wild { p -> ...wild... }
41 we substitute x for wild in the RHS of the case alternatives:
42 case x of wild { p -> ...x... }
43 This means that a sub-expression involving x is not "trapped" inside the RHS.
44 And it's not inconvenient because we already have a substitution.
45
46 Note that this is EXACTLY BACKWARDS from the what the simplifier does.
47 The simplifier tries to get rid of occurrences of x, in favour of wild,
48 in the hope that there will only be one remaining occurrence of x, namely
49 the scrutinee of the case, and we can inline it.
50 -}
51
52 {-# LANGUAGE CPP #-}
53 module SetLevels (
54 setLevels,
55
56 Level(..), tOP_LEVEL,
57 LevelledBind, LevelledExpr, LevelledBndr,
58 FloatSpec(..), floatSpecLevel,
59
60 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
61 ) where
62
63 #include "HsVersions.h"
64
65 import CoreSyn
66 import CoreMonad ( FloatOutSwitches(..) )
67 import CoreUtils ( exprType, exprOkForSpeculation, exprIsBottom )
68 import CoreArity ( exprBotStrictness_maybe )
69 import CoreFVs -- all of it
70 import CoreSubst
71 import MkCore ( sortQuantVars )
72 import Id
73 import IdInfo
74 import Var
75 import VarSet
76 import VarEnv
77 import Literal ( litIsTrivial )
78 import Demand ( StrictSig )
79 import Name ( getOccName, mkSystemVarName )
80 import OccName ( occNameString )
81 import Type ( isUnliftedType, Type, mkPiTypes )
82 import BasicTypes ( Arity, RecFlag(..) )
83 import UniqSupply
84 import Util
85 import Outputable
86 import FastString
87 import UniqDFM (udfmToUfm)
88 import FV
89
90 {-
91 ************************************************************************
92 * *
93 \subsection{Level numbers}
94 * *
95 ************************************************************************
96 -}
97
98 type LevelledExpr = TaggedExpr FloatSpec
99 type LevelledBind = TaggedBind FloatSpec
100 type LevelledBndr = TaggedBndr FloatSpec
101
102 data Level = Level Int -- Major level: number of enclosing value lambdas
103 Int -- Minor level: number of big-lambda and/or case
104 -- expressions between here and the nearest
105 -- enclosing value lambda
106
107 data FloatSpec
108 = FloatMe Level -- Float to just inside the binding
109 -- tagged with this level
110 | StayPut Level -- Stay where it is; binding is
111 -- tagged with tihs level
112
113 floatSpecLevel :: FloatSpec -> Level
114 floatSpecLevel (FloatMe l) = l
115 floatSpecLevel (StayPut l) = l
116
117 {-
118 The {\em level number} on a (type-)lambda-bound variable is the
119 nesting depth of the (type-)lambda which binds it. The outermost lambda
120 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
121
122 On an expression, it's the maximum level number of its free
123 (type-)variables. On a let(rec)-bound variable, it's the level of its
124 RHS. On a case-bound variable, it's the number of enclosing lambdas.
125
126 Top-level variables: level~0. Those bound on the RHS of a top-level
127 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
128 as ``subscripts'')...
129 \begin{verbatim}
130 a_0 = let b_? = ... in
131 x_1 = ... b ... in ...
132 \end{verbatim}
133
134 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
135 That's meant to be the level number of the enclosing binder in the
136 final (floated) program. If the level number of a sub-expression is
137 less than that of the context, then it might be worth let-binding the
138 sub-expression so that it will indeed float.
139
140 If you can float to level @Level 0 0@ worth doing so because then your
141 allocation becomes static instead of dynamic. We always start with
142 context @Level 0 0@.
143
144
145 Note [FloatOut inside INLINE]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
148 to say "don't float anything out of here". That's exactly what we
149 want for the body of an INLINE, where we don't want to float anything
150 out at all. See notes with lvlMFE below.
151
152 But, check this out:
153
154 -- At one time I tried the effect of not float anything out of an InlineMe,
155 -- but it sometimes works badly. For example, consider PrelArr.done. It
156 -- has the form __inline (\d. e)
157 -- where e doesn't mention d. If we float this to
158 -- __inline (let x = e in \d. x)
159 -- things are bad. The inliner doesn't even inline it because it doesn't look
160 -- like a head-normal form. So it seems a lesser evil to let things float.
161 -- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
162 -- which discourages floating out.
163
164 So the conclusion is: don't do any floating at all inside an InlineMe.
165 (In the above example, don't float the {x=e} out of the \d.)
166
167 One particular case is that of workers: we don't want to float the
168 call to the worker outside the wrapper, otherwise the worker might get
169 inlined into the floated expression, and an importing module won't see
170 the worker at all.
171 -}
172
173 instance Outputable FloatSpec where
174 ppr (FloatMe l) = char 'F' <> ppr l
175 ppr (StayPut l) = ppr l
176
177 tOP_LEVEL :: Level
178 tOP_LEVEL = Level 0 0
179
180 incMajorLvl :: Level -> Level
181 incMajorLvl (Level major _) = Level (major + 1) 0
182
183 incMinorLvl :: Level -> Level
184 incMinorLvl (Level major minor) = Level major (minor+1)
185
186 maxLvl :: Level -> Level -> Level
187 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
188 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
189 | otherwise = l2
190
191 ltLvl :: Level -> Level -> Bool
192 ltLvl (Level maj1 min1) (Level maj2 min2)
193 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
194
195 ltMajLvl :: Level -> Level -> Bool
196 -- Tells if one level belongs to a difft *lambda* level to another
197 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
198
199 isTopLvl :: Level -> Bool
200 isTopLvl (Level 0 0) = True
201 isTopLvl _ = False
202
203 instance Outputable Level where
204 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
205
206 instance Eq Level where
207 (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
208
209 {-
210 ************************************************************************
211 * *
212 \subsection{Main level-setting code}
213 * *
214 ************************************************************************
215 -}
216
217 setLevels :: FloatOutSwitches
218 -> CoreProgram
219 -> UniqSupply
220 -> [LevelledBind]
221
222 setLevels float_lams binds us
223 = initLvl us (do_them init_env binds)
224 where
225 init_env = initialEnv float_lams
226
227 do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
228 do_them _ [] = return []
229 do_them env (b:bs)
230 = do { (lvld_bind, env') <- lvlTopBind env b
231 ; lvld_binds <- do_them env' bs
232 ; return (lvld_bind : lvld_binds) }
233
234 lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
235 lvlTopBind env (NonRec bndr rhs)
236 = do { rhs' <- lvlExpr env (freeVars rhs)
237 ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]
238 ; return (NonRec bndr' rhs', env') }
239
240 lvlTopBind env (Rec pairs)
241 = do let (bndrs,rhss) = unzip pairs
242 (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL bndrs
243 rhss' <- mapM (lvlExpr env' . freeVars) rhss
244 return (Rec (bndrs' `zip` rhss'), env')
245
246 {-
247 ************************************************************************
248 * *
249 \subsection{Setting expression levels}
250 * *
251 ************************************************************************
252
253 Note [Floating over-saturated applications]
254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
255 If we see (f x y), and (f x) is a redex (ie f's arity is 1),
256 we call (f x) an "over-saturated application"
257
258 Should we float out an over-sat app, if can escape a value lambda?
259 It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
260 But we don't want to do it for class selectors, because the work saved
261 is minimal, and the extra local thunks allocated cost money.
262
263 Arguably we could float even class-op applications if they were going to
264 top level -- but then they must be applied to a constant dictionary and
265 will almost certainly be optimised away anyway.
266 -}
267
268 lvlExpr :: LevelEnv -- Context
269 -> CoreExprWithFVs -- Input expression
270 -> LvlM LevelledExpr -- Result expression
271
272 {-
273 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
274 binder. Here's an example
275
276 v = \x -> ...\y -> let r = case (..x..) of
277 ..x..
278 in ..
279
280 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
281 the level of @r@, even though it's inside a level-2 @\y@. It's
282 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
283 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
284 --- because it isn't a *maximal* free expression.
285
286 If there were another lambda in @r@'s rhs, it would get level-2 as well.
287 -}
288
289 lvlExpr env (_, AnnType ty) = return (Type (substTy (le_subst env) ty))
290 lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
291 lvlExpr env (_, AnnVar v) = return (lookupVar env v)
292 lvlExpr _ (_, AnnLit lit) = return (Lit lit)
293
294 lvlExpr env (_, AnnCast expr (_, co)) = do
295 expr' <- lvlExpr env expr
296 return (Cast expr' (substCo (le_subst env) co))
297
298 lvlExpr env (_, AnnTick tickish expr) = do
299 expr' <- lvlExpr env expr
300 return (Tick tickish expr')
301
302 lvlExpr env expr@(_, AnnApp _ _) = do
303 let
304 (fun, args) = collectAnnArgs expr
305 --
306 case fun of
307 (_, AnnVar f) | floatOverSat env -- See Note [Floating over-saturated applications]
308 , arity > 0
309 , arity < n_val_args
310 , Nothing <- isClassOpId_maybe f ->
311 do
312 let (lapp, rargs) = left (n_val_args - arity) expr []
313 rargs' <- mapM (lvlMFE False env) rargs
314 lapp' <- lvlMFE False env lapp
315 return (foldl App lapp' rargs')
316 where
317 n_val_args = count (isValArg . deAnnotate) args
318 arity = idArity f
319
320 -- separate out the PAP that we are floating from the extra
321 -- arguments, by traversing the spine until we have collected
322 -- (n_val_args - arity) value arguments.
323 left 0 e rargs = (e, rargs)
324 left n (_, AnnApp f a) rargs
325 | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
326 | otherwise = left n f (a:rargs)
327 left _ _ _ = panic "SetLevels.lvlExpr.left"
328
329 -- No PAPs that we can float: just carry on with the
330 -- arguments and the function.
331 _otherwise -> do
332 args' <- mapM (lvlMFE False env) args
333 fun' <- lvlExpr env fun
334 return (foldl App fun' args')
335
336 -- We don't split adjacent lambdas. That is, given
337 -- \x y -> (x+1,y)
338 -- we don't float to give
339 -- \x -> let v = x+1 in \y -> (v,y)
340 -- Why not? Because partial applications are fairly rare, and splitting
341 -- lambdas makes them more expensive.
342
343 lvlExpr env expr@(_, AnnLam {})
344 = do { new_body <- lvlMFE True new_env body
345 ; return (mkLams new_bndrs new_body) }
346 where
347 (bndrs, body) = collectAnnBndrs expr
348 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
349 (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
350 -- At one time we called a special verion of collectBinders,
351 -- which ignored coercions, because we don't want to split
352 -- a lambda like this (\x -> coerce t (\s -> ...))
353 -- This used to happen quite a bit in state-transformer programs,
354 -- but not nearly so much now non-recursive newtypes are transparent.
355 -- [See SetLevels rev 1.50 for a version with this approach.]
356
357 lvlExpr env (_, AnnLet bind body)
358 = do { (bind', new_env) <- lvlBind env bind
359 ; body' <- lvlExpr new_env body
360 -- No point in going via lvlMFE here. If the binding is alive
361 -- (mentioned in body), and the whole let-expression doesn't
362 -- float, then neither will the body
363 ; return (Let bind' body') }
364
365 lvlExpr env (_, AnnCase scrut case_bndr ty alts)
366 = do { scrut' <- lvlMFE True env scrut
367 ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
368
369 -------------------------------------------
370 lvlCase :: LevelEnv -- Level of in-scope names/tyvars
371 -> DVarSet -- Free vars of input scrutinee
372 -> LevelledExpr -- Processed scrutinee
373 -> Id -> Type -- Case binder and result type
374 -> [CoreAltWithFVs] -- Input alternatives
375 -> LvlM LevelledExpr -- Result expression
376 lvlCase env scrut_fvs scrut' case_bndr ty alts
377 | [(con@(DataAlt {}), bs, body)] <- alts
378 , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec]
379 , not (isTopLvl dest_lvl) -- Can't have top-level cases
380 = -- See Note [Floating cases]
381 -- Always float the case if possible
382 -- Unlike lets we don't insist that it escapes a value lambda
383 do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
384 ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
385 ; body' <- lvlMFE True rhs_env body
386 ; let alt' = (con, [TB b (StayPut dest_lvl) | b <- bs'], body')
387 ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) }
388
389 | otherwise -- Stays put
390 = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
391 alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
392 ; alts' <- mapM (lvl_alt alts_env) alts
393 ; return (Case scrut' case_bndr' ty alts') }
394 where
395 incd_lvl = incMinorLvl (le_ctxt_lvl env)
396 dest_lvl = maxFvLevel (const True) env scrut_fvs
397 -- Don't abstact over type variables, hence const True
398
399 lvl_alt alts_env (con, bs, rhs)
400 = do { rhs' <- lvlMFE True new_env rhs
401 ; return (con, bs', rhs') }
402 where
403 (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
404
405 {-
406 Note [Floating cases]
407 ~~~~~~~~~~~~~~~~~~~~~
408 Consider this:
409 data T a = MkT !a
410 f :: T Int -> blah
411 f x vs = case x of { MkT y ->
412 let f vs = ...(case y of I# w -> e)...f..
413 in f vs
414 Here we can float the (case y ...) out , because y is sure
415 to be evaluated, to give
416 f x vs = case x of { MkT y ->
417 caes y of I# w ->
418 let f vs = ...(e)...f..
419 in f vs
420
421 That saves unboxing it every time round the loop. It's important in
422 some DPH stuff where we really want to avoid that repeated unboxing in
423 the inner loop.
424
425 Things to note
426 * We can't float a case to top level
427 * It's worth doing this float even if we don't float
428 the case outside a value lambda. Example
429 case x of {
430 MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
431 If we floated the cases out we could eliminate one of them.
432 * We only do this with a single-alternative case
433
434 Note [Check the output scrutinee for okForSpec]
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436 Consider this:
437 case x of y {
438 A -> ....(case y of alts)....
439 }
440 Because of the binder-swap, the inner case will get substituted to
441 (case x of ..). So when testing whether the scrutinee is
442 okForSpecuation we must be careful to test the *result* scrutinee ('x'
443 in this case), not the *input* one 'y'. The latter *is* ok for
444 speculation here, but the former is not -- and indeed we can't float
445 the inner case out, at least not unless x is also evaluated at its
446 binding site.
447
448 That's why we apply exprOkForSpeculation to scrut' and not to scrut.
449 -}
450
451 lvlMFE :: Bool -- True <=> strict context [body of case or let]
452 -> LevelEnv -- Level of in-scope names/tyvars
453 -> CoreExprWithFVs -- input expression
454 -> LvlM LevelledExpr -- Result expression
455 -- lvlMFE is just like lvlExpr, except that it might let-bind
456 -- the expression, so that it can itself be floated.
457
458 lvlMFE _ env (_, AnnType ty)
459 = return (Type (substTy (le_subst env) ty))
460
461 -- No point in floating out an expression wrapped in a coercion or note
462 -- If we do we'll transform lvl = e |> co
463 -- to lvl' = e; lvl = lvl' |> co
464 -- and then inline lvl. Better just to float out the payload.
465 lvlMFE strict_ctxt env (_, AnnTick t e)
466 = do { e' <- lvlMFE strict_ctxt env e
467 ; return (Tick t e') }
468
469 lvlMFE strict_ctxt env (_, AnnCast e (_, co))
470 = do { e' <- lvlMFE strict_ctxt env e
471 ; return (Cast e' (substCo (le_subst env) co)) }
472
473 -- Note [Case MFEs]
474 lvlMFE True env e@(_, AnnCase {})
475 = lvlExpr env e -- Don't share cases
476
477 lvlMFE strict_ctxt env ann_expr
478 | isUnliftedType (exprType expr)
479 -- Can't let-bind it; see Note [Unlifted MFEs]
480 -- This includes coercions, which we don't want to float anyway
481 -- NB: no need to substitute cos isUnliftedType doesn't change
482 || notWorthFloating ann_expr abs_vars
483 || not float_me
484 = -- Don't float it out
485 lvlExpr env ann_expr
486
487 | otherwise -- Float it out!
488 = do { expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr
489 ; var <- newLvlVar expr' is_bot
490 ; return (Let (NonRec (TB var (FloatMe dest_lvl)) expr')
491 (mkVarApps (Var var) abs_vars)) }
492 where
493 expr = deAnnotate ann_expr
494 fvs = freeVarsOf ann_expr
495 is_bot = exprIsBottom expr -- Note [Bottoming floats]
496 dest_lvl = destLevel env fvs (isFunction ann_expr) is_bot
497 abs_vars = abstractVars dest_lvl env fvs
498
499 -- A decision to float entails let-binding this thing, and we only do
500 -- that if we'll escape a value lambda, or will go to the top level.
501 float_me = dest_lvl `ltMajLvl` (le_ctxt_lvl env) -- Escapes a value lambda
502 -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl
503 -- see Note [Escaping a value lambda]
504
505 || (isTopLvl dest_lvl -- Only float if we are going to the top level
506 && floatConsts env -- and the floatConsts flag is on
507 && not strict_ctxt) -- Don't float from a strict context
508 -- We are keen to float something to the top level, even if it does not
509 -- escape a lambda, because then it needs no allocation. But it's controlled
510 -- by a flag, because doing this too early loses opportunities for RULES
511 -- which (needless to say) are important in some nofib programs
512 -- (gcd is an example).
513 --
514 -- Beware:
515 -- concat = /\ a -> foldr ..a.. (++) []
516 -- was getting turned into
517 -- lvl = /\ a -> foldr ..a.. (++) []
518 -- concat = /\ a -> lvl a
519 -- which is pretty stupid. Hence the strict_ctxt test
520 --
521 -- Also a strict contxt includes uboxed values, and they
522 -- can't be bound at top level
523
524 {-
525 Note [Unlifted MFEs]
526 ~~~~~~~~~~~~~~~~~~~~
527 We don't float unlifted MFEs, which potentially loses big opportunites.
528 For example:
529 \x -> f (h y)
530 where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
531 the \x, but we don't because it's unboxed. Possible solution: box it.
532
533 Note [Bottoming floats]
534 ~~~~~~~~~~~~~~~~~~~~~~~
535 If we see
536 f = \x. g (error "urk")
537 we'd like to float the call to error, to get
538 lvl = error "urk"
539 f = \x. g lvl
540 Furthermore, we want to float a bottoming expression even if it has free
541 variables:
542 f = \x. g (let v = h x in error ("urk" ++ v))
543 Then we'd like to abstact over 'x' can float the whole arg of g:
544 lvl = \x. let v = h x in error ("urk" ++ v)
545 f = \x. g (lvl x)
546 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
547 of functional programs" (unpublished I think).
548
549 When we do this, we set the strictness and arity of the new bottoming
550 Id, *immediately*, for three reasons:
551
552 * To prevent the abstracted thing being immediately inlined back in again
553 via preInlineUnconditionally. The latter has a test for bottoming Ids
554 to stop inlining them, so we'd better make sure it *is* a bottoming Id!
555
556 * So that it's properly exposed as such in the interface file, even if
557 this is all happening after strictness analysis.
558
559 * In case we do CSE with the same expression that *is* marked bottom
560 lvl = error "urk"
561 x{str=bot) = error "urk"
562 Here we don't want to replace 'x' with 'lvl', else we may get Lint
563 errors, e.g. via a case with empty alternatives: (case x of {})
564 Lint complains unless the scrutinee of such a case is clearly bottom.
565
566 This was reported in Trac #11290. But since the whole bottoming-float
567 thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure
568 that it'll nail all such cases.
569
570 Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572 Tiresomely, though, the simplifier has an invariant that the manifest
573 arity of the RHS should be the same as the arity; but we can't call
574 etaExpand during SetLevels because it works over a decorated form of
575 CoreExpr. So we do the eta expansion later, in FloatOut.
576
577 Note [Case MFEs]
578 ~~~~~~~~~~~~~~~~
579 We don't float a case expression as an MFE from a strict context. Why not?
580 Because in doing so we share a tiny bit of computation (the switch) but
581 in exchange we build a thunk, which is bad. This case reduces allocation
582 by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
583 Doesn't change any other allocation at all.
584 -}
585
586 annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id
587 -- See Note [Bottoming floats] for why we want to add
588 -- bottoming information right now
589 annotateBotStr id Nothing = id
590 annotateBotStr id (Just (arity, sig)) = id `setIdArity` arity
591 `setIdStrictness` sig
592
593 notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool
594 -- Returns True if the expression would be replaced by
595 -- something bigger than it is now. For example:
596 -- abs_vars = tvars only: return True if e is trivial,
597 -- but False for anything bigger
598 -- abs_vars = [x] (an Id): return True for trivial, or an application (f x)
599 -- but False for (f x x)
600 --
601 -- One big goal is that floating should be idempotent. Eg if
602 -- we replace e with (lvl79 x y) and then run FloatOut again, don't want
603 -- to replace (lvl79 x y) with (lvl83 x y)!
604
605 notWorthFloating e abs_vars
606 = go e (count isId abs_vars)
607 where
608 go (_, AnnVar {}) n = n >= 0
609 go (_, AnnLit lit) n = ASSERT( n==0 )
610 litIsTrivial lit -- Note [Floating literals]
611 go (_, AnnTick t e) n = not (tickishIsCode t) && go e n
612 go (_, AnnCast e _) n = go e n
613 go (_, AnnApp e arg) n
614 | (_, AnnType {}) <- arg = go e n
615 | (_, AnnCoercion {}) <- arg = go e n
616 | n==0 = False
617 | is_triv arg = go e (n-1)
618 | otherwise = False
619 go _ _ = False
620
621 is_triv (_, AnnLit {}) = True -- Treat all literals as trivial
622 is_triv (_, AnnVar {}) = True -- (ie not worth floating)
623 is_triv (_, AnnCast e _) = is_triv e
624 is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
625 is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
626 is_triv (_, AnnTick t e) = not (tickishIsCode t) && is_triv e
627 is_triv _ = False
628
629 {-
630 Note [Floating literals]
631 ~~~~~~~~~~~~~~~~~~~~~~~~
632 It's important to float Integer literals, so that they get shared,
633 rather than being allocated every time round the loop.
634 Hence the litIsTrivial.
635
636 We'd *like* to share MachStr literal strings too, mainly so we could
637 CSE them, but alas can't do so directly because they are unlifted.
638
639
640 Note [Escaping a value lambda]
641 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
642 We want to float even cheap expressions out of value lambdas,
643 because that saves allocation. Consider
644 f = \x. .. (\y.e) ...
645 Then we'd like to avoid allocating the (\y.e) every time we call f,
646 (assuming e does not mention x).
647
648 An example where this really makes a difference is simplrun009.
649
650 Another reason it's good is because it makes SpecContr fire on functions.
651 Consider
652 f = \x. ....(f (\y.e))....
653 After floating we get
654 lvl = \y.e
655 f = \x. ....(f lvl)...
656 and that is much easier for SpecConstr to generate a robust specialisation for.
657
658 The OLD CODE (given where this Note is referred to) prevents floating
659 of the example above, so I just don't understand the old code. I
660 don't understand the old comment either (which appears below). I
661 measured the effect on nofib of changing OLD CODE to 'True', and got
662 zeros everywhere, but a 4% win for 'puzzle'. Very small 0.5% loss for
663 'cse'; turns out to be because our arity analysis isn't good enough
664 yet (mentioned in Simon-nofib-notes).
665
666 OLD comment was:
667 Even if it escapes a value lambda, we only
668 float if it's not cheap (unless it'll get all the
669 way to the top). I've seen cases where we
670 float dozens of tiny free expressions, which cost
671 more to allocate than to evaluate.
672 NB: exprIsCheap is also true of bottom expressions, which
673 is good; we don't want to share them
674
675 It's only Really Bad to float a cheap expression out of a
676 strict context, because that builds a thunk that otherwise
677 would never be built. So another alternative would be to
678 add
679 || (strict_ctxt && not (exprIsBottom expr))
680 to the condition above. We should really try this out.
681
682
683 ************************************************************************
684 * *
685 \subsection{Bindings}
686 * *
687 ************************************************************************
688
689 The binding stuff works for top level too.
690 -}
691
692 lvlBind :: LevelEnv
693 -> CoreBindWithFVs
694 -> LvlM (LevelledBind, LevelEnv)
695
696 lvlBind env (AnnNonRec bndr rhs)
697 | isTyVar bndr -- Don't do anything for TyVar binders
698 -- (simplifier gets rid of them pronto)
699 || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
700 -- so we will ignore this case for now
701 || not (profitableFloat env dest_lvl)
702 || (isTopLvl dest_lvl && isUnliftedType (idType bndr))
703 -- We can't float an unlifted binding to top level, so we don't
704 -- float it at all. It's a bit brutal, but unlifted bindings
705 -- aren't expensive either
706 = -- No float
707 do { rhs' <- lvlExpr env rhs
708 ; let bind_lvl = incMinorLvl (le_ctxt_lvl env)
709 (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
710 ; return (NonRec bndr' rhs', env') }
711
712 -- Otherwise we are going to float
713 | null abs_vars
714 = do { -- No type abstraction; clone existing binder
715 rhs' <- lvlExpr (setCtxtLvl env dest_lvl) rhs
716 ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
717 ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') }
718
719 | otherwise
720 = do { -- Yes, type abstraction; create a new binder, extend substitution, etc
721 rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs
722 ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
723 ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') }
724
725 where
726 rhs_fvs = freeVarsOf rhs
727 bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr
728 abs_vars = abstractVars dest_lvl env bind_fvs
729 dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot
730 is_bot = exprIsBottom (deAnnotate rhs)
731
732 lvlBind env (AnnRec pairs)
733 | not (profitableFloat env dest_lvl)
734 = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
735 (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
736 ; rhss' <- mapM (lvlExpr env') rhss
737 ; return (Rec (bndrs' `zip` rhss'), env') }
738
739 | null abs_vars
740 = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
741 ; new_rhss <- mapM (lvlExpr (setCtxtLvl new_env dest_lvl)) rhss
742 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
743 , new_env) }
744
745 -- ToDo: when enabling the floatLambda stuff,
746 -- I think we want to stop doing this
747 | [(bndr,rhs)] <- pairs
748 , count isId abs_vars > 1
749 = do -- Special case for self recursion where there are
750 -- several variables carried around: build a local loop:
751 -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
752 -- This just makes the closures a bit smaller. If we don't do
753 -- this, allocation rises significantly on some programs
754 --
755 -- We could elaborate it for the case where there are several
756 -- mutually functions, but it's quite a bit more complicated
757 --
758 -- This all seems a bit ad hoc -- sigh
759 let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
760 rhs_lvl = le_ctxt_lvl rhs_env
761
762 (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
763 let
764 (lam_bndrs, rhs_body) = collectAnnBndrs rhs
765 (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
766 (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
767 new_rhs_body <- lvlExpr body_env2 rhs_body
768 (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
769 return (Rec [(TB poly_bndr (FloatMe dest_lvl)
770 , mkLams abs_vars_w_lvls $
771 mkLams lam_bndrs2 $
772 Let (Rec [( TB new_bndr (StayPut rhs_lvl)
773 , mkLams lam_bndrs2 new_rhs_body)])
774 (mkVarApps (Var new_bndr) lam_bndrs1))]
775 , poly_env)
776
777 | otherwise -- Non-null abs_vars
778 = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
779 ; new_rhss <- mapM (lvlFloatRhs abs_vars dest_lvl new_env) rhss
780 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
781 , new_env) }
782
783 where
784 (bndrs,rhss) = unzip pairs
785
786 -- Finding the free vars of the binding group is annoying
787 bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
788 `unionDVarSet`
789 (fvDVarSet $ unionsFV [ idFVs bndr
790 | (bndr, (_,_)) <- pairs]))
791 `delDVarSetList`
792 bndrs
793
794 dest_lvl = destLevel env bind_fvs (all isFunction rhss) False
795 abs_vars = abstractVars dest_lvl env bind_fvs
796
797 profitableFloat :: LevelEnv -> Level -> Bool
798 profitableFloat env dest_lvl
799 = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda
800 || isTopLvl dest_lvl -- Going all the way to top level
801
802 ----------------------------------------------------
803 -- Three help functions for the type-abstraction case
804
805 lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> CoreExprWithFVs
806 -> UniqSM (Expr LevelledBndr)
807 lvlFloatRhs abs_vars dest_lvl env rhs
808 = do { rhs' <- lvlExpr rhs_env rhs
809 ; return (mkLams abs_vars_w_lvls rhs') }
810 where
811 (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
812
813 {-
814 ************************************************************************
815 * *
816 \subsection{Deciding floatability}
817 * *
818 ************************************************************************
819 -}
820
821 substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
822 substAndLvlBndrs is_rec env lvl bndrs
823 = lvlBndrs subst_env lvl subst_bndrs
824 where
825 (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
826
827 substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
828 -- So named only to avoid the name clash with CoreSubst.substBndrs
829 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
830 = ( env { le_subst = subst'
831 , le_env = foldl add_id id_env (bndrs `zip` bndrs') }
832 , bndrs')
833 where
834 (subst', bndrs') = case is_rec of
835 NonRecursive -> substBndrs subst bndrs
836 Recursive -> substRecBndrs subst bndrs
837
838 lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
839 -- Compute the levels for the binders of a lambda group
840 lvlLamBndrs env lvl bndrs
841 = lvlBndrs env new_lvl bndrs
842 where
843 new_lvl | any is_major bndrs = incMajorLvl lvl
844 | otherwise = incMinorLvl lvl
845
846 is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)
847 -- The "probably" part says "don't float things out of a
848 -- probable one-shot lambda"
849 -- See Note [Computing one-shot info] in Demand.hs
850
851
852 lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
853 -- The binders returned are exactly the same as the ones passed,
854 -- apart from applying the substitution, but they are now paired
855 -- with a (StayPut level)
856 --
857 -- The returned envt has ctxt_lvl updated to the new_lvl
858 --
859 -- All the new binders get the same level, because
860 -- any floating binding is either going to float past
861 -- all or none. We never separate binders.
862 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
863 = ( env { le_ctxt_lvl = new_lvl
864 , le_lvl_env = addLvls new_lvl lvl_env bndrs }
865 , lvld_bndrs)
866 where
867 lvld_bndrs = [TB bndr (StayPut new_lvl) | bndr <- bndrs]
868
869 -- Destination level is the max Id level of the expression
870 -- (We'll abstract the type variables, if any.)
871 destLevel :: LevelEnv -> DVarSet
872 -> Bool -- True <=> is function
873 -> Bool -- True <=> is bottom
874 -> Level
875 destLevel env fvs is_function is_bot
876 | is_bot = tOP_LEVEL -- Send bottoming bindings to the top
877 -- regardless; see Note [Bottoming floats]
878 | Just n_args <- floatLams env
879 , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case
880 , is_function
881 , countFreeIds fvs <= n_args
882 = tOP_LEVEL -- Send functions to top level; see
883 -- the comments with isFunction
884
885 | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars
886 -- will be abstracted
887
888 isFunction :: CoreExprWithFVs -> Bool
889 -- The idea here is that we want to float *functions* to
890 -- the top level. This saves no work, but
891 -- (a) it can make the host function body a lot smaller,
892 -- and hence inlinable.
893 -- (b) it can also save allocation when the function is recursive:
894 -- h = \x -> letrec f = \y -> ...f...y...x...
895 -- in f x
896 -- becomes
897 -- f = \x y -> ...(f x)...y...x...
898 -- h = \x -> f x x
899 -- No allocation for f now.
900 -- We may only want to do this if there are sufficiently few free
901 -- variables. We certainly only want to do it for values, and not for
902 -- constructors. So the simple thing is just to look for lambdas
903 isFunction (_, AnnLam b e) | isId b = True
904 | otherwise = isFunction e
905 -- isFunction (_, AnnTick _ e) = isFunction e -- dubious
906 isFunction _ = False
907
908 countFreeIds :: DVarSet -> Int
909 countFreeIds = foldVarSet add 0 . udfmToUfm
910 where
911 add :: Var -> Int -> Int
912 add v n | isId v = n+1
913 | otherwise = n
914
915 {-
916 ************************************************************************
917 * *
918 \subsection{Free-To-Level Monad}
919 * *
920 ************************************************************************
921 -}
922
923 type InVar = Var -- Pre cloning
924 type InId = Id -- Pre cloning
925 type OutVar = Var -- Post cloning
926 type OutId = Id -- Post cloning
927
928 data LevelEnv
929 = LE { le_switches :: FloatOutSwitches
930 , le_ctxt_lvl :: Level -- The current level
931 , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids
932 , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids
933 -- The Id -> CoreExpr in the Subst is ignored
934 -- (since we want to substitute a LevelledExpr for
935 -- an Id via le_env) but we do use the Co/TyVar substs
936 , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids
937 }
938 -- We clone let- and case-bound variables so that they are still
939 -- distinct when floated out; hence the le_subst/le_env.
940 -- (see point 3 of the module overview comment).
941 -- We also use these envs when making a variable polymorphic
942 -- because we want to float it out past a big lambda.
943 --
944 -- The le_subst and le_env always implement the same mapping, but the
945 -- le_subst maps to CoreExpr and the le_env to LevelledExpr
946 -- Since the range is always a variable or type application,
947 -- there is never any difference between the two, but sadly
948 -- the types differ. The le_subst is used when substituting in
949 -- a variable's IdInfo; the le_env when we find a Var.
950 --
951 -- In addition the le_env records a list of tyvars free in the
952 -- type application, just so we don't have to call freeVars on
953 -- the type application repeatedly.
954 --
955 -- The domain of the both envs is *pre-cloned* Ids, though
956 --
957 -- The domain of the le_lvl_env is the *post-cloned* Ids
958
959 initialEnv :: FloatOutSwitches -> LevelEnv
960 initialEnv float_lams
961 = LE { le_switches = float_lams
962 , le_ctxt_lvl = tOP_LEVEL
963 , le_lvl_env = emptyVarEnv
964 , le_subst = emptySubst
965 , le_env = emptyVarEnv }
966
967 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
968 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
969
970 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
971 addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs
972
973 floatLams :: LevelEnv -> Maybe Int
974 floatLams le = floatOutLambdas (le_switches le)
975
976 floatConsts :: LevelEnv -> Bool
977 floatConsts le = floatOutConstants (le_switches le)
978
979 floatOverSat :: LevelEnv -> Bool
980 floatOverSat le = floatOutOverSatApps (le_switches le)
981
982 setCtxtLvl :: LevelEnv -> Level -> LevelEnv
983 setCtxtLvl env lvl = env { le_ctxt_lvl = lvl }
984
985 -- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
986 -- See Note [Binder-swap during float-out]
987 extendCaseBndrEnv :: LevelEnv
988 -> Id -- Pre-cloned case binder
989 -> Expr LevelledBndr -- Post-cloned scrutinee
990 -> LevelEnv
991 extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
992 case_bndr (Var scrut_var)
993 = le { le_subst = extendSubstWithVar subst case_bndr scrut_var
994 , le_env = add_id id_env (case_bndr, scrut_var) }
995 extendCaseBndrEnv env _ _ = env
996
997 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
998 maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set
999 = foldDVarSet max_in tOP_LEVEL var_set
1000 where
1001 max_in in_var lvl
1002 = foldr max_out lvl (case lookupVarEnv id_env in_var of
1003 Just (abs_vars, _) -> abs_vars
1004 Nothing -> [in_var])
1005
1006 max_out out_var lvl
1007 | max_me out_var = case lookupVarEnv lvl_env out_var of
1008 Just lvl' -> maxLvl lvl' lvl
1009 Nothing -> lvl
1010 | otherwise = lvl -- Ignore some vars depending on max_me
1011
1012 lookupVar :: LevelEnv -> Id -> LevelledExpr
1013 lookupVar le v = case lookupVarEnv (le_env le) v of
1014 Just (_, expr) -> expr
1015 _ -> Var v
1016
1017 abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
1018 -- Find the variables in fvs, free vars of the target expresion,
1019 -- whose level is greater than the destination level
1020 -- These are the ones we are going to abstract out
1021 --
1022 -- Note that to get reproducible builds, the variables need to be
1023 -- abstracted in deterministic order, not dependent on the values of
1024 -- Uniques. This is achieved by using DVarSets, deterministic free
1025 -- variable computation and deterministic sort.
1026 -- See Note [Unique Determinism] in Unique for explanation of why
1027 -- Uniques are not deterministic.
1028 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
1029 = -- NB: sortQuantVars might not put duplicates next to each other
1030 map zap $ sortQuantVars $ uniq
1031 [out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs)
1032 , out_var <- dVarSetElems (close out_fv)
1033 , abstract_me out_var ]
1034 -- NB: it's important to call abstract_me only on the OutIds the
1035 -- come from substDVarSet (not on fv, which is an InId)
1036 where
1037 uniq :: [Var] -> [Var]
1038 -- Remove duplicates, preserving order
1039 uniq = dVarSetElems . mkDVarSet
1040
1041 abstract_me v = case lookupVarEnv lvl_env v of
1042 Just lvl -> dest_lvl `ltLvl` lvl
1043 Nothing -> False
1044
1045 -- We are going to lambda-abstract, so nuke any IdInfo,
1046 -- and add the tyvars of the Id (if necessary)
1047 zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
1048 not (isEmptyRuleInfo (idSpecialisation v)),
1049 text "absVarsOf: discarding info on" <+> ppr v )
1050 setIdInfo v vanillaIdInfo
1051 | otherwise = v
1052
1053 close :: Var -> DVarSet -- Close over variables free in the type
1054 -- Result includes the input variable itself
1055 close v = foldDVarSet (unionDVarSet . close)
1056 (unitDVarSet v)
1057 (fvDVarSet $ varTypeTyCoFVs v)
1058
1059 type LvlM result = UniqSM result
1060
1061 initLvl :: UniqSupply -> UniqSM a -> a
1062 initLvl = initUs_
1063
1064 newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] -> UniqSM (LevelEnv, [OutId])
1065 -- The envt is extended to bind the new bndrs to dest_lvl, but
1066 -- the ctxt_lvl is unaffected
1067 newPolyBndrs dest_lvl
1068 env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
1069 abs_vars bndrs
1070 = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer.
1071 do { uniqs <- getUniquesM
1072 ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
1073 bndr_prs = bndrs `zip` new_bndrs
1074 env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
1075 , le_subst = foldl add_subst subst bndr_prs
1076 , le_env = foldl add_id id_env bndr_prs }
1077 ; return (env', new_bndrs) }
1078 where
1079 add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
1080 add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
1081
1082 mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs
1083 mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
1084 where
1085 str = "poly_" ++ occNameString (getOccName bndr)
1086 poly_ty = mkPiTypes abs_vars (substTy subst (idType bndr))
1087
1088 newLvlVar :: LevelledExpr -- The RHS of the new binding
1089 -> Bool -- Whether it is bottom
1090 -> LvlM Id
1091 newLvlVar lvld_rhs is_bot
1092 = do { uniq <- getUniqueM
1093 ; return (add_bot_info (mkLocalIdOrCoVar (mk_name uniq) rhs_ty)) }
1094 where
1095 add_bot_info var -- We could call annotateBotStr always, but the is_bot
1096 -- flag just tells us when we don't need to do so
1097 | is_bot = annotateBotStr var (exprBotStrictness_maybe de_tagged_rhs)
1098 | otherwise = var
1099 de_tagged_rhs = deTagExpr lvld_rhs
1100 rhs_ty = exprType de_tagged_rhs
1101 mk_name uniq = mkSystemVarName uniq (mkFastString "lvl")
1102
1103 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1104 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1105 new_lvl vs
1106 = do { us <- getUniqueSupplyM
1107 ; let (subst', vs') = cloneBndrs subst us vs
1108 env' = env { le_ctxt_lvl = new_lvl
1109 , le_lvl_env = addLvls new_lvl lvl_env vs'
1110 , le_subst = subst'
1111 , le_env = foldl add_id id_env (vs `zip` vs') }
1112
1113 ; return (env', vs') }
1114
1115 cloneLetVars :: RecFlag -> LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1116 -- See Note [Need for cloning during float-out]
1117 -- Works for Ids bound by let(rec)
1118 -- The dest_lvl is attributed to the binders in the new env,
1119 -- but cloneVars doesn't affect the ctxt_lvl of the incoming env
1120 cloneLetVars is_rec
1121 env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1122 dest_lvl vs
1123 = do { us <- getUniqueSupplyM
1124 ; let (subst', vs1) = case is_rec of
1125 NonRecursive -> cloneBndrs subst us vs
1126 Recursive -> cloneRecIdBndrs subst us vs
1127 vs2 = map zap_demand_info vs1 -- See Note [Zapping the demand info]
1128 prs = vs `zip` vs2
1129 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
1130 , le_subst = subst'
1131 , le_env = foldl add_id id_env prs }
1132
1133 ; return (env', vs2) }
1134
1135 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1136 add_id id_env (v, v1)
1137 | isTyVar v = delVarEnv id_env v
1138 | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
1139
1140 zap_demand_info :: Var -> Var
1141 zap_demand_info v
1142 | isId v = zapIdDemandInfo v
1143 | otherwise = v
1144
1145 {-
1146 Note [Zapping the demand info]
1147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1148 VERY IMPORTANT: we must zap the demand info if the thing is going to
1149 float out, because it may be less demanded than at its original
1150 binding site. Eg
1151 f :: Int -> Int
1152 f x = let v = 3*4 in v+x
1153 Here v is strict; but if we float v to top level, it isn't any more.
1154 -}