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