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