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