\begin{code}
module Subst (
- -- In-scope set
- InScopeSet, emptyInScopeSet,
- lookupInScope, setInScope, extendInScope, extendInScopes, isInScope,
-
-- Substitution stuff
- Subst, TyVarSubst, IdSubst,
- emptySubst, mkSubst, substEnv, substInScope,
- lookupSubst, isEmptySubst, extendSubst, extendSubstList,
+ Subst, SubstResult(..),
+ emptySubst, mkSubst, substInScope, substTy,
+ lookupIdSubst, lookupTvSubst, isEmptySubst,
+ extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
zapSubstEnv, setSubstEnv,
+ getTvSubst, getTvSubstEnv, setTvSubstEnv,
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-- Binders
- substBndr, substBndrs, substTyVar, substId, substIds,
- substAndCloneId, substAndCloneIds,
+ simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
+ substAndCloneId, substAndCloneIds, substAndCloneRecIds,
- -- Type stuff
- mkTyVarSubst, mkTopTyVarSubst,
- substTy, substTheta,
+ setInScope, setInScopeSet,
+ extendInScope, extendInScopeIds,
+ isInScope, modifyInScope,
-- Expression stuff
- substExpr, substRules
+ substExpr, substRules, substId
) where
#include "HsVersions.h"
-
-import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
- CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
+import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
+ CoreRules(..), CoreRule(..),
+ isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
+ Unfolding(..)
)
-import CoreUnfold ( hasUnfolding, noUnfolding )
import CoreFVs ( exprFreeVars )
-import Type ( Type(..), ThetaType, TyNote(..),
- tyVarsOfType, tyVarsOfTypes, mkAppTy
- )
+import CoreUtils ( exprIsTrivial )
+
+import qualified Type ( substTy )
+import Type ( Type, tyVarsOfType, mkTyVarTy,
+ TvSubstEnv, TvSubst(..), substTyVar )
import VarSet
import VarEnv
-import Var ( setVarUnique, isId )
-import Id ( idType, setIdType )
-import IdInfo ( zapFragileIdInfo )
-import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
-import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar, maybeModifyIdInfo )
+import Var ( setVarUnique, isId, mustHaveLocalBinding )
+import Id ( idType, idInfo, setIdInfo, setIdType,
+ idUnfolding, setIdUnfolding,
+ idOccInfo, maybeModifyIdInfo )
+import IdInfo ( IdInfo, vanillaIdInfo,
+ occInfo, isFragileOcc, setOccInfo,
+ specInfo, setSpecInfo,
+ setArityInfo, unknownArity, arityInfo,
+ unfoldingInfo, setUnfoldingInfo,
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
+ )
+import BasicTypes ( OccInfo(..) )
+import Unique ( Unique )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
+import Var ( Var, Id, TyVar, isTyVar )
import Outputable
-import Util ( mapAccumL, foldl2, seqList, ($!) )
+import PprCore () -- Instances
+import Util ( mapAccumL, foldl2 )
+import FastTypes
\end{code}
+
%************************************************************************
%* *
\subsection{Substitutions}
%************************************************************************
\begin{code}
-type InScopeSet = VarSet
+data Subst
+ = Subst InScopeSet -- Variables in in scope (both Ids and TyVars)
+ IdSubstEnv -- Substitution for Ids
+ TvSubstEnv -- Substitution for TyVars
-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.
--
-- INVARIANT 2: No variable is both in scope and in the domain of the substitution
-- Equivalently, the substitution is idempotent
- --
-
-type IdSubst = Subst
+ -- [Sep 2000: Lies, all lies. The substitution now does contain
+ -- mappings x77 -> DoneId x77 occ
+ -- to record x's occurrence information.]
+ -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
+ -- Consider let x = case k of I# x77 -> ... in
+ -- let y = case k of I# x77 -> ... in ...
+ -- and suppose the body is strict in both x and y. Then the simplifier
+ -- will pull the first (case k) to the top; so the second (case k) will
+ -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
+ -- other is an out-Id. So the substitution is idempotent in the sense
+ -- that we *must not* repeatedly apply it.]
+
+
+type IdSubstEnv = IdEnv SubstResult
+
+data SubstResult
+ = DoneEx CoreExpr -- Completed term
+ | DoneId Id OccInfo -- Completed term variable, with occurrence info;
+ -- only used by the simplifier
+ | ContEx Subst CoreExpr -- A suspended substitution
\end{code}
-\begin{code}
-emptyInScopeSet :: InScopeSet
-emptyInScopeSet = emptyVarSet
-\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, occ info
+
+* substId adds a binding (DoneId new_id occ) to the substitution if
+ EITHER the Id's unique has changed
+ OR the Id has interesting occurrence information
+ So in effect you can only get to interesting occurrence information
+ by looking up the *old* Id; it's not really attached to the new id
+ at all.
+
+ 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}
isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ env) = isEmptySubstEnv env
+isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
emptySubst :: Subst
-emptySubst = Subst emptyVarSet emptySubstEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+mkSubst :: InScopeSet -> Subst
+mkSubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
+
+getTvSubst :: Subst -> TvSubst
+getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+
+getTvSubstEnv :: Subst -> TvSubstEnv
+getTvSubstEnv (Subst _ _ tv_env) = tv_env
+
+setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
+setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
-mkSubst :: InScopeSet -> SubstEnv -> Subst
-mkSubst in_scope env = Subst in_scope env
-substEnv :: Subst -> SubstEnv
-substEnv (Subst _ env) = env
substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _) = in_scope
+substInScope (Subst in_scope _ _) = in_scope
zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
+zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+
+-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
+extendIdSubst :: Subst -> Id -> SubstResult -> Subst
+extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+
+extendIdSubstList :: Subst -> [(Id, SubstResult)] -> Subst
+extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
-extendSubst :: Subst -> Var -> SubstResult -> Subst
-extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
+extendTvSubst :: Subst -> TyVar -> Type -> Subst
+extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
-extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
-extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
+extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
+extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
-lookupSubst :: Subst -> Var -> Maybe SubstResult
-lookupSubst (Subst _ env) v = lookupSubstEnv env v
+lookupIdSubst :: Subst -> Id -> Maybe SubstResult
+lookupIdSubst (Subst in_scope ids tvs) v = lookupVarEnv ids v
-lookupInScope :: Subst -> Var -> Maybe Var
-lookupInScope (Subst in_scope _) v = lookupVarSet in_scope v
+lookupTvSubst :: Subst -> TyVar -> Maybe Type
+lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v
+------------------------------
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _) = v `elemVarSet` in_scope
+isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+
+modifyInScope :: Subst -> Var -> Var -> Subst
+modifyInScope (Subst in_scope ids tvs) old_v new_v
+ = Subst (modifyInScopeSet in_scope old_v new_v) ids tvs
+ -- make old_v map to new_v
extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope env) v = Subst (extendVarSet in_scope v) env
+extendInScope (Subst in_scope ids tvs) v
+ = Subst (in_scope `extendInScopeSet` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v)
-extendInScopes :: Subst -> [Var] -> Subst
-extendInScopes (Subst in_scope env) vs = Subst (foldl extendVarSet in_scope vs) env
+extendInScopeIds :: Subst -> [Id] -> Subst
+extendInScopeIds (Subst in_scope ids tvs) vs
+ = Subst (in_scope `extendInScopeSetList` vs)
+ (ids `delVarEnvList` vs) tvs
-------------------------------
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)
- (extendSubstEnv env old_bndr subst_result)
- where
- subst_result | isId old_bndr = DoneEx (Var new_bndr)
- | otherwise = DoneTy (TyVarTy new_bndr)
+bindSubst (Subst in_scope ids tvs) old_bndr new_bndr
+ | isId old_bndr
+ = Subst (in_scope `extendInScopeSet` new_bndr)
+ (extendVarEnv ids old_bndr (DoneEx (Var new_bndr)))
+ tvs
+ | otherwise
+ = Subst (in_scope `extendInScopeSet` new_bndr)
+ ids
+ (extendVarEnv tvs old_bndr (mkTyVarTy new_bndr))
unBindSubst :: Subst -> Var -> Var -> Subst
-- 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)
+unBindSubst (Subst in_scope ids tvs) old_bndr new_bndr
+ = Subst (in_scope `delInScopeSet` new_bndr)
+ (delVarEnv ids old_bndr)
+ (delVarEnv tvs old_bndr)
-- And the "List" forms
bindSubstList :: Subst -> [Var] -> [Var] -> Subst
-------------------------------
+setInScopeSet :: Subst -> InScopeSet -> Subst
+setInScopeSet (Subst _ ids tvs) in_scope
+ = Subst in_scope ids tvs
+
setInScope :: Subst -- Take env part from here
- -> InScopeSet
+ -> Subst -- Take in-scope part from here
-> Subst
-setInScope (Subst in_scope1 env1) in_scope2
- = ASSERT( in_scope1 `subVarSet` in_scope1 )
- Subst in_scope2 env1
+setInScope (Subst _ ids tvs) (Subst in_scope _ _)
+ = Subst in_scope ids tvs
-setSubstEnv :: Subst -- Take in-scope part from here
- -> SubstEnv -- ... and env part from here
+setSubstEnv :: Subst -- Take in-scope part from here
+ -> Subst -- ... and env part from here
-> Subst
-setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Type substitution}
-%* *
-%************************************************************************
-
-\begin{code}
-type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
- -- (We could have a variant of Subst, but it doesn't seem worth it.)
-
--- mkTyVarSubst generates the in-scope set from
--- the types given; but it's just a thunk so with a bit of luck
--- it'll never be evaluated
-mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTyVarSubst tyvars tys = Subst (tyVarsOfTypes tys) (zip_ty_env tyvars tys emptySubstEnv)
-
--- mkTopTyVarSubst is called when doing top-level substitutions.
--- 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)
-
-zip_ty_env [] [] env = env
-zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
-\end{code}
-
-substTy works with general Substs, so that it can be called from substExpr too.
-
-\begin{code}
-substTy :: Subst -> Type -> Type
-substTy subst ty | isEmptySubst subst = ty
- | otherwise = subst_ty subst ty
-
-substTheta :: TyVarSubst -> ThetaType -> ThetaType
-substTheta subst theta
- | isEmptySubst subst = theta
- | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
-
-subst_ty subst ty
- = go ty
- where
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (NoteTy (UsgNote usg) ty2) = NoteTy $! UsgNote usg $! go ty2 -- Keep usage annot
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
- go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
- Nothing -> ty
- Just (DoneTy ty') -> ty'
-
- go (ForAllTy tv ty) = case substTyVar subst tv of
- (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
+setSubstEnv s1 s2 = setInScope s2 s1
\end{code}
-Here is where we invent a new binder if necessary.
+Pretty printing, for debugging only
\begin{code}
-substTyVar :: Subst -> TyVar -> (Subst, TyVar)
-substTyVar subst@(Subst in_scope env) old_var
- | old_var == new_var -- No need to clone
- -- But we *must* zap any current substitution for the variable.
- -- For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- --
- -- 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)
- (delSubstEnv env old_var),
- new_var)
-
- | otherwise -- The new binder is in scope so
- -- we'd better rename it away from the in-scope variables
- -- 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)
- (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
- new_var)
- where
- new_var = uniqAway in_scope old_var
- -- The uniqAway part makes sure the new variable is not already in scope
+instance Outputable SubstResult where
+ ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
+ ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
+ ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
+
+instance Outputable Subst where
+ ppr (Subst in_scope ids tvs)
+ = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
+ $$ ptext SLIT(" IdSubst =") <+> ppr ids
+ $$ ptext SLIT(" TvSubst =") <+> ppr tvs
+ <> char '>'
\end{code}
\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'
- 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.
+ go (Var v) = case substId 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 (Lit lit) = Lit lit
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)
+ (subst', bndrs') = substRecBndrs subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
- rhss' = map (subst_expr subst' . snd) pairs
-
- go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
- where
- (subst', bndr') = substBndr subst bndr
+ rhss' = map (substExpr subst' . snd) pairs
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr' (go_ty ty) (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
go_ty ty = substTy subst ty
-\end{code}
+substId :: Subst -> Id -> SubstResult
+substId (Subst in_scope ids tvs) v
+ = case lookupVarEnv ids v of
+ Just (DoneId v occ) -> DoneId (lookup v) occ
+ Just res -> res
+ Nothing -> let v' = lookup v
+ in DoneId v' (idOccInfo v')
+ -- Note [idOccInfo]
+ -- We don't use DoneId for LoopBreakers, so the idOccInfo is
+ -- very important! If isFragileOcc returned True for
+ -- loop breakers we could avoid this call, but at the expense
+ -- of adding more to the substitution, and building new Ids
+ -- in substId a bit more often than really necessary
+ where
+ -- Get the most up-to-date thing from the in-scope set
+ -- Even though it isn't in the substitution, it may be in
+ -- the in-scope set with a different type (we only use the
+ -- substitution if the unique changes).
+ lookup v = case lookupInScope in_scope v of
+ Just v' -> v'
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v ) v
-Substituting in binders is a rather tricky part of the whole compiler.
-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
+substTy :: Subst -> Type -> Type
+substTy subst ty = Type.substTy (getTvSubst subst) ty
+\end{code}
-\begin{code}
-substBndr :: Subst -> IdOrTyVar -> (Subst, IdOrTyVar)
-substBndr subst bndr
- | isTyVar bndr = substTyVar subst bndr
- | otherwise = substId subst bndr
-substBndrs :: Subst -> [IdOrTyVar] -> (Subst, [IdOrTyVar])
-substBndrs subst bndrs = mapAccumL substBndr subst bndrs
+%************************************************************************
+%* *
+\section{Substituting an Id binder}
+%* *
+%************************************************************************
+\begin{code}
+-- simplBndr and simplLetId are used by the simplifier
+
+simplBndr :: Subst -> Var -> (Subst, Var)
+-- Used for lambda and case-bound variables
+-- Clone Id if necessary, substitute type
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
+-- The substitution is extended only if the variable is cloned, because
+-- we *don't* need to use it to track occurrence info.
+simplBndr subst bndr
+ | isTyVar bndr = subst_tv subst bndr
+ | otherwise = subst_id False subst subst bndr
+
+simplBndrs :: Subst -> [Var] -> (Subst, [Var])
+simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
+
+simplLamBndr :: Subst -> Var -> (Subst, Var)
+-- Used for lambda binders. These sometimes have unfoldings added by
+-- the worker/wrapper pass that must be preserved, becuase they can't
+-- be reconstructed from context. For example:
+-- f x = case x of (a,b) -> fw a b x
+-- fw a b x{=(a,b)} = ...
+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
+simplLamBndr subst bndr
+ | not (isId bndr && hasSomeUnfolding old_unf)
+ = simplBndr subst bndr -- Normal case
+ | otherwise
+ = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
+ where
+ old_unf = idUnfolding bndr
+ (subst', bndr') = subst_id False subst subst bndr
+
+
+simplLetId :: Subst -> Id -> (Subst, Id)
+-- Clone Id if necessary
+-- Substitute its type
+-- Return an Id with completely zapped IdInfo
+-- [A subsequent substIdInfo will restore its IdInfo]
+-- Augment the subtitution
+-- if the unique changed, *or*
+-- if there's interesting occurrence info
+
+simplLetId subst@(Subst in_scope env tvs) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ where
+ old_info = idInfo old_id
+ id1 = uniqAway in_scope old_id
+ id2 = substIdType subst id1
+ new_id = setIdInfo id2 vanillaIdInfo
+
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
+ -- See the notes with substTyVar for the delSubstEnv
+ occ_info = occInfo old_info
+ new_env | new_id /= old_id || isFragileOcc occ_info
+ = extendVarEnv env old_id (DoneId new_id occ_info)
+ | otherwise
+ = delVarEnv env old_id
+
+simplIdInfo :: Subst -> IdInfo -> IdInfo
+ -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
+ -- subsequent to simplLetId having zapped its IdInfo
+simplIdInfo subst old_info
+ = case substIdInfo False subst old_info of
+ Just new_info -> new_info
+ Nothing -> old_info
+\end{code}
-substIds :: Subst -> [Id] -> (Subst, [Id])
-substIds subst bndrs = mapAccumL substId subst bndrs
+\begin{code}
+-- substBndr and friends are used when doing expression substitution only
+-- In this case we can *preserve* occurrence information, and indeed we *want*
+-- to do so else lose useful occ info in rules.
-substId :: Subst -> Id -> (Subst, Id)
+substBndr :: Subst -> Var -> (Subst, Var)
+substBndr subst bndr
+ | isTyVar bndr = subst_tv subst bndr
+ | otherwise = subst_id True {- keep fragile info -} subst subst bndr
--- Returns an Id with empty unfolding and spec-env.
--- It's up to the caller to sort these out.
+substBndrs :: Subst -> [Var] -> (Subst, [Var])
+substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-substId subst@(Subst in_scope env) old_id
- = (Subst (in_scope `extendVarSet` new_id)
- (extendSubstEnv env old_id (DoneEx (Var new_id))),
- new_id)
+substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
+-- Substitute a mutually recursive group
+substRecBndrs subst bndrs
+ = (new_subst, new_bndrs)
where
- id_ty = idType old_id
-
- -- id1 has its type zapped
- id1 | noTypeSubst env
- || isEmptyVarSet (tyVarsOfType id_ty) = old_id
- -- The tyVarsOfType is cheaper than it looks
- -- because we cache the free tyvars of the type
- -- in a Note in the id's type itself
- | otherwise = setIdType old_id (substTy subst id_ty)
+ -- Here's the reason we need to pass rec_subst to subst_id
+ (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
+ subst bndrs
+\end{code}
- -- id2 has its fragile IdInfo zapped
- id2 = maybeModifyIdInfo zapFragileIdInfo id1
- -- new_id is cloned if necessary
- new_id = uniqAway in_scope id2
+\begin{code}
+subst_tv :: Subst -> TyVar -> (Subst, TyVar)
+-- Unpackage and re-package for substTyVar
+subst_tv (Subst in_scope id_env tv_env) tv
+ = case substTyVar (TvSubst in_scope tv_env) tv of
+ (TvSubst in_scope' tv_env', tv')
+ -> (Subst in_scope' id_env tv_env', tv')
+
+subst_id :: Bool -- True <=> keep fragile info
+ -> Subst -- Substitution to use for the IdInfo
+ -> Subst -> Id -- Substitition and Id to transform
+ -> (Subst, Id) -- Transformed pair
+
+-- Returns with:
+-- * Unique changed if necessary
+-- * Type substituted
+-- * Unfolding zapped
+-- * Rules, worker, lbvar info all substituted
+-- * Occurrence info zapped if is_fragile_occ returns True
+-- * The in-scope set extended with the returned Id
+-- * The substitution extended with a DoneId if unique changed
+-- In this case, the var in the DoneId is the same as the
+-- var returned
+
+subst_id keep_fragile rec_subst subst@(Subst in_scope env tvs) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ where
+ -- id1 is cloned if necessary
+ id1 = uniqAway in_scope old_id
+
+ -- id2 has its type zapped
+ id2 = substIdType subst id1
+
+ -- new_id has the right IdInfo
+ -- The lazy-set is because we're in a loop here, with
+ -- rec_subst, when dealing with a mutually-recursive group
+ new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_subst) id2
+
+ -- Extend the substitution if the unique has changed
+ -- See the notes with substTyVar for the delSubstEnv
+ new_env | new_id /= old_id
+ = extendVarEnv env old_id (DoneId new_id (idOccInfo old_id))
+ | otherwise
+ = delVarEnv env old_id
\end{code}
Now a variant that unconditionally allocates a new unique.
+It also unconditionally zaps the OccInfo.
\begin{code}
-substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
-substAndCloneIds subst us [] = (subst, us, [])
-substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
- case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
- (subst2, us2, (b':bs')) }}
-
-substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
-substAndCloneId subst@(Subst in_scope env) us old_id
- = (Subst (in_scope `extendVarSet` new_id)
- (extendSubstEnv env old_id (DoneEx (Var new_id))),
- new_us,
- new_id)
+subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
+ -> Subst -> (Id, Unique) -- Substitition and Id to transform
+ -> (Subst, Id) -- Transformed pair
+
+subst_clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
where
- id_ty = idType old_id
- id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
- | otherwise = setIdType old_id (substTy subst id_ty)
+ id1 = setVarUnique old_id uniq
+ id2 = substIdType subst id1
+
+ new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
+ new_env = extendVarEnv env old_id (DoneId new_id NoOccInfo)
+
+substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+substAndCloneIds subst us ids
+ = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
- id2 = maybeModifyIdInfo zapFragileIdInfo id1
- new_id = setVarUnique id2 (uniqFromSupply us1)
- (us1,new_us) = splitUniqSupply us
+substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+substAndCloneRecIds subst us ids
+ = (subst', ids')
+ where
+ (subst', ids') = mapAccumL (subst_clone_id subst') subst
+ (ids `zip` uniqsFromSupply us)
+
+substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
+substAndCloneId subst us old_id
+ = subst_clone_id subst subst (old_id, uniqFromSupply us)
\end{code}
%************************************************************************
%* *
-\section{Rule substitution}
+\section{IdInfo substitution}
%* *
%************************************************************************
\begin{code}
+substIdInfo :: Bool -- True <=> keep even fragile info
+ -> Subst
+ -> IdInfo
+ -> Maybe IdInfo
+-- The keep_fragile flag is True when we are running a simple expression
+-- substitution that preserves all structure, so that arity and occurrence
+-- info are unaffected. The False state is used more often.
+--
+-- Substitute the
+-- rules
+-- worker info
+-- Zap the unfolding
+-- If keep_fragile then
+-- keep OccInfo
+-- keep Arity
+-- else
+-- keep only 'robust' OccInfo
+-- zap Arity
+--
+-- Seq'ing on the returned IdInfo is enough to cause all the
+-- substitutions to happen completely
+
+substIdInfo keep_fragile subst info
+ | nothing_to_do = Nothing
+ | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
+ `setArityInfo` (if keep_arity then old_arity else unknownArity)
+ `setSpecInfo` substRules subst old_rules
+ `setWorkerInfo` substWorker subst old_wrkr
+ `setUnfoldingInfo` noUnfolding)
+ -- setSpecInfo does a seq
+ -- setWorkerInfo does a seq
+ where
+ nothing_to_do = keep_occ && keep_arity &&
+ isEmptyCoreRules old_rules &&
+ not (workerExists old_wrkr) &&
+ not (hasUnfolding (unfoldingInfo info))
+
+ keep_occ = keep_fragile || not (isFragileOcc old_occ)
+ keep_arity = keep_fragile || old_arity == unknownArity
+ old_arity = arityInfo info
+ old_occ = occInfo info
+ old_rules = specInfo info
+ old_wrkr = workerInfo info
+
+------------------
+substIdType :: Subst -> Id -> Id
+substIdType subst@(Subst in_scope id_env tv_env) id
+ | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+ | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+ -- The tyVarsOfType is cheaper than it looks
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ where
+ old_ty = idType id
+
+------------------
+substWorker :: Subst -> WorkerInfo -> WorkerInfo
+ -- Seq'ing on the returned WorkerInfo is enough to cause all the
+ -- substitutions to happen completely
+
+substWorker subst NoWorker
+ = NoWorker
+substWorker subst (HasWorker w a)
+ = case substId subst w of
+ DoneId w1 _ -> HasWorker w1 a
+ DoneEx (Var w1) -> HasWorker w1 a
+ DoneEx other -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
+ NoWorker -- Worker has got substituted away altogether
+ -- This can happen if it's trivial,
+ -- via postInlineUnconditionally
+ ContEx se1 e -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
+ NoWorker -- Ditto
+
+------------------
+substUnfolding subst NoUnfolding = NoUnfolding
+substUnfolding subst (OtherCon cons) = OtherCon cons
+substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
+substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
+
+------------------
substRules :: Subst -> CoreRules -> CoreRules
+ -- Seq'ing on the returned CoreRules is enough to cause all the
+ -- substitutions to happen completely
+
+substRules subst rules
+ | isEmptySubst subst = rules
+
substRules subst (Rules rules rhs_fvs)
- = Rules (map do_subst rules)
- (subst_fvs (substEnv subst) rhs_fvs)
+ = seqRules new_rules `seq` new_rules
where
- do_subst (Rule name tpl_vars lhs_args rhs)
- = Rule name tpl_vars'
+ new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
+
+ do_subst rule@(BuiltinRule _ _) = rule
+ do_subst (Rule name act tpl_vars lhs_args rhs)
+ = Rule name act tpl_vars'
(map (substExpr subst') lhs_args)
(substExpr subst' rhs)
where
(subst', tpl_vars') = substBndrs subst tpl_vars
- subst_fvs se fvs
- = foldVarSet (unionVarSet . subst_fv) emptyVarSet rhs_fvs
- where
- subst_fv fv = case lookupSubstEnv se fv of
- Nothing -> unitVarSet fv
- Just (DoneEx expr) -> exprFreeVars expr
- Just (DoneTy ty) -> tyVarsOfType ty
- Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
+------------------
+substVarSet subst fvs
+ = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
+ where
+ subst_fv subst fv
+ | isId fv = case substId subst fv of
+ DoneId fv' _ -> unitVarSet fv'
+ DoneEx expr -> exprFreeVars expr
+ ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
+ | otherwise = case lookupTvSubst subst fv of
+ Nothing -> unitVarSet fv
+ Just ty -> substVarSet subst (tyVarsOfType ty)
\end{code}
projects / ghc-hetmet.git / blobdiff