Filter out BuiltinRules in occurrence analysis
[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 InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
11 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
12 InCoercion, OutCoercion,
13
14 -- The simplifier mode
15 setMode, getMode, updMode,
16
17 -- Environments
18 SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
19 mkSimplEnv, extendIdSubst, SimplEnv.extendTCvSubst,
20 zapSubstEnv, setSubstEnv,
21 getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
22 getSimplRules,
23
24 SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
25
26 simplNonRecBndr, simplRecBndrs,
27 simplBinder, simplBinders,
28 substTy, substTyVar, getTCvSubst,
29 substCo, substCoVar,
30
31 -- Floats
32 Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
33 wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
34 doFloatFromRhs, getFloatBinds
35 ) where
36
37 #include "HsVersions.h"
38
39 import SimplMonad
40 import CoreMonad ( SimplifierMode(..) )
41 import CoreSyn
42 import CoreUtils
43 import Var
44 import VarEnv
45 import VarSet
46 import OrdList
47 import Id
48 import MkCore ( mkWildValBinder )
49 import TysWiredIn
50 import qualified Type
51 import Type hiding ( substTy, substTyVar, substTyVarBndr )
52 import qualified Coercion
53 import Coercion hiding ( substCo, substCoVar, substCoVarBndr )
54 import BasicTypes
55 import MonadUtils
56 import Outputable
57 import Util
58
59 import Data.List
60
61 {-
62 ************************************************************************
63 * *
64 \subsection[Simplify-types]{Type declarations}
65 * *
66 ************************************************************************
67 -}
68
69 type InBndr = CoreBndr
70 type InVar = Var -- Not yet cloned
71 type InId = Id -- Not yet cloned
72 type InType = Type -- Ditto
73 type InBind = CoreBind
74 type InExpr = CoreExpr
75 type InAlt = CoreAlt
76 type InArg = CoreArg
77 type InCoercion = Coercion
78
79 type OutBndr = CoreBndr
80 type OutVar = Var -- Cloned
81 type OutId = Id -- Cloned
82 type OutTyVar = TyVar -- Cloned
83 type OutType = Type -- Cloned
84 type OutCoercion = Coercion
85 type OutBind = CoreBind
86 type OutExpr = CoreExpr
87 type OutAlt = CoreAlt
88 type OutArg = CoreArg
89
90 {-
91 ************************************************************************
92 * *
93 \subsubsection{The @SimplEnv@ type}
94 * *
95 ************************************************************************
96 -}
97
98 data SimplEnv
99 = SimplEnv {
100 ----------- Static part of the environment -----------
101 -- Static in the sense of lexically scoped,
102 -- wrt the original expression
103
104 seMode :: SimplifierMode,
105
106 -- The current substitution
107 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
108 seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion
109 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
110
111 ----------- Dynamic part of the environment -----------
112 -- Dynamic in the sense of describing the setup where
113 -- the expression finally ends up
114
115 -- The current set of in-scope variables
116 -- They are all OutVars, and all bound in this module
117 seInScope :: InScopeSet, -- OutVars only
118 -- Includes all variables bound by seFloats
119 seFloats :: Floats
120 -- See Note [Simplifier floats]
121 }
122
123 type StaticEnv = SimplEnv -- Just the static part is relevant
124
125 pprSimplEnv :: SimplEnv -> SDoc
126 -- Used for debugging; selective
127 pprSimplEnv env
128 = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
129 text "CvSubst:" <+> ppr (seCvSubst env),
130 text "IdSubst:" <+> ppr (seIdSubst env),
131 text "InScope:" <+> vcat (map ppr_one in_scope_vars)
132 ]
133 where
134 in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
135 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
136 | otherwise = ppr v
137
138 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
139 -- See Note [Extending the Subst] in CoreSubst
140
141 data SimplSR
142 = DoneEx OutExpr -- Completed term
143 | DoneId OutId -- Completed term variable
144 | ContEx TvSubstEnv -- A suspended substitution
145 CvSubstEnv
146 SimplIdSubst
147 InExpr
148
149 instance Outputable SimplSR where
150 ppr (DoneEx e) = text "DoneEx" <+> ppr e
151 ppr (DoneId v) = text "DoneId" <+> ppr v
152 ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
153 ppr (filter_env tv), ppr (filter_env id) -}]
154 -- where
155 -- fvs = exprFreeVars e
156 -- filter_env env = filterVarEnv_Directly keep env
157 -- keep uniq _ = uniq `elemUFM_Directly` fvs
158
159 {-
160 Note [SimplEnv invariants]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~
162 seInScope:
163 The in-scope part of Subst includes *all* in-scope TyVars and Ids
164 The elements of the set may have better IdInfo than the
165 occurrences of in-scope Ids, and (more important) they will
166 have a correctly-substituted type. So we use a lookup in this
167 set to replace occurrences
168
169 The Ids in the InScopeSet are replete with their Rules,
170 and as we gather info about the unfolding of an Id, we replace
171 it in the in-scope set.
172
173 The in-scope set is actually a mapping OutVar -> OutVar, and
174 in case expressions we sometimes bind
175
176 seIdSubst:
177 The substitution is *apply-once* only, because InIds and OutIds
178 can overlap.
179 For example, we generally omit mappings
180 a77 -> a77
181 from the substitution, when we decide not to clone a77, but it's quite
182 legitimate to put the mapping in the substitution anyway.
183
184 Furthermore, consider
185 let x = case k of I# x77 -> ... in
186 let y = case k of I# x77 -> ... in ...
187 and suppose the body is strict in both x and y. Then the simplifier
188 will pull the first (case k) to the top; so the second (case k) will
189 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
190 other is an out-Id.
191
192 Of course, the substitution *must* applied! Things in its domain
193 simply aren't necessarily bound in the result.
194
195 * substId adds a binding (DoneId new_id) to the substitution if
196 the Id's unique has changed
197
198 Note, though that the substitution isn't necessarily extended
199 if the type of the Id changes. Why not? Because of the next point:
200
201 * We *always, always* finish by looking up in the in-scope set
202 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
203 Reason: so that we never finish up with a "old" Id in the result.
204 An old Id might point to an old unfolding and so on... which gives a space
205 leak.
206
207 [The DoneEx and DoneVar hits map to "new" stuff.]
208
209 * It follows that substExpr must not do a no-op if the substitution is empty.
210 substType is free to do so, however.
211
212 * When we come to a let-binding (say) we generate new IdInfo, including an
213 unfolding, attach it to the binder, and add this newly adorned binder to
214 the in-scope set. So all subsequent occurrences of the binder will get
215 mapped to the full-adorned binder, which is also the one put in the
216 binding site.
217
218 * The in-scope "set" usually maps x->x; we use it simply for its domain.
219 But sometimes we have two in-scope Ids that are synomyms, and should
220 map to the same target: x->x, y->x. Notably:
221 case y of x { ... }
222 That's why the "set" is actually a VarEnv Var
223 -}
224
225 mkSimplEnv :: SimplifierMode -> SimplEnv
226 mkSimplEnv mode
227 = SimplEnv { seMode = mode
228 , seInScope = init_in_scope
229 , seFloats = emptyFloats
230 , seTvSubst = emptyVarEnv
231 , seCvSubst = emptyVarEnv
232 , seIdSubst = emptyVarEnv }
233 -- The top level "enclosing CC" is "SUBSUMED".
234
235 init_in_scope :: InScopeSet
236 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
237 -- See Note [WildCard binders]
238
239 {-
240 Note [WildCard binders]
241 ~~~~~~~~~~~~~~~~~~~~~~~
242 The program to be simplified may have wild binders
243 case e of wild { p -> ... }
244 We want to *rename* them away, so that there are no
245 occurrences of 'wild-id' (with wildCardKey). The easy
246 way to do that is to start of with a representative
247 Id in the in-scope set
248
249 There can be be *occurrences* of wild-id. For example,
250 MkCore.mkCoreApp transforms
251 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
252 This is ok provided 'wild' isn't free in 'e', and that's the delicate
253 thing. Generally, you want to run the simplifier to get rid of the
254 wild-ids before doing much else.
255
256 It's a very dark corner of GHC. Maybe it should be cleaned up.
257 -}
258
259 getMode :: SimplEnv -> SimplifierMode
260 getMode env = seMode env
261
262 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
263 setMode mode env = env { seMode = mode }
264
265 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
266 updMode upd env = env { seMode = upd (seMode env) }
267
268 ---------------------
269 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
270 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
271 = ASSERT2( isId var && not (isCoVar var), ppr var )
272 env {seIdSubst = extendVarEnv subst var res}
273
274 extendTCvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
275 extendTCvSubst env@(SimplEnv {seTvSubst = tsubst, seCvSubst = csubst}) var res
276 | isTyVar var
277 = env {seTvSubst = extendVarEnv tsubst var res}
278 | Just co <- isCoercionTy_maybe res
279 = env {seCvSubst = extendVarEnv csubst var co}
280 | otherwise
281 = pprPanic "SimplEnv.extendTCvSubst" (ppr res)
282
283 ---------------------
284 getInScope :: SimplEnv -> InScopeSet
285 getInScope env = seInScope env
286
287 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
288 setInScopeSet env in_scope = env {seInScope = in_scope}
289
290 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
291 -- Set the in-scope set, and *zap* the floats
292 setInScope env env_with_scope
293 = env { seInScope = seInScope env_with_scope,
294 seFloats = emptyFloats }
295
296 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
297 -- Set the in-scope set *and* the floats
298 setFloats env env_with_floats
299 = env { seInScope = seInScope env_with_floats,
300 seFloats = seFloats env_with_floats }
301
302 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
303 -- The new Ids are guaranteed to be freshly allocated
304 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
305 = env { seInScope = in_scope `extendInScopeSetList` vs,
306 seIdSubst = id_subst `delVarEnvList` vs }
307 -- Why delete? Consider
308 -- let x = a*b in (x, \x -> x+3)
309 -- We add [x |-> a*b] to the substitution, but we must
310 -- _delete_ it from the substitution when going inside
311 -- the (\x -> ...)!
312
313 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
314 -- The variable should already be in scope, but
315 -- replace the existing version with this new one
316 -- which has more information
317 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
318 = env {seInScope = extendInScopeSet in_scope v}
319
320 ---------------------
321 zapSubstEnv :: SimplEnv -> SimplEnv
322 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
323
324 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
325 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
326
327 mkContEx :: SimplEnv -> InExpr -> SimplSR
328 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
329
330 {-
331 ************************************************************************
332 * *
333 \subsection{Floats}
334 * *
335 ************************************************************************
336
337 Note [Simplifier floats]
338 ~~~~~~~~~~~~~~~~~~~~~~~~~
339 The Floats is a bunch of bindings, classified by a FloatFlag.
340
341 * All of them satisfy the let/app invariant
342
343 Examples
344
345 NonRec x (y:ys) FltLifted
346 Rec [(x,rhs)] FltLifted
347
348 NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted?
349 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
350
351 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
352
353 Can't happen:
354 NonRec x# (a /# b) -- Might fail; does not satisfy let/app
355 NonRec x# (f y) -- Might diverge; does not satisfy let/app
356 -}
357
358 data Floats = Floats (OrdList OutBind) FloatFlag
359 -- See Note [Simplifier floats]
360
361 data FloatFlag
362 = FltLifted -- All bindings are lifted and lazy
363 -- Hence ok to float to top level, or recursive
364
365 | FltOkSpec -- All bindings are FltLifted *or*
366 -- strict (perhaps because unlifted,
367 -- perhaps because of a strict binder),
368 -- *and* ok-for-speculation
369 -- Hence ok to float out of the RHS
370 -- of a lazy non-recursive let binding
371 -- (but not to top level, or into a rec group)
372
373 | FltCareful -- At least one binding is strict (or unlifted)
374 -- and not guaranteed cheap
375 -- Do not float these bindings out of a lazy let
376
377 instance Outputable Floats where
378 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
379
380 instance Outputable FloatFlag where
381 ppr FltLifted = text "FltLifted"
382 ppr FltOkSpec = text "FltOkSpec"
383 ppr FltCareful = text "FltCareful"
384
385 andFF :: FloatFlag -> FloatFlag -> FloatFlag
386 andFF FltCareful _ = FltCareful
387 andFF FltOkSpec FltCareful = FltCareful
388 andFF FltOkSpec _ = FltOkSpec
389 andFF FltLifted flt = flt
390
391 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
392 -- If you change this function look also at FloatIn.noFloatFromRhs
393 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
394 = not (isNilOL fs) && want_to_float && can_float
395 where
396 want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
397 -- See Note [Float when cheap or expandable]
398 can_float = case ff of
399 FltLifted -> True
400 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
401 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
402
403 {-
404 Note [Float when cheap or expandable]
405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
406 We want to float a let from a let if the residual RHS is
407 a) cheap, such as (\x. blah)
408 b) expandable, such as (f b) if f is CONLIKE
409 But there are
410 - cheap things that are not expandable (eg \x. expensive)
411 - expandable things that are not cheap (eg (f b) where b is CONLIKE)
412 so we must take the 'or' of the two.
413 -}
414
415 emptyFloats :: Floats
416 emptyFloats = Floats nilOL FltLifted
417
418 unitFloat :: OutBind -> Floats
419 -- This key function constructs a singleton float with the right form
420 unitFloat bind = Floats (unitOL bind) (flag bind)
421 where
422 flag (Rec {}) = FltLifted
423 flag (NonRec bndr rhs)
424 | not (isStrictId bndr) = FltLifted
425 | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
426 | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
427 FltCareful
428 -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
429
430 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
431 -- Add a non-recursive binding and extend the in-scope set
432 -- The latter is important; the binder may already be in the
433 -- in-scope set (although it might also have been created with newId)
434 -- but it may now have more IdInfo
435 addNonRec env id rhs
436 = id `seq` -- This seq forces the Id, and hence its IdInfo,
437 -- and hence any inner substitutions
438 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
439 seInScope = extendInScopeSet (seInScope env) id }
440
441 extendFloats :: SimplEnv -> OutBind -> SimplEnv
442 -- Add these bindings to the floats, and extend the in-scope env too
443 extendFloats env bind
444 = env { seFloats = seFloats env `addFlts` unitFloat bind,
445 seInScope = extendInScopeSetList (seInScope env) bndrs }
446 where
447 bndrs = bindersOf bind
448
449 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
450 -- Add the floats for env2 to env1;
451 -- *plus* the in-scope set for env2, which is bigger
452 -- than that for env1
453 addFloats env1 env2
454 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
455 seInScope = seInScope env2 }
456
457 addFlts :: Floats -> Floats -> Floats
458 addFlts (Floats bs1 l1) (Floats bs2 l2)
459 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
460
461 zapFloats :: SimplEnv -> SimplEnv
462 zapFloats env = env { seFloats = emptyFloats }
463
464 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
465 -- Flattens the floats from env2 into a single Rec group,
466 -- prepends the floats from env1, and puts the result back in env2
467 -- This is all very specific to the way recursive bindings are
468 -- handled; see Simplify.simplRecBind
469 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
470 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
471 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
472
473 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
474 -- Wrap the floats around the expression; they should all
475 -- satisfy the let/app invariant, so mkLets should do the job just fine
476 wrapFloats (SimplEnv {seFloats = Floats bs _}) body
477 = foldrOL Let body bs
478
479 getFloatBinds :: SimplEnv -> [CoreBind]
480 getFloatBinds (SimplEnv {seFloats = Floats bs _})
481 = fromOL bs
482
483 isEmptyFloats :: SimplEnv -> Bool
484 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
485 = isNilOL bs
486
487 mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
488 mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
489 = env { seFloats = Floats (mapOL app fs) ff }
490 where
491 app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
492 app (Rec bs) = Rec (map fun bs)
493
494 {-
495 ************************************************************************
496 * *
497 Substitution of Vars
498 * *
499 ************************************************************************
500
501 Note [Global Ids in the substitution]
502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
503 We look up even a global (eg imported) Id in the substitution. Consider
504 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
505 The binder-swap in the occurrence analyser will add a binding
506 for a LocalId version of g (with the same unique though):
507 case X.g_34 of b { (a,b) -> let g_34 = b in
508 ... case X.g_34 of { (p,q) -> ...} ... }
509 So we want to look up the inner X.g_34 in the substitution, where we'll
510 find that it has been substituted by b. (Or conceivably cloned.)
511 -}
512
513 substId :: SimplEnv -> InId -> SimplSR
514 -- Returns DoneEx only on a non-Var expression
515 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
516 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
517 Nothing -> DoneId (refineFromInScope in_scope v)
518 Just (DoneId v) -> DoneId (refineFromInScope in_scope v)
519 Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
520 Just res -> res -- DoneEx non-var, or ContEx
521
522 -- Get the most up-to-date thing from the in-scope set
523 -- Even though it isn't in the substitution, it may be in
524 -- the in-scope set with better IdInfo
525 refineFromInScope :: InScopeSet -> Var -> Var
526 refineFromInScope in_scope v
527 | isLocalId v = case lookupInScope in_scope v of
528 Just v' -> v'
529 Nothing -> WARN( True, ppr v ) v -- This is an error!
530 | otherwise = v
531
532 lookupRecBndr :: SimplEnv -> InId -> OutId
533 -- Look up an Id which has been put into the envt by simplRecBndrs,
534 -- but where we have not yet done its RHS
535 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
536 = case lookupVarEnv ids v of
537 Just (DoneId v) -> v
538 Just _ -> pprPanic "lookupRecBndr" (ppr v)
539 Nothing -> refineFromInScope in_scope v
540
541 {-
542 ************************************************************************
543 * *
544 \section{Substituting an Id binder}
545 * *
546 ************************************************************************
547
548
549 These functions are in the monad only so that they can be made strict via seq.
550 -}
551
552 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
553 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
554
555 -------------
556 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
557 -- Used for lambda and case-bound variables
558 -- Clone Id if necessary, substitute type
559 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
560 -- The substitution is extended only if the variable is cloned, because
561 -- we *don't* need to use it to track occurrence info.
562 simplBinder env bndr
563 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
564 ; seqTyVar tv `seq` return (env', tv) }
565 | otherwise = do { let (env', id) = substIdBndr env bndr
566 ; seqId id `seq` return (env', id) }
567
568 ---------------
569 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
570 -- A non-recursive let binder
571 simplNonRecBndr env id
572 = do { let (env1, id1) = substIdBndr env id
573 ; seqId id1 `seq` return (env1, id1) }
574
575 ---------------
576 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
577 -- Recursive let binders
578 simplRecBndrs env@(SimplEnv {}) ids
579 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
580 ; seqIds ids1 `seq` return env1 }
581
582 ---------------
583 substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
584 -- Might be a coercion variable
585 substIdBndr env bndr
586 | isCoVar bndr = substCoVarBndr env bndr
587 | otherwise = substNonCoVarIdBndr env bndr
588
589 ---------------
590 substNonCoVarIdBndr
591 :: SimplEnv
592 -> InBndr -- Env and binder to transform
593 -> (SimplEnv, OutBndr)
594 -- Clone Id if necessary, substitute its type
595 -- Return an Id with its
596 -- * Type substituted
597 -- * UnfoldingInfo, Rules, WorkerInfo zapped
598 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
599 -- * Robust info, retained especially arity and demand info,
600 -- so that they are available to occurrences that occur in an
601 -- earlier binding of a letrec
602 --
603 -- For the robust info, see Note [Arity robustness]
604 --
605 -- Augment the substitution if the unique changed
606 -- Extend the in-scope set with the new Id
607 --
608 -- Similar to CoreSubst.substIdBndr, except that
609 -- the type of id_subst differs
610 -- all fragile info is zapped
611 substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
612 old_id
613 = ASSERT2( not (isCoVar old_id), ppr old_id )
614 (env { seInScope = in_scope `extendInScopeSet` new_id,
615 seIdSubst = new_subst }, new_id)
616 where
617 id1 = uniqAway in_scope old_id
618 id2 = substIdType env id1
619 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
620 -- and fragile OccInfo
621
622 -- Extend the substitution if the unique has changed,
623 -- or there's some useful occurrence information
624 -- See the notes with substTyVarBndr for the delSubstEnv
625 new_subst | new_id /= old_id
626 = extendVarEnv id_subst old_id (DoneId new_id)
627 | otherwise
628 = delVarEnv id_subst old_id
629
630 ------------------------------------
631 seqTyVar :: TyVar -> ()
632 seqTyVar b = b `seq` ()
633
634 seqId :: Id -> ()
635 seqId id = seqType (idType id) `seq`
636 idInfo id `seq`
637 ()
638
639 seqIds :: [Id] -> ()
640 seqIds [] = ()
641 seqIds (id:ids) = seqId id `seq` seqIds ids
642
643 {-
644 Note [Arity robustness]
645 ~~~~~~~~~~~~~~~~~~~~~~~
646 We *do* transfer the arity from from the in_id of a let binding to the
647 out_id. This is important, so that the arity of an Id is visible in
648 its own RHS. For example:
649 f = \x. ....g (\y. f y)....
650 We can eta-reduce the arg to g, because f is a value. But that
651 needs to be visible.
652
653 This interacts with the 'state hack' too:
654 f :: Bool -> IO Int
655 f = \x. case x of
656 True -> f y
657 False -> \s -> ...
658 Can we eta-expand f? Only if we see that f has arity 1, and then we
659 take advantage of the 'state hack' on the result of
660 (f y) :: State# -> (State#, Int) to expand the arity one more.
661
662 There is a disadvantage though. Making the arity visible in the RHS
663 allows us to eta-reduce
664 f = \x -> f x
665 to
666 f = f
667 which technically is not sound. This is very much a corner case, so
668 I'm not worried about it. Another idea is to ensure that f's arity
669 never decreases; its arity started as 1, and we should never eta-reduce
670 below that.
671
672
673 Note [Robust OccInfo]
674 ~~~~~~~~~~~~~~~~~~~~~
675 It's important that we *do* retain the loop-breaker OccInfo, because
676 that's what stops the Id getting inlined infinitely, in the body of
677 the letrec.
678 -}
679
680
681 {-
682 ************************************************************************
683 * *
684 Impedence matching to type substitution
685 * *
686 ************************************************************************
687 -}
688
689 getTCvSubst :: SimplEnv -> TCvSubst
690 getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
691 = mkTCvSubst in_scope (tv_env, cv_env)
692
693 substTy :: SimplEnv -> Type -> Type
694 substTy env ty = Type.substTy (getTCvSubst env) ty
695
696 substTyVar :: SimplEnv -> TyVar -> Type
697 substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
698
699 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
700 substTyVarBndr env tv
701 = case Type.substTyVarBndr (getTCvSubst env) tv of
702 (TCvSubst in_scope' tv_env' cv_env', tv')
703 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
704
705 substCoVar :: SimplEnv -> CoVar -> Coercion
706 substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
707
708 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
709 substCoVarBndr env cv
710 = case Coercion.substCoVarBndr (getTCvSubst env) cv of
711 (TCvSubst in_scope' tv_env' cv_env', cv')
712 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
713
714 substCo :: SimplEnv -> Coercion -> Coercion
715 substCo env co = Coercion.substCo (getTCvSubst env) co
716
717 ------------------
718 substIdType :: SimplEnv -> Id -> Id
719 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
720 | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
721 || isEmptyVarSet (tyCoVarsOfType old_ty)
722 = id
723 | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
724 -- The tyCoVarsOfType is cheaper than it looks
725 -- because we cache the free tyvars of the type
726 -- in a Note in the id's type itself
727 where
728 old_ty = idType id