never executed always true always false
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
5 -}
6
7
8
9 module GHC.Core.Opt.Simplify.Env (
10 -- * The simplifier mode
11 setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,
12
13 -- * Environments
14 SimplEnv(..), pprSimplEnv, -- Temp not abstract
15 mkSimplEnv, extendIdSubst,
16 extendTvSubst, extendCvSubst,
17 zapSubstEnv, setSubstEnv, bumpCaseDepth,
18 getInScope, setInScopeFromE, setInScopeFromF,
19 setInScopeSet, modifyInScope, addNewInScopeIds,
20 getSimplRules,
21
22 -- * Substitution results
23 SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
24
25 -- * Simplifying 'Id' binders
26 simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
27 simplBinder, simplBinders,
28 substTy, substTyVar, getTCvSubst,
29 substCo, substCoVar,
30
31 -- * Floats
32 SimplFloats(..), emptyFloats, mkRecFloats,
33 mkFloatBind, addLetFloats, addJoinFloats, addFloats,
34 extendFloats, wrapFloats,
35 doFloatFromRhs, getTopFloatBinds,
36
37 -- * LetFloats
38 LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
39 addLetFlts, mapLetFloats,
40
41 -- * JoinFloats
42 JoinFloat, JoinFloats, emptyJoinFloats,
43 wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
44 ) where
45
46 import GHC.Prelude
47
48 import GHC.Core.Opt.Simplify.Monad
49 import GHC.Core.Opt.Monad ( SimplMode(..) )
50 import GHC.Core
51 import GHC.Core.Utils
52 import GHC.Core.Multiplicity ( scaleScaled )
53 import GHC.Core.Unfold
54 import GHC.Types.Var
55 import GHC.Types.Var.Env
56 import GHC.Types.Var.Set
57 import GHC.Data.OrdList
58 import GHC.Types.Id as Id
59 import GHC.Core.Make ( mkWildValBinder )
60 import GHC.Driver.Session ( DynFlags )
61 import GHC.Builtin.Types
62 import GHC.Core.TyCo.Rep ( TyCoBinder(..) )
63 import qualified GHC.Core.Type as Type
64 import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst )
65 import qualified GHC.Core.Coercion as Coercion
66 import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
67 import GHC.Types.Basic
68 import GHC.Utils.Monad
69 import GHC.Utils.Outputable
70 import GHC.Utils.Panic
71 import GHC.Utils.Panic.Plain
72 import GHC.Utils.Misc
73 import GHC.Utils.Logger
74 import GHC.Types.Unique.FM ( pprUniqFM )
75
76 import Data.List (mapAccumL)
77
78 {-
79 ************************************************************************
80 * *
81 \subsubsection{The @SimplEnv@ type}
82 * *
83 ************************************************************************
84 -}
85
86 data SimplEnv
87 = SimplEnv {
88 ----------- Static part of the environment -----------
89 -- Static in the sense of lexically scoped,
90 -- wrt the original expression
91
92 seMode :: !SimplMode
93
94 -- The current substitution
95 , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType
96 , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion
97 , seIdSubst :: SimplIdSubst -- InId |--> OutExpr
98
99 ----------- Dynamic part of the environment -----------
100 -- Dynamic in the sense of describing the setup where
101 -- the expression finally ends up
102
103 -- The current set of in-scope variables
104 -- They are all OutVars, and all bound in this module
105 , seInScope :: !InScopeSet -- OutVars only
106
107 , seCaseDepth :: !Int -- Depth of multi-branch case alternatives
108 }
109
110 data SimplFloats
111 = SimplFloats
112 { -- Ordinary let bindings
113 sfLetFloats :: LetFloats
114 -- See Note [LetFloats]
115
116 -- Join points
117 , sfJoinFloats :: JoinFloats
118 -- Handled separately; they don't go very far
119 -- We consider these to be /inside/ sfLetFloats
120 -- because join points can refer to ordinary bindings,
121 -- but not vice versa
122
123 -- Includes all variables bound by sfLetFloats and
124 -- sfJoinFloats, plus at least whatever is in scope where
125 -- these bindings land up.
126 , sfInScope :: InScopeSet -- All OutVars
127 }
128
129 instance Outputable SimplFloats where
130 ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
131 = text "SimplFloats"
132 <+> braces (vcat [ text "lets: " <+> ppr lf
133 , text "joins:" <+> ppr jf
134 , text "in_scope:" <+> ppr is ])
135
136 emptyFloats :: SimplEnv -> SimplFloats
137 emptyFloats env
138 = SimplFloats { sfLetFloats = emptyLetFloats
139 , sfJoinFloats = emptyJoinFloats
140 , sfInScope = seInScope env }
141
142 pprSimplEnv :: SimplEnv -> SDoc
143 -- Used for debugging; selective
144 pprSimplEnv env
145 = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
146 text "CvSubst:" <+> ppr (seCvSubst env),
147 text "IdSubst:" <+> id_subst_doc,
148 text "InScope:" <+> in_scope_vars_doc
149 ]
150 where
151 id_subst_doc = pprUniqFM ppr (seIdSubst env)
152 in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
153 (vcat . map ppr_one)
154 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
155 | otherwise = ppr v
156
157 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
158 -- See Note [Extending the Subst] in GHC.Core.Subst
159
160 -- | A substitution result.
161 data SimplSR
162 = DoneEx OutExpr (Maybe JoinArity)
163 -- If x :-> DoneEx e ja is in the SimplIdSubst
164 -- then replace occurrences of x by e
165 -- and ja = Just a <=> x is a join-point of arity a
166 -- See Note [Join arity in SimplIdSubst]
167
168
169 | DoneId OutId
170 -- If x :-> DoneId v is in the SimplIdSubst
171 -- then replace occurrences of x by v
172 -- and v is a join-point of arity a
173 -- <=> x is a join-point of arity a
174
175 | ContEx TvSubstEnv -- A suspended substitution
176 CvSubstEnv
177 SimplIdSubst
178 InExpr
179 -- If x :-> ContEx tv cv id e is in the SimplISubst
180 -- then replace occurrences of x by (subst (tv,cv,id) e)
181
182 instance Outputable SimplSR where
183 ppr (DoneId v) = text "DoneId" <+> ppr v
184 ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
185 where
186 pp_mj = case mj of
187 Nothing -> empty
188 Just n -> parens (int n)
189
190 ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
191 ppr (filter_env tv), ppr (filter_env id) -}]
192 -- where
193 -- fvs = exprFreeVars e
194 -- filter_env env = filterVarEnv_Directly keep env
195 -- keep uniq _ = uniq `elemUFM_Directly` fvs
196
197 {-
198 Note [SimplEnv invariants]
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~
200 seInScope:
201 The in-scope part of Subst includes *all* in-scope TyVars and Ids
202 The elements of the set may have better IdInfo than the
203 occurrences of in-scope Ids, and (more important) they will
204 have a correctly-substituted type. So we use a lookup in this
205 set to replace occurrences
206
207 The Ids in the InScopeSet are replete with their Rules,
208 and as we gather info about the unfolding of an Id, we replace
209 it in the in-scope set.
210
211 The in-scope set is actually a mapping OutVar -> OutVar, and
212 in case expressions we sometimes bind
213
214 seIdSubst:
215 The substitution is *apply-once* only, because InIds and OutIds
216 can overlap.
217 For example, we generally omit mappings
218 a77 -> a77
219 from the substitution, when we decide not to clone a77, but it's quite
220 legitimate to put the mapping in the substitution anyway.
221
222 Furthermore, consider
223 let x = case k of I# x77 -> ... in
224 let y = case k of I# x77 -> ... in ...
225 and suppose the body is strict in both x and y. Then the simplifier
226 will pull the first (case k) to the top; so the second (case k) will
227 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
228 other is an out-Id.
229
230 Of course, the substitution *must* applied! Things in its domain
231 simply aren't necessarily bound in the result.
232
233 * substId adds a binding (DoneId new_id) to the substitution if
234 the Id's unique has changed
235
236 Note, though that the substitution isn't necessarily extended
237 if the type of the Id changes. Why not? Because of the next point:
238
239 * We *always, always* finish by looking up in the in-scope set
240 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
241 Reason: so that we never finish up with a "old" Id in the result.
242 An old Id might point to an old unfolding and so on... which gives a space
243 leak.
244
245 [The DoneEx and DoneVar hits map to "new" stuff.]
246
247 * It follows that substExpr must not do a no-op if the substitution is empty.
248 substType is free to do so, however.
249
250 * When we come to a let-binding (say) we generate new IdInfo, including an
251 unfolding, attach it to the binder, and add this newly adorned binder to
252 the in-scope set. So all subsequent occurrences of the binder will get
253 mapped to the full-adorned binder, which is also the one put in the
254 binding site.
255
256 * The in-scope "set" usually maps x->x; we use it simply for its domain.
257 But sometimes we have two in-scope Ids that are synomyms, and should
258 map to the same target: x->x, y->x. Notably:
259 case y of x { ... }
260 That's why the "set" is actually a VarEnv Var
261
262 Note [Join arity in SimplIdSubst]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 We have to remember which incoming variables are join points: the occurrences
265 may not be marked correctly yet, and we're in change of propagating the change if
266 OccurAnal makes something a join point).
267
268 Normally the in-scope set is where we keep the latest information, but
269 the in-scope set tracks only OutVars; if a binding is unconditionally
270 inlined (via DoneEx), it never makes it into the in-scope set, and we
271 need to know at the occurrence site that the variable is a join point
272 so that we know to drop the context. Thus we remember which join
273 points we're substituting. -}
274
275 mkSimplEnv :: SimplMode -> SimplEnv
276 mkSimplEnv mode
277 = SimplEnv { seMode = mode
278 , seInScope = init_in_scope
279 , seTvSubst = emptyVarEnv
280 , seCvSubst = emptyVarEnv
281 , seIdSubst = emptyVarEnv
282 , seCaseDepth = 0 }
283 -- The top level "enclosing CC" is "SUBSUMED".
284
285 init_in_scope :: InScopeSet
286 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy))
287 -- See Note [WildCard binders]
288
289 {-
290 Note [WildCard binders]
291 ~~~~~~~~~~~~~~~~~~~~~~~
292 The program to be simplified may have wild binders
293 case e of wild { p -> ... }
294 We want to *rename* them away, so that there are no
295 occurrences of 'wild-id' (with wildCardKey). The easy
296 way to do that is to start of with a representative
297 Id in the in-scope set
298
299 There can be *occurrences* of wild-id. For example,
300 GHC.Core.Make.mkCoreApp transforms
301 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
302 This is ok provided 'wild' isn't free in 'e', and that's the delicate
303 thing. Generally, you want to run the simplifier to get rid of the
304 wild-ids before doing much else.
305
306 It's a very dark corner of GHC. Maybe it should be cleaned up.
307 -}
308
309 getMode :: SimplEnv -> SimplMode
310 getMode env = seMode env
311
312 seDynFlags :: SimplEnv -> DynFlags
313 seDynFlags env = sm_dflags (seMode env)
314
315 seLogger :: SimplEnv -> Logger
316 seLogger env = sm_logger (seMode env)
317
318
319 seUnfoldingOpts :: SimplEnv -> UnfoldingOpts
320 seUnfoldingOpts env = sm_uf_opts (seMode env)
321
322
323 setMode :: SimplMode -> SimplEnv -> SimplEnv
324 setMode mode env = env { seMode = mode }
325
326 updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
327 updMode upd env
328 = -- Avoid keeping env alive in case inlining fails.
329 let mode = upd $! (seMode env)
330 in env { seMode = mode }
331
332 bumpCaseDepth :: SimplEnv -> SimplEnv
333 bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }
334
335 ---------------------
336 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
337 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
338 = assertPpr (isId var && not (isCoVar var)) (ppr var) $
339 env { seIdSubst = extendVarEnv subst var res }
340
341 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
342 extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
343 = assertPpr (isTyVar var) (ppr var $$ ppr res) $
344 env {seTvSubst = extendVarEnv tsubst var res}
345
346 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
347 extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
348 = assert (isCoVar var) $
349 env {seCvSubst = extendVarEnv csubst var co}
350
351 ---------------------
352 getInScope :: SimplEnv -> InScopeSet
353 getInScope env = seInScope env
354
355 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
356 setInScopeSet env in_scope = env {seInScope = in_scope}
357
358 setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
359 -- See Note [Setting the right in-scope set]
360 setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }
361
362 setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
363 setInScopeFromF env floats = env { seInScope = sfInScope floats }
364
365 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
366 -- The new Ids are guaranteed to be freshly allocated
367 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
368 -- See Note [Bangs in the Simplifier]
369 = let !in_scope1 = in_scope `extendInScopeSetList` vs
370 !id_subst1 = id_subst `delVarEnvList` vs
371 in
372 env { seInScope = in_scope1,
373 seIdSubst = id_subst1 }
374 -- Why delete? Consider
375 -- let x = a*b in (x, \x -> x+3)
376 -- We add [x |-> a*b] to the substitution, but we must
377 -- _delete_ it from the substitution when going inside
378 -- the (\x -> ...)!
379
380 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
381 -- The variable should already be in scope, but
382 -- replace the existing version with this new one
383 -- which has more information
384 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
385 = env {seInScope = extendInScopeSet in_scope v}
386
387 {- Note [Setting the right in-scope set]
388 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 Consider
390 \x. (let x = e in b) arg[x]
391 where the let shadows the lambda. Really this means something like
392 \x1. (let x2 = e in b) arg[x1]
393
394 - When we capture the 'arg' in an ApplyToVal continuation, we capture
395 the environment, which says what 'x' is bound to, namely x1
396
397 - Then that continuation gets pushed under the let
398
399 - Finally we simplify 'arg'. We want
400 - the static, lexical environment binding x :-> x1
401 - the in-scopeset from "here", under the 'let' which includes
402 both x1 and x2
403
404 It's important to have the right in-scope set, else we may rename a
405 variable to one that is already in scope. So we must pick up the
406 in-scope set from "here", but otherwise use the environment we
407 captured along with 'arg'. This transfer of in-scope set is done by
408 setInScopeFromE.
409 -}
410
411 ---------------------
412 zapSubstEnv :: SimplEnv -> SimplEnv
413 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
414
415 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
416 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
417
418 mkContEx :: SimplEnv -> InExpr -> SimplSR
419 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
420
421 {-
422 ************************************************************************
423 * *
424 \subsection{LetFloats}
425 * *
426 ************************************************************************
427
428 Note [LetFloats]
429 ~~~~~~~~~~~~~~~~
430 The LetFloats is a bunch of bindings, classified by a FloatFlag.
431
432 * All of them satisfy the let/app invariant
433
434 Examples
435
436 NonRec x (y:ys) FltLifted
437 Rec [(x,rhs)] FltLifted
438
439 NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted?
440 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
441
442 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
443
444 Can't happen:
445 NonRec x# (a /# b) -- Might fail; does not satisfy let/app
446 NonRec x# (f y) -- Might diverge; does not satisfy let/app
447 -}
448
449 data LetFloats = LetFloats (OrdList OutBind) FloatFlag
450 -- See Note [LetFloats]
451
452 type JoinFloat = OutBind
453 type JoinFloats = OrdList JoinFloat
454
455 data FloatFlag
456 = FltLifted -- All bindings are lifted and lazy *or*
457 -- consist of a single primitive string literal
458 -- Hence ok to float to top level, or recursive
459
460 | FltOkSpec -- All bindings are FltLifted *or*
461 -- strict (perhaps because unlifted,
462 -- perhaps because of a strict binder),
463 -- *and* ok-for-speculation
464 -- Hence ok to float out of the RHS
465 -- of a lazy non-recursive let binding
466 -- (but not to top level, or into a rec group)
467
468 | FltCareful -- At least one binding is strict (or unlifted)
469 -- and not guaranteed cheap
470 -- Do not float these bindings out of a lazy let
471
472 instance Outputable LetFloats where
473 ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)
474
475 instance Outputable FloatFlag where
476 ppr FltLifted = text "FltLifted"
477 ppr FltOkSpec = text "FltOkSpec"
478 ppr FltCareful = text "FltCareful"
479
480 andFF :: FloatFlag -> FloatFlag -> FloatFlag
481 andFF FltCareful _ = FltCareful
482 andFF FltOkSpec FltCareful = FltCareful
483 andFF FltOkSpec _ = FltOkSpec
484 andFF FltLifted flt = flt
485
486 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
487 -- If you change this function look also at FloatIn.noFloatFromRhs
488 doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
489 = not (isNilOL fs) && want_to_float && can_float
490 where
491 want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
492 -- See Note [Float when cheap or expandable]
493 can_float = case ff of
494 FltLifted -> True
495 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
496 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
497
498 {-
499 Note [Float when cheap or expandable]
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 We want to float a let from a let if the residual RHS is
502 a) cheap, such as (\x. blah)
503 b) expandable, such as (f b) if f is CONLIKE
504 But there are
505 - cheap things that are not expandable (eg \x. expensive)
506 - expandable things that are not cheap (eg (f b) where b is CONLIKE)
507 so we must take the 'or' of the two.
508 -}
509
510 emptyLetFloats :: LetFloats
511 emptyLetFloats = LetFloats nilOL FltLifted
512
513 emptyJoinFloats :: JoinFloats
514 emptyJoinFloats = nilOL
515
516 unitLetFloat :: OutBind -> LetFloats
517 -- This key function constructs a singleton float with the right form
518 unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $
519 LetFloats (unitOL bind) (flag bind)
520 where
521 flag (Rec {}) = FltLifted
522 flag (NonRec bndr rhs)
523 | not (isStrictId bndr) = FltLifted
524 | exprIsTickedString rhs = FltLifted
525 -- String literals can be floated freely.
526 -- See Note [Core top-level string literals] in GHC.Core.
527 | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
528 | otherwise = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)
529 FltCareful
530 -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
531
532 unitJoinFloat :: OutBind -> JoinFloats
533 unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $
534 unitOL bind
535
536 mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
537 -- Make a singleton SimplFloats, and
538 -- extend the incoming SimplEnv's in-scope set with its binders
539 -- These binders may already be in the in-scope set,
540 -- but may have by now been augmented with more IdInfo
541 mkFloatBind env bind
542 = (floats, env { seInScope = in_scope' })
543 where
544 floats
545 | isJoinBind bind
546 = SimplFloats { sfLetFloats = emptyLetFloats
547 , sfJoinFloats = unitJoinFloat bind
548 , sfInScope = in_scope' }
549 | otherwise
550 = SimplFloats { sfLetFloats = unitLetFloat bind
551 , sfJoinFloats = emptyJoinFloats
552 , sfInScope = in_scope' }
553 -- See Note [Bangs in the Simplifier]
554 !in_scope' = seInScope env `extendInScopeSetBind` bind
555
556 extendFloats :: SimplFloats -> OutBind -> SimplFloats
557 -- Add this binding to the floats, and extend the in-scope env too
558 extendFloats (SimplFloats { sfLetFloats = floats
559 , sfJoinFloats = jfloats
560 , sfInScope = in_scope })
561 bind
562 | isJoinBind bind
563 = SimplFloats { sfInScope = in_scope'
564 , sfLetFloats = floats
565 , sfJoinFloats = jfloats' }
566 | otherwise
567 = SimplFloats { sfInScope = in_scope'
568 , sfLetFloats = floats'
569 , sfJoinFloats = jfloats }
570 where
571 in_scope' = in_scope `extendInScopeSetBind` bind
572 floats' = floats `addLetFlts` unitLetFloat bind
573 jfloats' = jfloats `addJoinFlts` unitJoinFloat bind
574
575 addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
576 -- Add the let-floats for env2 to env1;
577 -- *plus* the in-scope set for env2, which is bigger
578 -- than that for env1
579 addLetFloats floats let_floats
580 = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
581 , sfInScope = sfInScope floats `extendInScopeFromLF` let_floats }
582
583 extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet
584 extendInScopeFromLF in_scope (LetFloats binds _)
585 = foldlOL extendInScopeSetBind in_scope binds
586
587 addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
588 addJoinFloats floats join_floats
589 = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats
590 , sfInScope = foldlOL extendInScopeSetBind
591 (sfInScope floats) join_floats }
592
593 extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
594 extendInScopeSetBind in_scope bind
595 = extendInScopeSetList in_scope (bindersOf bind)
596
597 addFloats :: SimplFloats -> SimplFloats -> SimplFloats
598 -- Add both let-floats and join-floats for env2 to env1;
599 -- *plus* the in-scope set for env2, which is bigger
600 -- than that for env1
601 addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
602 (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })
603 = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2
604 , sfJoinFloats = jf1 `addJoinFlts` jf2
605 , sfInScope = in_scope }
606
607 addLetFlts :: LetFloats -> LetFloats -> LetFloats
608 addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
609 = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
610
611 letFloatBinds :: LetFloats -> [CoreBind]
612 letFloatBinds (LetFloats bs _) = fromOL bs
613
614 addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
615 addJoinFlts = appOL
616
617 mkRecFloats :: SimplFloats -> SimplFloats
618 -- Flattens the floats into a single Rec group,
619 -- They must either all be lifted LetFloats or all JoinFloats
620 mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
621 , sfJoinFloats = jbs
622 , sfInScope = in_scope })
623 = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $
624 SimplFloats { sfLetFloats = floats'
625 , sfJoinFloats = jfloats'
626 , sfInScope = in_scope }
627 where
628 -- See Note [Bangs in the Simplifier]
629 !floats' | isNilOL bs = emptyLetFloats
630 | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))
631 !jfloats' | isNilOL jbs = emptyJoinFloats
632 | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
633
634 wrapFloats :: SimplFloats -> OutExpr -> OutExpr
635 -- Wrap the floats around the expression; they should all
636 -- satisfy the let/app invariant, so mkLets should do the job just fine
637 wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _
638 , sfJoinFloats = jbs }) body
639 = foldrOL Let (wrapJoinFloats jbs body) bs
640 -- Note: Always safe to put the joins on the inside
641 -- since the values can't refer to them
642
643 wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
644 -- Wrap the sfJoinFloats of the env around the expression,
645 -- and take them out of the SimplEnv
646 wrapJoinFloatsX floats body
647 = ( floats { sfJoinFloats = emptyJoinFloats }
648 , wrapJoinFloats (sfJoinFloats floats) body )
649
650 wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
651 -- Wrap the sfJoinFloats of the env around the expression,
652 -- and take them out of the SimplEnv
653 wrapJoinFloats join_floats body
654 = foldrOL Let body join_floats
655
656 getTopFloatBinds :: SimplFloats -> [CoreBind]
657 getTopFloatBinds (SimplFloats { sfLetFloats = lbs
658 , sfJoinFloats = jbs})
659 = assert (isNilOL jbs) $ -- Can't be any top-level join bindings
660 letFloatBinds lbs
661
662 {-# INLINE mapLetFloats #-}
663 mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
664 mapLetFloats (LetFloats fs ff) fun
665 = LetFloats fs1 ff
666 where
667 app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
668 app (Rec bs) = Rec (strictMap fun bs)
669 !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]
670
671 {-
672 ************************************************************************
673 * *
674 Substitution of Vars
675 * *
676 ************************************************************************
677
678 Note [Global Ids in the substitution]
679 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
680 We look up even a global (eg imported) Id in the substitution. Consider
681 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
682 The binder-swap in the occurrence analyser will add a binding
683 for a LocalId version of g (with the same unique though):
684 case X.g_34 of b { (a,b) -> let g_34 = b in
685 ... case X.g_34 of { (p,q) -> ...} ... }
686 So we want to look up the inner X.g_34 in the substitution, where we'll
687 find that it has been substituted by b. (Or conceivably cloned.)
688 -}
689
690 substId :: SimplEnv -> InId -> SimplSR
691 -- Returns DoneEx only on a non-Var expression
692 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
693 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
694 Nothing -> DoneId (refineFromInScope in_scope v)
695 Just (DoneId v) -> DoneId (refineFromInScope in_scope v)
696 Just res -> res -- DoneEx non-var, or ContEx
697
698 -- Get the most up-to-date thing from the in-scope set
699 -- Even though it isn't in the substitution, it may be in
700 -- the in-scope set with better IdInfo.
701 --
702 -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify.
703
704 refineFromInScope :: InScopeSet -> Var -> Var
705 refineFromInScope in_scope v
706 | isLocalId v = case lookupInScope in_scope v of
707 Just v' -> v'
708 Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)
709 -- c.f #19074 for a subtle place where this went wrong
710 | otherwise = v
711
712 lookupRecBndr :: SimplEnv -> InId -> OutId
713 -- Look up an Id which has been put into the envt by simplRecBndrs,
714 -- but where we have not yet done its RHS
715 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
716 = case lookupVarEnv ids v of
717 Just (DoneId v) -> v
718 Just _ -> pprPanic "lookupRecBndr" (ppr v)
719 Nothing -> refineFromInScope in_scope v
720
721 {-
722 ************************************************************************
723 * *
724 \section{Substituting an Id binder}
725 * *
726 ************************************************************************
727
728
729 These functions are in the monad only so that they can be made strict via seq.
730
731 Note [Return type for join points]
732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733 Consider
734
735 (join j :: Char -> Int -> Int) 77
736 ( j x = \y. y + ord x )
737 (in case v of )
738 ( A -> j 'x' )
739 ( B -> j 'y' )
740 ( C -> <blah> )
741
742 The simplifier pushes the "apply to 77" continuation inwards to give
743
744 join j :: Char -> Int
745 j x = (\y. y + ord x) 77
746 in case v of
747 A -> j 'x'
748 B -> j 'y'
749 C -> <blah> 77
750
751 Notice that the "apply to 77" continuation went into the RHS of the
752 join point. And that meant that the return type of the join point
753 changed!!
754
755 That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr
756 takes a (Just res_ty) argument so that it knows to do the type-changing
757 thing.
758
759 See also Note [Scaling join point arguments].
760 -}
761
762 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
763 simplBinders !env bndrs = mapAccumLM simplBinder env bndrs
764
765 -------------
766 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
767 -- Used for lambda and case-bound variables
768 -- Clone Id if necessary, substitute type
769 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
770 -- The substitution is extended only if the variable is cloned, because
771 -- we *don't* need to use it to track occurrence info.
772 simplBinder !env bndr
773 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
774 ; seqTyVar tv `seq` return (env', tv) }
775 | otherwise = do { let (env', id) = substIdBndr env bndr
776 ; seqId id `seq` return (env', id) }
777
778 ---------------
779 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
780 -- A non-recursive let binder
781 simplNonRecBndr !env id
782 -- See Note [Bangs in the Simplifier]
783 = do { let (!env1, id1) = substIdBndr env id
784 ; seqId id1 `seq` return (env1, id1) }
785
786 ---------------
787 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
788 -- Recursive let binders
789 simplRecBndrs env@(SimplEnv {}) ids
790 -- See Note [Bangs in the Simplifier]
791 = assert (all (not . isJoinId) ids) $
792 do { let (!env1, ids1) = mapAccumL substIdBndr env ids
793 ; seqIds ids1 `seq` return env1 }
794
795
796 ---------------
797 substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
798 -- Might be a coercion variable
799 substIdBndr env bndr
800 | isCoVar bndr = substCoVarBndr env bndr
801 | otherwise = substNonCoVarIdBndr env bndr
802
803 ---------------
804 substNonCoVarIdBndr
805 :: SimplEnv
806 -> InBndr -- Env and binder to transform
807 -> (SimplEnv, OutBndr)
808 -- Clone Id if necessary, substitute its type
809 -- Return an Id with its
810 -- * Type substituted
811 -- * UnfoldingInfo, Rules, WorkerInfo zapped
812 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
813 -- * Robust info, retained especially arity and demand info,
814 -- so that they are available to occurrences that occur in an
815 -- earlier binding of a letrec
816 --
817 -- For the robust info, see Note [Arity robustness]
818 --
819 -- Augment the substitution if the unique changed
820 -- Extend the in-scope set with the new Id
821 --
822 -- Similar to GHC.Core.Subst.substIdBndr, except that
823 -- the type of id_subst differs
824 -- all fragile info is zapped
825 substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)
826
827 -- Inline to make the (OutId -> OutId) function a known call.
828 -- This is especially important for `substNonCoVarIdBndr` which
829 -- passes an identity lambda.
830 {-# INLINE subst_id_bndr #-}
831 subst_id_bndr :: SimplEnv
832 -> InBndr -- Env and binder to transform
833 -> (OutId -> OutId) -- Adjust the type
834 -> (SimplEnv, OutBndr)
835 subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
836 old_id adjust_type
837 = assertPpr (not (isCoVar old_id)) (ppr old_id)
838 (env { seInScope = new_in_scope,
839 seIdSubst = new_subst }, new_id)
840 -- It's important that both seInScope and seIdSubst are updated with
841 -- the new_id, /after/ applying adjust_type. That's why adjust_type
842 -- is done here. If we did adjust_type in simplJoinBndr (the only
843 -- place that gives a non-identity adjust_type) we'd have to fiddle
844 -- afresh with both seInScope and seIdSubst
845 where
846 -- See Note [Bangs in the Simplifier]
847 !id1 = uniqAway in_scope old_id
848 !id2 = substIdType env id1
849 !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
850 -- and fragile OccInfo
851 !new_id = adjust_type id3
852
853 -- Extend the substitution if the unique has changed,
854 -- or there's some useful occurrence information
855 -- See the notes with substTyVarBndr for the delSubstEnv
856 !new_subst | new_id /= old_id
857 = extendVarEnv id_subst old_id (DoneId new_id)
858 | otherwise
859 = delVarEnv id_subst old_id
860
861 !new_in_scope = in_scope `extendInScopeSet` new_id
862
863 ------------------------------------
864 seqTyVar :: TyVar -> ()
865 seqTyVar b = b `seq` ()
866
867 seqId :: Id -> ()
868 seqId id = seqType (idType id) `seq`
869 idInfo id `seq`
870 ()
871
872 seqIds :: [Id] -> ()
873 seqIds [] = ()
874 seqIds (id:ids) = seqId id `seq` seqIds ids
875
876 {-
877 Note [Arity robustness]
878 ~~~~~~~~~~~~~~~~~~~~~~~
879 We *do* transfer the arity from the in_id of a let binding to the
880 out_id. This is important, so that the arity of an Id is visible in
881 its own RHS. For example:
882 f = \x. ....g (\y. f y)....
883 We can eta-reduce the arg to g, because f is a value. But that
884 needs to be visible.
885
886 This interacts with the 'state hack' too:
887 f :: Bool -> IO Int
888 f = \x. case x of
889 True -> f y
890 False -> \s -> ...
891 Can we eta-expand f? Only if we see that f has arity 1, and then we
892 take advantage of the 'state hack' on the result of
893 (f y) :: State# -> (State#, Int) to expand the arity one more.
894
895 There is a disadvantage though. Making the arity visible in the RHS
896 allows us to eta-reduce
897 f = \x -> f x
898 to
899 f = f
900 which technically is not sound. This is very much a corner case, so
901 I'm not worried about it. Another idea is to ensure that f's arity
902 never decreases; its arity started as 1, and we should never eta-reduce
903 below that.
904
905
906 Note [Robust OccInfo]
907 ~~~~~~~~~~~~~~~~~~~~~
908 It's important that we *do* retain the loop-breaker OccInfo, because
909 that's what stops the Id getting inlined infinitely, in the body of
910 the letrec.
911 -}
912
913
914 {- *********************************************************************
915 * *
916 Join points
917 * *
918 ********************************************************************* -}
919
920 simplNonRecJoinBndr :: SimplEnv -> InBndr
921 -> Mult -> OutType
922 -> SimplM (SimplEnv, OutBndr)
923
924 -- A non-recursive let binder for a join point;
925 -- context being pushed inward may change the type
926 -- See Note [Return type for join points]
927 simplNonRecJoinBndr env id mult res_ty
928 = do { let (env1, id1) = simplJoinBndr mult res_ty env id
929 ; seqId id1 `seq` return (env1, id1) }
930
931 simplRecJoinBndrs :: SimplEnv -> [InBndr]
932 -> Mult -> OutType
933 -> SimplM SimplEnv
934 -- Recursive let binders for join points;
935 -- context being pushed inward may change types
936 -- See Note [Return type for join points]
937 simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty
938 = assert (all isJoinId ids) $
939 do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids
940 ; seqIds ids1 `seq` return env1 }
941
942 ---------------
943 simplJoinBndr :: Mult -> OutType
944 -> SimplEnv -> InBndr
945 -> (SimplEnv, OutBndr)
946 simplJoinBndr mult res_ty env id
947 = subst_id_bndr env id (adjustJoinPointType mult res_ty)
948
949 ---------------
950 adjustJoinPointType :: Mult
951 -> Type -- New result type
952 -> Id -- Old join-point Id
953 -> Id -- Adjusted jont-point Id
954 -- (adjustJoinPointType mult new_res_ty join_id) does two things:
955 --
956 -- 1. Set the return type of the join_id to new_res_ty
957 -- See Note [Return type for join points]
958 --
959 -- 2. Adjust the multiplicity of arrows in join_id's type, as
960 -- directed by 'mult'. See Note [Scaling join point arguments]
961 --
962 -- INVARIANT: If any of the first n binders are foralls, those tyvars
963 -- cannot appear in the original result type. See isValidJoinPointType.
964 adjustJoinPointType mult new_res_ty join_id
965 = assert (isJoinId join_id) $
966 setIdType join_id new_join_ty
967 where
968 orig_ar = idJoinArity join_id
969 orig_ty = idType join_id
970
971 new_join_ty = go orig_ar orig_ty :: Type
972
973 go 0 _ = new_res_ty
974 go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
975 = mkPiTy (scale_bndr arg_bndr) $
976 go (n-1) res_ty
977 | otherwise
978 = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)
979
980 -- See Note [Bangs in the Simplifier]
981 scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)
982 scale_bndr b@(Named _) = b
983
984 {- Note [Scaling join point arguments]
985 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
986 Consider a join point which is linear in its variable, in some context E:
987
988 E[join j :: a %1 -> a
989 j x = x
990 in case v of
991 A -> j 'x'
992 B -> <blah>]
993
994 The simplifier changes to:
995
996 join j :: a %1 -> a
997 j x = E[x]
998 in case v of
999 A -> j 'x'
1000 B -> E[<blah>]
1001
1002 If E uses its argument in a nonlinear way (e.g. a case['Many]), then
1003 this is wrong: the join point has to change its type to a -> a.
1004 Otherwise, we'd get a linearity error.
1005
1006 See also Note [Return type for join points] and Note [Join points and case-of-case].
1007 -}
1008
1009 {-
1010 ************************************************************************
1011 * *
1012 Impedance matching to type substitution
1013 * *
1014 ************************************************************************
1015 -}
1016
1017 getTCvSubst :: SimplEnv -> TCvSubst
1018 getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
1019 , seCvSubst = cv_env })
1020 = mkTCvSubst in_scope (tv_env, cv_env)
1021
1022 substTy :: SimplEnv -> Type -> Type
1023 substTy env ty = Type.substTy (getTCvSubst env) ty
1024
1025 substTyVar :: SimplEnv -> TyVar -> Type
1026 substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
1027
1028 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
1029 substTyVarBndr env tv
1030 = case Type.substTyVarBndr (getTCvSubst env) tv of
1031 (TCvSubst in_scope' tv_env' cv_env', tv')
1032 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
1033
1034 substCoVar :: SimplEnv -> CoVar -> Coercion
1035 substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
1036
1037 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
1038 substCoVarBndr env cv
1039 = case Coercion.substCoVarBndr (getTCvSubst env) cv of
1040 (TCvSubst in_scope' tv_env' cv_env', cv')
1041 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
1042
1043 substCo :: SimplEnv -> Coercion -> Coercion
1044 substCo env co = Coercion.substCo (getTCvSubst env) co
1045
1046 ------------------
1047 substIdType :: SimplEnv -> Id -> Id
1048 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
1049 | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
1050 || no_free_vars
1051 = id
1052 | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id
1053 -- The tyCoVarsOfType is cheaper than it looks
1054 -- because we cache the free tyvars of the type
1055 -- in a Note in the id's type itself
1056 where
1057 no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w
1058 subst = TCvSubst in_scope tv_env cv_env
1059 old_ty = idType id
1060 old_w = varMult id