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, MultiWayIf #-}
53 module SetLevels (
54 setLevels,
56 Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
57 LevelledBind, LevelledExpr, LevelledBndr,
58 FloatSpec(..), floatSpecLevel,
60 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
61 ) where
63 #include "HsVersions.h"
65 import GhcPrelude
67 import CoreSyn
68 import CoreMonad ( FloatOutSwitches(..) )
69 import CoreUtils ( exprType, exprIsHNF
70 , exprOkForSpeculation
71 , exprIsTopLevelBindable
72 , isExprLevPoly
73 , collectMakeStaticArgs
74 )
75 import CoreArity ( exprBotStrictness_maybe )
76 import CoreFVs -- all of it
77 import CoreSubst
78 import MkCore ( sortQuantVars )
80 import Id
81 import IdInfo
82 import Var
83 import VarSet
84 import UniqSet ( nonDetFoldUniqSet )
85 import UniqDSet ( getUniqDSet )
86 import VarEnv
87 import Literal ( litIsTrivial )
88 import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
89 import Name ( getOccName, mkSystemVarName )
90 import OccName ( occNameString )
91 import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )
92 import BasicTypes ( Arity, RecFlag(..), isRec )
93 import DataCon ( dataConOrigResTy )
94 import TysWiredIn
95 import UniqSupply
96 import Util
97 import Outputable
98 import FastString
99 import UniqDFM
100 import FV
101 import Data.Maybe
102 import MonadUtils ( mapAccumLM )
104 {-
105 ************************************************************************
106 * *
107 \subsection{Level numbers}
108 * *
109 ************************************************************************
110 -}
112 type LevelledExpr = TaggedExpr FloatSpec
113 type LevelledBind = TaggedBind FloatSpec
114 type LevelledBndr = TaggedBndr FloatSpec
116 data Level = Level Int -- Level number of enclosing lambdas
117 Int -- Number of big-lambda and/or case expressions and/or
118 -- context boundaries between
119 -- here and the nearest enclosing lambda
120 LevelType -- Binder or join ceiling?
121 data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)
123 data FloatSpec
124 = FloatMe Level -- Float to just inside the binding
125 -- tagged with this level
126 | StayPut Level -- Stay where it is; binding is
127 -- tagged with this level
129 floatSpecLevel :: FloatSpec -> Level
130 floatSpecLevel (FloatMe l) = l
131 floatSpecLevel (StayPut l) = l
133 {-
134 The {\em level number} on a (type-)lambda-bound variable is the
135 nesting depth of the (type-)lambda which binds it. The outermost lambda
136 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
138 On an expression, it's the maximum level number of its free
139 (type-)variables. On a let(rec)-bound variable, it's the level of its
140 RHS. On a case-bound variable, it's the number of enclosing lambdas.
142 Top-level variables: level~0. Those bound on the RHS of a top-level
143 definition but before'' a lambda; e.g., the \tr{x} in (levels shown
144 as subscripts'')...
145 \begin{verbatim}
146 a_0 = let b_? = ... in
147 x_1 = ... b ... in ...
148 \end{verbatim}
150 The main function @lvlExpr@ carries a context level'' (@le_ctxt_lvl@).
151 That's meant to be the level number of the enclosing binder in the
152 final (floated) program. If the level number of a sub-expression is
153 less than that of the context, then it might be worth let-binding the
154 sub-expression so that it will indeed float.
156 If you can float to level @Level 0 0@ worth doing so because then your
158 context @Level 0 0@.
161 Note [FloatOut inside INLINE]
162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 @InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
164 to say "don't float anything out of here". That's exactly what we
165 want for the body of an INLINE, where we don't want to float anything
166 out at all. See notes with lvlMFE below.
168 But, check this out:
170 -- At one time I tried the effect of not floating anything out of an InlineMe,
171 -- but it sometimes works badly. For example, consider PrelArr.done. It
172 -- has the form __inline (\d. e)
173 -- where e doesn't mention d. If we float this to
174 -- __inline (let x = e in \d. x)
175 -- things are bad. The inliner doesn't even inline it because it doesn't look
176 -- like a head-normal form. So it seems a lesser evil to let things float.
177 -- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
178 -- which discourages floating out.
180 So the conclusion is: don't do any floating at all inside an InlineMe.
181 (In the above example, don't float the {x=e} out of the \d.)
183 One particular case is that of workers: we don't want to float the
184 call to the worker outside the wrapper, otherwise the worker might get
185 inlined into the floated expression, and an importing module won't see
186 the worker at all.
188 Note [Join ceiling]
189 ~~~~~~~~~~~~~~~~~~~
190 Join points can't float very far; too far, and they can't remain join points
191 So, suppose we have:
193 f x = (joinrec j y = ... x ... in jump j x) + 1
195 One may be tempted to float j out to the top of f's RHS, but then the jump
196 would not be a tail call. Thus we keep track of a level called the *join
197 ceiling* past which join points are not allowed to float.
199 The troublesome thing is that, unlike most levels to which something might
200 float, there is not necessarily an identifier to which the join ceiling is
201 attached. Fortunately, if something is to be floated to a join ceiling, it must
202 be dropped at the *nearest* join ceiling. Thus each level is marked as to
203 whether it is a join ceiling, so that FloatOut can tell which binders are being
204 floated to the nearest join ceiling and which to a particular binder (or set of
205 binders).
206 -}
208 instance Outputable FloatSpec where
209 ppr (FloatMe l) = char 'F' <> ppr l
210 ppr (StayPut l) = ppr l
212 tOP_LEVEL :: Level
213 tOP_LEVEL = Level 0 0 BndrLvl
215 incMajorLvl :: Level -> Level
216 incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
218 incMinorLvl :: Level -> Level
219 incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
221 asJoinCeilLvl :: Level -> Level
222 asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
224 maxLvl :: Level -> Level -> Level
225 maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)
226 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
227 | otherwise = l2
229 ltLvl :: Level -> Level -> Bool
230 ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
231 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
233 ltMajLvl :: Level -> Level -> Bool
234 -- Tells if one level belongs to a difft *lambda* level to another
235 ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2
237 isTopLvl :: Level -> Bool
238 isTopLvl (Level 0 0 _) = True
239 isTopLvl _ = False
241 isJoinCeilLvl :: Level -> Bool
242 isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
244 instance Outputable Level where
245 ppr (Level maj min typ)
246 = hcat [ char '<', int maj, char ',', int min, char '>'
247 , ppWhen (typ == JoinCeilLvl) (char 'C') ]
249 instance Eq Level where
250 (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
252 {-
253 ************************************************************************
254 * *
255 \subsection{Main level-setting code}
256 * *
257 ************************************************************************
258 -}
260 setLevels :: FloatOutSwitches
261 -> CoreProgram
262 -> UniqSupply
263 -> [LevelledBind]
265 setLevels float_lams binds us
266 = initLvl us (do_them init_env binds)
267 where
268 init_env = initialEnv float_lams
270 do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
271 do_them _ [] = return []
272 do_them env (b:bs)
273 = do { (lvld_bind, env') <- lvlTopBind env b
274 ; lvld_binds <- do_them env' bs
275 ; return (lvld_bind : lvld_binds) }
277 lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
278 lvlTopBind env (NonRec bndr rhs)
279 = do { rhs' <- lvl_top env NonRecursive bndr rhs
280 ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]
281 ; return (NonRec bndr' rhs', env') }
283 lvlTopBind env (Rec pairs)
284 = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL
285 (map fst pairs)
286 ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs
287 ; return (Rec (bndrs' zip rhss'), env') }
289 lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr
290 lvl_top env is_rec bndr rhs
291 = lvlRhs env is_rec
292 (isBottomingId bndr)
293 Nothing -- Not a join point
294 (freeVars rhs)
296 {-
297 ************************************************************************
298 * *
299 \subsection{Setting expression levels}
300 * *
301 ************************************************************************
303 Note [Floating over-saturated applications]
304 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
305 If we see (f x y), and (f x) is a redex (ie f's arity is 1),
306 we call (f x) an "over-saturated application"
308 Should we float out an over-sat app, if can escape a value lambda?
309 It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
310 But we don't want to do it for class selectors, because the work saved
311 is minimal, and the extra local thunks allocated cost money.
313 Arguably we could float even class-op applications if they were going to
314 top level -- but then they must be applied to a constant dictionary and
315 will almost certainly be optimised away anyway.
316 -}
318 lvlExpr :: LevelEnv -- Context
319 -> CoreExprWithFVs -- Input expression
320 -> LvlM LevelledExpr -- Result expression
322 {-
323 The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
324 binder. Here's an example
326 v = \x -> ...\y -> let r = case (..x..) of
327 ..x..
328 in ..
330 When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's
331 the level of @r@, even though it's inside a level-2 @\y@. It's
332 important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
333 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
334 --- because it isn't a *maximal* free expression.
336 If there were another lambda in @r@'s rhs, it would get level-2 as well.
337 -}
339 lvlExpr env (_, AnnType ty) = return (Type (CoreSubst.substTy (le_subst env) ty))
340 lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
341 lvlExpr env (_, AnnVar v) = return (lookupVar env v)
342 lvlExpr _ (_, AnnLit lit) = return (Lit lit)
344 lvlExpr env (_, AnnCast expr (_, co)) = do
345 expr' <- lvlNonTailExpr env expr
346 return (Cast expr' (substCo (le_subst env) co))
348 lvlExpr env (_, AnnTick tickish expr) = do
349 expr' <- lvlNonTailExpr env expr
350 let tickish' = substTickish (le_subst env) tickish
351 return (Tick tickish' expr')
353 lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
355 -- We don't split adjacent lambdas. That is, given
356 -- \x y -> (x+1,y)
357 -- we don't float to give
358 -- \x -> let v = x+1 in \y -> (v,y)
359 -- Why not? Because partial applications are fairly rare, and splitting
360 -- lambdas makes them more expensive.
362 lvlExpr env expr@(_, AnnLam {})
363 = do { new_body <- lvlNonTailMFE new_env True body
364 ; return (mkLams new_bndrs new_body) }
365 where
366 (bndrs, body) = collectAnnBndrs expr
367 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
368 (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
369 -- At one time we called a special version of collectBinders,
370 -- which ignored coercions, because we don't want to split
371 -- a lambda like this (\x -> coerce t (\s -> ...))
372 -- This used to happen quite a bit in state-transformer programs,
373 -- but not nearly so much now non-recursive newtypes are transparent.
374 -- [See SetLevels rev 1.50 for a version with this approach.]
376 lvlExpr env (_, AnnLet bind body)
377 = do { (bind', new_env) <- lvlBind env bind
378 ; body' <- lvlExpr new_env body
379 -- No point in going via lvlMFE here. If the binding is alive
380 -- (mentioned in body), and the whole let-expression doesn't
381 -- float, then neither will the body
382 ; return (Let bind' body') }
384 lvlExpr env (_, AnnCase scrut case_bndr ty alts)
385 = do { scrut' <- lvlNonTailMFE env True scrut
386 ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
388 lvlNonTailExpr :: LevelEnv -- Context
389 -> CoreExprWithFVs -- Input expression
390 -> LvlM LevelledExpr -- Result expression
391 lvlNonTailExpr env expr
392 = lvlExpr (placeJoinCeiling env) expr
394 -------------------------------------------
395 lvlApp :: LevelEnv
396 -> CoreExprWithFVs
397 -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
398 -> LvlM LevelledExpr -- Result expression
399 lvlApp env orig_expr ((_,AnnVar fn), args)
400 | floatOverSat env -- See Note [Floating over-saturated applications]
401 , arity > 0
402 , arity < n_val_args
403 , Nothing <- isClassOpId_maybe fn
404 = do { rargs' <- mapM (lvlNonTailMFE env False) rargs
405 ; lapp' <- lvlNonTailMFE env False lapp
406 ; return (foldl' App lapp' rargs') }
408 | otherwise
409 = do { (_, args') <- mapAccumLM lvl_arg stricts args
410 -- Take account of argument strictness; see
411 -- Note [Floating to the top]
412 ; return (foldl' App (lookupVar env fn) args') }
413 where
414 n_val_args = count (isValArg . deAnnotate) args
415 arity = idArity fn
417 stricts :: [Demand] -- True for strict /value/ arguments
418 stricts = case splitStrictSig (idStrictness fn) of
419 (arg_ds, _) | arg_ds lengthExceeds n_val_args
420 -> []
421 | otherwise
422 -> arg_ds
424 -- Separate out the PAP that we are floating from the extra
425 -- arguments, by traversing the spine until we have collected
426 -- (n_val_args - arity) value arguments.
427 (lapp, rargs) = left (n_val_args - arity) orig_expr []
429 left 0 e rargs = (e, rargs)
430 left n (_, AnnApp f a) rargs
431 | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
432 | otherwise = left n f (a:rargs)
433 left _ _ _ = panic "SetLevels.lvlExpr.left"
435 is_val_arg :: CoreExprWithFVs -> Bool
436 is_val_arg (_, AnnType {}) = False
437 is_val_arg _ = True
439 lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
440 lvl_arg strs arg | (str1 : strs') <- strs
441 , is_val_arg arg
442 = do { arg' <- lvlMFE env (isStrictDmd str1) arg
443 ; return (strs', arg') }
444 | otherwise
445 = do { arg' <- lvlMFE env False arg
446 ; return (strs, arg') }
448 lvlApp env _ (fun, args)
449 = -- No PAPs that we can float: just carry on with the
450 -- arguments and the function.
451 do { args' <- mapM (lvlNonTailMFE env False) args
452 ; fun' <- lvlNonTailExpr env fun
453 ; return (foldl' App fun' args') }
455 -------------------------------------------
456 lvlCase :: LevelEnv -- Level of in-scope names/tyvars
457 -> DVarSet -- Free vars of input scrutinee
458 -> LevelledExpr -- Processed scrutinee
459 -> Id -> Type -- Case binder and result type
460 -> [CoreAltWithFVs] -- Input alternatives
461 -> LvlM LevelledExpr -- Result expression
462 lvlCase env scrut_fvs scrut' case_bndr ty alts
463 -- See Note [Floating single-alternative cases]
464 | [(con@(DataAlt {}), bs, body)] <- alts
465 , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF]
466 , not (isTopLvl dest_lvl) -- Can't have top-level cases
467 , not (floatTopLvlOnly env) -- Can float anywhere
468 = -- Always float the case if possible
469 -- Unlike lets we don't insist that it escapes a value lambda
470 do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
471 ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
472 ; body' <- lvlMFE rhs_env True body
473 ; let alt' = (con, map (stayPut dest_lvl) bs', body')
474 ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
476 | otherwise -- Stays put
477 = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
478 alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
479 ; alts' <- mapM (lvl_alt alts_env) alts
480 ; return (Case scrut' case_bndr' ty' alts') }
481 where
482 ty' = substTy (le_subst env) ty
484 incd_lvl = incMinorLvl (le_ctxt_lvl env)
485 dest_lvl = maxFvLevel (const True) env scrut_fvs
486 -- Don't abstract over type variables, hence const True
488 lvl_alt alts_env (con, bs, rhs)
489 = do { rhs' <- lvlMFE new_env True rhs
490 ; return (con, bs', rhs') }
491 where
492 (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
494 {- Note [Floating single-alternative cases]
495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
496 Consider this:
497 data T a = MkT !a
498 f :: T Int -> blah
499 f x vs = case x of { MkT y ->
500 let f vs = ...(case y of I# w -> e)...f..
501 in f vs
503 Here we can float the (case y ...) out, because y is sure
504 to be evaluated, to give
505 f x vs = case x of { MkT y ->
506 caes y of I# w ->
507 let f vs = ...(e)...f..
508 in f vs
510 That saves unboxing it every time round the loop. It's important in
511 some DPH stuff where we really want to avoid that repeated unboxing in
512 the inner loop.
514 Things to note:
516 * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
518 - exrpIsHNF catches the key case of an evaluated variable
520 - exprOkForSpeculation is /false/ of an evaluated variable;
521 See Note [exprOkForSpeculation and evaluated variables] in CoreUtils
522 So we'd actually miss the key case!
524 - Nothing is gained from the extra generality of exprOkForSpeculation
525 since we only consider floating a case whose single alternative
526 is a DataAlt K a b -> rhs
528 * We can't float a case to top level
530 * It's worth doing this float even if we don't float
531 the case outside a value lambda. Example
532 case x of {
533 MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
534 If we floated the cases out we could eliminate one of them.
536 * We only do this with a single-alternative case
538 Note [Check the output scrutinee for exprIsHNF]
539 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
540 Consider this:
541 case x of y {
542 A -> ....(case y of alts)....
543 }
545 Because of the binder-swap, the inner case will get substituted to
546 (case x of ..). So when testing whether the scrutinee is in HNF we
547 must be careful to test the *result* scrutinee ('x' in this case), not
548 the *input* one 'y'. The latter *is* in HNF here (because y is
549 evaluated), but the former is not -- and indeed we can't float the
550 inner case out, at least not unless x is also evaluated at its binding
551 site. See #5453.
553 That's why we apply exprIsHNF to scrut' and not to scrut.
555 See Note [Floating single-alternative cases] for why
556 we use exprIsHNF in the first place.
557 -}
559 lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars
560 -> Bool -- True <=> strict context [body of case
561 -- or let]
562 -> CoreExprWithFVs -- input expression
563 -> LvlM LevelledExpr -- Result expression
564 lvlNonTailMFE env strict_ctxt ann_expr
565 = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
567 lvlMFE :: LevelEnv -- Level of in-scope names/tyvars
568 -> Bool -- True <=> strict context [body of case or let]
569 -> CoreExprWithFVs -- input expression
570 -> LvlM LevelledExpr -- Result expression
571 -- lvlMFE is just like lvlExpr, except that it might let-bind
572 -- the expression, so that it can itself be floated.
574 lvlMFE env _ (_, AnnType ty)
575 = return (Type (CoreSubst.substTy (le_subst env) ty))
577 -- No point in floating out an expression wrapped in a coercion or note
578 -- If we do we'll transform lvl = e |> co
579 -- to lvl' = e; lvl = lvl' |> co
580 -- and then inline lvl. Better just to float out the payload.
581 lvlMFE env strict_ctxt (_, AnnTick t e)
582 = do { e' <- lvlMFE env strict_ctxt e
583 ; let t' = substTickish (le_subst env) t
584 ; return (Tick t' e') }
586 lvlMFE env strict_ctxt (_, AnnCast e (_, co))
587 = do { e' <- lvlMFE env strict_ctxt e
588 ; return (Cast e' (substCo (le_subst env) co)) }
590 lvlMFE env strict_ctxt e@(_, AnnCase {})
591 | strict_ctxt -- Don't share cases in a strict context
592 = lvlExpr env e -- See Note [Case MFEs]
594 lvlMFE env strict_ctxt ann_expr
595 | floatTopLvlOnly env && not (isTopLvl dest_lvl)
596 -- Only floating to the top level is allowed.
597 || anyDVarSet isJoinId fvs -- If there is a free join, don't float
598 -- See Note [Free join points]
599 || isExprLevPoly expr
600 -- We can't let-bind levity polymorphic expressions
601 -- See Note [Levity polymorphism invariants] in CoreSyn
602 || notWorthFloating expr abs_vars
603 || not float_me
604 = -- Don't float it out
605 lvlExpr env ann_expr
607 | float_is_new_lam || exprIsTopLevelBindable expr expr_ty
608 -- No wrapping needed if the type is lifted, or is a literal string
609 -- or if we are wrapping it in one or more value lambdas
610 = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
611 (isJust mb_bot_str)
612 join_arity_maybe
613 ann_expr
614 -- Treat the expr just like a right-hand side
615 ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
616 ; let var2 = annotateBotStr var float_n_lams mb_bot_str
617 ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
618 (mkVarApps (Var var2) abs_vars)) }
620 -- OK, so the float has an unlifted type (not top-level bindable)
621 -- and no new value lambdas (float_is_new_lam is False)
622 -- Try for the boxing strategy
623 -- See Note [Floating MFEs of unlifted type]
624 | escapes_value_lam
625 , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
626 -- See Note [Test cheapness with exprOkForSpeculation]
627 , Just (tc, _) <- splitTyConApp_maybe expr_ty
628 , Just dc <- boxingDataCon_maybe tc
629 , let dc_res_ty = dataConOrigResTy dc -- No free type variables
630 [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]
631 = do { expr1 <- lvlExpr rhs_env ann_expr
632 ; let l1r = incMinorLvlFrom rhs_env
633 float_rhs = mkLams abs_vars_w_lvls $634 Case expr1 (stayPut l1r ubx_bndr) dc_res_ty 635 [(DEFAULT, [], mkConApp dc [Var ubx_bndr])] 637 ; var <- newLvlVar float_rhs Nothing is_mk_static 638 ; let l1u = incMinorLvlFrom env 639 use_expr = Case (mkVarApps (Var var) abs_vars) 640 (stayPut l1u bx_bndr) expr_ty 641 [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)] 642 ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) 643 use_expr) } 645 | otherwise -- e.g. do not float unboxed tuples 646 = lvlExpr env ann_expr 648 where 649 expr = deAnnotate ann_expr 650 expr_ty = exprType expr 651 fvs = freeVarsOf ann_expr 652 fvs_ty = tyCoVarsOfType expr_ty 653 is_bot = isBottomThunk mb_bot_str 654 is_function = isFunction ann_expr 655 mb_bot_str = exprBotStrictness_maybe expr 656 -- See Note [Bottoming floats] 657 -- esp Bottoming floats (2) 658 expr_ok_for_spec = exprOkForSpeculation expr 659 dest_lvl = destLevel env fvs fvs_ty is_function is_bot False 660 abs_vars = abstractVars dest_lvl env fvs 662 -- float_is_new_lam: the floated thing will be a new value lambda 663 -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is 664 -- allocation saved. The benefit is to get it to the top level 665 -- and hence out of the body of this function altogether, making 666 -- it smaller and more inlinable 667 float_is_new_lam = float_n_lams > 0 668 float_n_lams = count isId abs_vars 670 (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars 672 join_arity_maybe = Nothing 674 is_mk_static = isJust (collectMakeStaticArgs expr) 675 -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable 677 -- A decision to float entails let-binding this thing, and we only do 678 -- that if we'll escape a value lambda, or will go to the top level. 679 float_me = saves_work || saves_alloc || is_mk_static 681 -- We can save work if we can move a redex outside a value lambda 682 -- But if float_is_new_lam is True, then the redex is wrapped in a 683 -- a new lambda, so no work is saved 684 saves_work = escapes_value_lam && not float_is_new_lam 686 escapes_value_lam = dest_lvl ltMajLvl (le_ctxt_lvl env) 687 -- See Note [Escaping a value lambda] 689 -- See Note [Floating to the top] 690 saves_alloc = isTopLvl dest_lvl 691 && floatConsts env 692 && (not strict_ctxt || is_bot || exprIsHNF expr) 694 isBottomThunk :: Maybe (Arity, s) -> Bool 695 -- See Note [Bottoming floats] (2) 696 isBottomThunk (Just (0, _)) = True -- Zero arity 697 isBottomThunk _ = False 699 {- Note [Floating to the top] 700 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 701 We are keen to float something to the top level, even if it does not 702 escape a value lambda (and hence save work), for two reasons: 704 * Doing so makes the function smaller, by floating out 705 bottoming expressions, or integer or string literals. That in 706 turn makes it easier to inline, with less duplication. 708 * (Minor) Doing so may turn a dynamic allocation (done by machine 709 instructions) into a static one. Minor because we are assuming 710 we are not escaping a value lambda. 712 But do not so if: 713 - the context is a strict, and 714 - the expression is not a HNF, and 715 - the expression is not bottoming 717 Exammples: 719 * Bottoming 720 f x = case x of 721 0 -> error <big thing> 722 _ -> x+1 723 Here we want to float (error <big thing>) to top level, abstracting 724 over 'x', so as to make f's RHS smaller. 726 * HNF 727 f = case y of 728 True -> p:q 729 False -> blah 730 We may as well float the (p:q) so it becomes a static data structure. 732 * Case scrutinee 733 f = case g True of .... 734 Don't float (g True) to top level; then we have the admin of a 735 top-level thunk to worry about, with zero gain. 737 * Case alternative 738 h = case y of 739 True -> g True 740 False -> False 741 Don't float (g True) to the top level 743 * Arguments 744 t = f (g True) 745 If f is lazy, we /do/ float (g True) because then we can allocate 746 the thunk statically rather than dynamically. But if f is strict 747 we don't (see the use of idStrictness in lvlApp). It's not clear 748 if this test is worth the bother: it's only about CAFs! 750 It's controlled by a flag (floatConsts), because doing this too 751 early loses opportunities for RULES which (needless to say) are 752 important in some nofib programs (gcd is an example). [SPJ note: 753 I think this is obselete; the flag seems always on.] 755 Note [Floating join point bindings] 756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 757 Mostly we only float a join point if it can /stay/ a join point. But 758 there is one exception: if it can go to the top level (#13286). 759 Consider 760 f x = joinrec j y n = <...j y' n'...> 761 in jump j x 0 763 Here we may just as well produce 764 j y n = <....j y' n'...> 765 f x = j x 0 767 and now there is a chance that 'f' will be inlined at its call sites. 768 It shouldn't make a lot of difference, but thes tests 769 perf/should_run/MethSharing 770 simplCore/should_compile/spec-inline 771 and one nofib program, all improve if you do float to top, because 772 of the resulting inlining of f. So ok, let's do it. 774 Note [Free join points] 775 ~~~~~~~~~~~~~~~~~~~~~~~ 776 We never float a MFE that has a free join-point variable. You mght think 777 this can never occur. After all, consider 778 join j x = ... 779 in ....(jump j x).... 780 How might we ever want to float that (jump j x)? 781 * If it would escape a value lambda, thus 782 join j x = ... in (\y. ...(jump j x)... ) 783 then 'j' isn't a valid join point in the first place. 785 But consider 786 join j x = .... in 787 joinrec j2 y = ...(jump j x)...(a+b).... 789 Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec. 790 But it is emphatically /not/ good to float the (jump j x) out: 791 (a) 'j' will stop being a join point 792 (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no 793 work would be saved by floating it out of the \y. 795 Even if we floated 'j' to top level, (b) would still hold. 797 Bottom line: never float a MFE that has a free JoinId. 799 Note [Floating MFEs of unlifted type] 800 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 801 Suppose we have 802 case f x of (r::Int#) -> blah 803 we'd like to float (f x). But it's not trivial because it has type 804 Int#, and we don't want to evaluate it too early. But we can instead 805 float a boxed version 806 y = case f x of r -> I# r 807 and replace the original (f x) with 808 case (case y of I# r -> r) of r -> blah 810 Being able to float unboxed expressions is sometimes important; see 811 #12603. I'm not sure how /often/ it is important, but it's 812 not hard to achieve. 814 We only do it for a fixed collection of types for which we have a 815 convenient boxing constructor (see boxingDataCon_maybe). In 816 particular we /don't/ do it for unboxed tuples; it's better to float 817 the components of the tuple individually. 819 I did experiment with a form of boxing that works for any type, namely 820 wrapping in a function. In our example 822 let y = case f x of r -> \v. f x 823 in case y void of r -> blah 825 It works fine, but it's 50% slower (based on some crude benchmarking). 826 I suppose we could do it for types not covered by boxingDataCon_maybe, 827 but it's more code and I'll wait to see if anyone wants it. 829 Note [Test cheapness with exprOkForSpeculation] 830 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 831 We don't want to float very cheap expressions by boxing and unboxing. 832 But we use exprOkForSpeculation for the test, not exprIsCheap. 833 Why? Because it's important /not/ to transform 834 f (a /# 3) 835 to 836 f (case bx of I# a -> a /# 3) 837 and float bx = I# (a /# 3), because the application of f no 838 longer obeys the let/app invariant. But (a /# 3) is ok-for-spec 839 due to a special hack that says division operators can't fail 840 when the denominator is definitely non-zero. And yet that 841 same expression says False to exprIsCheap. Simplest way to 842 guarantee the let/app invariant is to use the same function! 844 If an expression is okay for speculation, we could also float it out 845 *without* boxing and unboxing, since evaluating it early is okay. 846 However, it turned out to usually be better not to float such expressions, 847 since they tend to be extremely cheap things like (x +# 1#). Even the 848 cost of spilling the let-bound variable to the stack across a call may 849 exceed the cost of recomputing such an expression. (And we can't float 850 unlifted bindings to top-level.) 852 We could try to do something smarter here, and float out expensive yet 853 okay-for-speculation things, such as division by non-zero constants. 854 But I suspect it's a narrow target. 856 Note [Bottoming floats] 857 ~~~~~~~~~~~~~~~~~~~~~~~ 858 If we see 859 f = \x. g (error "urk") 860 we'd like to float the call to error, to get 861 lvl = error "urk" 862 f = \x. g lvl 864 But, as ever, we need to be careful: 866 (1) We want to float a bottoming 867 expression even if it has free variables: 868 f = \x. g (let v = h x in error ("urk" ++ v)) 869 Then we'd like to abstract over 'x' can float the whole arg of g: 870 lvl = \x. let v = h x in error ("urk" ++ v) 871 f = \x. g (lvl x) 872 To achieve this we pass is_bot to destLevel 874 (2) We do not do this for lambdas that return 875 bottom. Instead we treat the /body/ of such a function specially, 876 via point (1). For example: 877 f = \x. ....(\y z. if x then error y else error z).... 878 ===> 879 lvl = \x z y. if b then error y else error z 880 f = \x. ...(\y z. lvl x z y)... 881 (There is no guarantee that we'll choose the perfect argument order.) 883 (3) If we have a /binding/ that returns bottom, we want to float it to top 884 level, even if it has free vars (point (1)), and even it has lambdas. 885 Example: 886 ... let { v = \y. error (show x ++ show y) } in ... 887 We want to abstract over x and float the whole thing to top: 888 lvl = \xy. errror (show x ++ show y) 889 ...let {v = lvl x} in ... 891 Then of course we don't want to separately float the body (error ...) 892 as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot 893 argument. 895 See Maessen's paper 1999 "Bottom extraction: factoring error handling out 896 of functional programs" (unpublished I think). 898 When we do this, we set the strictness and arity of the new bottoming 899 Id, *immediately*, for three reasons: 901 * To prevent the abstracted thing being immediately inlined back in again 902 via preInlineUnconditionally. The latter has a test for bottoming Ids 903 to stop inlining them, so we'd better make sure it *is* a bottoming Id! 905 * So that it's properly exposed as such in the interface file, even if 906 this is all happening after strictness analysis. 908 * In case we do CSE with the same expression that *is* marked bottom 909 lvl = error "urk" 910 x{str=bot) = error "urk" 911 Here we don't want to replace 'x' with 'lvl', else we may get Lint 912 errors, e.g. via a case with empty alternatives: (case x of {}) 913 Lint complains unless the scrutinee of such a case is clearly bottom. 915 This was reported in #11290. But since the whole bottoming-float 916 thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure 917 that it'll nail all such cases. 919 Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] 920 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 921 Tiresomely, though, the simplifier has an invariant that the manifest 922 arity of the RHS should be the same as the arity; but we can't call 923 etaExpand during SetLevels because it works over a decorated form of 924 CoreExpr. So we do the eta expansion later, in FloatOut. 926 Note [Case MFEs] 927 ~~~~~~~~~~~~~~~~ 928 We don't float a case expression as an MFE from a strict context. Why not? 929 Because in doing so we share a tiny bit of computation (the switch) but 930 in exchange we build a thunk, which is bad. This case reduces allocation 931 by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. 932 Doesn't change any other allocation at all. 934 We will make a separate decision for the scrutinee and alternatives. 936 However this can have a knock-on effect for fusion: consider 937 \v -> foldr k z (case x of I# y -> build ..y..) 938 Perhaps we can float the entire (case x of ...) out of the \v. Then 939 fusion will not happen, but we will get more sharing. But if we don't 940 float the case (as advocated here) we won't float the (build ...y..) 941 either, so fusion will happen. It can be a big effect, esp in some 942 artificial benchmarks (e.g. integer, queens), but there is no perfect 943 answer. 945 -} 947 annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id 948 -- See Note [Bottoming floats] for why we want to add 949 -- bottoming information right now 950 -- 951 -- n_extra are the number of extra value arguments added during floating 952 annotateBotStr id n_extra mb_str 953 = case mb_str of 954 Nothing -> id 955 Just (arity, sig) -> id setIdArity (arity + n_extra) 956 setIdStrictness (increaseStrictSigArity n_extra sig) 958 notWorthFloating :: CoreExpr -> [Var] -> Bool 959 -- Returns True if the expression would be replaced by 960 -- something bigger than it is now. For example: 961 -- abs_vars = tvars only: return True if e is trivial, 962 -- but False for anything bigger 963 -- abs_vars = [x] (an Id): return True for trivial, or an application (f x) 964 -- but False for (f x x) 965 -- 966 -- One big goal is that floating should be idempotent. Eg if 967 -- we replace e with (lvl79 x y) and then run FloatOut again, don't want 968 -- to replace (lvl79 x y) with (lvl83 x y)! 970 notWorthFloating e abs_vars 971 = go e (count isId abs_vars) 972 where 973 go (Var {}) n = n >= 0 974 go (Lit lit) n = ASSERT( n==0 ) 975 litIsTrivial lit -- Note [Floating literals] 976 go (Tick t e) n = not (tickishIsCode t) && go e n 977 go (Cast e _) n = go e n 978 go (App e arg) n 979 | Type {} <- arg = go e n 980 | Coercion {} <- arg = go e n 981 | n==0 = False 982 | is_triv arg = go e (n-1) 983 | otherwise = False 984 go _ _ = False 986 is_triv (Lit {}) = True -- Treat all literals as trivial 987 is_triv (Var {}) = True -- (ie not worth floating) 988 is_triv (Cast e _) = is_triv e 989 is_triv (App e (Type {})) = is_triv e 990 is_triv (App e (Coercion {})) = is_triv e 991 is_triv (Tick t e) = not (tickishIsCode t) && is_triv e 992 is_triv _ = False 994 {- 995 Note [Floating literals] 996 ~~~~~~~~~~~~~~~~~~~~~~~~ 997 It's important to float Integer literals, so that they get shared, 998 rather than being allocated every time round the loop. 999 Hence the litIsTrivial. 1001 Ditto literal strings (LitString), which we'd like to float to top 1002 level, which is now possible. 1005 Note [Escaping a value lambda] 1006 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1007 We want to float even cheap expressions out of value lambdas, 1008 because that saves allocation. Consider 1009 f = \x. .. (\y.e) ... 1010 Then we'd like to avoid allocating the (\y.e) every time we call f, 1011 (assuming e does not mention x). An example where this really makes a 1012 difference is simplrun009. 1014 Another reason it's good is because it makes SpecContr fire on functions. 1015 Consider 1016 f = \x. ....(f (\y.e)).... 1017 After floating we get 1018 lvl = \y.e 1019 f = \x. ....(f lvl)... 1020 and that is much easier for SpecConstr to generate a robust 1021 specialisation for. 1023 However, if we are wrapping the thing in extra value lambdas (in 1024 abs_vars), then nothing is saved. E.g. 1025 f = \xyz. ...(e1[y],e2).... 1026 If we float 1027 lvl = \y. (e1[y],e2) 1028 f = \xyz. ...(lvl y)... 1029 we have saved nothing: one pair will still be allocated for each 1030 call of 'f'. Hence the (not float_is_lam) in float_me. 1033 ************************************************************************ 1034 * * 1035 \subsection{Bindings} 1036 * * 1037 ************************************************************************ 1039 The binding stuff works for top level too. 1040 -} 1042 lvlBind :: LevelEnv 1043 -> CoreBindWithFVs 1044 -> LvlM (LevelledBind, LevelEnv) 1046 lvlBind env (AnnNonRec bndr rhs) 1047 | isTyVar bndr -- Don't do anything for TyVar binders 1048 -- (simplifier gets rid of them pronto) 1049 || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) 1050 -- so we will ignore this case for now 1051 || not (profitableFloat env dest_lvl) 1052 || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty)) 1053 -- We can't float an unlifted binding to top level (except 1054 -- literal strings), so we don't float it at all. It's a 1055 -- bit brutal, but unlifted bindings aren't expensive either 1057 = -- No float 1058 do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs 1059 ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) 1060 (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] 1061 ; return (NonRec bndr' rhs', env') } 1063 -- Otherwise we are going to float 1064 | null abs_vars 1065 = do { -- No type abstraction; clone existing binder 1066 rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive 1067 is_bot mb_join_arity rhs 1068 ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] 1069 ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str 1070 ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } 1072 | otherwise 1073 = do { -- Yes, type abstraction; create a new binder, extend substitution, etc 1074 rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive 1075 is_bot mb_join_arity rhs 1076 ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] 1077 ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str 1078 ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } 1080 where 1081 bndr_ty = idType bndr 1082 ty_fvs = tyCoVarsOfType bndr_ty 1083 rhs_fvs = freeVarsOf rhs 1084 bind_fvs = rhs_fvs unionDVarSet dIdFreeVars bndr 1085 abs_vars = abstractVars dest_lvl env bind_fvs 1086 dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join 1088 deann_rhs = deAnnotate rhs 1089 mb_bot_str = exprBotStrictness_maybe deann_rhs 1090 is_bot = isJust mb_bot_str 1091 -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) 1093 n_extra = count isId abs_vars 1094 mb_join_arity = isJoinId_maybe bndr 1095 is_join = isJust mb_join_arity 1097 lvlBind env (AnnRec pairs) 1098 | floatTopLvlOnly env && not (isTopLvl dest_lvl) 1099 -- Only floating to the top level is allowed. 1100 || not (profitableFloat env dest_lvl) 1101 = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) 1102 (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs 1103 lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r 1104 ; rhss' <- mapM lvl_rhs pairs 1105 ; return (Rec (bndrs' zip rhss'), env') } 1107 | null abs_vars 1108 = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs 1109 ; new_rhss <- mapM (do_rhs new_env) pairs 1110 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] zip new_rhss) 1111 , new_env) } 1113 -- ToDo: when enabling the floatLambda stuff, 1114 -- I think we want to stop doing this 1115 | [(bndr,rhs)] <- pairs 1116 , count isId abs_vars > 1 1117 = do -- Special case for self recursion where there are 1118 -- several variables carried around: build a local loop: 1119 -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars 1120 -- This just makes the closures a bit smaller. If we don't do 1121 -- this, allocation rises significantly on some programs 1122 -- 1123 -- We could elaborate it for the case where there are several 1124 -- mutually recursive functions, but it's quite a bit more complicated 1125 -- 1126 -- This all seems a bit ad hoc -- sigh 1127 let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars 1128 rhs_lvl = le_ctxt_lvl rhs_env 1130 (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr] 1131 let 1132 (lam_bndrs, rhs_body) = collectAnnBndrs rhs 1133 (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs 1134 (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 1135 new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body 1136 (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] 1137 return (Rec [(TB poly_bndr (FloatMe dest_lvl) 1138 , mkLams abs_vars_w_lvls$
1139 mkLams lam_bndrs2 $1140 Let (Rec [( TB new_bndr (StayPut rhs_lvl) 1141 , mkLams lam_bndrs2 new_rhs_body)]) 1142 (mkVarApps (Var new_bndr) lam_bndrs1))] 1143 , poly_env) 1145 | otherwise -- Non-null abs_vars 1146 = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs 1147 ; new_rhss <- mapM (do_rhs new_env) pairs 1148 ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] zip new_rhss) 1149 , new_env) } 1151 where 1152 (bndrs,rhss) = unzip pairs 1153 is_join = isJoinId (head bndrs) 1154 -- bndrs is always non-empty and if one is a join they all are 1155 -- Both are checked by Lint 1156 is_fun = all isFunction rhss 1157 is_bot = False -- It's odd to have an unconditionally divergent 1158 -- function in a Rec, and we don't much care what 1159 -- happens to it. False is simple! 1161 do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive 1162 is_bot (get_join bndr) 1163 rhs 1165 get_join bndr | need_zap = Nothing 1166 | otherwise = isJoinId_maybe bndr 1167 need_zap = dest_lvl ltLvl joinCeilingLevel env 1169 -- Finding the free vars of the binding group is annoying 1170 bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) 1171 unionDVarSet 1172 (fvDVarSet$ unionsFV [ idFVs bndr
1173 | (bndr, (_,_)) <- pairs]))
1174 delDVarSetList
1175 bndrs
1177 ty_fvs = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
1178 dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
1179 abs_vars = abstractVars dest_lvl env bind_fvs
1181 profitableFloat :: LevelEnv -> Level -> Bool
1182 profitableFloat env dest_lvl
1183 = (dest_lvl ltMajLvl le_ctxt_lvl env) -- Escapes a value lambda
1184 || isTopLvl dest_lvl -- Going all the way to top level
1187 ----------------------------------------------------
1188 -- Three help functions for the type-abstraction case
1190 lvlRhs :: LevelEnv
1191 -> RecFlag
1192 -> Bool -- Is this a bottoming function
1193 -> Maybe JoinArity
1194 -> CoreExprWithFVs
1195 -> LvlM LevelledExpr
1196 lvlRhs env rec_flag is_bot mb_join_arity expr
1197 = lvlFloatRhs [] (le_ctxt_lvl env) env
1198 rec_flag is_bot mb_join_arity expr
1200 lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
1201 -> Bool -- Binding is for a bottoming function
1202 -> Maybe JoinArity
1203 -> CoreExprWithFVs
1204 -> LvlM (Expr LevelledBndr)
1205 -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
1206 lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
1207 = do { body' <- if not is_bot -- See Note [Floating from a RHS]
1208 && any isId bndrs
1209 then lvlMFE body_env True body
1210 else lvlExpr body_env body
1211 ; return (mkLams bndrs' body') }
1212 where
1213 (bndrs, body) | Just join_arity <- mb_join_arity
1214 = collectNAnnBndrs join_arity rhs
1215 | otherwise
1216 = collectAnnBndrs rhs
1217 (env1, bndrs1) = substBndrsSL NonRecursive env bndrs
1218 all_bndrs = abs_vars ++ bndrs1
1219 (body_env, bndrs') | Just _ <- mb_join_arity
1220 = lvlJoinBndrs env1 dest_lvl rec all_bndrs
1221 | otherwise
1222 = case lvlLamBndrs env1 dest_lvl all_bndrs of
1223 (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
1224 -- The important thing here is that we call lvlLamBndrs on
1225 -- all these binders at once (abs_vars and bndrs), so they
1226 -- all get the same major level. Otherwise we create stupid
1227 -- let-bindings inside, joyfully thinking they can float; but
1228 -- in the end they don't because we never float bindings in
1229 -- between lambdas
1231 {- Note [Floating from a RHS]
1232 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1233 When floating the RHS of a let-binding, we don't always want to apply
1234 lvlMFE to the body of a lambda, as we usually do, because the entire
1235 binding body is already going to the right place (dest_lvl).
1237 A particular example is the top level. Consider
1238 concat = /\ a -> foldr ..a.. (++) []
1239 We don't want to float the body of the lambda to get
1240 lvl = /\ a -> foldr ..a.. (++) []
1241 concat = /\ a -> lvl a
1242 That would be stupid.
1244 Previously this was avoided in a much nastier way, by testing strict_ctxt
1245 in float_me in lvlMFE. But that wasn't even right because it would fail
1246 to float out the error sub-expression in
1247 f = \x. case x of
1248 True -> error ("blah" ++ show x)
1249 False -> ...
1251 But we must be careful:
1254 f = \x -> factorial 20
1255 we /would/ want to float that (factorial 20) out! Functions are treated
1256 differently: see the use of isFunction in the calls to destLevel. If
1257 there are only type lambdas, then destLevel will say "go to top, and
1258 abstract over the free tyvars" and we don't want that here.
1260 * But if we had
1261 f = \x -> error (...x....)
1262 we would NOT want to float the bottoming expression out to give
1263 lvl = \x -> error (...x...)
1264 f = \x -> lvl x
1266 Conclusion: use lvlMFE if there are
1267 * any value lambdas in the original function, and
1268 * this is not a bottoming function (the is_bot argument)
1269 Use lvlExpr otherwise. A little subtle, and I got it wrong at least twice
1270 (e.g. #13369).
1271 -}
1273 {-
1274 ************************************************************************
1275 * *
1276 \subsection{Deciding floatability}
1277 * *
1278 ************************************************************************
1279 -}
1281 substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
1282 substAndLvlBndrs is_rec env lvl bndrs
1283 = lvlBndrs subst_env lvl subst_bndrs
1284 where
1285 (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
1287 substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
1288 -- So named only to avoid the name clash with CoreSubst.substBndrs
1289 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
1290 = ( env { le_subst = subst'
1291 , le_env = foldl' add_id id_env (bndrs zip bndrs') }
1292 , bndrs')
1293 where
1294 (subst', bndrs') = case is_rec of
1295 NonRecursive -> substBndrs subst bndrs
1296 Recursive -> substRecBndrs subst bndrs
1298 lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
1299 -- Compute the levels for the binders of a lambda group
1300 lvlLamBndrs env lvl bndrs
1301 = lvlBndrs env new_lvl bndrs
1302 where
1303 new_lvl | any is_major bndrs = incMajorLvl lvl
1304 | otherwise = incMinorLvl lvl
1306 is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)
1307 -- The "probably" part says "don't float things out of a
1308 -- probable one-shot lambda"
1309 -- See Note [Computing one-shot info] in Demand.hs
1311 lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
1312 -> (LevelEnv, [LevelledBndr])
1313 lvlJoinBndrs env lvl rec bndrs
1314 = lvlBndrs env new_lvl bndrs
1315 where
1316 new_lvl | isRec rec = incMajorLvl lvl
1317 | otherwise = incMinorLvl lvl
1318 -- Non-recursive join points are one-shot; recursive ones are not
1320 lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
1321 -- The binders returned are exactly the same as the ones passed,
1322 -- apart from applying the substitution, but they are now paired
1323 -- with a (StayPut level)
1324 --
1325 -- The returned envt has le_ctxt_lvl updated to the new_lvl
1326 --
1327 -- All the new binders get the same level, because
1328 -- any floating binding is either going to float past
1329 -- all or none. We never separate binders.
1330 lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
1331 = ( env { le_ctxt_lvl = new_lvl
1332 , le_join_ceil = new_lvl
1333 , le_lvl_env = addLvls new_lvl lvl_env bndrs }
1334 , map (stayPut new_lvl) bndrs)
1336 stayPut :: Level -> OutVar -> LevelledBndr
1337 stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
1339 -- Destination level is the max Id level of the expression
1340 -- (We'll abstract the type variables, if any.)
1341 destLevel :: LevelEnv
1342 -> DVarSet -- Free vars of the term
1343 -> TyCoVarSet -- Free in the /type/ of the term
1344 -- (a subset of the previous argument)
1345 -> Bool -- True <=> is function
1346 -> Bool -- True <=> is bottom
1347 -> Bool -- True <=> is a join point
1348 -> Level
1349 -- INVARIANT: if is_join=True then result >= join_ceiling
1350 destLevel env fvs fvs_ty is_function is_bot is_join
1351 | isTopLvl max_fv_id_level -- Float even joins if they get to top level
1352 -- See Note [Floating join point bindings]
1353 = tOP_LEVEL
1355 | is_join -- Never float a join point past the join ceiling
1356 -- See Note [Join points] in FloatOut
1357 = if max_fv_id_level ltLvl join_ceiling
1358 then join_ceiling
1359 else max_fv_id_level
1361 | is_bot -- Send bottoming bindings to the top
1362 = as_far_as_poss -- regardless; see Note [Bottoming floats]
1363 -- Esp Bottoming floats (1)
1365 | Just n_args <- floatLams env
1366 , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case
1367 , is_function
1368 , countFreeIds fvs <= n_args
1369 = as_far_as_poss -- Send functions to top level; see
1370 -- the comments with isFunction
1372 | otherwise = max_fv_id_level
1373 where
1374 join_ceiling = joinCeilingLevel env
1375 max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
1376 -- tyvars will be abstracted
1378 as_far_as_poss = maxFvLevel' isId env fvs_ty
1379 -- See Note [Floating and kind casts]
1381 {- Note [Floating and kind casts]
1382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1383 Consider this
1384 case x of
1385 K (co :: * ~# k) -> let v :: Int |> co
1386 v = e
1387 in blah
1389 Then, even if we are abstracting over Ids, or if e is bottom, we can't
1390 float v outside the 'co' binding. Reason: if we did we'd get
1391 v' :: forall k. (Int ~# Age) => Int |> co
1392 and now 'co' isn't in scope in that type. The underlying reason is
1393 that 'co' is a value-level thing and we can't abstract over that in a
1394 type (else we'd get a dependent type). So if v's /type/ mentions 'co'
1395 we can't float it out beyond the binding site of 'co'.
1397 That's why we have this as_far_as_poss stuff. Usually as_far_as_poss
1398 is just tOP_LEVEL; but occasionally a coercion variable (which is an
1399 Id) mentioned in type prevents this.
1401 Example #14270 comment:15.
1402 -}
1405 isFunction :: CoreExprWithFVs -> Bool
1406 -- The idea here is that we want to float *functions* to
1407 -- the top level. This saves no work, but
1408 -- (a) it can make the host function body a lot smaller,
1409 -- and hence inlinable.
1410 -- (b) it can also save allocation when the function is recursive:
1411 -- h = \x -> letrec f = \y -> ...f...y...x...
1412 -- in f x
1413 -- becomes
1414 -- f = \x y -> ...(f x)...y...x...
1415 -- h = \x -> f x x
1416 -- No allocation for f now.
1417 -- We may only want to do this if there are sufficiently few free
1418 -- variables. We certainly only want to do it for values, and not for
1419 -- constructors. So the simple thing is just to look for lambdas
1420 isFunction (_, AnnLam b e) | isId b = True
1421 | otherwise = isFunction e
1422 -- isFunction (_, AnnTick _ e) = isFunction e -- dubious
1423 isFunction _ = False
1425 countFreeIds :: DVarSet -> Int
1426 countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet
1427 -- It's OK to use nonDetFoldUDFM here because we're just counting things.
1428 where
1429 add :: Var -> Int -> Int
1430 add v n | isId v = n+1
1431 | otherwise = n
1433 {-
1434 ************************************************************************
1435 * *
1437 * *
1438 ************************************************************************
1439 -}
1441 data LevelEnv
1442 = LE { le_switches :: FloatOutSwitches
1443 , le_ctxt_lvl :: Level -- The current level
1444 , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids
1445 , le_join_ceil:: Level -- Highest level to which joins float
1446 -- Invariant: always >= le_ctxt_lvl
1448 -- See Note [le_subst and le_env]
1449 , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids
1450 -- The Id -> CoreExpr in the Subst is ignored
1451 -- (since we want to substitute a LevelledExpr for
1452 -- an Id via le_env) but we do use the Co/TyVar substs
1453 , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids
1454 }
1456 {- Note [le_subst and le_env]
1457 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1458 We clone let- and case-bound variables so that they are still distinct
1459 when floated out; hence the le_subst/le_env. (see point 3 of the
1460 module overview comment). We also use these envs when making a
1461 variable polymorphic because we want to float it out past a big
1462 lambda.
1464 The le_subst and le_env always implement the same mapping,
1465 in_x :-> out_x a b
1466 where out_x is an OutVar, and a,b are its arguments (when
1467 we perform abstraction at the same time as floating).
1469 le_subst maps to CoreExpr
1470 le_env maps to LevelledExpr
1472 Since the range is always a variable or application, there is never
1473 any difference between the two, but sadly the types differ. The
1474 le_subst is used when substituting in a variable's IdInfo; the le_env
1475 when we find a Var.
1477 In addition the le_env records a [OutVar] of variables free in the
1478 OutExpr/LevelledExpr, just so we don't have to call freeVars
1479 repeatedly. This list is always non-empty, and the first element is
1480 out_x
1482 The domain of the both envs is *pre-cloned* Ids, though
1484 The domain of the le_lvl_env is the *post-cloned* Ids
1485 -}
1487 initialEnv :: FloatOutSwitches -> LevelEnv
1488 initialEnv float_lams
1489 = LE { le_switches = float_lams
1490 , le_ctxt_lvl = tOP_LEVEL
1491 , le_join_ceil = panic "initialEnv"
1492 , le_lvl_env = emptyVarEnv
1493 , le_subst = emptySubst
1494 , le_env = emptyVarEnv }
1496 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
1497 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
1499 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
1502 floatLams :: LevelEnv -> Maybe Int
1503 floatLams le = floatOutLambdas (le_switches le)
1505 floatConsts :: LevelEnv -> Bool
1506 floatConsts le = floatOutConstants (le_switches le)
1508 floatOverSat :: LevelEnv -> Bool
1509 floatOverSat le = floatOutOverSatApps (le_switches le)
1511 floatTopLvlOnly :: LevelEnv -> Bool
1512 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
1514 incMinorLvlFrom :: LevelEnv -> Level
1515 incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
1517 -- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
1518 -- See Note [Binder-swap during float-out]
1519 extendCaseBndrEnv :: LevelEnv
1520 -> Id -- Pre-cloned case binder
1521 -> Expr LevelledBndr -- Post-cloned scrutinee
1522 -> LevelEnv
1523 extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
1524 case_bndr (Var scrut_var)
1525 = le { le_subst = extendSubstWithVar subst case_bndr scrut_var
1526 , le_env = add_id id_env (case_bndr, scrut_var) }
1527 extendCaseBndrEnv env _ _ = env
1529 -- See Note [Join ceiling]
1530 placeJoinCeiling :: LevelEnv -> LevelEnv
1531 placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
1532 = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }
1533 where
1534 lvl' = asJoinCeilLvl (incMinorLvl lvl)
1536 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
1537 maxFvLevel max_me env var_set
1538 = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
1540 maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
1541 -- Same but for TyCoVarSet
1542 maxFvLevel' max_me env var_set
1543 = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
1545 maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
1546 maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
1547 = case lookupVarEnv id_env in_var of
1548 Just (abs_vars, _) -> foldr max_out lvl abs_vars
1549 Nothing -> max_out in_var lvl
1550 where
1551 max_out out_var lvl
1552 | max_me out_var = case lookupVarEnv lvl_env out_var of
1553 Just lvl' -> maxLvl lvl' lvl
1554 Nothing -> lvl
1555 | otherwise = lvl -- Ignore some vars depending on max_me
1557 lookupVar :: LevelEnv -> Id -> LevelledExpr
1558 lookupVar le v = case lookupVarEnv (le_env le) v of
1559 Just (_, expr) -> expr
1560 _ -> Var v
1562 -- Level to which join points are allowed to float (boundary of current tail
1563 -- context). See Note [Join ceiling]
1564 joinCeilingLevel :: LevelEnv -> Level
1565 joinCeilingLevel = le_join_ceil
1567 abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
1568 -- Find the variables in fvs, free vars of the target expression,
1569 -- whose level is greater than the destination level
1570 -- These are the ones we are going to abstract out
1571 --
1572 -- Note that to get reproducible builds, the variables need to be
1573 -- abstracted in deterministic order, not dependent on the values of
1574 -- Uniques. This is achieved by using DVarSets, deterministic free
1575 -- variable computation and deterministic sort.
1576 -- See Note [Unique Determinism] in Unique for explanation of why
1577 -- Uniques are not deterministic.
1578 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
1579 = -- NB: sortQuantVars might not put duplicates next to each other
1580 map zap $sortQuantVars$
1581 filter abstract_me $1582 dVarSetElems$
1583 closeOverKindsDSet $1584 substDVarSet subst in_fvs 1585 -- NB: it's important to call abstract_me only on the OutIds the 1586 -- come from substDVarSet (not on fv, which is an InId) 1587 where 1588 abstract_me v = case lookupVarEnv lvl_env v of 1589 Just lvl -> dest_lvl ltLvl lvl 1590 Nothing -> False 1592 -- We are going to lambda-abstract, so nuke any IdInfo, 1593 -- and add the tyvars of the Id (if necessary) 1594 zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || 1595 not (isEmptyRuleInfo (idSpecialisation v)), 1596 text "absVarsOf: discarding info on" <+> ppr v ) 1597 setIdInfo v vanillaIdInfo 1598 | otherwise = v 1600 type LvlM result = UniqSM result 1602 initLvl :: UniqSupply -> UniqSM a -> a 1603 initLvl = initUs_ 1605 newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] 1606 -> LvlM (LevelEnv, [OutId]) 1607 -- The envt is extended to bind the new bndrs to dest_lvl, but 1608 -- the le_ctxt_lvl is unaffected 1609 newPolyBndrs dest_lvl 1610 env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) 1611 abs_vars bndrs 1612 = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. 1613 do { uniqs <- getUniquesM 1614 ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs 1615 bndr_prs = bndrs zip new_bndrs 1616 env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs 1617 , le_subst = foldl' add_subst subst bndr_prs 1618 , le_env = foldl' add_id id_env bndr_prs } 1619 ; return (env', new_bndrs) } 1620 where 1621 add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) 1622 add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) 1624 mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars$ -- Note [transferPolyIdInfo] in Id.hs
1625 transfer_join_info bndr \$
1626 mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
1627 where
1628 str = "poly_" ++ occNameString (getOccName bndr)
1629 poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))
1631 -- If we are floating a join point to top level, it stops being
1632 -- a join point. Otherwise it continues to be a join point,
1633 -- but we may need to adjust its arity
1634 dest_is_top = isTopLvl dest_lvl
1635 transfer_join_info bndr new_bndr
1636 | Just join_arity <- isJoinId_maybe bndr
1637 , not dest_is_top
1638 = new_bndr asJoinId join_arity + length abs_vars
1639 | otherwise
1640 = new_bndr
1642 newLvlVar :: LevelledExpr -- The RHS of the new binding
1643 -> Maybe JoinArity -- Its join arity, if it is a join point
1644 -> Bool -- True <=> the RHS looks like (makeStatic ...)
1645 -> LvlM Id
1646 newLvlVar lvld_rhs join_arity_maybe is_mk_static
1647 = do { uniq <- getUniqueM
1648 ; return (add_join_info (mk_id uniq rhs_ty))
1649 }
1650 where
1651 add_join_info var = var asJoinId_maybe join_arity_maybe
1652 de_tagged_rhs = deTagExpr lvld_rhs
1653 rhs_ty = exprType de_tagged_rhs
1655 mk_id uniq rhs_ty
1656 -- See Note [Grand plan for static forms] in StaticPtrTable.
1657 | is_mk_static
1658 = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
1659 rhs_ty
1660 | otherwise
1661 = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
1663 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
1664 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1665 new_lvl vs
1666 = do { us <- getUniqueSupplyM
1667 ; let (subst', vs') = cloneBndrs subst us vs
1668 env' = env { le_ctxt_lvl = new_lvl
1669 , le_join_ceil = new_lvl
1670 , le_lvl_env = addLvls new_lvl lvl_env vs'
1671 , le_subst = subst'
1672 , le_env = foldl' add_id id_env (vs zip vs') }
1674 ; return (env', vs') }
1676 cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
1677 -> LvlM (LevelEnv, [OutVar])
1678 -- See Note [Need for cloning during float-out]
1679 -- Works for Ids bound by let(rec)
1680 -- The dest_lvl is attributed to the binders in the new env,
1681 -- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env
1682 cloneLetVars is_rec
1683 env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
1684 dest_lvl vs
1685 = do { us <- getUniqueSupplyM
1686 ; let vs1 = map zap vs
1687 -- See Note [Zapping the demand info]
1688 (subst', vs2) = case is_rec of
1689 NonRecursive -> cloneBndrs subst us vs1
1690 Recursive -> cloneRecIdBndrs subst us vs1
1691 prs = vs zip vs2
1692 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
1693 , le_subst = subst'
1694 , le_env = foldl' add_id id_env prs }
1696 ; return (env', vs2) }
1697 where
1698 zap :: Var -> Var
1699 zap v | isId v = zap_join (zapIdDemandInfo v)
1700 | otherwise = v
1702 zap_join | isTopLvl dest_lvl = zapJoinId
1703 | otherwise = id
1705 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1707 | isTyVar v = delVarEnv id_env v
1708 | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
1710 {-
1711 Note [Zapping the demand info]
1712 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1713 VERY IMPORTANT: we must zap the demand info if the thing is going to
1714 float out, because it may be less demanded than at its original
1715 binding site. Eg
1716 f :: Int -> Int
1717 f x = let v = 3*4 in v+x
1718 Here v is strict; but if we float v to top level, it isn't any more.
1720 Similarly, if we're floating a join point, it won't be one anymore, so we zap
1721 join point information as well.
1722 -}