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