Prepare source-tree for base-4.13 MFP bump
[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, MultiWayIf #-}
53 module SetLevels (
54 setLevels,
55
56 Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
57 LevelledBind, LevelledExpr, LevelledBndr,
58 FloatSpec(..), floatSpecLevel,
59
60 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
61 ) where
62
63 #include "HsVersions.h"
64
65 import GhcPrelude
66
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 )
79
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 )
103
104 {-
105 ************************************************************************
106 * *
107 \subsection{Level numbers}
108 * *
109 ************************************************************************
110 -}
111
112 type LevelledExpr = TaggedExpr FloatSpec
113 type LevelledBind = TaggedBind FloatSpec
114 type LevelledBndr = TaggedBndr FloatSpec
115
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)
122
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
128
129 floatSpecLevel :: FloatSpec -> Level
130 floatSpecLevel (FloatMe l) = l
131 floatSpecLevel (StayPut l) = l
132
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.
137
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.
141
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}
149
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.
155
156 If you can float to level @Level 0 0@ worth doing so because then your
157 allocation becomes static instead of dynamic. We always start with
158 context @Level 0 0@.
159
160
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.
167
168 But, check this out:
169
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.
179
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.)
182
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.
187
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:
192
193 f x = (joinrec j y = ... x ... in jump j x) + 1
194
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.
198
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 -}
207
208 instance Outputable FloatSpec where
209 ppr (FloatMe l) = char 'F' <> ppr l
210 ppr (StayPut l) = ppr l
211
212 tOP_LEVEL :: Level
213 tOP_LEVEL = Level 0 0 BndrLvl
214
215 incMajorLvl :: Level -> Level
216 incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
217
218 incMinorLvl :: Level -> Level
219 incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
220
221 asJoinCeilLvl :: Level -> Level
222 asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
223
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
228
229 ltLvl :: Level -> Level -> Bool
230 ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
231 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
232
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
236
237 isTopLvl :: Level -> Bool
238 isTopLvl (Level 0 0 _) = True
239 isTopLvl _ = False
240
241 isJoinCeilLvl :: Level -> Bool
242 isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
243
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') ]
248
249 instance Eq Level where
250 (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
251
252 {-
253 ************************************************************************
254 * *
255 \subsection{Main level-setting code}
256 * *
257 ************************************************************************
258 -}
259
260 setLevels :: FloatOutSwitches
261 -> CoreProgram
262 -> UniqSupply
263 -> [LevelledBind]
264
265 setLevels float_lams binds us
266 = initLvl us (do_them init_env binds)
267 where
268 init_env = initialEnv float_lams
269
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) }
276
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') }
282
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') }
288
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)
295
296 {-
297 ************************************************************************
298 * *
299 \subsection{Setting expression levels}
300 * *
301 ************************************************************************
302
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"
307
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.
312
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 -}
317
318 lvlExpr :: LevelEnv -- Context
319 -> CoreExprWithFVs -- Input expression
320 -> LvlM LevelledExpr -- Result expression
321
322 {-
323 The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
324 binder. Here's an example
325
326 v = \x -> ...\y -> let r = case (..x..) of
327 ..x..
328 in ..
329
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.
335
336 If there were another lambda in @r@'s rhs, it would get level-2 as well.
337 -}
338
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)
343
344 lvlExpr env (_, AnnCast expr (_, co)) = do
345 expr' <- lvlNonTailExpr env expr
346 return (Cast expr' (substCo (le_subst env) co))
347
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')
352
353 lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
354
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.
361
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.]
375
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') }
383
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 }
387
388 lvlNonTailExpr :: LevelEnv -- Context
389 -> CoreExprWithFVs -- Input expression
390 -> LvlM LevelledExpr -- Result expression
391 lvlNonTailExpr env expr
392 = lvlExpr (placeJoinCeiling env) expr
393
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') }
407
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
416
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
423
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 []
428
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"
434
435 is_val_arg :: CoreExprWithFVs -> Bool
436 is_val_arg (_, AnnType {}) = False
437 is_val_arg _ = True
438
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') }
447
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') }
454
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']) }
475
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
483
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
487
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
493
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
502
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
509
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.
513
514 Things to note:
515
516 * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
517
518 - exrpIsHNF catches the key case of an evaluated variable
519
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!
523
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
527
528 * We can't float a case to top level
529
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.
535
536 * We only do this with a single-alternative case
537
538 Note [Check the output scrutinee for exprIsHNF]
539 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
540 Consider this:
541 case x of y {
542 A -> ....(case y of alts)....
543 }
544
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 Trac #5453.
552
553 That's why we apply exprIsHNF to scrut' and not to scrut.
554
555 See Note [Floating single-alternative cases] for why
556 we use exprIsHNF in the first place.
557 -}
558
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
566
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.
573
574 lvlMFE env _ (_, AnnType ty)
575 = return (Type (CoreSubst.substTy (le_subst env) ty))
576
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') }
585
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)) }
589
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]
593
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
606
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)) }
619
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])]
636
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) }
644
645 | otherwise -- e.g. do not float unboxed tuples
646 = lvlExpr env ann_expr
647
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
661
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
669
670 (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
671
672 join_arity_maybe = Nothing
673
674 is_mk_static = isJust (collectMakeStaticArgs expr)
675 -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable
676
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
680
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
685
686 escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
687 -- See Note [Escaping a value lambda]
688
689 -- See Note [Floating to the top]
690 saves_alloc = isTopLvl dest_lvl
691 && floatConsts env
692 && (not strict_ctxt || is_bot || exprIsHNF expr)
693
694 isBottomThunk :: Maybe (Arity, s) -> Bool
695 -- See Note [Bottoming floats] (2)
696 isBottomThunk (Just (0, _)) = True -- Zero arity
697 isBottomThunk _ = False
698
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:
703
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.
707
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.
711
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
716
717 Exammples:
718
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.
725
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.
731
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.
736
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
742
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!
749
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.]
754
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 (Trac #13286).
759 Consider
760 f x = joinrec j y n = <...j y' n'...>
761 in jump j x 0
762
763 Here we may just as well produce
764 j y n = <....j y' n'...>
765 f x = j x 0
766
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.
773
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.
784
785 But consider
786 join j x = .... in
787 joinrec j2 y = ...(jump j x)...(a+b)....
788
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.
794
795 Even if we floated 'j' to top level, (b) would still hold.
796
797 Bottom line: never float a MFE that has a free JoinId.
798
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
809
810 Being able to float unboxed expressions is sometimes important; see
811 Trac #12603. I'm not sure how /often/ it is important, but it's
812 not hard to achieve.
813
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.
818
819 I did experiment with a form of boxing that works for any type, namely
820 wrapping in a function. In our example
821
822 let y = case f x of r -> \v. f x
823 in case y void of r -> blah
824
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.
828
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!
843
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.)
851
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.
855
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
863
864 But, as ever, we need to be careful:
865
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
873
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.)
882
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 ...
890
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.
894
895 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
896 of functional programs" (unpublished I think).
897
898 When we do this, we set the strictness and arity of the new bottoming
899 Id, *immediately*, for three reasons:
900
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!
904
905 * So that it's properly exposed as such in the interface file, even if
906 this is all happening after strictness analysis.
907
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.
914
915 This was reported in Trac #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.
918
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.
925
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.
933
934 We will make a separate decision for the scrutinee and alternatives.
935
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.
944
945 -}
946
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)
957
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)!
969
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
985
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
993
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.
1000
1001 Ditto literal strings (LitString), which we'd like to float to top
1002 level, which is now possible.
1003
1004
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.
1013
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.
1022
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.
1031
1032
1033 ************************************************************************
1034 * *
1035 \subsection{Bindings}
1036 * *
1037 ************************************************************************
1038
1039 The binding stuff works for top level too.
1040 -}
1041
1042 lvlBind :: LevelEnv
1043 -> CoreBindWithFVs
1044 -> LvlM (LevelledBind, LevelEnv)
1045
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
1056
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') }
1062
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') }
1071
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') }
1079
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
1087
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)
1092
1093 n_extra = count isId abs_vars
1094 mb_join_arity = isJoinId_maybe bndr
1095 is_join = isJust mb_join_arity
1096
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') }
1106
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) }
1112
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
1129
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)
1144
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) }
1150
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!
1160
1161 do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
1162 is_bot (get_join bndr)
1163 rhs
1164
1165 get_join bndr | need_zap = Nothing
1166 | otherwise = isJoinId_maybe bndr
1167 need_zap = dest_lvl `ltLvl` joinCeilingLevel env
1168
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
1176
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
1180
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
1185
1186
1187 ----------------------------------------------------
1188 -- Three help functions for the type-abstraction case
1189
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
1199
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
1230
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).
1236
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.
1243
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 -> ...
1250
1251 But we must be careful:
1252
1253 * If we had
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.
1259
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
1265
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. Trac #13369).
1271 -}
1272
1273 {-
1274 ************************************************************************
1275 * *
1276 \subsection{Deciding floatability}
1277 * *
1278 ************************************************************************
1279 -}
1280
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
1286
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
1297
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
1305
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
1310
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
1319
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)
1335
1336 stayPut :: Level -> OutVar -> LevelledBndr
1337 stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
1338
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
1354
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
1360
1361 | is_bot -- Send bottoming bindings to the top
1362 = as_far_as_poss -- regardless; see Note [Bottoming floats]
1363 -- Esp Bottoming floats (1)
1364
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
1371
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
1377
1378 as_far_as_poss = maxFvLevel' isId env fvs_ty
1379 -- See Note [Floating and kind casts]
1380
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
1388
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'.
1396
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.
1400
1401 Example Trac #14270 comment:15.
1402 -}
1403
1404
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
1424
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
1432
1433 {-
1434 ************************************************************************
1435 * *
1436 \subsection{Free-To-Level Monad}
1437 * *
1438 ************************************************************************
1439 -}
1440
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
1447
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 }
1455
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.
1463
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).
1468
1469 le_subst maps to CoreExpr
1470 le_env maps to LevelledExpr
1471
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.
1476
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
1481
1482 The domain of the both envs is *pre-cloned* Ids, though
1483
1484 The domain of the le_lvl_env is the *post-cloned* Ids
1485 -}
1486
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 }
1495
1496 addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
1497 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
1498
1499 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
1500 addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
1501
1502 floatLams :: LevelEnv -> Maybe Int
1503 floatLams le = floatOutLambdas (le_switches le)
1504
1505 floatConsts :: LevelEnv -> Bool
1506 floatConsts le = floatOutConstants (le_switches le)
1507
1508 floatOverSat :: LevelEnv -> Bool
1509 floatOverSat le = floatOutOverSatApps (le_switches le)
1510
1511 floatTopLvlOnly :: LevelEnv -> Bool
1512 floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
1513
1514 incMinorLvlFrom :: LevelEnv -> Level
1515 incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
1516
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
1528
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)
1535
1536 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
1537 maxFvLevel max_me env var_set
1538 = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
1539
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
1544
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
1556
1557 lookupVar :: LevelEnv -> Id -> LevelledExpr
1558 lookupVar le v = case lookupVarEnv (le_env le) v of
1559 Just (_, expr) -> expr
1560 _ -> Var v
1561
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
1566
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
1591
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
1599
1600 type LvlM result = UniqSM result
1601
1602 initLvl :: UniqSupply -> UniqSM a -> a
1603 initLvl = initUs_
1604
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)
1623
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))
1630
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
1641
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
1654
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
1662
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') }
1673
1674 ; return (env', vs') }
1675
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 }
1695
1696 ; return (env', vs2) }
1697 where
1698 zap :: Var -> Var
1699 zap v | isId v = zap_join (zapIdDemandInfo v)
1700 | otherwise = v
1701
1702 zap_join | isTopLvl dest_lvl = zapJoinId
1703 | otherwise = id
1704
1705 add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
1706 add_id id_env (v, v1)
1707 | isTyVar v = delVarEnv id_env v
1708 | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
1709
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.
1719
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 -}