2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 InScopeSet, emptyInScopeSet, mkInScopeSet,
10 extendInScopeSet, extendInScopeSetList,
11 lookupInScope, elemInScopeSet, uniqAway,
15 Subst, TyVarSubst, IdSubst,
16 emptySubst, mkSubst, substEnv, substInScope,
17 lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
18 zapSubstEnv, setSubstEnv,
20 extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
21 isInScope, modifyInScope,
23 bindSubst, unBindSubst, bindSubstList, unBindSubstList,
26 simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
27 substAndCloneId, substAndCloneIds, substAndCloneRecIds,
30 mkTyVarSubst, mkTopTyVarSubst,
31 substTyWith, substTy, substTheta, deShadowTy,
37 #include "HsVersions.h"
39 import CmdLineOpts ( opt_PprStyle_Debug )
40 import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
41 CoreRules(..), CoreRule(..),
42 isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
45 import CoreFVs ( exprFreeVars )
46 import TypeRep ( Type(..), TyNote(..) ) -- friend
47 import Type ( ThetaType, SourceType(..), PredType,
48 tyVarsOfType, tyVarsOfTypes, mkAppTy,
52 import Var ( setVarUnique, isId, mustHaveLocalBinding )
53 import Id ( idType, idInfo, setIdInfo, setIdType,
54 idUnfolding, setIdUnfolding,
55 idOccInfo, maybeModifyIdInfo )
56 import IdInfo ( IdInfo, vanillaIdInfo,
57 occInfo, isFragileOcc, setOccInfo,
58 specInfo, setSpecInfo,
59 unfoldingInfo, setUnfoldingInfo,
60 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
61 lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
63 import BasicTypes ( OccInfo(..) )
64 import Unique ( Unique, Uniquable(..), deriveUnique )
65 import UniqSet ( elemUniqSet_Directly )
66 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
67 import Var ( Var, Id, TyVar, isTyVar )
69 import PprCore () -- Instances
70 import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
71 import Util ( mapAccumL, foldl2, seqList )
76 %************************************************************************
78 \subsection{The in-scope set}
80 %************************************************************************
83 data InScopeSet = InScope (VarEnv Var) FastInt
84 -- The Int# is a kind of hash-value used by uniqAway
85 -- For example, it might be the size of the set
86 -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
88 emptyInScopeSet :: InScopeSet
89 emptyInScopeSet = InScope emptyVarSet 1#
91 mkInScopeSet :: VarEnv Var -> InScopeSet
92 mkInScopeSet in_scope = InScope in_scope 1#
94 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
95 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
97 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
98 extendInScopeSetList (InScope in_scope n) vs
99 = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
100 (n +# iUnbox (length vs))
102 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
103 -- Exploit the fact that the in-scope "set" is really a map
104 -- Make old_v map to new_v
105 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
107 delInScopeSet :: InScopeSet -> Var -> InScopeSet
108 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
110 elemInScopeSet :: Var -> InScopeSet -> Bool
111 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
113 lookupInScope :: InScopeSet -> Var -> Var
114 -- It's important to look for a fixed point
115 -- When we see (case x of y { I# v -> ... })
116 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
117 -- When we lookup up an occurrence of x, we map to y, but then
118 -- we want to look up y in case it has acquired more evaluation information by now.
119 lookupInScope (InScope in_scope n) v
122 go v = case lookupVarEnv in_scope v of
123 Just v' | v == v' -> v' -- Reached a fixed point
125 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
130 uniqAway :: InScopeSet -> Var -> Var
131 -- (uniqAway in_scope v) finds a unique that is not used in the
132 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
133 -- in the hope that it won't have to change it, nad thereafter uses a combination
134 -- of that and the hash-code found in the in-scope set
135 uniqAway (InScope set n) var
136 | not (var `elemVarSet` set) = var -- Nothing to do
139 orig_unique = getUnique var
143 = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
145 | uniq `elemUniqSet_Directly` set = try (k +# 1#)
147 | opt_PprStyle_Debug && k ># 3#
148 = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
149 setVarUnique var uniq
151 | otherwise = setVarUnique var uniq
153 uniq = deriveUnique orig_unique (iBox (n *# k))
157 %************************************************************************
159 \subsection{Substitutions}
161 %************************************************************************
164 data Subst = Subst InScopeSet -- In scope
165 SubstEnv -- Substitution itself
166 -- INVARIANT 1: The (domain of the) in-scope set is a superset
167 -- of the free vars of the range of the substitution
168 -- that might possibly clash with locally-bound variables
169 -- in the thing being substituted in.
170 -- This is what lets us deal with name capture properly
171 -- It's a hard invariant to check...
172 -- There are various ways of causing it to happen:
173 -- - arrange that the in-scope set really is all the things in scope
174 -- - arrange that it's the free vars of the range of the substitution
175 -- - make it empty because all the free vars of the subst are fresh,
176 -- and hence can't possibly clash.a
178 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
179 -- Equivalently, the substitution is idempotent
180 -- [Sep 2000: Lies, all lies. The substitution now does contain
181 -- mappings x77 -> DoneId x77 occ
182 -- to record x's occurrence information.]
183 -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
184 -- Consider let x = case k of I# x77 -> ... in
185 -- let y = case k of I# x77 -> ... in ...
186 -- and suppose the body is strict in both x and y. Then the simplifier
187 -- will pull the first (case k) to the top; so the second (case k) will
188 -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
189 -- other is an out-Id. So the substitution is idempotent in the sense
190 -- that we *must not* repeatedly apply it.]
195 The general plan about the substitution and in-scope set for Ids is as follows
197 * substId always adds new_id to the in-scope set.
198 new_id has a correctly-substituted type, occ info
200 * substId adds a binding (DoneId new_id occ) to the substitution if
201 EITHER the Id's unique has changed
202 OR the Id has interesting occurrence information
203 So in effect you can only get to interesting occurrence information
204 by looking up the *old* Id; it's not really attached to the new id
207 Note, though that the substitution isn't necessarily extended
208 if the type changes. Why not? Because of the next point:
210 * We *always, always* finish by looking up in the in-scope set
211 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
212 Reason: so that we never finish up with a "old" Id in the result.
213 An old Id might point to an old unfolding and so on... which gives a space leak.
215 [The DoneEx and DoneVar hits map to "new" stuff.]
217 * It follows that substExpr must not do a no-op if the substitution is empty.
218 substType is free to do so, however.
220 * When we come to a let-binding (say) we generate new IdInfo, including an
221 unfolding, attach it to the binder, and add this newly adorned binder to
222 the in-scope set. So all subsequent occurrences of the binder will get mapped
223 to the full-adorned binder, which is also the one put in the binding site.
225 * The in-scope "set" usually maps x->x; we use it simply for its domain.
226 But sometimes we have two in-scope Ids that are synomyms, and should
227 map to the same target: x->x, y->x. Notably:
229 That's why the "set" is actually a VarEnv Var
233 isEmptySubst :: Subst -> Bool
234 isEmptySubst (Subst _ env) = isEmptySubstEnv env
237 emptySubst = Subst emptyInScopeSet emptySubstEnv
239 mkSubst :: InScopeSet -> SubstEnv -> Subst
240 mkSubst in_scope env = Subst in_scope env
242 substEnv :: Subst -> SubstEnv
243 substEnv (Subst _ env) = env
245 substInScope :: Subst -> InScopeSet
246 substInScope (Subst in_scope _) = in_scope
248 zapSubstEnv :: Subst -> Subst
249 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
251 extendSubst :: Subst -> Var -> SubstResult -> Subst
252 extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
254 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
255 extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
257 lookupSubst :: Subst -> Var -> Maybe SubstResult
258 lookupSubst (Subst _ env) v = lookupSubstEnv env v
260 lookupIdSubst :: Subst -> Id -> SubstResult
261 -- Does the lookup in the in-scope set too
262 lookupIdSubst (Subst in_scope env) v
263 = case lookupSubstEnv env v of
264 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
266 Nothing -> DoneId v' (idOccInfo v')
267 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
268 -- very important! If isFragileOcc returned True for
269 -- loop breakers we could avoid this call, but at the expense
270 -- of adding more to the substitution, and building new Ids
271 -- in substId a bit more often than really necessary
273 v' = lookupInScope in_scope v
275 isInScope :: Var -> Subst -> Bool
276 isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
278 modifyInScope :: Subst -> Var -> Var -> Subst
279 modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
280 -- make old_v map to new_v
282 extendInScope :: Subst -> Var -> Subst
283 -- Add a new variable as in-scope
284 -- Remember to delete any existing binding in the substitution!
285 extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
286 (env `delSubstEnv` v)
288 extendInScopeList :: Subst -> [Var] -> Subst
289 extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
290 (delSubstEnvList env vs)
292 -- The "New" variants are guaranteed to be adding freshly-allocated variables
293 -- It's not clear that the gain (not needing to delete it from the substitution)
294 -- is worth the extra proof obligation
295 extendNewInScope :: Subst -> Var -> Subst
296 extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
298 extendNewInScopeList :: Subst -> [Var] -> Subst
299 extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
301 -------------------------------
302 bindSubst :: Subst -> Var -> Var -> Subst
303 -- Extend with a substitution, v1 -> Var v2
304 -- and extend the in-scopes with v2
305 bindSubst (Subst in_scope env) old_bndr new_bndr
306 = Subst (in_scope `extendInScopeSet` new_bndr)
307 (extendSubstEnv env old_bndr subst_result)
309 subst_result | isId old_bndr = DoneEx (Var new_bndr)
310 | otherwise = DoneTy (TyVarTy new_bndr)
312 unBindSubst :: Subst -> Var -> Var -> Subst
313 -- Reverse the effect of bindSubst
314 -- If old_bndr was already in the substitution, this doesn't quite work
315 unBindSubst (Subst in_scope env) old_bndr new_bndr
316 = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
318 -- And the "List" forms
319 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
320 bindSubstList subst old_bndrs new_bndrs
321 = foldl2 bindSubst subst old_bndrs new_bndrs
323 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
324 unBindSubstList subst old_bndrs new_bndrs
325 = foldl2 unBindSubst subst old_bndrs new_bndrs
328 -------------------------------
329 setInScope :: Subst -- Take env part from here
332 setInScope (Subst in_scope1 env1) in_scope2
333 = Subst in_scope2 env1
335 setSubstEnv :: Subst -- Take in-scope part from here
336 -> SubstEnv -- ... and env part from here
338 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
341 Pretty printing, for debugging only
344 instance Outputable SubstResult where
345 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
346 ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
347 ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
348 ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t
350 instance Outputable SubstEnv where
351 ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
353 ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
355 instance Outputable Subst where
356 ppr (Subst (InScope in_scope _) se)
357 = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope)))
358 $$ ptext SLIT(" Subst =") <+> ppr se <> char '>'
361 %************************************************************************
363 \subsection{Type substitution}
365 %************************************************************************
368 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
369 -- (We could have a variant of Subst, but it doesn't seem worth it.)
371 -- mkTyVarSubst generates the in-scope set from
372 -- the types given; but it's just a thunk so with a bit of luck
373 -- it'll never be evaluated
374 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
375 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
376 (zipTyEnv tyvars tys)
378 -- mkTopTyVarSubst is called when doing top-level substitutions.
379 -- Here we expect that the free vars of the range of the
380 -- substitution will be empty.
381 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
382 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
386 | length tyvars /= length tys
387 = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
390 = zip_ty_env tyvars tys emptySubstEnv
392 zip_ty_env [] [] env = env
393 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
394 -- There used to be a special case for when
396 -- (a not-uncommon case) in which case the substitution was dropped.
397 -- But the type-tidier changes the print-name of a type variable without
398 -- changing the unique, and that led to a bug. Why? Pre-tidying, we had
399 -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype.
400 -- And it happened that t was the type variable of the class. Post-tiding,
401 -- it got turned into {Foo t2}. The ext-core printer expanded this using
402 -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
403 -- and so generated a rep type mentioning t not t2.
405 -- Simplest fix is to nuke the "optimisation"
408 substTy works with general Substs, so that it can be called from substExpr too.
411 substTyWith :: [TyVar] -> [Type] -> Type -> Type
412 substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
414 substTy :: Subst -> Type -> Type
415 substTy subst ty | isEmptySubst subst = ty
416 | otherwise = subst_ty subst ty
418 deShadowTy :: Type -> Type -- Remove any shadowing from the type
419 deShadowTy ty = subst_ty emptySubst ty
421 substTheta :: TyVarSubst -> ThetaType -> ThetaType
422 substTheta subst theta
423 | isEmptySubst subst = theta
424 | otherwise = map (substPred subst) theta
426 substPred :: TyVarSubst -> PredType -> PredType
427 substPred = substSourceType
429 substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty)
430 substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
431 substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys)
436 go (TyConApp tc tys) = let args = map go tys
437 in args `seqList` TyConApp tc args
439 go (SourceTy p) = SourceTy $! (substSourceType subst p)
441 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
442 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
444 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
445 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
446 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
448 Just (DoneTy ty') -> ty'
450 go (ForAllTy tv ty) = case substTyVar subst tv of
451 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
454 Here is where we invent a new binder if necessary.
457 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
458 substTyVar subst@(Subst in_scope env) old_var
459 | old_var == new_var -- No need to clone
460 -- But we *must* zap any current substitution for the variable.
462 -- (\x.e) with id_subst = [x |-> e']
463 -- Here we must simply zap the substitution for x
465 -- The new_id isn't cloned, but it may have a different type
466 -- etc, so we must return it, not the old id
467 = (Subst (in_scope `extendInScopeSet` new_var)
468 (delSubstEnv env old_var),
471 | otherwise -- The new binder is in scope so
472 -- we'd better rename it away from the in-scope variables
473 -- Extending the substitution to do this renaming also
474 -- has the (correct) effect of discarding any existing
475 -- substitution for that variable
476 = (Subst (in_scope `extendInScopeSet` new_var)
477 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
480 new_var = uniqAway in_scope old_var
481 -- The uniqAway part makes sure the new variable is not already in scope
485 %************************************************************************
487 \section{Expression substitution}
489 %************************************************************************
491 This expression substituter deals correctly with name capture.
493 BUT NOTE that substExpr silently discards the
496 IdInfo attached to any binders in the expression. It's quite
497 tricky to do them 'right' in the case of mutually recursive bindings,
498 and so far has proved unnecessary.
501 substExpr :: Subst -> CoreExpr -> CoreExpr
503 -- NB: we do not do a no-op when the substitution is empty,
504 -- because we always want to substitute the variables in the
505 -- in-scope set for their occurrences. Why?
506 -- (a) because they may contain more information
507 -- (b) because leaving an un-substituted Id might cause
508 -- a space leak (its unfolding might point to an old version
509 -- of its right hand side).
513 go (Var v) = -- See the notes at the top, with the Subst data type declaration
514 case lookupIdSubst subst v of
516 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
520 go (Type ty) = Type (go_ty ty)
521 go (Lit lit) = Lit lit
522 go (App fun arg) = App (go fun) (go arg)
523 go (Note note e) = Note (go_note note) (go e)
525 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
527 (subst', bndr') = substBndr subst bndr
529 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
531 (subst', bndr') = substBndr subst bndr
533 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
535 (subst', bndrs') = substRecIds subst (map fst pairs)
536 pairs' = bndrs' `zip` rhss'
537 rhss' = map (substExpr subst' . snd) pairs
539 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
541 (subst', bndr') = substBndr subst bndr
543 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
545 (subst', bndrs') = substBndrs subst bndrs
547 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
550 go_ty ty = substTy subst ty
555 %************************************************************************
557 \section{Substituting an Id binder}
559 %************************************************************************
562 -- simplBndr and simplLetId are used by the simplifier
564 simplBndr :: Subst -> Var -> (Subst, Var)
565 -- Used for lambda and case-bound variables
566 -- Clone Id if necessary, substitute type
567 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
568 -- The substitution is extended only if the variable is cloned, because
569 -- we *don't* need to use it to track occurrence info.
571 | isTyVar bndr = substTyVar subst bndr
572 | otherwise = subst_id isFragileOcc subst subst bndr
574 simplBndrs :: Subst -> [Var] -> (Subst, [Var])
575 simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
577 simplLamBndr :: Subst -> Var -> (Subst, Var)
578 -- Used for lambda binders. These sometimes have unfoldings added by
579 -- the worker/wrapper pass that must be preserved, becuase they can't
580 -- be reconstructed from context. For example:
581 -- f x = case x of (a,b) -> fw a b x
582 -- fw a b x{=(a,b)} = ...
583 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
584 simplLamBndr subst bndr
585 | not (isId bndr && hasSomeUnfolding old_unf)
586 = simplBndr subst bndr -- Normal case
588 = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
590 old_unf = idUnfolding bndr
591 (subst', bndr') = subst_id isFragileOcc subst subst bndr
594 simplLetId :: Subst -> Id -> (Subst, Id)
595 -- Clone Id if necessary
596 -- Substitute its type
597 -- Return an Id with completely zapped IdInfo
598 -- [A subsequent substIdInfo will restore its IdInfo]
599 -- Augment the subtitution
600 -- if the unique changed, *or*
601 -- if there's interesting occurrence info
603 simplLetId subst@(Subst in_scope env) old_id
604 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
606 old_info = idInfo old_id
607 id1 = uniqAway in_scope old_id
608 id2 = substIdType subst id1
609 new_id = setIdInfo id2 vanillaIdInfo
611 -- Extend the substitution if the unique has changed,
612 -- or there's some useful occurrence information
613 -- See the notes with substTyVar for the delSubstEnv
614 occ_info = occInfo old_info
615 new_env | new_id /= old_id || isFragileOcc occ_info
616 = extendSubstEnv env old_id (DoneId new_id occ_info)
618 = delSubstEnv env old_id
620 simplIdInfo :: Subst -> IdInfo -> IdInfo
621 -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
622 -- subsequent to simplLetId having zapped its IdInfo
623 simplIdInfo subst old_info
624 = case substIdInfo subst isFragileOcc old_info of
625 Just new_info -> new_info
630 -- substBndr and friends are used when doing expression substitution only
631 -- In this case we can *preserve* occurrence information, and indeed we *want*
632 -- to do so else lose useful occ info in rules. Hence the calls to
633 -- simpl_id with keepOccInfo
635 substBndr :: Subst -> Var -> (Subst, Var)
637 | isTyVar bndr = substTyVar subst bndr
638 | otherwise = subst_id keepOccInfo subst subst bndr
640 substBndrs :: Subst -> [Var] -> (Subst, [Var])
641 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
643 substRecIds :: Subst -> [Id] -> (Subst, [Id])
644 -- Substitute a mutually recursive group
645 substRecIds subst bndrs
646 = (new_subst, new_bndrs)
648 -- Here's the reason we need to pass rec_subst to subst_id
649 (new_subst, new_bndrs) = mapAccumL (subst_id keepOccInfo new_subst) subst bndrs
651 keepOccInfo occ = False -- Never fragile
656 subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile
657 -> Subst -- Substitution to use for the IdInfo
658 -> Subst -> Id -- Substitition and Id to transform
659 -> (Subst, Id) -- Transformed pair
662 -- * Unique changed if necessary
663 -- * Type substituted
664 -- * Unfolding zapped
665 -- * Rules, worker, lbvar info all substituted
666 -- * Occurrence info zapped if is_fragile_occ returns True
667 -- * The in-scope set extended with the returned Id
668 -- * The substitution extended with a DoneId if unique changed
669 -- In this case, the var in the DoneId is the same as the
672 subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
673 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
675 -- id1 is cloned if necessary
676 id1 = uniqAway in_scope old_id
678 -- id2 has its type zapped
679 id2 = substIdType subst id1
681 -- new_id has the right IdInfo
682 -- The lazy-set is because we're in a loop here, with
683 -- rec_subst, when dealing with a mutually-recursive group
684 new_id = maybeModifyIdInfo (substIdInfo rec_subst is_fragile_occ) id2
686 -- Extend the substitution if the unique has changed
687 -- See the notes with substTyVar for the delSubstEnv
688 new_env | new_id /= old_id
689 = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
691 = delSubstEnv env old_id
694 Now a variant that unconditionally allocates a new unique.
695 It also unconditionally zaps the OccInfo.
698 subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
699 -> Subst -> (Id, Unique) -- Substitition and Id to transform
700 -> (Subst, Id) -- Transformed pair
702 subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
703 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
705 id1 = setVarUnique old_id uniq
706 id2 = substIdType subst id1
708 new_id = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
709 new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
711 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
712 substAndCloneIds subst us ids
713 = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
715 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
716 substAndCloneRecIds subst us ids
719 (subst', ids') = mapAccumL (subst_clone_id subst') subst
720 (ids `zip` uniqsFromSupply us)
722 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
723 substAndCloneId subst@(Subst in_scope env) us old_id
724 = subst_clone_id subst subst (old_id, uniqFromSupply us)
728 %************************************************************************
730 \section{IdInfo substitution}
732 %************************************************************************
736 -> (OccInfo -> Bool) -- True <=> zap the occurrence info
744 -- Zap the occ info if instructed to do so
746 -- Seq'ing on the returned IdInfo is enough to cause all the
747 -- substitutions to happen completely
749 substIdInfo subst is_fragile_occ info
750 | nothing_to_do = Nothing
751 | otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
752 `setSpecInfo` substRules subst old_rules
753 `setWorkerInfo` substWorker subst old_wrkr
754 `setLBVarInfo` substLBVar subst old_lbv
755 `setUnfoldingInfo` noUnfolding)
756 -- setSpecInfo does a seq
757 -- setWorkerInfo does a seq
759 nothing_to_do = not zap_occ &&
760 isEmptyCoreRules old_rules &&
761 not (workerExists old_wrkr) &&
762 hasNoLBVarInfo old_lbv &&
763 not (hasUnfolding (unfoldingInfo info))
765 zap_occ = is_fragile_occ old_occ
766 old_occ = occInfo info
767 old_rules = specInfo info
768 old_wrkr = workerInfo info
769 old_lbv = lbvarInfo info
772 substIdType :: Subst -> Id -> Id
773 substIdType subst@(Subst in_scope env) id
774 | noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
775 | otherwise = setIdType id (substTy subst old_ty)
776 -- The tyVarsOfType is cheaper than it looks
777 -- because we cache the free tyvars of the type
778 -- in a Note in the id's type itself
783 substWorker :: Subst -> WorkerInfo -> WorkerInfo
784 -- Seq'ing on the returned WorkerInfo is enough to cause all the
785 -- substitutions to happen completely
787 substWorker subst NoWorker
789 substWorker subst (HasWorker w a)
790 = case lookupIdSubst subst w of
791 (DoneId w1 _) -> HasWorker w1 a
792 (DoneEx (Var w1)) -> HasWorker w1 a
793 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
794 NoWorker -- Worker has got substituted away altogether
795 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
799 substUnfolding subst NoUnfolding = NoUnfolding
800 substUnfolding subst (OtherCon cons) = OtherCon cons
801 substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
802 substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
805 substRules :: Subst -> CoreRules -> CoreRules
806 -- Seq'ing on the returned CoreRules is enough to cause all the
807 -- substitutions to happen completely
809 substRules subst rules
810 | isEmptySubst subst = rules
812 substRules subst (Rules rules rhs_fvs)
813 = seqRules new_rules `seq` new_rules
815 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
817 do_subst rule@(BuiltinRule _ _) = rule
818 do_subst (Rule name act tpl_vars lhs_args rhs)
819 = Rule name act tpl_vars'
820 (map (substExpr subst') lhs_args)
821 (substExpr subst' rhs)
823 (subst', tpl_vars') = substBndrs subst tpl_vars
826 substVarSet subst fvs
827 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
829 subst_fv subst fv = case lookupIdSubst subst fv of
830 DoneId fv' _ -> unitVarSet fv'
831 DoneEx expr -> exprFreeVars expr
832 DoneTy ty -> tyVarsOfType ty
833 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
836 substLBVar subst NoLBVarInfo = NoLBVarInfo
837 substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
839 ty1 = substTy subst ty