94a7e9e90e872d70dcd90ab21abe659492a634f8
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{SetLevels}
6 ***************************
7 Overview
8 ***************************
10 1. We attach binding levels to Core bindings, in preparation for floating
11 outwards (@FloatOut@).
13 2. We also let-ify many expressions (notably case scrutinees), so they
14 will have a fighting chance of being floated sensible.
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
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
31 NOTE: Very tiresomely, we must apply this substitution to
32 the rules stored inside a variable too.
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
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.
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 -}
52 {-# LANGUAGE CPP #-}
53 module SetLevels (
54 setLevels,
56 Level(..), tOP_LEVEL,
57 LevelledBind, LevelledExpr, LevelledBndr,
58 FloatSpec(..), floatSpecLevel,
60 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
61 ) where
63 #include "HsVersions.h"
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
88 import FV
90 {-
91 ************************************************************************
92 * *
93 \subsection{Level numbers}
94 * *
95 ************************************************************************
96 -}
98 type LevelledExpr = TaggedExpr FloatSpec
99 type LevelledBind = TaggedBind FloatSpec
100 type LevelledBndr = TaggedBndr FloatSpec
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
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
113 floatSpecLevel :: FloatSpec -> Level
114 floatSpecLevel (FloatMe l) = l
115 floatSpecLevel (StayPut l) = l
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.
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.
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}
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.
140 If you can float to level @Level 0 0@ worth doing so because then your
142 context @Level 0 0@.
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.
152 But, check this out:
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.
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.)
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 -}
173 instance Outputable FloatSpec where
174 ppr (FloatMe l) = char 'F' <> ppr l
175 ppr (StayPut l) = ppr l
177 tOP_LEVEL :: Level
178 tOP_LEVEL = Level 0 0
180 incMajorLvl :: Level -> Level
181 incMajorLvl (Level major _) = Level (major + 1) 0
183 incMinorLvl :: Level -> Level
184 incMinorLvl (Level major minor) = Level major (minor+1)
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
191 ltLvl :: Level -> Level -> Bool
192 ltLvl (Level maj1 min1) (Level maj2 min2)
193 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
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
199 isTopLvl :: Level -> Bool
200 isTopLvl (Level 0 0) = True
201 isTopLvl _ = False
203 instance Outputable Level where
204 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
206 instance Eq Level where
207 (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
209 {-
210 ************************************************************************
211 * *
212 \subsection{Main level-setting code}
213 * *
214 ************************************************************************
215 -}
217 setLevels :: FloatOutSwitches
218 -> CoreProgram
219 -> UniqSupply
220 -> [LevelledBind]
222 setLevels float_lams binds us
223 = initLvl us (do_them init_env binds)
224 where
225 init_env = initialEnv float_lams
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) }
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') }
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')
246 {-
247 ************************************************************************
248 * *
249 \subsection{Setting expression levels}
250 * *
251 ************************************************************************
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"
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.
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 -}
268 lvlExpr :: LevelEnv -- Context
269 -> CoreExprWithFVs -- Input expression
270 -> LvlM LevelledExpr -- Result expression
272 {-
273 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
274 binder. Here's an example
276 v = \x -> ...\y -> let r = case (..x..) of
277 ..x..
278 in ..
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.
286 If there were another lambda in @r@'s rhs, it would get level-2 as well.
287 -}
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)
294 lvlExpr env (_, AnnCast expr (_, co)) = do
295 expr' <- lvlExpr env expr
296 return (Cast expr' (substCo (le_subst env) co))
298 lvlExpr env (_, AnnTick tickish expr) = do
299 expr' <- lvlExpr env expr
300 return (Tick tickish expr')
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
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"
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')
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.
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.]
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') }
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 }
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 , not (floatTopLvlOnly env) -- Can float anywhere
381 = -- See Note [Floating cases]
382 -- Always float the case if possible
383 -- Unlike lets we don't insist that it escapes a value lambda
384 do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
385 ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
386 ; body' <- lvlMFE True rhs_env body
387 ; let alt' = (con, [TB b (StayPut dest_lvl) | b <- bs'], body')
388 ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) }
390 | otherwise -- Stays put
391 = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
392 alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
393 ; alts' <- mapM (lvl_alt alts_env) alts
394 ; return (Case scrut' case_bndr' ty alts') }
395 where
396 incd_lvl = incMinorLvl (le_ctxt_lvl env)
397 dest_lvl = maxFvLevel (const True) env scrut_fvs
398 -- Don't abstact over type variables, hence const True
400 lvl_alt alts_env (con, bs, rhs)
401 = do { rhs' <- lvlMFE True new_env rhs
402 ; return (con, bs', rhs') }
403 where
404 (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
406 {-
407 Note [Floating cases]
408 ~~~~~~~~~~~~~~~~~~~~~
409 Consider this:
410 data T a = MkT !a
411 f :: T Int -> blah
412 f x vs = case x of { MkT y ->
413 let f vs = ...(case y of I# w -> e)...f..
414 in f vs
415 Here we can float the (case y ...) out , because y is sure
416 to be evaluated, to give
417 f x vs = case x of { MkT y ->
418 caes y of I# w ->
419 let f vs = ...(e)...f..
420 in f vs
422 That saves unboxing it every time round the loop. It's important in
423 some DPH stuff where we really want to avoid that repeated unboxing in
424 the inner loop.
426 Things to note
427 * We can't float a case to top level
428 * It's worth doing this float even if we don't float
429 the case outside a value lambda. Example
430 case x of {
431 MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
432 If we floated the cases out we could eliminate one of them.
433 * We only do this with a single-alternative case
435 Note [Check the output scrutinee for okForSpec]
436 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
437 Consider this:
438 case x of y {
439 A -> ....(case y of alts)....
440 }
441 Because of the binder-swap, the inner case will get substituted to
442 (case x of ..). So when testing whether the scrutinee is
443 okForSpecuation we must be careful to test the *result* scrutinee ('x'
444 in this case), not the *input* one 'y'. The latter *is* ok for
445 speculation here, but the former is not -- and indeed we can't float
446 the inner case out, at least not unless x is also evaluated at its
447 binding site.
449 That's why we apply exprOkForSpeculation to scrut' and not to scrut.
450 -}
452 lvlMFE :: Bool -- True <=> strict context [body of case or let]
453 -> LevelEnv -- Level of in-scope names/tyvars
454 -> CoreExprWithFVs -- input expression
455 -> LvlM LevelledExpr -- Result expression
456 -- lvlMFE is just like lvlExpr, except that it might let-bind
457 -- the expression, so that it can itself be floated.
459 lvlMFE _ env (_, AnnType ty)
460 = return (Type (substTy (le_subst env) ty))
462 -- No point in floating out an expression wrapped in a coercion or note
463 -- If we do we'll transform lvl = e |> co
464 -- to lvl' = e; lvl = lvl' |> co
465 -- and then inline lvl. Better just to float out the payload.
466 lvlMFE strict_ctxt env (_, AnnTick t e)
467 = do { e' <- lvlMFE strict_ctxt env e
468 ; return (Tick t e') }
470 lvlMFE strict_ctxt env (_, AnnCast e (_, co))
471 = do { e' <- lvlMFE strict_ctxt env e
472 ; return (Cast e' (substCo (le_subst env) co)) }
474 -- Note [Case MFEs]
475 lvlMFE True env e@(_, AnnCase {})
476 = lvlExpr env e -- Don't share cases
478 lvlMFE strict_ctxt env ann_expr
479 | floatTopLvlOnly env && not (isTopLvl dest_lvl)
480 -- Only floating to the top level is allowed.
481 || isUnliftedType (exprType expr)
482 -- Can't let-bind it; see Note [Unlifted MFEs]
483 -- This includes coercions, which we don't want to float anyway
484 -- NB: no need to substitute cos isUnliftedType doesn't change
485 || notWorthFloating ann_expr abs_vars
486 || not float_me
487 = -- Don't float it out
488 lvlExpr env ann_expr
490 | otherwise -- Float it out!
491 = do { expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr
492 ; var <- newLvlVar expr' is_bot
493 ; return (Let (NonRec (TB var (FloatMe dest_lvl)) expr')
494 (mkVarApps (Var var) abs_vars)) }
495 where
496 expr = deAnnotate ann_expr
497 fvs = freeVarsOf ann_expr
498 is_bot = exprIsBottom expr -- Note [Bottoming floats]
499 dest_lvl = destLevel env fvs (isFunction ann_expr) is_bot
500 abs_vars = abstractVars dest_lvl env fvs
502 -- A decision to float entails let-binding this thing, and we only do
503 -- that if we'll escape a value lambda, or will go to the top level.
504 float_me = dest_lvl ltMajLvl (le_ctxt_lvl env) -- Escapes a value lambda
505 -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl
506 -- see Note [Escaping a value lambda]
508 || (isTopLvl dest_lvl -- Only float if we are going to the top level
509 && floatConsts env -- and the floatConsts flag is on
510 && not strict_ctxt) -- Don't float from a strict context
511 -- We are keen to float something to the top level, even if it does not
512 -- escape a lambda, because then it needs no allocation. But it's controlled
513 -- by a flag, because doing this too early loses opportunities for RULES
514 -- which (needless to say) are important in some nofib programs
515 -- (gcd is an example).
516 --
517 -- Beware:
518 -- concat = /\ a -> foldr ..a.. (++) []
519 -- was getting turned into
520 -- lvl = /\ a -> foldr ..a.. (++) []
521 -- concat = /\ a -> lvl a
522 -- which is pretty stupid. Hence the strict_ctxt test
523 --
524 -- Also a strict contxt includes uboxed values, and they
525 -- can't be bound at top level
527 {-
528 Note [Unlifted MFEs]
529 ~~~~~~~~~~~~~~~~~~~~
530 We don't float unlifted MFEs, which potentially loses big opportunites.
531 For example:
532 \x -> f (h y)
533 where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
534 the \x, but we don't because it's unboxed. Possible solution: box it.
536 Note [Bottoming floats]
537 ~~~~~~~~~~~~~~~~~~~~~~~
538 If we see
539 f = \x. g (error "urk")
540 we'd like to float the call to error, to get
541 lvl = error "urk"
542 f = \x. g lvl
543 Furthermore, we want to float a bottoming expression even if it has free
544 variables:
545 f = \x. g (let v = h x in error ("urk" ++ v))
546 Then we'd like to abstact over 'x' can float the whole arg of g:
547 lvl = \x. let v = h x in error ("urk" ++ v)
548 f = \x. g (lvl x)
549 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
550 of functional programs" (unpublished I think).
552 When we do this, we set the strictness and arity of the new bottoming
553 Id, *immediately*, for three reasons:
555 * To prevent the abstracted thing being immediately inlined back in again
556 via preInlineUnconditionally. The latter has a test for bottoming Ids
557 to stop inlining them, so we'd better make sure it *is* a bottoming Id!
559 * So that it's properly exposed as such in the interface file, even if
560 this is all happening after strictness analysis.
562 * In case we do CSE with the same expression that *is* marked bottom
563 lvl = error "urk"
564 x{str=bot) = error "urk"
565 Here we don't want to replace 'x' with 'lvl', else we may get Lint
566 errors, e.g. via a case with empty alternatives: (case x of {})
567 Lint complains unless the scrutinee of such a case is clearly bottom.
569 This was reported in Trac #11290. But since the whole bottoming-float
570 thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure
571 that it'll nail all such cases.
573 Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
574 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
575 Tiresomely, though, the simplifier has an invariant that the manifest
576 arity of the RHS should be the same as the arity; but we can't call
577 etaExpand during SetLevels because it works over a decorated form of
578 CoreExpr. So we do the eta expansion later, in FloatOut.
580 Note [Case MFEs]
581 ~~~~~~~~~~~~~~~~
582 We don't float a case expression as an MFE from a strict context. Why not?
583 Because in doing so we share a tiny bit of computation (the switch) but
584 in exchange we build a thunk, which is bad. This case reduces allocation
585 by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
586 Doesn't change any other allocation at all.
587 -}
589 annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id
590 -- See Note [Bottoming floats] for why we want to add
591 -- bottoming information right now
592 annotateBotStr id Nothing = id
593 annotateBotStr id (Just (arity, sig)) = id setIdArity arity
594 setIdStrictness sig
596 notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool
597 -- Returns True if the expression would be replaced by
598 -- something bigger than it is now. For example:
599 -- abs_vars = tvars only: return True if e is trivial,
600 -- but False for anything bigger
601 -- abs_vars = [x] (an Id): return True for trivial, or an application (f x)
602 -- but False for (f x x)
603 --
604 -- One big goal is that floating should be idempotent. Eg if
605 -- we replace e with (lvl79 x y) and then run FloatOut again, don't want
606 -- to replace (lvl79 x y) with (lvl83 x y)!
608 notWorthFloating e abs_vars
609 = go e (count isId abs_vars)
610 where
611 go (_, AnnVar {}) n = n >= 0
612 go (_, AnnLit lit) n = ASSERT( n==0 )
613 litIsTrivial lit -- Note [Floating literals]
614 go (_, AnnTick t e) n = not (tickishIsCode t) && go e n
615 go (_, AnnCast e _) n = go e n
616 go (_, AnnApp e arg) n
617 | (_, AnnType {}) <- arg = go e n
618 | (_, AnnCoercion {}) <- arg = go e n
619 | n==0 = False
620 | is_triv arg = go e (n-1)
621 | otherwise = False
622 go _ _ = False
624 is_triv (_, AnnLit {}) = True -- Treat all literals as trivial
625 is_triv (_, AnnVar {}) = True -- (ie not worth floating)
626 is_triv (_, AnnCast e _) = is_triv e
627 is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
628 is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
629 is_triv (_, AnnTick t e) = not (tickishIsCode t) && is_triv e
630 is_triv _ = False
632 {-
633 Note [Floating literals]
634 ~~~~~~~~~~~~~~~~~~~~~~~~
635 It's important to float Integer literals, so that they get shared,
636 rather than being allocated every time round the loop.
637 Hence the litIsTrivial.
639 We'd *like* to share MachStr literal strings too, mainly so we could
640 CSE them, but alas can't do so directly because they are unlifted.
643 Note [Escaping a value lambda]
644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645 We want to float even cheap expressions out of value lambdas,
646 because that saves allocation. Consider
647 f = \x. .. (\y.e) ...
648 Then we'd like to avoid allocating the (\y.e) every time we call f,
649 (assuming e does not mention x).
651 An example where this really makes a difference is simplrun009.
653 Another reason it's good is because it makes SpecContr fire on functions.
654 Consider
655 f = \x. ....(f (\y.e))....
656 After floating we get
657 lvl = \y.e
658 f = \x. ....(f lvl)...
659 and that is much easier for SpecConstr to generate a robust specialisation for.
661 The OLD CODE (given where this Note is referred to) prevents floating
662 of the example above, so I just don't understand the old code. I
663 don't understand the old comment either (which appears below). I
664 measured the effect on nofib of changing OLD CODE to 'True', and got
665 zeros everywhere, but a 4% win for 'puzzle'. Very small 0.5% loss for
666 'cse'; turns out to be because our arity analysis isn't good enough
667 yet (mentioned in Simon-nofib-notes).
669 OLD comment was:
670 Even if it escapes a value lambda, we only
671 float if it's not cheap (unless it'll get all the
672 way to the top). I've seen cases where we
673 float dozens of tiny free expressions, which cost
674 more to allocate than to evaluate.
675 NB: exprIsCheap is also true of bottom expressions, which
676 is good; we don't want to share them
678 It's only Really Bad to float a cheap expression out of a
679 strict context, because that builds a thunk that otherwise
680 would never be built. So another alternative would be to
682 || (strict_ctxt && not (exprIsBottom expr))
683 to the condition above. We should really try this out.
686 ************************************************************************
687 * *
688 \subsection{Bindings}
689 * *
690 ************************************************************************
692 The binding stuff works for top level too.
693 -}
695 lvlBind :: LevelEnv
696 -> CoreBindWithFVs
697 -> LvlM (LevelledBind, LevelEnv)
699 lvlBind env (AnnNonRec bndr rhs)
700 | isTyVar bndr -- Don't do anything for TyVar binders
701 -- (simplifier gets rid of them pronto)
702 || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
703 -- so we will ignore this case for now
704 || not (profitableFloat env dest_lvl)
705 || (isTopLvl dest_lvl && isUnliftedType (idType bndr))
706 -- We can't float an unlifted binding to top level, so we don't
707 -- float it at all. It's a bit brutal, but unlifted bindings
708 -- aren't expensive either
709 = -- No float
710 do { rhs' <- lvlExpr env rhs
711 ; let bind_lvl = incMinorLvl (le_ctxt_lvl env)
712 (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
713 ; return (NonRec bndr' rhs', env') }
715 -- Otherwise we are going to float
716 | null abs_vars
717 = do { -- No type abstraction; clone existing binder
718 rhs' <- lvlExpr (setCtxtLvl env dest_lvl) rhs
719 ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
720 ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') }
722 | otherwise
723 = do { -- Yes, type abstraction; create a new binder, extend substitution, etc
724 rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs
725 ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
726 ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') }
728 where
729 rhs_fvs = freeVarsOf rhs
730 bind_fvs = rhs_fvs unionDVarSet dIdFreeVars bndr
731 abs_vars = abstractVars dest_lvl env bind_fvs
732 dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot
733 is_bot = exprIsBottom (deAnnotate rhs)
735 lvlBind env (AnnRec pairs)
736 | floatTopLvlOnly env && not (isTopLvl dest_lvl)
737 -- Only floating to the top level is allowed.
738 || not (profitableFloat env dest_lvl)
739 = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
740 (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
741 ; rhss' <- mapM (lvlExpr env') rhss
742 ; return (Rec (bndrs' zip rhss'), env') }
744 | null abs_vars
745 = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
746 ; new_rhss <- mapM (lvlExpr (setCtxtLvl new_env dest_lvl)) rhss
747 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] zip new_rhss)
748 , new_env) }
750 -- ToDo: when enabling the floatLambda stuff,
751 -- I think we want to stop doing this
752 | [(bndr,rhs)] <- pairs
753 , count isId abs_vars > 1
754 = do -- Special case for self recursion where there are
755 -- several variables carried around: build a local loop:
756 -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
757 -- This just makes the closures a bit smaller. If we don't do
758 -- this, allocation rises significantly on some programs
759 --
760 -- We could elaborate it for the case where there are several
761 -- mutually functions, but it's quite a bit more complicated
762 --
763 -- This all seems a bit ad hoc -- sigh
764 let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
765 rhs_lvl = le_ctxt_lvl rhs_env
767 (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
768 let
769 (lam_bndrs, rhs_body) = collectAnnBndrs rhs
770 (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
771 (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
772 new_rhs_body <- lvlExpr body_env2 rhs_body
773 (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
774 return (Rec [(TB poly_bndr (FloatMe dest_lvl)
775 , mkLams abs_vars_w_lvls $776 mkLams lam_bndrs2$
777 Let (Rec [( TB new_bndr (StayPut rhs_lvl)
778 , mkLams lam_bndrs2 new_rhs_body)])
779 (mkVarApps (Var new_bndr) lam_bndrs1))]
780 , poly_env)
782 | otherwise -- Non-null abs_vars
783 = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
784 ; new_rhss <- mapM (lvlFloatRhs abs_vars dest_lvl new_env) rhss
785 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] zip new_rhss)
786 , new_env) }
788 where
789 (bndrs,rhss) = unzip pairs
791 -- Finding the free vars of the binding group is annoying
792 bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
793 unionDVarSet
794 (fvDVarSet $unionsFV [ idFVs bndr 795 | (bndr, (_,_)) <- pairs])) 796 delDVarSetList 797 bndrs 799 dest_lvl = destLevel env bind_fvs (all isFunction rhss) False 800 abs_vars = abstractVars dest_lvl env bind_fvs 802 profitableFloat :: LevelEnv -> Level -> Bool 803 profitableFloat env dest_lvl 804 = (dest_lvl ltMajLvl le_ctxt_lvl env) -- Escapes a value lambda 805 || isTopLvl dest_lvl -- Going all the way to top level 807 ---------------------------------------------------- 808 -- Three help functions for the type-abstraction case 810 lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> CoreExprWithFVs 811 -> UniqSM (Expr LevelledBndr) 812 lvlFloatRhs abs_vars dest_lvl env rhs 813 = do { rhs' <- lvlExpr rhs_env rhs 814 ; return (mkLams abs_vars_w_lvls rhs') } 815 where 816 (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars 818 {- 819 ************************************************************************ 820 * * 821 \subsection{Deciding floatability} 822 * * 823 ************************************************************************ 824 -} 826 substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) 827 substAndLvlBndrs is_rec env lvl bndrs 828 = lvlBndrs subst_env lvl subst_bndrs 829 where 830 (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs 832 substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) 833 -- So named only to avoid the name clash with CoreSubst.substBndrs 834 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs 835 = ( env { le_subst = subst' 836 , le_env = foldl add_id id_env (bndrs zip bndrs') } 837 , bndrs') 838 where 839 (subst', bndrs') = case is_rec of 840 NonRecursive -> substBndrs subst bndrs 841 Recursive -> substRecBndrs subst bndrs 843 lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) 844 -- Compute the levels for the binders of a lambda group 845 lvlLamBndrs env lvl bndrs 846 = lvlBndrs env new_lvl bndrs 847 where 848 new_lvl | any is_major bndrs = incMajorLvl lvl 849 | otherwise = incMinorLvl lvl 851 is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) 852 -- The "probably" part says "don't float things out of a 853 -- probable one-shot lambda" 854 -- See Note [Computing one-shot info] in Demand.hs 857 lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) 858 -- The binders returned are exactly the same as the ones passed, 859 -- apart from applying the substitution, but they are now paired 860 -- with a (StayPut level) 861 -- 862 -- The returned envt has ctxt_lvl updated to the new_lvl 863 -- 864 -- All the new binders get the same level, because 865 -- any floating binding is either going to float past 866 -- all or none. We never separate binders. 867 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs 868 = ( env { le_ctxt_lvl = new_lvl 869 , le_lvl_env = addLvls new_lvl lvl_env bndrs } 870 , lvld_bndrs) 871 where 872 lvld_bndrs = [TB bndr (StayPut new_lvl) | bndr <- bndrs] 874 -- Destination level is the max Id level of the expression 875 -- (We'll abstract the type variables, if any.) 876 destLevel :: LevelEnv -> DVarSet 877 -> Bool -- True <=> is function 878 -> Bool -- True <=> is bottom 879 -> Level 880 destLevel env fvs is_function is_bot 881 | is_bot = tOP_LEVEL -- Send bottoming bindings to the top 882 -- regardless; see Note [Bottoming floats] 883 | Just n_args <- floatLams env 884 , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case 885 , is_function 886 , countFreeIds fvs <= n_args 887 = tOP_LEVEL -- Send functions to top level; see 888 -- the comments with isFunction 890 | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars 891 -- will be abstracted 893 isFunction :: CoreExprWithFVs -> Bool 894 -- The idea here is that we want to float *functions* to 895 -- the top level. This saves no work, but 896 -- (a) it can make the host function body a lot smaller, 897 -- and hence inlinable. 898 -- (b) it can also save allocation when the function is recursive: 899 -- h = \x -> letrec f = \y -> ...f...y...x... 900 -- in f x 901 -- becomes 902 -- f = \x y -> ...(f x)...y...x... 903 -- h = \x -> f x x 904 -- No allocation for f now. 905 -- We may only want to do this if there are sufficiently few free 906 -- variables. We certainly only want to do it for values, and not for 907 -- constructors. So the simple thing is just to look for lambdas 908 isFunction (_, AnnLam b e) | isId b = True 909 | otherwise = isFunction e 910 -- isFunction (_, AnnTick _ e) = isFunction e -- dubious 911 isFunction _ = False 913 countFreeIds :: DVarSet -> Int 914 countFreeIds = nonDetFoldUDFM add 0 915 -- It's OK to use nonDetFoldUDFM here because we're just counting things. 916 where 917 add :: Var -> Int -> Int 918 add v n | isId v = n+1 919 | otherwise = n 921 {- 922 ************************************************************************ 923 * * 924 \subsection{Free-To-Level Monad} 925 * * 926 ************************************************************************ 927 -} 929 type InVar = Var -- Pre cloning 930 type InId = Id -- Pre cloning 931 type OutVar = Var -- Post cloning 932 type OutId = Id -- Post cloning 934 data LevelEnv 935 = LE { le_switches :: FloatOutSwitches 936 , le_ctxt_lvl :: Level -- The current level 937 , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids 938 , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids 939 -- The Id -> CoreExpr in the Subst is ignored 940 -- (since we want to substitute a LevelledExpr for 941 -- an Id via le_env) but we do use the Co/TyVar substs 942 , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids 943 } 944 -- We clone let- and case-bound variables so that they are still 945 -- distinct when floated out; hence the le_subst/le_env. 946 -- (see point 3 of the module overview comment). 947 -- We also use these envs when making a variable polymorphic 948 -- because we want to float it out past a big lambda. 949 -- 950 -- The le_subst and le_env always implement the same mapping, but the 951 -- le_subst maps to CoreExpr and the le_env to LevelledExpr 952 -- Since the range is always a variable or type application, 953 -- there is never any difference between the two, but sadly 954 -- the types differ. The le_subst is used when substituting in 955 -- a variable's IdInfo; the le_env when we find a Var. 956 -- 957 -- In addition the le_env records a list of tyvars free in the 958 -- type application, just so we don't have to call freeVars on 959 -- the type application repeatedly. 960 -- 961 -- The domain of the both envs is *pre-cloned* Ids, though 962 -- 963 -- The domain of the le_lvl_env is the *post-cloned* Ids 965 initialEnv :: FloatOutSwitches -> LevelEnv 966 initialEnv float_lams 967 = LE { le_switches = float_lams 968 , le_ctxt_lvl = tOP_LEVEL 969 , le_lvl_env = emptyVarEnv 970 , le_subst = emptySubst 971 , le_env = emptyVarEnv } 973 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level 974 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl 976 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level 977 addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs 979 floatLams :: LevelEnv -> Maybe Int 980 floatLams le = floatOutLambdas (le_switches le) 982 floatConsts :: LevelEnv -> Bool 983 floatConsts le = floatOutConstants (le_switches le) 985 floatOverSat :: LevelEnv -> Bool 986 floatOverSat le = floatOutOverSatApps (le_switches le) 988 floatTopLvlOnly :: LevelEnv -> Bool 989 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) 991 setCtxtLvl :: LevelEnv -> Level -> LevelEnv 992 setCtxtLvl env lvl = env { le_ctxt_lvl = lvl } 994 -- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can 995 -- See Note [Binder-swap during float-out] 996 extendCaseBndrEnv :: LevelEnv 997 -> Id -- Pre-cloned case binder 998 -> Expr LevelledBndr -- Post-cloned scrutinee 999 -> LevelEnv 1000 extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) 1001 case_bndr (Var scrut_var) 1002 = le { le_subst = extendSubstWithVar subst case_bndr scrut_var 1003 , le_env = add_id id_env (case_bndr, scrut_var) } 1004 extendCaseBndrEnv env _ _ = env 1006 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level 1007 maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set 1008 = foldDVarSet max_in tOP_LEVEL var_set 1009 where 1010 max_in in_var lvl 1011 = foldr max_out lvl (case lookupVarEnv id_env in_var of 1012 Just (abs_vars, _) -> abs_vars 1013 Nothing -> [in_var]) 1015 max_out out_var lvl 1016 | max_me out_var = case lookupVarEnv lvl_env out_var of 1017 Just lvl' -> maxLvl lvl' lvl 1018 Nothing -> lvl 1019 | otherwise = lvl -- Ignore some vars depending on max_me 1021 lookupVar :: LevelEnv -> Id -> LevelledExpr 1022 lookupVar le v = case lookupVarEnv (le_env le) v of 1023 Just (_, expr) -> expr 1024 _ -> Var v 1026 abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] 1027 -- Find the variables in fvs, free vars of the target expresion, 1028 -- whose level is greater than the destination level 1029 -- These are the ones we are going to abstract out 1030 -- 1031 -- Note that to get reproducible builds, the variables need to be 1032 -- abstracted in deterministic order, not dependent on the values of 1033 -- Uniques. This is achieved by using DVarSets, deterministic free 1034 -- variable computation and deterministic sort. 1035 -- See Note [Unique Determinism] in Unique for explanation of why 1036 -- Uniques are not deterministic. 1037 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs 1038 = -- NB: sortQuantVars might not put duplicates next to each other 1039 map zap$ sortQuantVars $uniq 1040 [out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs) 1041 , out_var <- dVarSetElems (close out_fv) 1042 , abstract_me out_var ] 1043 -- NB: it's important to call abstract_me only on the OutIds the 1044 -- come from substDVarSet (not on fv, which is an InId) 1045 where 1046 uniq :: [Var] -> [Var] 1047 -- Remove duplicates, preserving order 1048 uniq = dVarSetElems . mkDVarSet 1050 abstract_me v = case lookupVarEnv lvl_env v of 1051 Just lvl -> dest_lvl ltLvl lvl 1052 Nothing -> False 1054 -- We are going to lambda-abstract, so nuke any IdInfo, 1055 -- and add the tyvars of the Id (if necessary) 1056 zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || 1057 not (isEmptyRuleInfo (idSpecialisation v)), 1058 text "absVarsOf: discarding info on" <+> ppr v ) 1059 setIdInfo v vanillaIdInfo 1060 | otherwise = v 1062 close :: Var -> DVarSet -- Close over variables free in the type 1063 -- Result includes the input variable itself 1064 close v = foldDVarSet (unionDVarSet . close) 1065 (unitDVarSet v) 1066 (fvDVarSet$ varTypeTyCoFVs v)
1068 type LvlM result = UniqSM result
1070 initLvl :: UniqSupply -> UniqSM a -> a
1071 initLvl = initUs_
1073 newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] -> UniqSM (LevelEnv, [OutId])
1074 -- The envt is extended to bind the new bndrs to dest_lvl, but
1075 -- the ctxt_lvl is unaffected
1076 newPolyBndrs dest_lvl
1077 env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
1078 abs_vars bndrs
1079 = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer.
1080 do { uniqs <- getUniquesM
1081 ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
1082 bndr_prs = bndrs zip new_bndrs
1083 env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
1084 , le_subst = foldl add_subst subst bndr_prs
1085 , le_env = foldl add_id id_env bndr_prs }
1086 ; return (env', new_bndrs) }
1087 where
1088 add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
1089 add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
1091 mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars \$ -- Note [transferPolyIdInfo] in Id.hs
1092 mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
1093 where
1094 str = "poly_" ++ occNameString (getOccName bndr)
1095 poly_ty = mkPiTypes abs_vars (substTy subst (idType bndr))
1097 newLvlVar :: LevelledExpr -- The RHS of the new binding
1098 -> Bool -- Whether it is bottom
1099 -> LvlM Id
1100 newLvlVar lvld_rhs is_bot
1101 = do { uniq <- getUniqueM
1102 ; return (add_bot_info (mkLocalIdOrCoVar (mk_name uniq) rhs_ty)) }
1103 where
1104 add_bot_info var -- We could call annotateBotStr always, but the is_bot
1105 -- flag just tells us when we don't need to do so
1106 | is_bot = annotateBotStr var (exprBotStrictness_maybe de_tagged_rhs)
1107 | otherwise = var
1108 de_tagged_rhs = deTagExpr lvld_rhs
1109 rhs_ty = exprType de_tagged_rhs
1110 mk_name uniq = mkSystemVarName uniq (mkFastString "lvl")
1112 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1113 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1114 new_lvl vs
1115 = do { us <- getUniqueSupplyM
1116 ; let (subst', vs') = cloneBndrs subst us vs
1117 env' = env { le_ctxt_lvl = new_lvl
1118 , le_lvl_env = addLvls new_lvl lvl_env vs'
1119 , le_subst = subst'
1120 , le_env = foldl add_id id_env (vs zip vs') }
1122 ; return (env', vs') }
1124 cloneLetVars :: RecFlag -> LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1125 -- See Note [Need for cloning during float-out]
1126 -- Works for Ids bound by let(rec)
1127 -- The dest_lvl is attributed to the binders in the new env,
1128 -- but cloneVars doesn't affect the ctxt_lvl of the incoming env
1129 cloneLetVars is_rec
1130 env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1131 dest_lvl vs
1132 = do { us <- getUniqueSupplyM
1133 ; let (subst', vs1) = case is_rec of
1134 NonRecursive -> cloneBndrs subst us vs
1135 Recursive -> cloneRecIdBndrs subst us vs
1136 vs2 = map zap_demand_info vs1 -- See Note [Zapping the demand info]
1137 prs = vs zip vs2
1138 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
1139 , le_subst = subst'
1140 , le_env = foldl add_id id_env prs }
1142 ; return (env', vs2) }
1144 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1146 | isTyVar v = delVarEnv id_env v
1147 | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
1149 zap_demand_info :: Var -> Var
1150 zap_demand_info v
1151 | isId v = zapIdDemandInfo v
1152 | otherwise = v
1154 {-
1155 Note [Zapping the demand info]
1156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1157 VERY IMPORTANT: we must zap the demand info if the thing is going to
1158 float out, because it may be less demanded than at its original
1159 binding site. Eg
1160 f :: Int -> Int
1161 f x = let v = 3*4 in v+x
1162 Here v is strict; but if we float v to top level, it isn't any more.
1163 -}