Do not inline or apply rules on LHS of rules
[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.extendTvSubst, SimplEnv.extendCvSubst,
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, getTvSubst,
29 getCvSubst, 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, substTyVarBndr, substTyVar )
52 import qualified Coercion
53 import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
54 import BasicTypes
55 import MonadUtils
56 import Outputable
57 import FastString
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 [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
130 ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
131 ptext (sLit "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) = ptext (sLit "DoneEx") <+> ppr e
151 ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
152 ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "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 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
275 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
276 = env {seTvSubst = extendVarEnv subst var res}
277
278 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
279 extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
280 = env {seCvSubst = extendVarEnv subst var res}
281
282 ---------------------
283 getInScope :: SimplEnv -> InScopeSet
284 getInScope env = seInScope env
285
286 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
287 setInScopeSet env in_scope = env {seInScope = in_scope}
288
289 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
290 -- Set the in-scope set, and *zap* the floats
291 setInScope env env_with_scope
292 = env { seInScope = seInScope env_with_scope,
293 seFloats = emptyFloats }
294
295 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
296 -- Set the in-scope set *and* the floats
297 setFloats env env_with_floats
298 = env { seInScope = seInScope env_with_floats,
299 seFloats = seFloats env_with_floats }
300
301 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
302 -- The new Ids are guaranteed to be freshly allocated
303 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
304 = env { seInScope = in_scope `extendInScopeSetList` vs,
305 seIdSubst = id_subst `delVarEnvList` vs }
306 -- Why delete? Consider
307 -- let x = a*b in (x, \x -> x+3)
308 -- We add [x |-> a*b] to the substitution, but we must
309 -- _delete_ it from the substitution when going inside
310 -- the (\x -> ...)!
311
312 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
313 -- The variable should already be in scope, but
314 -- replace the existing version with this new one
315 -- which has more information
316 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
317 = env {seInScope = extendInScopeSet in_scope v}
318
319 ---------------------
320 zapSubstEnv :: SimplEnv -> SimplEnv
321 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
322
323 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
324 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
325
326 mkContEx :: SimplEnv -> InExpr -> SimplSR
327 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
328
329 {-
330 ************************************************************************
331 * *
332 \subsection{Floats}
333 * *
334 ************************************************************************
335
336 Note [Simplifier floats]
337 ~~~~~~~~~~~~~~~~~~~~~~~~~
338 The Floats is a bunch of bindings, classified by a FloatFlag.
339
340 * All of them satisfy the let/app invariant
341
342 Examples
343
344 NonRec x (y:ys) FltLifted
345 Rec [(x,rhs)] FltLifted
346
347 NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted?
348 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
349
350 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
351
352 Can't happen:
353 NonRec x# (a /# b) -- Might fail; does not satisfy let/app
354 NonRec x# (f y) -- Might diverge; does not satisfy let/app
355 -}
356
357 data Floats = Floats (OrdList OutBind) FloatFlag
358 -- See Note [Simplifier floats]
359
360 data FloatFlag
361 = FltLifted -- All bindings are lifted and lazy
362 -- Hence ok to float to top level, or recursive
363
364 | FltOkSpec -- All bindings are FltLifted *or*
365 -- strict (perhaps because unlifted,
366 -- perhaps because of a strict binder),
367 -- *and* ok-for-speculation
368 -- Hence ok to float out of the RHS
369 -- of a lazy non-recursive let binding
370 -- (but not to top level, or into a rec group)
371
372 | FltCareful -- At least one binding is strict (or unlifted)
373 -- and not guaranteed cheap
374 -- Do not float these bindings out of a lazy let
375
376 instance Outputable Floats where
377 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
378
379 instance Outputable FloatFlag where
380 ppr FltLifted = ptext (sLit "FltLifted")
381 ppr FltOkSpec = ptext (sLit "FltOkSpec")
382 ppr FltCareful = ptext (sLit "FltCareful")
383
384 andFF :: FloatFlag -> FloatFlag -> FloatFlag
385 andFF FltCareful _ = FltCareful
386 andFF FltOkSpec FltCareful = FltCareful
387 andFF FltOkSpec _ = FltOkSpec
388 andFF FltLifted flt = flt
389
390 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
391 -- If you change this function look also at FloatIn.noFloatFromRhs
392 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
393 = not (isNilOL fs) && want_to_float && can_float
394 where
395 want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
396 -- See Note [Float when cheap or expandable]
397 can_float = case ff of
398 FltLifted -> True
399 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
400 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
401
402 {-
403 Note [Float when cheap or expandable]
404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
405 We want to float a let from a let if the residual RHS is
406 a) cheap, such as (\x. blah)
407 b) expandable, such as (f b) if f is CONLIKE
408 But there are
409 - cheap things that are not expandable (eg \x. expensive)
410 - expandable things that are not cheap (eg (f b) where b is CONLIKE)
411 so we must take the 'or' of the two.
412 -}
413
414 emptyFloats :: Floats
415 emptyFloats = Floats nilOL FltLifted
416
417 unitFloat :: OutBind -> Floats
418 -- This key function constructs a singleton float with the right form
419 unitFloat bind = Floats (unitOL bind) (flag bind)
420 where
421 flag (Rec {}) = FltLifted
422 flag (NonRec bndr rhs)
423 | not (isStrictId bndr) = FltLifted
424 | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
425 | otherwise = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr )
426 FltCareful
427 -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
428
429 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
430 -- Add a non-recursive binding and extend the in-scope set
431 -- The latter is important; the binder may already be in the
432 -- in-scope set (although it might also have been created with newId)
433 -- but it may now have more IdInfo
434 addNonRec env id rhs
435 = id `seq` -- This seq forces the Id, and hence its IdInfo,
436 -- and hence any inner substitutions
437 env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
438 seInScope = extendInScopeSet (seInScope env) id }
439
440 extendFloats :: SimplEnv -> OutBind -> SimplEnv
441 -- Add these bindings to the floats, and extend the in-scope env too
442 extendFloats env bind
443 = env { seFloats = seFloats env `addFlts` unitFloat bind,
444 seInScope = extendInScopeSetList (seInScope env) bndrs }
445 where
446 bndrs = bindersOf bind
447
448 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
449 -- Add the floats for env2 to env1;
450 -- *plus* the in-scope set for env2, which is bigger
451 -- than that for env1
452 addFloats env1 env2
453 = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
454 seInScope = seInScope env2 }
455
456 addFlts :: Floats -> Floats -> Floats
457 addFlts (Floats bs1 l1) (Floats bs2 l2)
458 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
459
460 zapFloats :: SimplEnv -> SimplEnv
461 zapFloats env = env { seFloats = emptyFloats }
462
463 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
464 -- Flattens the floats from env2 into a single Rec group,
465 -- prepends the floats from env1, and puts the result back in env2
466 -- This is all very specific to the way recursive bindings are
467 -- handled; see Simplify.simplRecBind
468 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
469 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
470 env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
471
472 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
473 -- Wrap the floats around the expression; they should all
474 -- satisfy the let/app invariant, so mkLets should do the job just fine
475 wrapFloats (SimplEnv {seFloats = Floats bs _}) body
476 = foldrOL Let body bs
477
478 getFloatBinds :: SimplEnv -> [CoreBind]
479 getFloatBinds (SimplEnv {seFloats = Floats bs _})
480 = fromOL bs
481
482 isEmptyFloats :: SimplEnv -> Bool
483 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
484 = isNilOL bs
485
486 mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
487 mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
488 = env { seFloats = Floats (mapOL app fs) ff }
489 where
490 app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
491 app (Rec bs) = Rec (map fun bs)
492
493 {-
494 ************************************************************************
495 * *
496 Substitution of Vars
497 * *
498 ************************************************************************
499
500 Note [Global Ids in the substitution]
501 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
502 We look up even a global (eg imported) Id in the substitution. Consider
503 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
504 The binder-swap in the occurrence analyser will add a binding
505 for a LocalId version of g (with the same unique though):
506 case X.g_34 of b { (a,b) -> let g_34 = b in
507 ... case X.g_34 of { (p,q) -> ...} ... }
508 So we want to look up the inner X.g_34 in the substitution, where we'll
509 find that it has been substituted by b. (Or conceivably cloned.)
510 -}
511
512 substId :: SimplEnv -> InId -> SimplSR
513 -- Returns DoneEx only on a non-Var expression
514 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
515 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
516 Nothing -> DoneId (refineFromInScope in_scope v)
517 Just (DoneId v) -> DoneId (refineFromInScope in_scope v)
518 Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
519 Just res -> res -- DoneEx non-var, or ContEx
520
521 -- Get the most up-to-date thing from the in-scope set
522 -- Even though it isn't in the substitution, it may be in
523 -- the in-scope set with better IdInfo
524 refineFromInScope :: InScopeSet -> Var -> Var
525 refineFromInScope in_scope v
526 | isLocalId v = case lookupInScope in_scope v of
527 Just v' -> v'
528 Nothing -> WARN( True, ppr v ) v -- This is an error!
529 | otherwise = v
530
531 lookupRecBndr :: SimplEnv -> InId -> OutId
532 -- Look up an Id which has been put into the envt by simplRecBndrs,
533 -- but where we have not yet done its RHS
534 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
535 = case lookupVarEnv ids v of
536 Just (DoneId v) -> v
537 Just _ -> pprPanic "lookupRecBndr" (ppr v)
538 Nothing -> refineFromInScope in_scope v
539
540 {-
541 ************************************************************************
542 * *
543 \section{Substituting an Id binder}
544 * *
545 ************************************************************************
546
547
548 These functions are in the monad only so that they can be made strict via seq.
549 -}
550
551 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
552 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
553
554 -------------
555 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
556 -- Used for lambda and case-bound variables
557 -- Clone Id if necessary, substitute type
558 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
559 -- The substitution is extended only if the variable is cloned, because
560 -- we *don't* need to use it to track occurrence info.
561 simplBinder env bndr
562 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
563 ; seqTyVar tv `seq` return (env', tv) }
564 | otherwise = do { let (env', id) = substIdBndr env bndr
565 ; seqId id `seq` return (env', id) }
566
567 ---------------
568 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
569 -- A non-recursive let binder
570 simplNonRecBndr env id
571 = do { let (env1, id1) = substIdBndr env id
572 ; seqId id1 `seq` return (env1, id1) }
573
574 ---------------
575 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
576 -- Recursive let binders
577 simplRecBndrs env@(SimplEnv {}) ids
578 = do { let (env1, ids1) = mapAccumL substIdBndr env ids
579 ; seqIds ids1 `seq` return env1 }
580
581 ---------------
582 substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
583 -- Might be a coercion variable
584 substIdBndr env bndr
585 | isCoVar bndr = substCoVarBndr env bndr
586 | otherwise = substNonCoVarIdBndr env bndr
587
588 ---------------
589 substNonCoVarIdBndr
590 :: SimplEnv
591 -> InBndr -- Env and binder to transform
592 -> (SimplEnv, OutBndr)
593 -- Clone Id if necessary, substitute its type
594 -- Return an Id with its
595 -- * Type substituted
596 -- * UnfoldingInfo, Rules, WorkerInfo zapped
597 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
598 -- * Robust info, retained especially arity and demand info,
599 -- so that they are available to occurrences that occur in an
600 -- earlier binding of a letrec
601 --
602 -- For the robust info, see Note [Arity robustness]
603 --
604 -- Augment the substitution if the unique changed
605 -- Extend the in-scope set with the new Id
606 --
607 -- Similar to CoreSubst.substIdBndr, except that
608 -- the type of id_subst differs
609 -- all fragile info is zapped
610 substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
611 old_id
612 = ASSERT2( not (isCoVar old_id), ppr old_id )
613 (env { seInScope = in_scope `extendInScopeSet` new_id,
614 seIdSubst = new_subst }, new_id)
615 where
616 id1 = uniqAway in_scope old_id
617 id2 = substIdType env id1
618 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
619 -- and fragile OccInfo
620
621 -- Extend the substitution if the unique has changed,
622 -- or there's some useful occurrence information
623 -- See the notes with substTyVarBndr for the delSubstEnv
624 new_subst | new_id /= old_id
625 = extendVarEnv id_subst old_id (DoneId new_id)
626 | otherwise
627 = delVarEnv id_subst old_id
628
629 ------------------------------------
630 seqTyVar :: TyVar -> ()
631 seqTyVar b = b `seq` ()
632
633 seqId :: Id -> ()
634 seqId id = seqType (idType id) `seq`
635 idInfo id `seq`
636 ()
637
638 seqIds :: [Id] -> ()
639 seqIds [] = ()
640 seqIds (id:ids) = seqId id `seq` seqIds ids
641
642 {-
643 Note [Arity robustness]
644 ~~~~~~~~~~~~~~~~~~~~~~~
645 We *do* transfer the arity from from the in_id of a let binding to the
646 out_id. This is important, so that the arity of an Id is visible in
647 its own RHS. For example:
648 f = \x. ....g (\y. f y)....
649 We can eta-reduce the arg to g, because f is a value. But that
650 needs to be visible.
651
652 This interacts with the 'state hack' too:
653 f :: Bool -> IO Int
654 f = \x. case x of
655 True -> f y
656 False -> \s -> ...
657 Can we eta-expand f? Only if we see that f has arity 1, and then we
658 take advantage of the 'state hack' on the result of
659 (f y) :: State# -> (State#, Int) to expand the arity one more.
660
661 There is a disadvantage though. Making the arity visible in the RHS
662 allows us to eta-reduce
663 f = \x -> f x
664 to
665 f = f
666 which technically is not sound. This is very much a corner case, so
667 I'm not worried about it. Another idea is to ensure that f's arity
668 never decreases; its arity started as 1, and we should never eta-reduce
669 below that.
670
671
672 Note [Robust OccInfo]
673 ~~~~~~~~~~~~~~~~~~~~~
674 It's important that we *do* retain the loop-breaker OccInfo, because
675 that's what stops the Id getting inlined infinitely, in the body of
676 the letrec.
677 -}
678
679
680 {-
681 ************************************************************************
682 * *
683 Impedence matching to type substitution
684 * *
685 ************************************************************************
686 -}
687
688 getTvSubst :: SimplEnv -> TvSubst
689 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
690 = mkTvSubst in_scope tv_env
691
692 getCvSubst :: SimplEnv -> CvSubst
693 getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
694 = CvSubst in_scope tv_env cv_env
695
696 substTy :: SimplEnv -> Type -> Type
697 substTy env ty = Type.substTy (getTvSubst env) ty
698
699 substTyVar :: SimplEnv -> TyVar -> Type
700 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
701
702 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
703 substTyVarBndr env tv
704 = case Type.substTyVarBndr (getTvSubst env) tv of
705 (TvSubst in_scope' tv_env', tv')
706 -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
707
708 substCoVar :: SimplEnv -> CoVar -> Coercion
709 substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
710
711 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
712 substCoVarBndr env cv
713 = case Coercion.substCoVarBndr (getCvSubst env) cv of
714 (CvSubst in_scope' tv_env' cv_env', cv')
715 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
716
717 substCo :: SimplEnv -> Coercion -> Coercion
718 substCo env co = Coercion.substCo (getCvSubst env) co
719
720 ------------------
721 substIdType :: SimplEnv -> Id -> Id
722 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
723 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
724 | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
725 -- The tyVarsOfType is cheaper than it looks
726 -- because we cache the free tyvars of the type
727 -- in a Note in the id's type itself
728 where
729 old_ty = idType id