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 substBndr, substBndrs, substTyVar, substId, substIds,
27 substAndCloneId, substAndCloneIds,
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
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, setIdType, idOccInfo, zapFragileIdInfo, maybeModifyIdInfo )
53 import IdInfo ( IdInfo, isFragileOcc,
54 specInfo, setSpecInfo,
55 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
56 lbvarInfo, LBVarInfo(..), setLBVarInfo
58 import Unique ( Uniquable(..), deriveUnique )
59 import UniqSet ( elemUniqSet_Directly )
60 import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
61 import Var ( Var, Id, TyVar, isTyVar )
63 import PprCore () -- Instances
64 import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
65 import Util ( mapAccumL, foldl2, seqList )
70 %************************************************************************
72 \subsection{The in-scope set}
74 %************************************************************************
77 data InScopeSet = InScope (VarEnv Var) FastInt
78 -- The Int# is a kind of hash-value used by uniqAway
79 -- For example, it might be the size of the set
80 -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
82 emptyInScopeSet :: InScopeSet
83 emptyInScopeSet = InScope emptyVarSet 1#
85 mkInScopeSet :: VarEnv Var -> InScopeSet
86 mkInScopeSet in_scope = InScope in_scope 1#
88 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
89 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
91 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
92 extendInScopeSetList (InScope in_scope n) vs
93 = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
94 (n +# iUnbox (length vs))
96 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
97 -- Exploit the fact that the in-scope "set" is really a map
98 -- Make old_v map to new_v
99 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
101 delInScopeSet :: InScopeSet -> Var -> InScopeSet
102 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
104 elemInScopeSet :: Var -> InScopeSet -> Bool
105 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
107 lookupInScope :: InScopeSet -> Var -> Var
108 -- It's important to look for a fixed point
109 -- When we see (case x of y { I# v -> ... })
110 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
111 -- When we lookup up an occurrence of x, we map to y, but then
112 -- we want to look up y in case it has acquired more evaluation information by now.
113 lookupInScope (InScope in_scope n) v
116 go v = case lookupVarEnv in_scope v of
117 Just v' | v == v' -> v' -- Reached a fixed point
119 Nothing -> WARN( mustHaveLocalBinding v, ppr v )
124 uniqAway :: InScopeSet -> Var -> Var
125 -- (uniqAway in_scope v) finds a unique that is not used in the
126 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
127 -- in the hope that it won't have to change it, nad thereafter uses a combination
128 -- of that and the hash-code found in the in-scope set
129 uniqAway (InScope set n) var
130 | not (var `elemVarSet` set) = var -- Nothing to do
133 orig_unique = getUnique var
137 = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
139 | uniq `elemUniqSet_Directly` set = try (k +# 1#)
141 | opt_PprStyle_Debug && k ># 3#
142 = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
143 setVarUnique var uniq
145 | otherwise = setVarUnique var uniq
147 uniq = deriveUnique orig_unique (iBox (n *# k))
151 %************************************************************************
153 \subsection{Substitutions}
155 %************************************************************************
158 data Subst = Subst InScopeSet -- In scope
159 SubstEnv -- Substitution itself
160 -- INVARIANT 1: The (domain of the) in-scope set is a superset
161 -- of the free vars of the range of the substitution
162 -- that might possibly clash with locally-bound variables
163 -- in the thing being substituted in.
164 -- This is what lets us deal with name capture properly
165 -- It's a hard invariant to check...
166 -- There are various ways of causing it to happen:
167 -- - arrange that the in-scope set really is all the things in scope
168 -- - arrange that it's the free vars of the range of the substitution
169 -- - make it empty because all the free vars of the subst are fresh,
170 -- and hence can't possibly clash.a
172 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
173 -- Equivalently, the substitution is idempotent
174 -- [Sep 2000: Lies, all lies. The substitution now does contain
175 -- mappings x77 -> DoneId x77 occ
176 -- to record x's occurrence information.]
177 -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
178 -- Consider let x = case k of I# x77 -> ... in
179 -- let y = case k of I# x77 -> ... in ...
180 -- and suppose the body is strict in both x and y. Then the simplifier
181 -- will pull the first (case k) to the top; so the second (case k) will
182 -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
183 -- other is an out-Id. So the substitution is idempotent in the sense
184 -- that we *must not* repeatedly apply it.]
189 The general plan about the substitution and in-scope set for Ids is as follows
191 * substId always adds new_id to the in-scope set.
192 new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
193 That is added back in later. So new_id is the minimal thing it's
194 correct to substitute.
196 * substId adds a binding (DoneId new_id occ) to the substitution if
197 EITHER the Id's unique has changed
198 OR the Id has interesting occurrence information
199 So in effect you can only get to interesting occurrence information
200 by looking up the *old* Id; it's not really attached to the new id
203 Note, though that the substitution isn't necessarily extended
204 if the type changes. Why not? Because of the next point:
206 * We *always, always* finish by looking up in the in-scope set
207 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
208 Reason: so that we never finish up with a "old" Id in the result.
209 An old Id might point to an old unfolding and so on... which gives a space leak.
211 [The DoneEx and DoneVar hits map to "new" stuff.]
213 * It follows that substExpr must not do a no-op if the substitution is empty.
214 substType is free to do so, however.
216 * When we come to a let-binding (say) we generate new IdInfo, including an
217 unfolding, attach it to the binder, and add this newly adorned binder to
218 the in-scope set. So all subsequent occurrences of the binder will get mapped
219 to the full-adorned binder, which is also the one put in the binding site.
221 * The in-scope "set" usually maps x->x; we use it simply for its domain.
222 But sometimes we have two in-scope Ids that are synomyms, and should
223 map to the same target: x->x, y->x. Notably:
225 That's why the "set" is actually a VarEnv Var
229 isEmptySubst :: Subst -> Bool
230 isEmptySubst (Subst _ env) = isEmptySubstEnv env
233 emptySubst = Subst emptyInScopeSet emptySubstEnv
235 mkSubst :: InScopeSet -> SubstEnv -> Subst
236 mkSubst in_scope env = Subst in_scope env
238 substEnv :: Subst -> SubstEnv
239 substEnv (Subst _ env) = env
241 substInScope :: Subst -> InScopeSet
242 substInScope (Subst in_scope _) = in_scope
244 zapSubstEnv :: Subst -> Subst
245 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
247 extendSubst :: Subst -> Var -> SubstResult -> Subst
248 extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
249 Subst in_scope (extendSubstEnv env v r)
251 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
252 extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
253 Subst in_scope (extendSubstEnvList env v r)
255 lookupSubst :: Subst -> Var -> Maybe SubstResult
256 lookupSubst (Subst _ env) v = lookupSubstEnv env v
258 lookupIdSubst :: Subst -> Id -> SubstResult
259 -- Does the lookup in the in-scope set too
260 lookupIdSubst (Subst in_scope env) v
261 = case lookupSubstEnv env v of
262 Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
264 Nothing -> DoneId v' (idOccInfo v')
265 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
266 -- very important! If isFragileOcc returned True for
267 -- loop breakers we could avoid this call, but at the expense
268 -- of adding more to the substitution, and building new Ids
269 -- in substId a bit more often than really necessary
271 v' = lookupInScope in_scope v
273 isInScope :: Var -> Subst -> Bool
274 isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
276 modifyInScope :: Subst -> Var -> Var -> Subst
277 modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
278 -- make old_v map to new_v
280 extendInScope :: Subst -> Var -> Subst
281 -- Add a new variable as in-scope
282 -- Remember to delete any existing binding in the substitution!
283 extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
284 (env `delSubstEnv` v)
286 extendInScopeList :: Subst -> [Var] -> Subst
287 extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
288 (delSubstEnvList env vs)
290 -- The "New" variants are guaranteed to be adding freshly-allocated variables
291 -- It's not clear that the gain (not needing to delete it from the substitution)
292 -- is worth the extra proof obligation
293 extendNewInScope :: Subst -> Var -> Subst
294 extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
296 extendNewInScopeList :: Subst -> [Var] -> Subst
297 extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
299 -------------------------------
300 bindSubst :: Subst -> Var -> Var -> Subst
301 -- Extend with a substitution, v1 -> Var v2
302 -- and extend the in-scopes with v2
303 bindSubst (Subst in_scope env) old_bndr new_bndr
304 = Subst (in_scope `extendInScopeSet` new_bndr)
305 (extendSubstEnv env old_bndr subst_result)
307 subst_result | isId old_bndr = DoneEx (Var new_bndr)
308 | otherwise = DoneTy (TyVarTy new_bndr)
310 unBindSubst :: Subst -> Var -> Var -> Subst
311 -- Reverse the effect of bindSubst
312 -- If old_bndr was already in the substitution, this doesn't quite work
313 unBindSubst (Subst in_scope env) old_bndr new_bndr
314 = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
316 -- And the "List" forms
317 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
318 bindSubstList subst old_bndrs new_bndrs
319 = foldl2 bindSubst subst old_bndrs new_bndrs
321 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
322 unBindSubstList subst old_bndrs new_bndrs
323 = foldl2 unBindSubst subst old_bndrs new_bndrs
326 -------------------------------
327 setInScope :: Subst -- Take env part from here
330 setInScope (Subst in_scope1 env1) in_scope2
331 = Subst in_scope2 env1
333 setSubstEnv :: Subst -- Take in-scope part from here
334 -> SubstEnv -- ... and env part from here
336 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
339 Pretty printing, for debugging only
342 instance Outputable SubstResult where
343 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
344 ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
345 ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
346 ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t
348 instance Outputable SubstEnv where
349 ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
351 ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
353 instance Outputable Subst where
354 ppr (Subst (InScope in_scope _) se)
355 = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope)))
356 $$ ptext SLIT(" Subst =") <+> ppr se <> char '>'
359 %************************************************************************
361 \subsection{Type substitution}
363 %************************************************************************
366 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
367 -- (We could have a variant of Subst, but it doesn't seem worth it.)
369 -- mkTyVarSubst generates the in-scope set from
370 -- the types given; but it's just a thunk so with a bit of luck
371 -- it'll never be evaluated
372 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
373 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) (zip_ty_env tyvars tys emptySubstEnv)
375 -- mkTopTyVarSubst is called when doing top-level substitutions.
376 -- Here we expect that the free vars of the range of the
377 -- substitution will be empty.
378 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
379 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
381 zip_ty_env [] [] env = env
382 zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) )
383 zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
386 substTy works with general Substs, so that it can be called from substExpr too.
389 substTy :: Subst -> Type -> Type
390 substTy subst ty | isEmptySubst subst = ty
391 | otherwise = subst_ty subst ty
393 substClasses :: TyVarSubst -> ClassContext -> ClassContext
394 substClasses subst theta
395 | isEmptySubst subst = theta
396 | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
398 substTheta :: TyVarSubst -> ThetaType -> ThetaType
399 substTheta subst theta
400 | isEmptySubst subst = theta
401 | otherwise = map (substPred subst) theta
403 substPred :: TyVarSubst -> PredType -> PredType
404 substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
405 substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
410 go (TyConApp tc tys) = let args = map go tys
411 in args `seqList` TyConApp tc args
413 go (PredTy p) = PredTy $! (substPred subst p)
415 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
416 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
418 go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
419 go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
420 go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
422 Just (DoneTy ty') -> ty'
424 go (ForAllTy tv ty) = case substTyVar subst tv of
425 (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
427 go (UsageTy u ty) = mkUTy (go u) $! (go ty)
430 Here is where we invent a new binder if necessary.
433 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
434 substTyVar subst@(Subst in_scope env) old_var
435 | old_var == new_var -- No need to clone
436 -- But we *must* zap any current substitution for the variable.
438 -- (\x.e) with id_subst = [x |-> e']
439 -- Here we must simply zap the substitution for x
441 -- The new_id isn't cloned, but it may have a different type
442 -- etc, so we must return it, not the old id
443 = (Subst (in_scope `extendInScopeSet` new_var)
444 (delSubstEnv env old_var),
447 | otherwise -- The new binder is in scope so
448 -- we'd better rename it away from the in-scope variables
449 -- Extending the substitution to do this renaming also
450 -- has the (correct) effect of discarding any existing
451 -- substitution for that variable
452 = (Subst (in_scope `extendInScopeSet` new_var)
453 (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
456 new_var = uniqAway in_scope old_var
457 -- The uniqAway part makes sure the new variable is not already in scope
461 %************************************************************************
463 \section{Expression substitution}
465 %************************************************************************
467 This expression substituter deals correctly with name capture.
469 BUT NOTE that substExpr silently discards the
472 IdInfo attached to any binders in the expression. It's quite
473 tricky to do them 'right' in the case of mutually recursive bindings,
474 and so far has proved unnecessary.
477 substExpr :: Subst -> CoreExpr -> CoreExpr
479 -- NB: we do not do a no-op when the substitution is empty,
480 -- because we always want to substitute the variables in the
481 -- in-scope set for their occurrences. Why?
482 -- (a) because they may contain more information
483 -- (b) because leaving an un-substituted Id might cause
484 -- a space leak (its unfolding might point to an old version
485 -- of its right hand side).
489 go (Var v) = -- See the notes at the top, with the Subst data type declaration
490 case lookupIdSubst subst v of
492 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
496 go (Type ty) = Type (go_ty ty)
497 go (Lit lit) = Lit lit
498 go (App fun arg) = App (go fun) (go arg)
499 go (Note note e) = Note (go_note note) (go e)
501 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
503 (subst', bndr') = substBndr subst bndr
505 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
507 (subst', bndr') = substBndr subst bndr
509 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
511 (subst', bndrs') = substBndrs subst (map fst pairs)
512 pairs' = bndrs' `zip` rhss'
513 rhss' = map (substExpr subst' . snd) pairs
515 go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
517 (subst', bndr') = substBndr subst bndr
519 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
521 (subst', bndrs') = substBndrs subst bndrs
523 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
526 go_ty ty = substTy subst ty
530 Substituting in binders is a rather tricky part of the whole compiler.
532 When we hit a binder we may need to
533 (a) apply the the type envt (if non-empty) to its type
534 (c) give it a new unique to avoid name clashes
537 substBndr :: Subst -> Var -> (Subst, Var)
539 | isTyVar bndr = substTyVar subst bndr
540 | otherwise = substId subst bndr
542 substBndrs :: Subst -> [Var] -> (Subst, [Var])
543 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
546 substIds :: Subst -> [Id] -> (Subst, [Id])
547 substIds subst bndrs = mapAccumL substId subst bndrs
549 substId :: Subst -> Id -> (Subst, Id)
550 -- Returns an Id with empty IdInfo
551 -- See the notes with the Subst data type decl at the
552 -- top of this module
554 substId subst@(Subst in_scope env) old_id
555 = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
557 id_ty = idType old_id
558 occ_info = idOccInfo old_id
560 -- id1 has its type zapped
561 id1 | noTypeSubst env
562 || isEmptyVarSet (tyVarsOfType id_ty) = old_id
563 -- The tyVarsOfType is cheaper than it looks
564 -- because we cache the free tyvars of the type
565 -- in a Note in the id's type itself
566 | otherwise = setIdType old_id (substTy subst id_ty)
568 -- id2 has its IdInfo zapped
569 id2 = zapFragileIdInfo id1
571 -- id3 has its LBVarInfo zapped
572 id3 = maybeModifyIdInfo (\ info -> go info (lbvarInfo info)) id2
573 where go info (LBVarInfo u@(TyVarTy _)) = Just $ setLBVarInfo info $
574 LBVarInfo (subst_ty subst u)
577 -- new_id is cloned if necessary
578 new_id = uniqAway in_scope id3
579 -- Extend the substitution if the unique has changed,
580 -- or there's some useful occurrence information
581 -- See the notes with substTyVar for the delSubstEnv
582 new_env | new_id /= old_id || isFragileOcc occ_info
583 = extendSubstEnv env old_id (DoneId new_id occ_info)
585 = delSubstEnv env old_id
588 Now a variant that unconditionally allocates a new unique.
591 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
592 substAndCloneIds subst us [] = (subst, us, [])
593 substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
594 case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
595 (subst2, us2, (b':bs')) }}
597 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
598 substAndCloneId subst@(Subst in_scope env) us old_id
599 = (Subst (in_scope `extendInScopeSet` new_id)
600 (extendSubstEnv env old_id (DoneEx (Var new_id))),
604 id_ty = idType old_id
605 id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
606 | otherwise = setIdType old_id (substTy subst id_ty)
608 id2 = zapFragileIdInfo id1
609 new_id = setVarUnique id2 (uniqFromSupply us1)
610 (us1,new_us) = splitUniqSupply us
614 %************************************************************************
616 \section{IdInfo substitution}
618 %************************************************************************
622 -> IdInfo -- Get un-substituted ones from here
623 -> IdInfo -- Substitute it and add it to here
624 -> IdInfo -- To give this
625 -- Seq'ing on the returned IdInfo is enough to cause all the
626 -- substitutions to happen completely
628 substIdInfo subst old_info new_info
631 info1 | isEmptyCoreRules old_rules = new_info
632 | otherwise = new_info `setSpecInfo` new_rules
633 -- setSpecInfo does a seq
635 new_rules = substRules subst old_rules
637 info2 | not (workerExists old_wrkr) = info1
638 | otherwise = info1 `setWorkerInfo` new_wrkr
639 -- setWorkerInfo does a seq
641 new_wrkr = substWorker subst old_wrkr
643 old_rules = specInfo old_info
644 old_wrkr = workerInfo old_info
646 substWorker :: Subst -> WorkerInfo -> WorkerInfo
647 -- Seq'ing on the returned WorkerInfo is enough to cause all the
648 -- substitutions to happen completely
650 substWorker subst NoWorker
652 substWorker subst (HasWorker w a)
653 = case lookupIdSubst subst w of
654 (DoneId w1 _) -> HasWorker w1 a
655 (DoneEx (Var w1)) -> HasWorker w1 a
656 (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
657 NoWorker -- Worker has got substituted away altogether
658 (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
661 substRules :: Subst -> CoreRules -> CoreRules
662 -- Seq'ing on the returned CoreRules is enough to cause all the
663 -- substitutions to happen completely
665 substRules subst rules
666 | isEmptySubst subst = rules
668 substRules subst (Rules rules rhs_fvs)
669 = seqRules new_rules `seq` new_rules
671 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
673 do_subst rule@(BuiltinRule _) = rule
674 do_subst (Rule name tpl_vars lhs_args rhs)
675 = Rule name tpl_vars'
676 (map (substExpr subst') lhs_args)
677 (substExpr subst' rhs)
679 (subst', tpl_vars') = substBndrs subst tpl_vars
681 substVarSet subst fvs
682 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
684 subst_fv subst fv = case lookupIdSubst subst fv of
685 DoneId fv' _ -> unitVarSet fv'
686 DoneEx expr -> exprFreeVars expr
687 DoneTy ty -> tyVarsOfType ty
688 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)