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 setArityInfo, unknownArity, arityInfo,
60 unfoldingInfo, setUnfoldingInfo,
61 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
62 lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
64 import BasicTypes ( OccInfo(..) )
65 import Unique ( Unique, Uniquable(..), deriveUnique )
66 import UniqSet ( elemUniqSet_Directly )
67 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
68 import Var ( Var, Id, TyVar, isTyVar )
70 import PprCore () -- Instances
71 import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
72 import Util ( mapAccumL, foldl2, seqList )
77 %************************************************************************
79 \subsection{The in-scope set}
81 %************************************************************************
84 data InScopeSet = InScope (VarEnv Var) FastInt
85 -- The Int# is a kind of hash-value used by uniqAway
86 -- For example, it might be the size of the set
87 -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
89 emptyInScopeSet :: InScopeSet
90 emptyInScopeSet = InScope emptyVarSet 1#
92 mkInScopeSet :: VarEnv Var -> InScopeSet
93 mkInScopeSet in_scope = InScope in_scope 1#
95 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
96 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
98 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
99 extendInScopeSetList (InScope in_scope n) vs
100 = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
101 (n +# iUnbox (length vs))
103 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
104 -- Exploit the fact that the in-scope "set" is really a map
105 -- Make old_v map to new_v
106 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
108 delInScopeSet :: InScopeSet -> Var -> InScopeSet
109 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
111 elemInScopeSet :: Var -> InScopeSet -> Bool
112 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
114 lookupInScope :: InScopeSet -> Var -> Var
115 -- It's important to look for a fixed point
116 -- When we see (case x of y { I# v -> ... })
117 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
118 -- When we lookup up an occurrence of x, we map to y, but then
119 -- we want to look up y in case it has acquired more evaluation information by now.
120 lookupInScope (InScope in_scope n) v
123 go v = case lookupVarEnv in_scope v of
124 Just v' | v == v' -> v' -- Reached a fixed point
126 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
131 uniqAway :: InScopeSet -> Var -> Var
132 -- (uniqAway in_scope v) finds a unique that is not used in the
133 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
134 -- in the hope that it won't have to change it, nad thereafter uses a combination
135 -- of that and the hash-code found in the in-scope set
136 uniqAway (InScope set n) var
137 | not (var `elemVarSet` set) = var -- Nothing to do
140 orig_unique = getUnique var
144 = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
146 | uniq `elemUniqSet_Directly` set = try (k +# 1#)
148 | opt_PprStyle_Debug && k ># 3#
149 = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
150 setVarUnique var uniq
152 | otherwise = setVarUnique var uniq
154 uniq = deriveUnique orig_unique (iBox (n *# k))
158 %************************************************************************
160 \subsection{Substitutions}
162 %************************************************************************
165 data Subst = Subst InScopeSet -- In scope
166 SubstEnv -- Substitution itself
167 -- INVARIANT 1: The (domain of the) in-scope set is a superset
168 -- of the free vars of the range of the substitution
169 -- that might possibly clash with locally-bound variables
170 -- in the thing being substituted in.
171 -- This is what lets us deal with name capture properly
172 -- It's a hard invariant to check...
173 -- There are various ways of causing it to happen:
174 -- - arrange that the in-scope set really is all the things in scope
175 -- - arrange that it's the free vars of the range of the substitution
176 -- - make it empty because all the free vars of the subst are fresh,
177 -- and hence can't possibly clash.a
179 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
180 -- Equivalently, the substitution is idempotent
181 -- [Sep 2000: Lies, all lies. The substitution now does contain
182 -- mappings x77 -> DoneId x77 occ
183 -- to record x's occurrence information.]
184 -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
185 -- Consider 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. So the substitution is idempotent in the sense
191 -- that we *must not* repeatedly apply it.]
196 The general plan about the substitution and in-scope set for Ids is as follows
198 * substId always adds new_id to the in-scope set.
199 new_id has a correctly-substituted type, occ info
201 * substId adds a binding (DoneId new_id occ) to the substitution if
202 EITHER the Id's unique has changed
203 OR the Id has interesting occurrence information
204 So in effect you can only get to interesting occurrence information
205 by looking up the *old* Id; it's not really attached to the new id
208 Note, though that the substitution isn't necessarily extended
209 if the type changes. Why not? Because of the next point:
211 * We *always, always* finish by looking up in the in-scope set
212 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
213 Reason: so that we never finish up with a "old" Id in the result.
214 An old Id might point to an old unfolding and so on... which gives a space leak.
216 [The DoneEx and DoneVar hits map to "new" stuff.]
218 * It follows that substExpr must not do a no-op if the substitution is empty.
219 substType is free to do so, however.
221 * When we come to a let-binding (say) we generate new IdInfo, including an
222 unfolding, attach it to the binder, and add this newly adorned binder to
223 the in-scope set. So all subsequent occurrences of the binder will get mapped
224 to the full-adorned binder, which is also the one put in the binding site.
226 * The in-scope "set" usually maps x->x; we use it simply for its domain.
227 But sometimes we have two in-scope Ids that are synomyms, and should
228 map to the same target: x->x, y->x. Notably:
230 That's why the "set" is actually a VarEnv Var
234 isEmptySubst :: Subst -> Bool
235 isEmptySubst (Subst _ env) = isEmptySubstEnv env
238 emptySubst = Subst emptyInScopeSet emptySubstEnv
240 mkSubst :: InScopeSet -> SubstEnv -> Subst
241 mkSubst in_scope env = Subst in_scope env
243 substEnv :: Subst -> SubstEnv
244 substEnv (Subst _ env) = env
246 substInScope :: Subst -> InScopeSet
247 substInScope (Subst in_scope _) = in_scope
249 zapSubstEnv :: Subst -> Subst
250 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
252 extendSubst :: Subst -> Var -> SubstResult -> Subst
253 extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
255 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
256 extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
258 lookupSubst :: Subst -> Var -> Maybe SubstResult
259 lookupSubst (Subst _ env) v = lookupSubstEnv env v
261 lookupIdSubst :: Subst -> Id -> SubstResult
262 -- Does the lookup in the in-scope set too
263 lookupIdSubst (Subst in_scope env) v
264 = case lookupSubstEnv env v of
265 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
267 Nothing -> DoneId v' (idOccInfo v')
268 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
269 -- very important! If isFragileOcc returned True for
270 -- loop breakers we could avoid this call, but at the expense
271 -- of adding more to the substitution, and building new Ids
272 -- in substId a bit more often than really necessary
274 v' = lookupInScope in_scope v
276 isInScope :: Var -> Subst -> Bool
277 isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
279 modifyInScope :: Subst -> Var -> Var -> Subst
280 modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
281 -- make old_v map to new_v
283 extendInScope :: Subst -> Var -> Subst
284 -- Add a new variable as in-scope
285 -- Remember to delete any existing binding in the substitution!
286 extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
287 (env `delSubstEnv` v)
289 extendInScopeList :: Subst -> [Var] -> Subst
290 extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
291 (delSubstEnvList env vs)
293 -- The "New" variants are guaranteed to be adding freshly-allocated variables
294 -- It's not clear that the gain (not needing to delete it from the substitution)
295 -- is worth the extra proof obligation
296 extendNewInScope :: Subst -> Var -> Subst
297 extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
299 extendNewInScopeList :: Subst -> [Var] -> Subst
300 extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
302 -------------------------------
303 bindSubst :: Subst -> Var -> Var -> Subst
304 -- Extend with a substitution, v1 -> Var v2
305 -- and extend the in-scopes with v2
306 bindSubst (Subst in_scope env) old_bndr new_bndr
307 = Subst (in_scope `extendInScopeSet` new_bndr)
308 (extendSubstEnv env old_bndr subst_result)
310 subst_result | isId old_bndr = DoneEx (Var new_bndr)
311 | otherwise = DoneTy (TyVarTy new_bndr)
313 unBindSubst :: Subst -> Var -> Var -> Subst
314 -- Reverse the effect of bindSubst
315 -- If old_bndr was already in the substitution, this doesn't quite work
316 unBindSubst (Subst in_scope env) old_bndr new_bndr
317 = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
319 -- And the "List" forms
320 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
321 bindSubstList subst old_bndrs new_bndrs
322 = foldl2 bindSubst subst old_bndrs new_bndrs
324 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
325 unBindSubstList subst old_bndrs new_bndrs
326 = foldl2 unBindSubst subst old_bndrs new_bndrs
329 -------------------------------
330 setInScope :: Subst -- Take env part from here
333 setInScope (Subst in_scope1 env1) in_scope2
334 = Subst in_scope2 env1
336 setSubstEnv :: Subst -- Take in-scope part from here
337 -> SubstEnv -- ... and env part from here
339 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
342 Pretty printing, for debugging only
345 instance Outputable SubstResult where
346 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
347 ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
348 ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
349 ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t
351 instance Outputable SubstEnv where
352 ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
354 ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
356 instance Outputable Subst where
357 ppr (Subst (InScope in_scope _) se)
358 = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope)))
359 $$ ptext SLIT(" Subst =") <+> ppr se <> char '>'
362 %************************************************************************
364 \subsection{Type substitution}
366 %************************************************************************
369 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
370 -- (We could have a variant of Subst, but it doesn't seem worth it.)
372 -- mkTyVarSubst generates the in-scope set from
373 -- the types given; but it's just a thunk so with a bit of luck
374 -- it'll never be evaluated
375 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
376 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
377 (zipTyEnv tyvars tys)
379 -- mkTopTyVarSubst is called when doing top-level substitutions.
380 -- Here we expect that the free vars of the range of the
381 -- substitution will be empty.
382 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
383 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
387 | length tyvars /= length tys
388 = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
391 = zip_ty_env tyvars tys emptySubstEnv
393 zip_ty_env [] [] env = env
394 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
395 -- There used to be a special case for when
397 -- (a not-uncommon case) in which case the substitution was dropped.
398 -- But the type-tidier changes the print-name of a type variable without
399 -- changing the unique, and that led to a bug. Why? Pre-tidying, we had
400 -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype.
401 -- And it happened that t was the type variable of the class. Post-tiding,
402 -- it got turned into {Foo t2}. The ext-core printer expanded this using
403 -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
404 -- and so generated a rep type mentioning t not t2.
406 -- Simplest fix is to nuke the "optimisation"
409 substTy works with general Substs, so that it can be called from substExpr too.
412 substTyWith :: [TyVar] -> [Type] -> Type -> Type
413 substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
415 substTy :: Subst -> Type -> Type
416 substTy subst ty | isEmptySubst subst = ty
417 | otherwise = subst_ty subst ty
419 deShadowTy :: Type -> Type -- Remove any shadowing from the type
420 deShadowTy ty = subst_ty emptySubst ty
422 substTheta :: TyVarSubst -> ThetaType -> ThetaType
423 substTheta subst theta
424 | isEmptySubst subst = theta
425 | otherwise = map (substPred subst) theta
427 substPred :: TyVarSubst -> PredType -> PredType
428 substPred = substSourceType
430 substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty)
431 substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
432 substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys)
437 go (TyConApp tc tys) = let args = map go tys
438 in args `seqList` TyConApp tc args
440 go (SourceTy p) = SourceTy $! (substSourceType subst p)
442 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
443 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
445 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
446 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
447 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
449 Just (DoneTy ty') -> ty'
451 go (ForAllTy tv ty) = case substTyVar subst tv of
452 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
455 Here is where we invent a new binder if necessary.
458 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
459 substTyVar subst@(Subst in_scope env) old_var
460 | old_var == new_var -- No need to clone
461 -- But we *must* zap any current substitution for the variable.
463 -- (\x.e) with id_subst = [x |-> e']
464 -- Here we must simply zap the substitution for x
466 -- The new_id isn't cloned, but it may have a different type
467 -- etc, so we must return it, not the old id
468 = (Subst (in_scope `extendInScopeSet` new_var)
469 (delSubstEnv env old_var),
472 | otherwise -- The new binder is in scope so
473 -- we'd better rename it away from the in-scope variables
474 -- Extending the substitution to do this renaming also
475 -- has the (correct) effect of discarding any existing
476 -- substitution for that variable
477 = (Subst (in_scope `extendInScopeSet` new_var)
478 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
481 new_var = uniqAway in_scope old_var
482 -- The uniqAway part makes sure the new variable is not already in scope
486 %************************************************************************
488 \section{Expression substitution}
490 %************************************************************************
492 This expression substituter deals correctly with name capture.
494 BUT NOTE that substExpr silently discards the
497 IdInfo attached to any binders in the expression. It's quite
498 tricky to do them 'right' in the case of mutually recursive bindings,
499 and so far has proved unnecessary.
502 substExpr :: Subst -> CoreExpr -> CoreExpr
504 -- NB: we do not do a no-op when the substitution is empty,
505 -- because we always want to substitute the variables in the
506 -- in-scope set for their occurrences. Why?
507 -- (a) because they may contain more information
508 -- (b) because leaving an un-substituted Id might cause
509 -- a space leak (its unfolding might point to an old version
510 -- of its right hand side).
514 go (Var v) = -- See the notes at the top, with the Subst data type declaration
515 case lookupIdSubst subst v of
517 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
521 go (Type ty) = Type (go_ty ty)
522 go (Lit lit) = Lit lit
523 go (App fun arg) = App (go fun) (go arg)
524 go (Note note e) = Note (go_note note) (go e)
526 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
528 (subst', bndr') = substBndr subst bndr
530 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
532 (subst', bndr') = substBndr subst bndr
534 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
536 (subst', bndrs') = substRecBndrs subst (map fst pairs)
537 pairs' = bndrs' `zip` rhss'
538 rhss' = map (substExpr subst' . snd) pairs
540 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
542 (subst', bndr') = substBndr subst bndr
544 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
546 (subst', bndrs') = substBndrs subst bndrs
548 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
551 go_ty ty = substTy subst ty
556 %************************************************************************
558 \section{Substituting an Id binder}
560 %************************************************************************
563 -- simplBndr and simplLetId are used by the simplifier
565 simplBndr :: Subst -> Var -> (Subst, Var)
566 -- Used for lambda and case-bound variables
567 -- Clone Id if necessary, substitute type
568 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
569 -- The substitution is extended only if the variable is cloned, because
570 -- we *don't* need to use it to track occurrence info.
572 | isTyVar bndr = substTyVar subst bndr
573 | otherwise = subst_id False subst subst bndr
575 simplBndrs :: Subst -> [Var] -> (Subst, [Var])
576 simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
578 simplLamBndr :: Subst -> Var -> (Subst, Var)
579 -- Used for lambda binders. These sometimes have unfoldings added by
580 -- the worker/wrapper pass that must be preserved, becuase they can't
581 -- be reconstructed from context. For example:
582 -- f x = case x of (a,b) -> fw a b x
583 -- fw a b x{=(a,b)} = ...
584 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
585 simplLamBndr subst bndr
586 | not (isId bndr && hasSomeUnfolding old_unf)
587 = simplBndr subst bndr -- Normal case
589 = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
591 old_unf = idUnfolding bndr
592 (subst', bndr') = subst_id False subst subst bndr
595 simplLetId :: Subst -> Id -> (Subst, Id)
596 -- Clone Id if necessary
597 -- Substitute its type
598 -- Return an Id with completely zapped IdInfo
599 -- [A subsequent substIdInfo will restore its IdInfo]
600 -- Augment the subtitution
601 -- if the unique changed, *or*
602 -- if there's interesting occurrence info
604 simplLetId subst@(Subst in_scope env) old_id
605 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
607 old_info = idInfo old_id
608 id1 = uniqAway in_scope old_id
609 id2 = substIdType subst id1
610 new_id = setIdInfo id2 vanillaIdInfo
612 -- Extend the substitution if the unique has changed,
613 -- or there's some useful occurrence information
614 -- See the notes with substTyVar for the delSubstEnv
615 occ_info = occInfo old_info
616 new_env | new_id /= old_id || isFragileOcc occ_info
617 = extendSubstEnv env old_id (DoneId new_id occ_info)
619 = delSubstEnv env old_id
621 simplIdInfo :: Subst -> IdInfo -> IdInfo
622 -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
623 -- subsequent to simplLetId having zapped its IdInfo
624 simplIdInfo subst old_info
625 = case substIdInfo False subst old_info of
626 Just new_info -> new_info
631 -- substBndr and friends are used when doing expression substitution only
632 -- In this case we can *preserve* occurrence information, and indeed we *want*
633 -- to do so else lose useful occ info in rules. Hence the calls to
634 -- simpl_id with keepOccInfo
636 substBndr :: Subst -> Var -> (Subst, Var)
638 | isTyVar bndr = substTyVar subst bndr
639 | otherwise = subst_id True {- keep fragile info -} subst subst bndr
641 substBndrs :: Subst -> [Var] -> (Subst, [Var])
642 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
644 substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
645 -- Substitute a mutually recursive group
646 substRecBndrs subst bndrs
647 = (new_subst, new_bndrs)
649 -- Here's the reason we need to pass rec_subst to subst_id
650 (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
653 keepOccInfo occ = False -- Never fragile
658 subst_id :: Bool -- True <=> keep fragile info
659 -> Subst -- Substitution to use for the IdInfo
660 -> Subst -> Id -- Substitition and Id to transform
661 -> (Subst, Id) -- Transformed pair
664 -- * Unique changed if necessary
665 -- * Type substituted
666 -- * Unfolding zapped
667 -- * Rules, worker, lbvar info all substituted
668 -- * Occurrence info zapped if is_fragile_occ returns True
669 -- * The in-scope set extended with the returned Id
670 -- * The substitution extended with a DoneId if unique changed
671 -- In this case, the var in the DoneId is the same as the
674 subst_id keep_fragile rec_subst subst@(Subst in_scope env) old_id
675 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
677 -- id1 is cloned if necessary
678 id1 = uniqAway in_scope old_id
680 -- id2 has its type zapped
681 id2 = substIdType subst id1
683 -- new_id has the right IdInfo
684 -- The lazy-set is because we're in a loop here, with
685 -- rec_subst, when dealing with a mutually-recursive group
686 new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_subst) id2
688 -- Extend the substitution if the unique has changed
689 -- See the notes with substTyVar for the delSubstEnv
690 new_env | new_id /= old_id
691 = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
693 = delSubstEnv env old_id
696 Now a variant that unconditionally allocates a new unique.
697 It also unconditionally zaps the OccInfo.
700 subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
701 -> Subst -> (Id, Unique) -- Substitition and Id to transform
702 -> (Subst, Id) -- Transformed pair
704 subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
705 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
707 id1 = setVarUnique old_id uniq
708 id2 = substIdType subst id1
710 new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
711 new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
713 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
714 substAndCloneIds subst us ids
715 = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
717 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
718 substAndCloneRecIds subst us ids
721 (subst', ids') = mapAccumL (subst_clone_id subst') subst
722 (ids `zip` uniqsFromSupply us)
724 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
725 substAndCloneId subst@(Subst in_scope env) us old_id
726 = subst_clone_id subst subst (old_id, uniqFromSupply us)
730 %************************************************************************
732 \section{IdInfo substitution}
734 %************************************************************************
737 substIdInfo :: Bool -- True <=> keep even fragile info
741 -- The keep_fragile flag is True when we are running a simple expression
742 -- substitution that preserves all structure, so that arity and occurrence
743 -- info are unaffected. The False state is used more often.
750 -- If keep_fragile then
754 -- keep only 'robust' OccInfo
757 -- Seq'ing on the returned IdInfo is enough to cause all the
758 -- substitutions to happen completely
760 substIdInfo keep_fragile subst info
761 | nothing_to_do = Nothing
762 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
763 `setArityInfo` (if keep_arity then old_arity else unknownArity)
764 `setSpecInfo` substRules subst old_rules
765 `setWorkerInfo` substWorker subst old_wrkr
766 `setUnfoldingInfo` noUnfolding)
767 -- setSpecInfo does a seq
768 -- setWorkerInfo does a seq
770 nothing_to_do = keep_occ && keep_arity &&
771 isEmptyCoreRules old_rules &&
772 not (workerExists old_wrkr) &&
773 not (hasUnfolding (unfoldingInfo info))
775 keep_occ = keep_fragile || not (isFragileOcc old_occ)
776 keep_arity = keep_fragile || old_arity == unknownArity
777 old_arity = arityInfo info
778 old_occ = occInfo info
779 old_rules = specInfo info
780 old_wrkr = workerInfo info
783 substIdType :: Subst -> Id -> Id
784 substIdType subst@(Subst in_scope env) id
785 | noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
786 | otherwise = setIdType id (substTy subst old_ty)
787 -- The tyVarsOfType is cheaper than it looks
788 -- because we cache the free tyvars of the type
789 -- in a Note in the id's type itself
794 substWorker :: Subst -> WorkerInfo -> WorkerInfo
795 -- Seq'ing on the returned WorkerInfo is enough to cause all the
796 -- substitutions to happen completely
798 substWorker subst NoWorker
800 substWorker subst (HasWorker w a)
801 = case lookupIdSubst subst w of
802 (DoneId w1 _) -> HasWorker w1 a
803 (DoneEx (Var w1)) -> HasWorker w1 a
804 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
805 NoWorker -- Worker has got substituted away altogether
806 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
810 substUnfolding subst NoUnfolding = NoUnfolding
811 substUnfolding subst (OtherCon cons) = OtherCon cons
812 substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
813 substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
816 substRules :: Subst -> CoreRules -> CoreRules
817 -- Seq'ing on the returned CoreRules is enough to cause all the
818 -- substitutions to happen completely
820 substRules subst rules
821 | isEmptySubst subst = rules
823 substRules subst (Rules rules rhs_fvs)
824 = seqRules new_rules `seq` new_rules
826 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
828 do_subst rule@(BuiltinRule _ _) = rule
829 do_subst (Rule name act tpl_vars lhs_args rhs)
830 = Rule name act tpl_vars'
831 (map (substExpr subst') lhs_args)
832 (substExpr subst' rhs)
834 (subst', tpl_vars') = substBndrs subst tpl_vars
837 substVarSet subst fvs
838 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
840 subst_fv subst fv = case lookupIdSubst subst fv of
841 DoneId fv' _ -> unitVarSet fv'
842 DoneEx expr -> exprFreeVars expr
843 DoneTy ty -> tyVarsOfType ty
844 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)