diff options
Diffstat (limited to 'compiler/coreSyn/CoreSubst.lhs')
| -rw-r--r-- | compiler/coreSyn/CoreSubst.lhs | 393 |
1 files changed, 393 insertions, 0 deletions
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs new file mode 100644 index 0000000000..c432d55f94 --- /dev/null +++ b/compiler/coreSyn/CoreSubst.lhs @@ -0,0 +1,393 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[CoreUtils]{Utility functions on @Core@ syntax} + +\begin{code} +module CoreSubst ( + -- Substitution stuff + Subst, TvSubstEnv, IdSubstEnv, InScopeSet, + + substTy, substExpr, substSpec, substWorker, + lookupIdSubst, lookupTvSubst, + + emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, + extendInScope, extendInScopeIds, + isInScope, + + -- Binders + substBndr, substBndrs, substRecBndrs, + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + ) where + +#include "HsVersions.h" + +import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, + CoreRule(..), hasUnfolding, noUnfolding + ) +import CoreFVs ( exprFreeVars ) +import CoreUtils ( exprIsTrivial ) + +import qualified Type ( substTy, substTyVarBndr ) +import Type ( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), mkTyVarTy ) +import VarSet +import VarEnv +import Var ( setVarUnique, isId ) +import Id ( idType, setIdType, maybeModifyIdInfo, isLocalId ) +import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + unfoldingInfo, setUnfoldingInfo, seqSpecInfo, + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo + ) +import Unique ( Unique ) +import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply ) +import Var ( Var, Id, TyVar, isTyVar ) +import Maybes ( orElse ) +import Outputable +import PprCore () -- Instances +import Util ( mapAccumL ) +import FastTypes +\end{code} + + +%************************************************************************ +%* * +\subsection{Substitutions} +%* * +%************************************************************************ + +\begin{code} +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) + IdSubstEnv -- Substitution for Ids + TvSubstEnv -- Substitution for TyVars + + -- 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. + -- This is what lets us deal with name capture properly + -- It's a hard invariant to check... + -- There are various ways of causing it to happen: + -- - arrange that the in-scope set really is all the things in scope + -- - arrange that it's the free vars of the range of the substitution + -- - make it empty because all the free vars of the subst are fresh, + -- and hence can't possibly clash.a + -- + -- INVARIANT 2: The substitution is apply-once; see notes with + -- Types.TvSubstEnv + +type IdSubstEnv = IdEnv CoreExpr + +---------------------------- +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv + +mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs ids = Subst in_scope ids tvs + +-- 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 + +substInScope :: Subst -> InScopeSet +substInScope (Subst in_scope _ _) = in_scope + +-- zapSubstEnv :: Subst -> Subst +-- 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 -> CoreExpr -> Subst +extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs + +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs + +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) + +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) + +lookupIdSubst :: Subst -> Id -> CoreExpr +lookupIdSubst (Subst in_scope ids tvs) v + | not (isLocalId v) = Var v + | otherwise + = case lookupVarEnv ids v of { + Just e -> e ; + Nothing -> + case lookupInScope in_scope v of { + -- Watch out! Must get the Id from the in-scope set, + -- because its type there may differ + Just v -> Var v ; + Nothing -> WARN( True, ptext SLIT("CoreSubst.lookupIdSubst") <+> ppr v ) + Var v + }} + +lookupTvSubst :: Subst -> TyVar -> Type +lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v `orElse` mkTyVarTy v + +------------------------------ +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope + +extendInScope :: Subst -> Var -> Subst +extendInScope (Subst in_scope ids tvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) + +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) tvs +\end{code} + +Pretty printing, for debugging only + +\begin{code} +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} + + +%************************************************************************ +%* * + Substituting expressions +%* * +%************************************************************************ + +\begin{code} +substExpr :: Subst -> CoreExpr -> CoreExpr +substExpr subst expr + = go expr + where + go (Var v) = lookupIdSubst subst v + go (Type ty) = Type (substTy subst ty) + 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' (substExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + + 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') (substExpr subst' body) + where + (subst', bndrs') = substRecBndrs subst (map fst pairs) + pairs' = bndrs' `zip` rhss' + rhss' = map (substExpr subst' . snd) pairs + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + + go_note (Coerce ty1 ty2) = Coerce (substTy subst ty1) (substTy subst ty2) + go_note note = note +\end{code} + + +%************************************************************************ +%* * + Substituting binders +%* * +%************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. + +\begin{code} +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | otherwise = substIdBndr subst subst bndr + +substBndrs :: Subst -> [Var] -> (Subst, [Var]) +substBndrs subst bndrs = mapAccumL substBndr subst bndrs + +substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +-- Substitute a mutually recursive group +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr new_subst) subst bndrs +\end{code} + + +\begin{code} +substIdBndr :: Subst -- Substitution to use for the IdInfo + -> Subst -> Id -- Substitition and Id to transform + -> (Subst, Id) -- Transformed pair + +substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 = substIdType subst id1 -- id2 has its type zapped + + -- 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 rec_subst) id2 + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | new_id /= old_id = extendVarEnv env old_id (Var new_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} +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids + = (subst', ids') + where + (subst', ids') = mapAccumL (clone_id subst') subst + (ids `zip` uniqsFromSupply us) + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitition and Id to transform + -> (Subst, Id) -- Transformed pair + +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 + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2 + new_env = extendVarEnv env old_id (Var new_id) +\end{code} + + +%************************************************************************ +%* * + Types +%* * +%************************************************************************ + +For types we just call the corresponding function in Type, but we have +to repackage the substitution, from a Subst to a TvSubst + +\begin{code} +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env) tv + = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env', tv') + +substTy :: Subst -> Type -> Type +substTy (Subst in_scope id_env tv_env) ty + = Type.substTy (TvSubst in_scope tv_env) ty +\end{code} + + +%************************************************************************ +%* * +\section{IdInfo substitution} +%* * +%************************************************************************ + +\begin{code} +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 (substTy subst 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 + +------------------ +substIdInfo :: Subst -> IdInfo -> Maybe IdInfo +-- Always zaps the unfolding, to save substitution work +substIdInfo subst info + | nothing_to_do = Nothing + | otherwise = Just (info `setSpecInfo` substSpec subst old_rules + `setWorkerInfo` substWorker subst old_wrkr + `setUnfoldingInfo` noUnfolding) + where + old_rules = specInfo info + old_wrkr = workerInfo info + nothing_to_do = isEmptySpecInfo old_rules && + not (workerExists old_wrkr) && + not (hasUnfolding (unfoldingInfo info)) + + +------------------ +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 lookupIdSubst subst w of + Var w1 -> HasWorker w1 a + other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w ) + NoWorker -- Worker has got substituted away altogether + -- (This can happen if it's trivial, + -- via postInlineUnconditionally, hence warning) + +------------------ +substSpec :: Subst -> SpecInfo -> SpecInfo + +substSpec subst spec@(SpecInfo rules rhs_fvs) + | isEmptySubst subst + = spec + | otherwise + = seqSpecInfo new_rules `seq` new_rules + where + new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs) + + do_subst rule@(BuiltinRule {}) = rule + do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = rule { ru_bndrs = bndrs', + ru_args = map (substExpr subst') args, + ru_rhs = substExpr subst' rhs } + where + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substVarSet subst fvs + = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs + where + subst_fv subst fv + | isId fv = exprFreeVars (lookupIdSubst subst fv) + | otherwise = tyVarsOfType (lookupTvSubst subst fv) +\end{code} |