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, simplIdInfo,
27 substAndCloneId, substAndCloneIds, substAndCloneRecIds,
30 mkTyVarSubst, mkTopTyVarSubst,
31 substTy, substClasses, substTheta,
34 substExpr, substIdInfo
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
44 import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
45 import TypeRep ( Type(..), TyNote(..) ) -- friend
46 import Type ( ThetaType, PredType(..), ClassContext,
47 tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
51 import Var ( setVarUnique, isId )
52 import Id ( idType, idInfo, setIdInfo, setIdType, idOccInfo, maybeModifyIdInfo )
53 import IdInfo ( IdInfo, mkIdInfo,
54 occInfo, isFragileOcc, setOccInfo,
55 specInfo, setSpecInfo, flavourInfo,
56 unfoldingInfo, setUnfoldingInfo,
58 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
59 lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
61 import BasicTypes ( OccInfo(..) )
62 import Unique ( Unique, Uniquable(..), deriveUnique )
63 import UniqSet ( elemUniqSet_Directly )
64 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
65 import Var ( Var, Id, TyVar, isTyVar )
67 import PprCore () -- Instances
68 import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
69 import Util ( mapAccumL, foldl2, seqList )
74 %************************************************************************
76 \subsection{The in-scope set}
78 %************************************************************************
81 data InScopeSet = InScope (VarEnv Var) FastInt
82 -- The Int# is a kind of hash-value used by uniqAway
83 -- For example, it might be the size of the set
84 -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
86 emptyInScopeSet :: InScopeSet
87 emptyInScopeSet = InScope emptyVarSet 1#
89 mkInScopeSet :: VarEnv Var -> InScopeSet
90 mkInScopeSet in_scope = InScope in_scope 1#
92 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
93 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
95 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
96 extendInScopeSetList (InScope in_scope n) vs
97 = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
98 (n +# iUnbox (length vs))
100 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
101 -- Exploit the fact that the in-scope "set" is really a map
102 -- Make old_v map to new_v
103 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
105 delInScopeSet :: InScopeSet -> Var -> InScopeSet
106 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
108 elemInScopeSet :: Var -> InScopeSet -> Bool
109 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
111 lookupInScope :: InScopeSet -> Var -> Var
112 -- It's important to look for a fixed point
113 -- When we see (case x of y { I# v -> ... })
114 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
115 -- When we lookup up an occurrence of x, we map to y, but then
116 -- we want to look up y in case it has acquired more evaluation information by now.
117 lookupInScope (InScope in_scope n) v
120 go v = case lookupVarEnv in_scope v of
121 Just v' | v == v' -> v' -- Reached a fixed point
123 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
128 uniqAway :: InScopeSet -> Var -> Var
129 -- (uniqAway in_scope v) finds a unique that is not used in the
130 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
131 -- in the hope that it won't have to change it, nad thereafter uses a combination
132 -- of that and the hash-code found in the in-scope set
133 uniqAway (InScope set n) var
134 | not (var `elemVarSet` set) = var -- Nothing to do
137 orig_unique = getUnique var
141 = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
143 | uniq `elemUniqSet_Directly` set = try (k +# 1#)
145 | opt_PprStyle_Debug && k ># 3#
146 = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
147 setVarUnique var uniq
149 | otherwise = setVarUnique var uniq
151 uniq = deriveUnique orig_unique (iBox (n *# k))
155 %************************************************************************
157 \subsection{Substitutions}
159 %************************************************************************
162 data Subst = Subst InScopeSet -- In scope
163 SubstEnv -- Substitution itself
164 -- INVARIANT 1: The (domain of the) in-scope set is a superset
165 -- of the free vars of the range of the substitution
166 -- that might possibly clash with locally-bound variables
167 -- in the thing being substituted in.
168 -- This is what lets us deal with name capture properly
169 -- It's a hard invariant to check...
170 -- There are various ways of causing it to happen:
171 -- - arrange that the in-scope set really is all the things in scope
172 -- - arrange that it's the free vars of the range of the substitution
173 -- - make it empty because all the free vars of the subst are fresh,
174 -- and hence can't possibly clash.a
176 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
177 -- Equivalently, the substitution is idempotent
178 -- [Sep 2000: Lies, all lies. The substitution now does contain
179 -- mappings x77 -> DoneId x77 occ
180 -- to record x's occurrence information.]
181 -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
182 -- Consider let x = case k of I# x77 -> ... in
183 -- let y = case k of I# x77 -> ... in ...
184 -- and suppose the body is strict in both x and y. Then the simplifier
185 -- will pull the first (case k) to the top; so the second (case k) will
186 -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
187 -- other is an out-Id. So the substitution is idempotent in the sense
188 -- that we *must not* repeatedly apply it.]
193 The general plan about the substitution and in-scope set for Ids is as follows
195 * substId always adds new_id to the in-scope set.
196 new_id has a correctly-substituted type, occ info
198 * substId adds a binding (DoneId new_id occ) to the substitution if
199 EITHER the Id's unique has changed
200 OR the Id has interesting occurrence information
201 So in effect you can only get to interesting occurrence information
202 by looking up the *old* Id; it's not really attached to the new id
205 Note, though that the substitution isn't necessarily extended
206 if the type changes. Why not? Because of the next point:
208 * We *always, always* finish by looking up in the in-scope set
209 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
210 Reason: so that we never finish up with a "old" Id in the result.
211 An old Id might point to an old unfolding and so on... which gives a space leak.
213 [The DoneEx and DoneVar hits map to "new" stuff.]
215 * It follows that substExpr must not do a no-op if the substitution is empty.
216 substType is free to do so, however.
218 * When we come to a let-binding (say) we generate new IdInfo, including an
219 unfolding, attach it to the binder, and add this newly adorned binder to
220 the in-scope set. So all subsequent occurrences of the binder will get mapped
221 to the full-adorned binder, which is also the one put in the binding site.
223 * The in-scope "set" usually maps x->x; we use it simply for its domain.
224 But sometimes we have two in-scope Ids that are synomyms, and should
225 map to the same target: x->x, y->x. Notably:
227 That's why the "set" is actually a VarEnv Var
231 isEmptySubst :: Subst -> Bool
232 isEmptySubst (Subst _ env) = isEmptySubstEnv env
235 emptySubst = Subst emptyInScopeSet emptySubstEnv
237 mkSubst :: InScopeSet -> SubstEnv -> Subst
238 mkSubst in_scope env = Subst in_scope env
240 substEnv :: Subst -> SubstEnv
241 substEnv (Subst _ env) = env
243 substInScope :: Subst -> InScopeSet
244 substInScope (Subst in_scope _) = in_scope
246 zapSubstEnv :: Subst -> Subst
247 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
249 extendSubst :: Subst -> Var -> SubstResult -> Subst
250 extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
251 Subst in_scope (extendSubstEnv env v r)
253 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
254 extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
255 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)) (zip_ty_env tyvars tys emptySubstEnv)
377 -- mkTopTyVarSubst is called when doing top-level substitutions.
378 -- Here we expect that the free vars of the range of the
379 -- substitution will be empty.
380 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
381 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
383 zip_ty_env [] [] env = env
384 zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) )
385 zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
388 substTy works with general Substs, so that it can be called from substExpr too.
391 substTy :: Subst -> Type -> Type
392 substTy subst ty | isEmptySubst subst = ty
393 | otherwise = subst_ty subst ty
395 substClasses :: TyVarSubst -> ClassContext -> ClassContext
396 substClasses subst theta
397 | isEmptySubst subst = theta
398 | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
400 substTheta :: TyVarSubst -> ThetaType -> ThetaType
401 substTheta subst theta
402 | isEmptySubst subst = theta
403 | otherwise = map (substPred subst) theta
405 substPred :: TyVarSubst -> PredType -> PredType
406 substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
407 substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
412 go (TyConApp tc tys) = let args = map go tys
413 in args `seqList` TyConApp tc args
415 go (PredTy p) = PredTy $! (substPred subst p)
417 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
418 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
420 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
421 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
422 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
424 Just (DoneTy ty') -> ty'
426 go (ForAllTy tv ty) = case substTyVar subst tv of
427 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
429 go (UsageTy u ty) = mkUTy (go u) $! (go ty)
432 Here is where we invent a new binder if necessary.
435 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
436 substTyVar subst@(Subst in_scope env) old_var
437 | old_var == new_var -- No need to clone
438 -- But we *must* zap any current substitution for the variable.
440 -- (\x.e) with id_subst = [x |-> e']
441 -- Here we must simply zap the substitution for x
443 -- The new_id isn't cloned, but it may have a different type
444 -- etc, so we must return it, not the old id
445 = (Subst (in_scope `extendInScopeSet` new_var)
446 (delSubstEnv env old_var),
449 | otherwise -- The new binder is in scope so
450 -- we'd better rename it away from the in-scope variables
451 -- Extending the substitution to do this renaming also
452 -- has the (correct) effect of discarding any existing
453 -- substitution for that variable
454 = (Subst (in_scope `extendInScopeSet` new_var)
455 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
458 new_var = uniqAway in_scope old_var
459 -- The uniqAway part makes sure the new variable is not already in scope
463 %************************************************************************
465 \section{Expression substitution}
467 %************************************************************************
469 This expression substituter deals correctly with name capture.
471 BUT NOTE that substExpr silently discards the
474 IdInfo attached to any binders in the expression. It's quite
475 tricky to do them 'right' in the case of mutually recursive bindings,
476 and so far has proved unnecessary.
479 substExpr :: Subst -> CoreExpr -> CoreExpr
481 -- NB: we do not do a no-op when the substitution is empty,
482 -- because we always want to substitute the variables in the
483 -- in-scope set for their occurrences. Why?
484 -- (a) because they may contain more information
485 -- (b) because leaving an un-substituted Id might cause
486 -- a space leak (its unfolding might point to an old version
487 -- of its right hand side).
491 go (Var v) = -- See the notes at the top, with the Subst data type declaration
492 case lookupIdSubst subst v of
494 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
498 go (Type ty) = Type (go_ty ty)
499 go (Lit lit) = Lit lit
500 go (App fun arg) = App (go fun) (go arg)
501 go (Note note e) = Note (go_note note) (go e)
503 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
505 (subst', bndr') = substBndr subst bndr
507 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
509 (subst', bndr') = substBndr subst bndr
511 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
513 (subst', bndrs') = substRecIds subst (map fst pairs)
514 pairs' = bndrs' `zip` rhss'
515 rhss' = map (substExpr subst' . snd) pairs
517 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
519 (subst', bndr') = substBndr subst bndr
521 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
523 (subst', bndrs') = substBndrs subst bndrs
525 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
528 go_ty ty = substTy subst ty
533 %************************************************************************
535 \section{Substituting an Id binder}
537 %************************************************************************
540 -- simplBndr and simplLetId are used by the simplifier
542 simplBndr :: Subst -> Var -> (Subst, Var)
543 -- Used for lambda and case-bound variables
544 -- Clone Id if necessary, substitute type
545 -- Return with IdInfo already substituted,
546 -- but occurrence info zapped
547 -- The substitution is extended only if the variable is cloned, because
548 -- we don't need to use it to track occurrence info.
550 | isTyVar bndr = substTyVar subst bndr
551 | otherwise = subst_id isFragileOcc subst subst bndr
553 simplBndrs :: Subst -> [Var] -> (Subst, [Var])
554 simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
556 simplLetId :: Subst -> Id -> (Subst, Id)
557 -- Clone Id if necessary
558 -- Substitute its type
559 -- Return an Id with completely zapped IdInfo
560 -- Augment the subtitution if the unique changed or if there's
561 -- interesting occurrence info
562 -- [A subsequent substIdInfo will restore its IdInfo]
563 simplLetId subst@(Subst in_scope env) old_id
564 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
566 old_info = idInfo old_id
567 id1 = uniqAway in_scope old_id
568 id2 = substIdType subst id1
569 new_id = id2 `setIdInfo` mkIdInfo (flavourInfo old_info) NoCafRefs
570 -- Zap the IdIno altogether, but preserve the flavour
572 -- Extend the substitution if the unique has changed,
573 -- or there's some useful occurrence information
574 -- See the notes with substTyVar for the delSubstEnv
575 occ_info = occInfo old_info
576 new_env | new_id /= old_id || isFragileOcc occ_info
577 = extendSubstEnv env old_id (DoneId new_id occ_info)
579 = delSubstEnv env old_id
581 simplIdInfo :: Subst -> IdInfo -> Id -> Id
582 -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
583 -- subsequent to simplLetId having zapped its IdInfo
584 simplIdInfo subst old_info bndr
585 = case substIdInfo subst isFragileOcc old_info of
586 Just new_info -> bndr `setIdInfo` new_info
587 Nothing -> bndr `setIdInfo` old_info
591 -- substBndr and friends are used when doing expression substitution only
592 -- In this case we can preserve occurrence information, and indeed we want
593 -- to do so else lose useful occ info in rules. Hence the calls to
594 -- simpl_id with keepOccInfo
596 substBndr :: Subst -> Var -> (Subst, Var)
598 | isTyVar bndr = substTyVar subst bndr
599 | otherwise = subst_id keepOccInfo subst subst bndr
601 substBndrs :: Subst -> [Var] -> (Subst, [Var])
602 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
604 substRecIds :: Subst -> [Id] -> (Subst, [Id])
605 -- Substitute a mutually recursive group
606 substRecIds subst bndrs
607 = (new_subst, new_bndrs)
609 -- Here's the reason we need to pass rec_subst to subst_id
610 (new_subst, new_bndrs) = mapAccumL (subst_id keepOccInfo new_subst) subst bndrs
612 keepOccInfo occ = False -- Never fragile
617 subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile
618 -> Subst -- Substitution to use for the IdInfo
619 -> Subst -> Id -- Substitition and Id to transform
620 -> (Subst, Id) -- Transformed pair
623 -- * Unique changed if necessary
624 -- * Type substituted
625 -- * Unfolding zapped
626 -- * Rules, worker, lbvar info all substituted
627 -- * Occurrence info zapped if is_fragile_occ returns True
628 -- * The in-scope set extended with the returned Id
629 -- * The substitution extended with a DoneId if unique changed
630 -- In this case, the var in the DoneId is the same as the
633 subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
634 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
636 -- id1 is cloned if necessary
637 id1 = uniqAway in_scope old_id
639 -- id2 has its type zapped
640 id2 = substIdType subst id1
642 -- new_id has the right IdInfo
643 -- The lazy-set is because we're in a loop here, with
644 -- rec_subst, when dealing with a mutually-recursive group
645 new_id = maybeModifyIdInfo (substIdInfo rec_subst is_fragile_occ) id2
647 -- Extend the substitution if the unique has changed
648 -- See the notes with substTyVar for the delSubstEnv
649 new_env | new_id /= old_id
650 = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
652 = delSubstEnv env old_id
655 Now a variant that unconditionally allocates a new unique.
656 It also unconditionally zaps the OccInfo.
659 subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
660 -> Subst -> (Id, Unique) -- Substitition and Id to transform
661 -> (Subst, Id) -- Transformed pair
663 subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
664 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
666 id1 = setVarUnique old_id uniq
667 id2 = substIdType subst id1
669 new_id = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
670 new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
672 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
673 substAndCloneIds subst us ids
674 = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply (length ids) us)
676 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
677 substAndCloneRecIds subst us ids
680 (subst', ids') = mapAccumL (subst_clone_id subst') subst
681 (ids `zip` uniqsFromSupply (length ids) us)
683 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
684 substAndCloneId subst@(Subst in_scope env) us old_id
685 = subst_clone_id subst subst (old_id, uniqFromSupply us)
689 %************************************************************************
691 \section{IdInfo substitution}
693 %************************************************************************
697 -> (OccInfo -> Bool) -- True <=> zap the occurrence info
705 -- Zap the occ info if instructed to do so
707 -- Seq'ing on the returned IdInfo is enough to cause all the
708 -- substitutions to happen completely
710 substIdInfo subst is_fragile_occ info
711 | nothing_to_do = Nothing
712 | otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
713 `setSpecInfo` substRules subst old_rules
714 `setWorkerInfo` substWorker subst old_wrkr
715 `setLBVarInfo` substLBVar subst old_lbv
716 `setUnfoldingInfo` noUnfolding)
717 -- setSpecInfo does a seq
718 -- setWorkerInfo does a seq
720 nothing_to_do = not zap_occ &&
721 isEmptyCoreRules old_rules &&
722 not (workerExists old_wrkr) &&
723 hasNoLBVarInfo old_lbv &&
724 not (hasUnfolding (unfoldingInfo info))
726 zap_occ = is_fragile_occ old_occ
727 old_occ = occInfo info
728 old_rules = specInfo info
729 old_wrkr = workerInfo info
730 old_lbv = lbvarInfo info
732 substIdType :: Subst -> Id -> Id
733 substIdType subst@(Subst in_scope env) id
734 | noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
735 | otherwise = setIdType id (substTy subst old_ty)
736 -- The tyVarsOfType is cheaper than it looks
737 -- because we cache the free tyvars of the type
738 -- in a Note in the id's type itself
742 substWorker :: Subst -> WorkerInfo -> WorkerInfo
743 -- Seq'ing on the returned WorkerInfo is enough to cause all the
744 -- substitutions to happen completely
746 substWorker subst NoWorker
748 substWorker subst (HasWorker w a)
749 = case lookupIdSubst subst w of
750 (DoneId w1 _) -> HasWorker w1 a
751 (DoneEx (Var w1)) -> HasWorker w1 a
752 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
753 NoWorker -- Worker has got substituted away altogether
754 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
757 substRules :: Subst -> CoreRules -> CoreRules
758 -- Seq'ing on the returned CoreRules is enough to cause all the
759 -- substitutions to happen completely
761 substRules subst rules
762 | isEmptySubst subst = rules
764 substRules subst (Rules rules rhs_fvs)
765 = seqRules new_rules `seq` new_rules
767 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
769 do_subst rule@(BuiltinRule _) = rule
770 do_subst (Rule name tpl_vars lhs_args rhs)
771 = Rule name tpl_vars'
772 (map (substExpr subst') lhs_args)
773 (substExpr subst' rhs)
775 (subst', tpl_vars') = substBndrs subst tpl_vars
777 substVarSet subst fvs
778 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
780 subst_fv subst fv = case lookupIdSubst subst fv of
781 DoneId fv' _ -> unitVarSet fv'
782 DoneEx expr -> exprFreeVars expr
783 DoneTy ty -> tyVarsOfType ty
784 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
786 substLBVar subst NoLBVarInfo = NoLBVarInfo
787 substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
789 ty1 = substTy subst ty