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