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