Re-add FunTy (big patch)
[ghc.git] / compiler / simplCore / SetLevels.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section{SetLevels}
5
6 ***************************
7 Overview
8 ***************************
9
10 1. We attach binding levels to Core bindings, in preparation for floating
11 outwards (@FloatOut@).
12
13 2. We also let-ify many expressions (notably case scrutinees), so they
14 will have a fighting chance of being floated sensible.
15
16 3. Note [Need for cloning during float-out]
17 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
18 We clone the binders of any floatable let-binding, so that when it is
19 floated out it will be unique. Example
20 (let x=2 in x) + (let x=3 in x)
21 we must clone before floating so we get
22 let x1=2 in
23 let x2=3 in
24 x1+x2
25
26 NOTE: this can't be done using the uniqAway idea, because the variable
27 must be unique in the whole program, not just its current scope,
28 because two variables in different scopes may float out to the
29 same top level place
30
31 NOTE: Very tiresomely, we must apply this substitution to
32 the rules stored inside a variable too.
33
34 We do *not* clone top-level bindings, because some of them must not change,
35 but we *do* clone bindings that are heading for the top level
36
37 4. Note [Binder-swap during float-out]
38 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
39 In the expression
40 case x of wild { p -> ...wild... }
41 we substitute x for wild in the RHS of the case alternatives:
42 case x of wild { p -> ...x... }
43 This means that a sub-expression involving x is not "trapped" inside the RHS.
44 And it's not inconvenient because we already have a substitution.
45
46 Note that this is EXACTLY BACKWARDS from the what the simplifier does.
47 The simplifier tries to get rid of occurrences of x, in favour of wild,
48 in the hope that there will only be one remaining occurrence of x, namely
49 the scrutinee of the case, and we can inline it.
50 -}
51
52 {-# LANGUAGE CPP #-}
53 module SetLevels (
54 setLevels,
55
56 Level(..), tOP_LEVEL,
57 LevelledBind, LevelledExpr, LevelledBndr,
58 FloatSpec(..), floatSpecLevel,
59
60 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
61 ) where
62
63 #include "HsVersions.h"
64
65 import CoreSyn
66 import CoreMonad ( FloatOutSwitches(..) )
67 import CoreUtils ( exprType, exprOkForSpeculation, exprIsBottom )
68 import CoreArity ( exprBotStrictness_maybe )
69 import CoreFVs -- all of it
70 import CoreSubst
71 import MkCore ( sortQuantVars )
72 import Id
73 import IdInfo
74 import Var
75 import VarSet
76 import VarEnv
77 import Literal ( litIsTrivial )
78 import Demand ( StrictSig )
79 import Name ( getOccName, mkSystemVarName )
80 import OccName ( occNameString )
81 import Type ( isUnliftedType, Type, mkLamTypes )
82 import BasicTypes ( Arity, RecFlag(..) )
83 import UniqSupply
84 import Util
85 import Outputable
86 import FastString
87 import UniqDFM
88 import FV
89
90 {-
91 ************************************************************************
92 * *
93 \subsection{Level numbers}
94 * *
95 ************************************************************************
96 -}
97
98 type LevelledExpr = TaggedExpr FloatSpec
99 type LevelledBind = TaggedBind FloatSpec
100 type LevelledBndr = TaggedBndr FloatSpec
101
102 data Level = Level Int -- Major level: number of enclosing value lambdas
103 Int -- Minor level: number of big-lambda and/or case
104 -- expressions between here and the nearest
105 -- enclosing value lambda
106
107 data FloatSpec
108 = FloatMe Level -- Float to just inside the binding
109 -- tagged with this level
110 | StayPut Level -- Stay where it is; binding is
111 -- tagged with tihs level
112
113 floatSpecLevel :: FloatSpec -> Level
114 floatSpecLevel (FloatMe l) = l
115 floatSpecLevel (StayPut l) = l
116
117 {-
118 The {\em level number} on a (type-)lambda-bound variable is the
119 nesting depth of the (type-)lambda which binds it. The outermost lambda
120 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
121
122 On an expression, it's the maximum level number of its free
123 (type-)variables. On a let(rec)-bound variable, it's the level of its
124 RHS. On a case-bound variable, it's the number of enclosing lambdas.
125
126 Top-level variables: level~0. Those bound on the RHS of a top-level
127 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
128 as ``subscripts'')...
129 \begin{verbatim}
130 a_0 = let b_? = ... in
131 x_1 = ... b ... in ...
132 \end{verbatim}
133
134 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
135 That's meant to be the level number of the enclosing binder in the
136 final (floated) program. If the level number of a sub-expression is
137 less than that of the context, then it might be worth let-binding the
138 sub-expression so that it will indeed float.
139
140 If you can float to level @Level 0 0@ worth doing so because then your
141 allocation becomes static instead of dynamic. We always start with
142 context @Level 0 0@.
143
144
145 Note [FloatOut inside INLINE]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
148 to say "don't float anything out of here". That's exactly what we
149 want for the body of an INLINE, where we don't want to float anything
150 out at all. See notes with lvlMFE below.
151
152 But, check this out:
153
154 -- At one time I tried the effect of not float anything out of an InlineMe,
155 -- but it sometimes works badly. For example, consider PrelArr.done. It
156 -- has the form __inline (\d. e)
157 -- where e doesn't mention d. If we float this to
158 -- __inline (let x = e in \d. x)
159 -- things are bad. The inliner doesn't even inline it because it doesn't look
160 -- like a head-normal form. So it seems a lesser evil to let things float.
161 -- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
162 -- which discourages floating out.
163
164 So the conclusion is: don't do any floating at all inside an InlineMe.
165 (In the above example, don't float the {x=e} out of the \d.)
166
167 One particular case is that of workers: we don't want to float the
168 call to the worker outside the wrapper, otherwise the worker might get
169 inlined into the floated expression, and an importing module won't see
170 the worker at all.
171 -}
172
173 instance Outputable FloatSpec where
174 ppr (FloatMe l) = char 'F' <> ppr l
175 ppr (StayPut l) = ppr l
176
177 tOP_LEVEL :: Level
178 tOP_LEVEL = Level 0 0
179
180 incMajorLvl :: Level -> Level
181 incMajorLvl (Level major _) = Level (major + 1) 0
182
183 incMinorLvl :: Level -> Level
184 incMinorLvl (Level major minor) = Level major (minor+1)
185
186 maxLvl :: Level -> Level -> Level
187 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
188 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
189 | otherwise = l2
190
191 ltLvl :: Level -> Level -> Bool
192 ltLvl (Level maj1 min1) (Level maj2 min2)
193 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
194
195 ltMajLvl :: Level -> Level -> Bool
196 -- Tells if one level belongs to a difft *lambda* level to another
197 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
198
199 isTopLvl :: Level -> Bool
200 isTopLvl (Level 0 0) = True
201 isTopLvl _ = False
202
203 instance Outputable Level where
204 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
205
206 instance Eq Level where
207 (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
208
209 {-
210 ************************************************************************
211 * *
212 \subsection{Main level-setting code}
213 * *
214 ************************************************************************
215 -}
216
217 setLevels :: FloatOutSwitches
218 -> CoreProgram
219 -> UniqSupply
220 -> [LevelledBind]
221
222 setLevels float_lams binds us
223 = initLvl us (do_them init_env binds)
224 where
225 init_env = initialEnv float_lams
226
227 do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
228 do_them _ [] = return []
229 do_them env (b:bs)
230 = do { (lvld_bind, env') <- lvlTopBind env b
231 ; lvld_binds <- do_them env' bs
232 ; return (lvld_bind : lvld_binds) }
233
234 lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
235 lvlTopBind env (NonRec bndr rhs)
236 = do { rhs' <- lvlExpr env (freeVars rhs)
237 ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]
238 ; return (NonRec bndr' rhs', env') }
239
240 lvlTopBind env (Rec pairs)
241 = do let (bndrs,rhss) = unzip pairs
242 (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL bndrs
243 rhss' <- mapM (lvlExpr env' . freeVars) rhss
244 return (Rec (bndrs' `zip` rhss'), env')
245
246 {-
247 ************************************************************************
248 * *
249 \subsection{Setting expression levels}
250 * *
251 ************************************************************************
252
253 Note [Floating over-saturated applications]
254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
255 If we see (f x y), and (f x) is a redex (ie f's arity is 1),
256 we call (f x) an "over-saturated application"
257
258 Should we float out an over-sat app, if can escape a value lambda?
259 It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
260 But we don't want to do it for class selectors, because the work saved
261 is minimal, and the extra local thunks allocated cost money.
262
263 Arguably we could float even class-op applications if they were going to
264 top level -- but then they must be applied to a constant dictionary and
265 will almost certainly be optimised away anyway.
266 -}
267
268 lvlExpr :: LevelEnv -- Context
269 -> CoreExprWithFVs -- Input expression
270 -> LvlM LevelledExpr -- Result expression
271
272 {-
273 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
274 binder. Here's an example
275
276 v = \x -> ...\y -> let r = case (..x..) of
277 ..x..
278 in ..
279
280 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
281 the level of @r@, even though it's inside a level-2 @\y@. It's
282 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
283 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
284 --- because it isn't a *maximal* free expression.
285
286 If there were another lambda in @r@'s rhs, it would get level-2 as well.
287 -}
288
289 lvlExpr env (_, AnnType ty) = return (Type (substTy (le_subst env) ty))
290 lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
291 lvlExpr env (_, AnnVar v) = return (lookupVar env v)
292 lvlExpr _ (_, AnnLit lit) = return (Lit lit)
293
294 lvlExpr env (_, AnnCast expr (_, co)) = do
295 expr' <- lvlExpr env expr
296 return (Cast expr' (substCo (le_subst env) co))
297
298 lvlExpr env (_, AnnTick tickish expr) = do
299 expr' <- lvlExpr env expr
300 return (Tick tickish expr')
301
302 lvlExpr env expr@(_, AnnApp _ _) = do
303 let
304 (fun, args) = collectAnnArgs expr
305 --
306 case fun of
307 (_, AnnVar f) | floatOverSat env -- See Note [Floating over-saturated applications]
308 , arity > 0
309 , arity < n_val_args
310 , Nothing <- isClassOpId_maybe f ->
311 do
312 let (lapp, rargs) = left (n_val_args - arity) expr []
313 rargs' <- mapM (lvlMFE False env) rargs
314 lapp' <- lvlMFE False env lapp
315 return (foldl App lapp' rargs')
316 where
317 n_val_args = count (isValArg . deAnnotate) args
318 arity = idArity f
319
320 -- separate out the PAP that we are floating from the extra
321 -- arguments, by traversing the spine until we have collected
322 -- (n_val_args - arity) value arguments.
323 left 0 e rargs = (e, rargs)
324 left n (_, AnnApp f a) rargs
325 | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
326 | otherwise = left n f (a:rargs)
327 left _ _ _ = panic "SetLevels.lvlExpr.left"
328
329 -- No PAPs that we can float: just carry on with the
330 -- arguments and the function.
331 _otherwise -> do
332 args' <- mapM (lvlMFE False env) args
333 fun' <- lvlExpr env fun
334 return (foldl App fun' args')
335
336 -- We don't split adjacent lambdas. That is, given
337 -- \x y -> (x+1,y)
338 -- we don't float to give
339 -- \x -> let v = x+1 in \y -> (v,y)
340 -- Why not? Because partial applications are fairly rare, and splitting
341 -- lambdas makes them more expensive.
342
343 lvlExpr env expr@(_, AnnLam {})
344 = do { new_body <- lvlMFE True new_env body
345 ; return (mkLams new_bndrs new_body) }
346 where
347 (bndrs, body) = collectAnnBndrs expr
348 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
349 (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
350 -- At one time we called a special verion of collectBinders,
351 -- which ignored coercions, because we don't want to split
352 -- a lambda like this (\x -> coerce t (\s -> ...))
353 -- This used to happen quite a bit in state-transformer programs,
354 -- but not nearly so much now non-recursive newtypes are transparent.
355 -- [See SetLevels rev 1.50 for a version with this approach.]
356
357 lvlExpr env (_, AnnLet bind body)
358 = do { (bind', new_env) <- lvlBind env bind
359 ; body' <- lvlExpr new_env body
360 -- No point in going via lvlMFE here. If the binding is alive
361 -- (mentioned in body), and the whole let-expression doesn't
362 -- float, then neither will the body
363 ; return (Let bind' body') }
364
365 lvlExpr env (_, AnnCase scrut case_bndr ty alts)
366 = do { scrut' <- lvlMFE True env scrut
367 ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
368
369 -------------------------------------------
370 lvlCase :: LevelEnv -- Level of in-scope names/tyvars
371 -> DVarSet -- Free vars of input scrutinee
372 -> LevelledExpr -- Processed scrutinee
373 -> Id -> Type -- Case binder and result type
374 -> [CoreAltWithFVs] -- Input alternatives
375 -> LvlM LevelledExpr -- Result expression
376 lvlCase env scrut_fvs scrut' case_bndr ty alts
377 | [(con@(DataAlt {}), bs, body)] <- alts
378 , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec]
379 , not (isTopLvl dest_lvl) -- Can't have top-level cases
380 , 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']) }
389
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
399
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
405
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
421
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.
425
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
434
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.
448
449 That's why we apply exprOkForSpeculation to scrut' and not to scrut.
450 -}
451
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.
458
459 lvlMFE _ env (_, AnnType ty)
460 = return (Type (substTy (le_subst env) ty))
461
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') }
469
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)) }
473
474 -- Note [Case MFEs]
475 lvlMFE True env e@(_, AnnCase {})
476 = lvlExpr env e -- Don't share cases
477
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
489
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
501
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]
507
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
526
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.
535
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).
551
552 When we do this, we set the strictness and arity of the new bottoming
553 Id, *immediately*, for three reasons:
554
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!
558
559 * So that it's properly exposed as such in the interface file, even if
560 this is all happening after strictness analysis.
561
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.
568
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.
572
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.
579
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 -}
588
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
595
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)!
607
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
623
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
631
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.
638
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.
641
642
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).
650
651 An example where this really makes a difference is simplrun009.
652
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.
660
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).
668
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
677
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
681 add
682 || (strict_ctxt && not (exprIsBottom expr))
683 to the condition above. We should really try this out.
684
685
686 ************************************************************************
687 * *
688 \subsection{Bindings}
689 * *
690 ************************************************************************
691
692 The binding stuff works for top level too.
693 -}
694
695 lvlBind :: LevelEnv
696 -> CoreBindWithFVs
697 -> LvlM (LevelledBind, LevelEnv)
698
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') }
714
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') }
721
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') }
727
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)
734
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') }
743
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) }
749
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
766
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)
781
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) }
787
788 where
789 (bndrs,rhss) = unzip pairs
790
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
798
799 dest_lvl = destLevel env bind_fvs (all isFunction rhss) False
800 abs_vars = abstractVars dest_lvl env bind_fvs
801
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
806
807 ----------------------------------------------------
808 -- Three help functions for the type-abstraction case
809
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
817
818 {-
819 ************************************************************************
820 * *
821 \subsection{Deciding floatability}
822 * *
823 ************************************************************************
824 -}
825
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
831
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
842
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
850
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
855
856
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]
873
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
889
890 | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars
891 -- will be abstracted
892
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
912
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
920
921 {-
922 ************************************************************************
923 * *
924 \subsection{Free-To-Level Monad}
925 * *
926 ************************************************************************
927 -}
928
929 type InVar = Var -- Pre cloning
930 type InId = Id -- Pre cloning
931 type OutVar = Var -- Post cloning
932 type OutId = Id -- Post cloning
933
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
964
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 }
972
973 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
974 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
975
976 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
977 addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs
978
979 floatLams :: LevelEnv -> Maybe Int
980 floatLams le = floatOutLambdas (le_switches le)
981
982 floatConsts :: LevelEnv -> Bool
983 floatConsts le = floatOutConstants (le_switches le)
984
985 floatOverSat :: LevelEnv -> Bool
986 floatOverSat le = floatOutOverSatApps (le_switches le)
987
988 floatTopLvlOnly :: LevelEnv -> Bool
989 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
990
991 setCtxtLvl :: LevelEnv -> Level -> LevelEnv
992 setCtxtLvl env lvl = env { le_ctxt_lvl = lvl }
993
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
1005
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])
1014
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
1020
1021 lookupVar :: LevelEnv -> Id -> LevelledExpr
1022 lookupVar le v = case lookupVarEnv (le_env le) v of
1023 Just (_, expr) -> expr
1024 _ -> Var v
1025
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
1049
1050 abstract_me v = case lookupVarEnv lvl_env v of
1051 Just lvl -> dest_lvl `ltLvl` lvl
1052 Nothing -> False
1053
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
1061
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)
1067
1068 type LvlM result = UniqSM result
1069
1070 initLvl :: UniqSupply -> UniqSM a -> a
1071 initLvl = initUs_
1072
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)
1090
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 = mkLamTypes abs_vars (substTy subst (idType bndr))
1096
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")
1111
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') }
1121
1122 ; return (env', vs') }
1123
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 }
1141
1142 ; return (env', vs2) }
1143
1144 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1145 add_id id_env (v, v1)
1146 | isTyVar v = delVarEnv id_env v
1147 | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
1148
1149 zap_demand_info :: Var -> Var
1150 zap_demand_info v
1151 | isId v = zapIdDemandInfo v
1152 | otherwise = v
1153
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 -}