2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 IdSubstEnv, SubstResult(..),
11 Subst, emptySubst, mkSubst, substInScope, substTy,
12 lookupIdSubst, lookupTvSubst, isEmptySubst,
13 extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
14 zapSubstEnv, setSubstEnv,
15 getTvSubst, getTvSubstEnv, setTvSubstEnv,
18 simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
19 substAndCloneId, substAndCloneIds, substAndCloneRecIds,
21 setInScope, setInScopeSet,
22 extendInScope, extendInScopeIds,
23 isInScope, modifyInScope,
26 substExpr, substRules, substId
29 #include "HsVersions.h"
31 import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
32 CoreRules(..), CoreRule(..),
33 isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
36 import CoreFVs ( exprFreeVars )
37 import CoreUtils ( exprIsTrivial )
39 import qualified Type ( substTy )
40 import Type ( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), substTyVarBndr )
43 import Var ( setVarUnique, isId, mustHaveLocalBinding )
44 import Id ( idType, idInfo, setIdInfo, setIdType,
45 idUnfolding, setIdUnfolding,
46 idOccInfo, maybeModifyIdInfo )
47 import IdInfo ( IdInfo, vanillaIdInfo,
48 occInfo, isFragileOcc, setOccInfo,
49 specInfo, setSpecInfo,
50 setArityInfo, unknownArity, arityInfo,
51 unfoldingInfo, setUnfoldingInfo,
52 WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
54 import BasicTypes ( OccInfo(..) )
55 import Unique ( Unique )
56 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
57 import Var ( Var, Id, TyVar, isTyVar )
59 import PprCore () -- Instances
60 import Util ( mapAccumL )
65 %************************************************************************
67 \subsection{Substitutions}
69 %************************************************************************
73 = Subst InScopeSet -- Variables in in scope (both Ids and TyVars)
74 IdSubstEnv -- Substitution for Ids
75 TvSubstEnv -- Substitution for TyVars
77 -- INVARIANT 1: The (domain of the) in-scope set is a superset
78 -- of the free vars of the range of the substitution
79 -- that might possibly clash with locally-bound variables
80 -- in the thing being substituted in.
81 -- This is what lets us deal with name capture properly
82 -- It's a hard invariant to check...
83 -- There are various ways of causing it to happen:
84 -- - arrange that the in-scope set really is all the things in scope
85 -- - arrange that it's the free vars of the range of the substitution
86 -- - make it empty because all the free vars of the subst are fresh,
87 -- and hence can't possibly clash.a
89 -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
90 -- Equivalently, the substitution is idempotent
91 -- [Sep 2000: Lies, all lies. The substitution now does contain
92 -- mappings x77 -> DoneId x77 occ
93 -- to record x's occurrence information.]
94 -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
95 -- Consider let x = case k of I# x77 -> ... in
96 -- let y = case k of I# x77 -> ... in ...
97 -- and suppose the body is strict in both x and y. Then the simplifier
98 -- will pull the first (case k) to the top; so the second (case k) will
99 -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
100 -- other is an out-Id. So the substitution is idempotent in the sense
101 -- that we *must not* repeatedly apply it.]
104 type IdSubstEnv = IdEnv SubstResult
107 = DoneEx CoreExpr -- Completed term
108 | DoneId Id OccInfo -- Completed term variable, with occurrence info;
109 -- only used by the simplifier
110 | ContEx Subst CoreExpr -- A suspended substitution
113 The general plan about the substitution and in-scope set for Ids is as follows
115 * substId always adds new_id to the in-scope set.
116 new_id has a correctly-substituted type, occ info
118 * substId adds a binding (DoneId new_id occ) to the substitution if
119 EITHER the Id's unique has changed
120 OR the Id has interesting occurrence information
121 So in effect you can only get to interesting occurrence information
122 by looking up the *old* Id; it's not really attached to the new id
125 Note, though that the substitution isn't necessarily extended
126 if the type changes. Why not? Because of the next point:
128 * We *always, always* finish by looking up in the in-scope set
129 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
130 Reason: so that we never finish up with a "old" Id in the result.
131 An old Id might point to an old unfolding and so on... which gives a space leak.
133 [The DoneEx and DoneVar hits map to "new" stuff.]
135 * It follows that substExpr must not do a no-op if the substitution is empty.
136 substType is free to do so, however.
138 * When we come to a let-binding (say) we generate new IdInfo, including an
139 unfolding, attach it to the binder, and add this newly adorned binder to
140 the in-scope set. So all subsequent occurrences of the binder will get mapped
141 to the full-adorned binder, which is also the one put in the binding site.
143 * The in-scope "set" usually maps x->x; we use it simply for its domain.
144 But sometimes we have two in-scope Ids that are synomyms, and should
145 map to the same target: x->x, y->x. Notably:
147 That's why the "set" is actually a VarEnv Var
151 isEmptySubst :: Subst -> Bool
152 isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
155 emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
157 mkSubst :: InScopeSet -> Subst
158 mkSubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
160 getTvSubst :: Subst -> TvSubst
161 getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
163 getTvSubstEnv :: Subst -> TvSubstEnv
164 getTvSubstEnv (Subst _ _ tv_env) = tv_env
166 setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
167 setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
171 substInScope :: Subst -> InScopeSet
172 substInScope (Subst in_scope _ _) = in_scope
174 zapSubstEnv :: Subst -> Subst
175 zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
177 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
178 extendIdSubst :: Subst -> Id -> SubstResult -> Subst
179 extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
181 extendIdSubstList :: Subst -> [(Id, SubstResult)] -> Subst
182 extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
184 extendTvSubst :: Subst -> TyVar -> Type -> Subst
185 extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
187 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
188 extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
190 lookupIdSubst :: Subst -> Id -> Maybe SubstResult
191 lookupIdSubst (Subst in_scope ids tvs) v = lookupVarEnv ids v
193 lookupTvSubst :: Subst -> TyVar -> Maybe Type
194 lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v
196 ------------------------------
197 isInScope :: Var -> Subst -> Bool
198 isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
200 modifyInScope :: Subst -> Var -> Var -> Subst
201 modifyInScope (Subst in_scope ids tvs) old_v new_v
202 = Subst (modifyInScopeSet in_scope old_v new_v) ids tvs
203 -- make old_v map to new_v
205 extendInScope :: Subst -> Var -> Subst
206 extendInScope (Subst in_scope ids tvs) v
207 = Subst (in_scope `extendInScopeSet` v)
208 (ids `delVarEnv` v) (tvs `delVarEnv` v)
210 extendInScopeIds :: Subst -> [Id] -> Subst
211 extendInScopeIds (Subst in_scope ids tvs) vs
212 = Subst (in_scope `extendInScopeSetList` vs)
213 (ids `delVarEnvList` vs) tvs
215 -------------------------------
216 setInScopeSet :: Subst -> InScopeSet -> Subst
217 setInScopeSet (Subst _ ids tvs) in_scope
218 = Subst in_scope ids tvs
220 setInScope :: Subst -- Take env part from here
221 -> Subst -- Take in-scope part from here
223 setInScope (Subst _ ids tvs) (Subst in_scope _ _)
224 = Subst in_scope ids tvs
226 setSubstEnv :: Subst -- Take in-scope part from here
227 -> Subst -- ... and env part from here
229 setSubstEnv s1 s2 = setInScope s2 s1
232 Pretty printing, for debugging only
235 instance Outputable SubstResult where
236 ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
237 ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
238 ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
240 instance Outputable Subst where
241 ppr (Subst in_scope ids tvs)
242 = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
243 $$ ptext SLIT(" IdSubst =") <+> ppr ids
244 $$ ptext SLIT(" TvSubst =") <+> ppr tvs
249 %************************************************************************
251 \section{Expression substitution}
253 %************************************************************************
255 This expression substituter deals correctly with name capture.
257 BUT NOTE that substExpr silently discards the
260 IdInfo attached to any binders in the expression. It's quite
261 tricky to do them 'right' in the case of mutually recursive bindings,
262 and so far has proved unnecessary.
265 substExpr :: Subst -> CoreExpr -> CoreExpr
267 -- NB: we do not do a no-op when the substitution is empty,
268 -- because we always want to substitute the variables in the
269 -- in-scope set for their occurrences. Why?
270 -- (a) because they may contain more information
271 -- (b) because leaving an un-substituted Id might cause
272 -- a space leak (its unfolding might point to an old version
273 -- of its right hand side).
277 go (Var v) = case substId subst v of
278 ContEx env' e' -> substExpr (setSubstEnv subst env') e'
282 go (Type ty) = Type (go_ty ty)
283 go (Lit lit) = Lit lit
284 go (App fun arg) = App (go fun) (go arg)
285 go (Note note e) = Note (go_note note) (go e)
287 go (Lam bndr body) = Lam bndr' (substExpr subst' body)
289 (subst', bndr') = substBndr subst bndr
291 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
293 (subst', bndr') = substBndr subst bndr
295 go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
297 (subst', bndrs') = substRecBndrs subst (map fst pairs)
298 pairs' = bndrs' `zip` rhss'
299 rhss' = map (substExpr subst' . snd) pairs
300 go (Case scrut bndr ty alts) = Case (go scrut) bndr' (go_ty ty) (map (go_alt subst') alts)
302 (subst', bndr') = substBndr subst bndr
304 go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
306 (subst', bndrs') = substBndrs subst bndrs
308 go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
311 go_ty ty = substTy subst ty
313 substId :: Subst -> Id -> SubstResult
314 substId (Subst in_scope ids tvs) v
315 = case lookupVarEnv ids v of
316 Just (DoneId v occ) -> DoneId (lookup v) occ
318 Nothing -> let v' = lookup v
319 in DoneId v' (idOccInfo v')
321 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
322 -- very important! If isFragileOcc returned True for
323 -- loop breakers we could avoid this call, but at the expense
324 -- of adding more to the substitution, and building new Ids
325 -- in substId a bit more often than really necessary
327 -- Get the most up-to-date thing from the in-scope set
328 -- Even though it isn't in the substitution, it may be in
329 -- the in-scope set with a different type (we only use the
330 -- substitution if the unique changes).
331 lookup v = case lookupInScope in_scope v of
333 Nothing -> WARN( mustHaveLocalBinding v, ppr v ) v
336 substTy :: Subst -> Type -> Type
337 substTy subst ty = Type.substTy (getTvSubst subst) ty
341 %************************************************************************
343 \section{Substituting an Id binder}
345 %************************************************************************
348 -- simplBndr and simplLetId are used by the simplifier
350 simplBndr :: Subst -> Var -> (Subst, Var)
351 -- Used for lambda and case-bound variables
352 -- Clone Id if necessary, substitute type
353 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
354 -- The substitution is extended only if the variable is cloned, because
355 -- we *don't* need to use it to track occurrence info.
357 | isTyVar bndr = subst_tv subst bndr
358 | otherwise = subst_id False subst subst bndr
360 simplBndrs :: Subst -> [Var] -> (Subst, [Var])
361 simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
363 simplLamBndr :: Subst -> Var -> (Subst, Var)
364 -- Used for lambda binders. These sometimes have unfoldings added by
365 -- the worker/wrapper pass that must be preserved, becuase they can't
366 -- be reconstructed from context. For example:
367 -- f x = case x of (a,b) -> fw a b x
368 -- fw a b x{=(a,b)} = ...
369 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
370 simplLamBndr subst bndr
371 | not (isId bndr && hasSomeUnfolding old_unf)
372 = simplBndr subst bndr -- Normal case
374 = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
376 old_unf = idUnfolding bndr
377 (subst', bndr') = subst_id False subst subst bndr
380 simplLetId :: Subst -> Id -> (Subst, Id)
381 -- Clone Id if necessary
382 -- Substitute its type
383 -- Return an Id with completely zapped IdInfo
384 -- [A subsequent substIdInfo will restore its IdInfo]
385 -- Augment the subtitution
386 -- if the unique changed, *or*
387 -- if there's interesting occurrence info
389 simplLetId subst@(Subst in_scope env tvs) old_id
390 = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
392 old_info = idInfo old_id
393 id1 = uniqAway in_scope old_id
394 id2 = substIdType subst id1
395 new_id = setIdInfo id2 vanillaIdInfo
397 -- Extend the substitution if the unique has changed,
398 -- or there's some useful occurrence information
399 -- See the notes with substTyVarBndr for the delSubstEnv
400 occ_info = occInfo old_info
401 new_env | new_id /= old_id || isFragileOcc occ_info
402 = extendVarEnv env old_id (DoneId new_id occ_info)
404 = delVarEnv env old_id
406 simplIdInfo :: Subst -> IdInfo -> IdInfo
407 -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
408 -- subsequent to simplLetId having zapped its IdInfo
409 simplIdInfo subst old_info
410 = case substIdInfo False subst old_info of
411 Just new_info -> new_info
416 -- substBndr and friends are used when doing expression substitution only
417 -- In this case we can *preserve* occurrence information, and indeed we *want*
418 -- to do so else lose useful occ info in rules.
420 substBndr :: Subst -> Var -> (Subst, Var)
422 | isTyVar bndr = subst_tv subst bndr
423 | otherwise = subst_id True {- keep fragile info -} subst subst bndr
425 substBndrs :: Subst -> [Var] -> (Subst, [Var])
426 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
428 substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
429 -- Substitute a mutually recursive group
430 substRecBndrs subst bndrs
431 = (new_subst, new_bndrs)
433 -- Here's the reason we need to pass rec_subst to subst_id
434 (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
440 subst_tv :: Subst -> TyVar -> (Subst, TyVar)
441 -- Unpackage and re-package for substTyVarBndr
442 subst_tv (Subst in_scope id_env tv_env) tv
443 = case substTyVarBndr (TvSubst in_scope tv_env) tv of
444 (TvSubst in_scope' tv_env', tv')
445 -> (Subst in_scope' id_env tv_env', tv')
447 subst_id :: Bool -- True <=> keep fragile info
448 -> Subst -- Substitution to use for the IdInfo
449 -> Subst -> Id -- Substitition and Id to transform
450 -> (Subst, Id) -- Transformed pair
453 -- * Unique changed if necessary
454 -- * Type substituted
455 -- * Unfolding zapped
456 -- * Rules, worker, lbvar info all substituted
457 -- * Occurrence info zapped if is_fragile_occ returns True
458 -- * The in-scope set extended with the returned Id
459 -- * The substitution extended with a DoneId if unique changed
460 -- In this case, the var in the DoneId is the same as the
463 subst_id keep_fragile rec_subst subst@(Subst in_scope env tvs) old_id
464 = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
466 -- id1 is cloned if necessary
467 id1 = uniqAway in_scope old_id
469 -- id2 has its type zapped
470 id2 = substIdType subst id1
472 -- new_id has the right IdInfo
473 -- The lazy-set is because we're in a loop here, with
474 -- rec_subst, when dealing with a mutually-recursive group
475 new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_subst) id2
477 -- Extend the substitution if the unique has changed
478 -- See the notes with substTyVarBndr for the delSubstEnv
479 new_env | new_id /= old_id
480 = extendVarEnv env old_id (DoneId new_id (idOccInfo old_id))
482 = delVarEnv env old_id
485 Now a variant that unconditionally allocates a new unique.
486 It also unconditionally zaps the OccInfo.
489 subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
490 -> Subst -> (Id, Unique) -- Substitition and Id to transform
491 -> (Subst, Id) -- Transformed pair
493 subst_clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
494 = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
496 id1 = setVarUnique old_id uniq
497 id2 = substIdType subst id1
499 new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
500 new_env = extendVarEnv env old_id (DoneId new_id NoOccInfo)
502 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
503 substAndCloneIds subst us ids
504 = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
506 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
507 substAndCloneRecIds subst us ids
510 (subst', ids') = mapAccumL (subst_clone_id subst') subst
511 (ids `zip` uniqsFromSupply us)
513 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
514 substAndCloneId subst us old_id
515 = subst_clone_id subst subst (old_id, uniqFromSupply us)
519 %************************************************************************
521 \section{IdInfo substitution}
523 %************************************************************************
526 substIdInfo :: Bool -- True <=> keep even fragile info
530 -- The keep_fragile flag is True when we are running a simple expression
531 -- substitution that preserves all structure, so that arity and occurrence
532 -- info are unaffected. The False state is used more often.
538 -- If keep_fragile then
542 -- keep only 'robust' OccInfo
545 -- Seq'ing on the returned IdInfo is enough to cause all the
546 -- substitutions to happen completely
548 substIdInfo keep_fragile subst info
549 | nothing_to_do = Nothing
550 | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
551 `setArityInfo` (if keep_arity then old_arity else unknownArity)
552 `setSpecInfo` substRules subst old_rules
553 `setWorkerInfo` substWorker subst old_wrkr
554 `setUnfoldingInfo` noUnfolding)
555 -- setSpecInfo does a seq
556 -- setWorkerInfo does a seq
558 nothing_to_do = keep_occ && keep_arity &&
559 isEmptyCoreRules old_rules &&
560 not (workerExists old_wrkr) &&
561 not (hasUnfolding (unfoldingInfo info))
563 keep_occ = keep_fragile || not (isFragileOcc old_occ)
564 keep_arity = keep_fragile || old_arity == unknownArity
565 old_arity = arityInfo info
566 old_occ = occInfo info
567 old_rules = specInfo info
568 old_wrkr = workerInfo info
571 substIdType :: Subst -> Id -> Id
572 substIdType subst@(Subst in_scope id_env tv_env) id
573 | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
574 | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
575 -- The tyVarsOfType is cheaper than it looks
576 -- because we cache the free tyvars of the type
577 -- in a Note in the id's type itself
582 substWorker :: Subst -> WorkerInfo -> WorkerInfo
583 -- Seq'ing on the returned WorkerInfo is enough to cause all the
584 -- substitutions to happen completely
586 substWorker subst NoWorker
588 substWorker subst (HasWorker w a)
589 = case substId subst w of
590 DoneId w1 _ -> HasWorker w1 a
591 DoneEx (Var w1) -> HasWorker w1 a
592 DoneEx other -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
593 NoWorker -- Worker has got substituted away altogether
594 -- This can happen if it's trivial,
595 -- via postInlineUnconditionally
596 ContEx se1 e -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
600 substUnfolding subst NoUnfolding = NoUnfolding
601 substUnfolding subst (OtherCon cons) = OtherCon cons
602 substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
603 substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
606 substRules :: Subst -> CoreRules -> CoreRules
607 -- Seq'ing on the returned CoreRules is enough to cause all the
608 -- substitutions to happen completely
610 substRules subst rules
611 | isEmptySubst subst = rules
613 substRules subst (Rules rules rhs_fvs)
614 = seqRules new_rules `seq` new_rules
616 new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
618 do_subst rule@(BuiltinRule _ _) = rule
619 do_subst (Rule name act tpl_vars lhs_args rhs)
620 = Rule name act tpl_vars'
621 (map (substExpr subst') lhs_args)
622 (substExpr subst' rhs)
624 (subst', tpl_vars') = substBndrs subst tpl_vars
627 substVarSet subst fvs
628 = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
631 | isId fv = case substId subst fv of
632 DoneId fv' _ -> unitVarSet fv'
633 DoneEx expr -> exprFreeVars expr
634 ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
635 | otherwise = case lookupTvSubst subst fv of
636 Nothing -> unitVarSet fv
637 Just ty -> substVarSet subst (tyVarsOfType ty)