module Subst (
-- In-scope set
InScopeSet, emptyInScopeSet,
- lookupInScope, setInScope, extendInScope, extendInScopes, isInScope,
+ lookupInScope, setInScope, extendInScope, extendInScopes, isInScope, modifyInScope,
-- Substitution stuff
Subst, TyVarSubst, IdSubst,
emptySubst, mkSubst, substEnv, substInScope,
- lookupSubst, isEmptySubst, extendSubst, extendSubstList,
+ lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
zapSubstEnv, setSubstEnv,
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
import VarSet
import VarEnv
import Var ( setVarUnique, isId )
-import Id ( idType, setIdType )
-import IdInfo ( IdInfo, zapFragileIdInfo,
+import Id ( idType, setIdType, getIdOccInfo, zapFragileIdInfo )
+import Name ( isLocallyDefined )
+import IdInfo ( IdInfo, isFragileOccInfo,
specInfo, setSpecInfo,
workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
-import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar, maybeModifyIdInfo )
+import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar )
import Outputable
import Util ( mapAccumL, foldl2, seqList, ($!) )
\end{code}
%************************************************************************
\begin{code}
-type InScopeSet = VarSet
+type InScopeSet = VarEnv Var
data Subst = Subst InScopeSet -- In scope
SubstEnv -- Substitution itself
- -- INVARIANT 1: The in-scope set is a superset
+ -- INVARIANT 1: The (domain of the) in-scope set is a superset
-- of the free vars of the range of the substitution
-- that might possibly clash with locally-bound variables
-- in the thing being substituted in.
type IdSubst = Subst
\end{code}
+The general plan about the substitution and in-scope set for Ids is as follows
+
+* substId always adds new_id to the in-scope set.
+ new_id has a correctly-substituted type, but all its fragile IdInfo has been zapped.
+ That is added back in later. So new_id is the minimal thing it's
+ correct to substitute.
+
+* substId adds a binding (DoneVar new_id occ) to the substitution if
+ EITHER the Id's unique has changed
+ OR the Id has interesting occurrence information
+ Note, though that the substitution isn't necessarily extended
+ if the type changes. Why not? Because of the next point:
+
+* We *always, always* finish by looking up in the in-scope set
+ any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
+ Reason: so that we never finish up with a "old" Id in the result.
+ An old Id might point to an old unfolding and so on... which gives a space leak.
+
+ [The DoneEx and DoneVar hits map to "new" stuff.]
+
+* It follows that substExpr must not do a no-op if the substitution is empty.
+ substType is free to do so, however.
+
+* When we come to a let-binding (say) we generate new IdInfo, including an
+ unfolding, attach it to the binder, and add this newly adorned binder to
+ the in-scope set. So all subsequent occurrences of the binder will get mapped
+ to the full-adorned binder, which is also the one put in the binding site.
+
+* The in-scope "set" usually maps x->x; we use it simply for its domain.
+ But sometimes we have two in-scope Ids that are synomyms, and should
+ map to the same target: x->x, y->x. Notably:
+ case y of x { ... }
+ That's why the "set" is actually a VarEnv Var
+
\begin{code}
emptyInScopeSet :: InScopeSet
emptyInScopeSet = emptyVarSet
+
+add_in_scope :: InScopeSet -> Var -> InScopeSet
+add_in_scope in_scope v = extendVarEnv in_scope v v
\end{code}
isEmptySubst (Subst _ env) = isEmptySubstEnv env
emptySubst :: Subst
-emptySubst = Subst emptyVarSet emptySubstEnv
+emptySubst = Subst emptyInScopeSet emptySubstEnv
mkSubst :: InScopeSet -> SubstEnv -> Subst
mkSubst in_scope env = Subst in_scope env
lookupSubst :: Subst -> Var -> Maybe SubstResult
lookupSubst (Subst _ env) v = lookupSubstEnv env v
+lookupIdSubst :: Subst -> Id -> SubstResult
+-- Does the lookup in the in-scope set too
+lookupIdSubst (Subst in_scope env) v
+ = case lookupSubstEnv env v of
+ Just (DoneId v' occ) -> case lookupVarEnv in_scope v' of
+ Just v'' -> DoneId v'' occ
+ Nothing -> DoneId v' occ
+ Just res -> res
+ Nothing -> DoneId v' (getIdOccInfo v')
+ where
+ v' = case lookupVarEnv in_scope v of
+ Just v' -> v'
+ Nothing -> v
+
lookupInScope :: Subst -> Var -> Maybe Var
-lookupInScope (Subst in_scope _) v = lookupVarSet in_scope v
+lookupInScope (Subst in_scope _) v = lookupVarEnv in_scope v
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _) = v `elemVarSet` in_scope
+isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope env) v = Subst (extendVarSet in_scope v) env
+extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env
+
+modifyInScope :: Subst -> Var -> Var -> Subst
+modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env
+ -- make old_v map to new_v
extendInScopes :: Subst -> [Var] -> Subst
-extendInScopes (Subst in_scope env) vs = Subst (foldl extendVarSet in_scope vs) env
+extendInScopes (Subst in_scope env) vs = Subst (foldl add_in_scope in_scope vs) env
-------------------------------
bindSubst :: Subst -> Var -> Var -> Subst
-- Extend with a substitution, v1 -> Var v2
-- and extend the in-scopes with v2
bindSubst (Subst in_scope env) old_bndr new_bndr
- = Subst (in_scope `extendVarSet` new_bndr)
+ = Subst (in_scope `add_in_scope` new_bndr)
(extendSubstEnv env old_bndr subst_result)
where
subst_result | isId old_bndr = DoneEx (Var new_bndr)
-- Reverse the effect of bindSubst
-- If old_bndr was already in the substitution, this doesn't quite work
unBindSubst (Subst in_scope env) old_bndr new_bndr
- = Subst (in_scope `delVarSet` new_bndr) (delSubstEnv env old_bndr)
+ = Subst (in_scope `delVarEnv` new_bndr) (delSubstEnv env old_bndr)
-- And the "List" forms
bindSubstList :: Subst -> [Var] -> [Var] -> Subst
-> InScopeSet
-> Subst
setInScope (Subst in_scope1 env1) in_scope2
- = ASSERT( in_scope1 `subVarSet` in_scope1 )
- Subst in_scope2 env1
+ = Subst in_scope2 env1
setSubstEnv :: Subst -- Take in-scope part from here
-> SubstEnv -- ... and env part from here
-- Here we expect that the free vars of the range of the
-- substitution will be empty.
mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTopTyVarSubst tyvars tys = Subst emptyVarSet (zip_ty_env tyvars tys emptySubstEnv)
+mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
zip_ty_env [] [] env = env
zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
--
-- The new_id isn't cloned, but it may have a different type
-- etc, so we must return it, not the old id
- = (Subst (in_scope `extendVarSet` new_var)
+ = (Subst (in_scope `add_in_scope` new_var)
(delSubstEnv env old_var),
new_var)
-- Extending the substitution to do this renaming also
-- has the (correct) effect of discarding any existing
-- substitution for that variable
- = (Subst (in_scope `extendVarSet` new_var)
+ = (Subst (in_scope `add_in_scope` new_var)
(extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
new_var)
where
\begin{code}
substExpr :: Subst -> CoreExpr -> CoreExpr
-substExpr subst expr | isEmptySubst subst = expr
- | otherwise = subst_expr subst expr
+substExpr subst expr
+ -- NB: we do not do a no-op when the substitution is empty,
+ -- because we always want to substitute the variables in the
+ -- in-scope set for their occurrences. Why?
+ -- (a) because they may contain more information
+ -- (b) because leaving an un-substituted Id might cause
+ -- a space leak (its unfolding might point to an old version
+ -- of its right hand side).
-subst_expr subst expr
= go expr
where
- go (Var v) = case lookupSubst subst v of
- Just (DoneEx e') -> e'
- Just (ContEx env' e') -> subst_expr (setSubstEnv subst env') e'
--- NO! NO! SLPJ 14 July 99
- Nothing -> case lookupInScope subst v of
- Just v' -> Var v'
- Nothing -> Var v
- -- NB: we look up in the in_scope set because the variable
- -- there may have more info. In particular, when substExpr
- -- is called from the simplifier, the type inside the *occurrences*
- -- of a variable may not be right; we should replace it with the
- -- binder, from the in_scope set.
-
--- Nothing -> Var v
+ go (Var v) = -- See the notes at the top, with the Subst data type declaration
+ case lookupIdSubst subst v of
+
+ ContEx env' e' -> substExpr (setSubstEnv subst env') e'
+ DoneId v _ -> Var v
+ DoneEx e' -> e'
go (Type ty) = Type (go_ty ty)
go (Con con args) = Con con (map go args)
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
- go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
+ go (Lam bndr body) = Lam bndr' (substExpr subst' body)
where
(subst', bndr') = substBndr subst bndr
- go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr subst' body)
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
where
(subst', bndr') = substBndr subst bndr
- go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr subst' body)
+ go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
where
(subst', bndrs') = substBndrs subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
- rhss' = map (subst_expr subst' . snd) pairs
+ rhss' = map (substExpr subst' . snd) pairs
go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
where
(subst', bndr') = substBndr subst bndr
- go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
where
(subst', bndrs') = substBndrs subst bndrs
When we hit a binder we may need to
(a) apply the the type envt (if non-empty) to its type
- (b) apply the type envt and id envt to its SpecEnv (if it has one)
(c) give it a new unique to avoid name clashes
\begin{code}
substIds subst bndrs = mapAccumL substId subst bndrs
substId :: Subst -> Id -> (Subst, Id)
-
--- Returns an Id with empty unfolding and spec-env.
--- It's up to the caller to sort these out.
+ -- Returns an Id with empty IdInfo
+ -- See the notes with the Subst data type decl at the
+ -- top of this module
substId subst@(Subst in_scope env) old_id
- = (Subst (in_scope `extendVarSet` new_id)
- (extendSubstEnv env old_id (DoneEx (Var new_id))),
- new_id)
+ = (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
where
id_ty = idType old_id
+ occ_info = getIdOccInfo old_id
-- id1 has its type zapped
id1 | noTypeSubst env
-- in a Note in the id's type itself
| otherwise = setIdType old_id (substTy subst id_ty)
- -- id2 has its fragile IdInfo zapped
- id2 = maybeModifyIdInfo zapFragileIdInfo id1
+ -- id2 has its IdInfo zapped
+ id2 = zapFragileIdInfo id1
-- new_id is cloned if necessary
new_id = uniqAway in_scope id2
+
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
+ -- See the notes with substTyVar for the delSubstEnv
+ new_env | new_id /= old_id || isFragileOccInfo occ_info
+ = extendSubstEnv env old_id (DoneId new_id occ_info)
+ | otherwise
+ = delSubstEnv env old_id
\end{code}
Now a variant that unconditionally allocates a new unique.
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
- = (Subst (in_scope `extendVarSet` new_id)
+ = (Subst (in_scope `add_in_scope` new_id)
(extendSubstEnv env old_id (DoneEx (Var new_id))),
new_us,
new_id)
id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
| otherwise = setIdType old_id (substTy subst id_ty)
- id2 = maybeModifyIdInfo zapFragileIdInfo id1
+ id2 = zapFragileIdInfo id1
new_id = setVarUnique id2 (uniqFromSupply us1)
(us1,new_us) = splitUniqSupply us
\end{code}
substWorker subst (Just w)
= case lookupSubst subst w of
Nothing -> Just w
+ Just (DoneId w1 _) -> Just w1
Just (DoneEx (Var w1)) -> Just w1
Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
Nothing -- Worker has got substituted away altogether
where
subst_fv fv = case lookupSubstEnv se fv of
Nothing -> unitVarSet fv
+ Just (DoneId fv' _) -> unitVarSet fv'
Just (DoneEx expr) -> exprFreeVars expr
Just (DoneTy ty) -> tyVarsOfType ty
Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
projects / ghc-hetmet.git / blobdiff