X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=212e914f9cecf264529bc9582cc2d6d5213a465e;hb=de0864de66d27f8d7523fac11ecfae0347b739f3;hp=ab51482543ddcef1ed8b677a70d3c02a71bdc917;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index ab51482..212e914 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -6,67 +6,161 @@ \begin{code} module Subst ( -- In-scope set - InScopeSet, emptyInScopeSet, - lookupInScope, setInScope, extendInScope, extendInScopes, isInScope, modifyInScope, + InScopeSet, emptyInScopeSet, mkInScopeSet, + extendInScopeSet, extendInScopeSetList, + lookupInScope, elemInScopeSet, uniqAway, + -- Substitution stuff Subst, TyVarSubst, IdSubst, emptySubst, mkSubst, substEnv, substInScope, lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList, zapSubstEnv, setSubstEnv, + setInScope, + extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList, + isInScope, modifyInScope, 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, substClasses, substTheta, + substTyWith, substTy, substTheta, deShadowTy, -- Expression stuff - substExpr, substIdInfo + substExpr, substRules ) where #include "HsVersions.h" -import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, +import CmdLineOpts ( opt_PprStyle_Debug ) +import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreRules(..), CoreRule(..), - emptyCoreRules, isEmptyCoreRules, seqRules + isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding, + Unfolding(..) ) import CoreFVs ( exprFreeVars ) -import TypeRep ( Type(..), TyNote(..), - ) -- friend -import Type ( ThetaType, PredType(..), ClassContext, - tyVarsOfType, tyVarsOfTypes, mkAppTy +import TypeRep ( Type(..), TyNote(..) ) -- friend +import Type ( ThetaType, SourceType(..), PredType, + tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet import VarEnv -import Var ( setVarUnique, isId ) -import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) -import Name ( isLocallyDefined ) -import IdInfo ( IdInfo, isFragileOccInfo, +import Var ( setVarUnique, isId, mustHaveLocalBinding ) +import Id ( idType, idInfo, setIdInfo, setIdType, + idUnfolding, setIdUnfolding, + idOccInfo, maybeModifyIdInfo ) +import IdInfo ( IdInfo, vanillaIdInfo, + occInfo, isFragileOcc, setOccInfo, specInfo, setSpecInfo, - WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo + unfoldingInfo, setUnfoldingInfo, + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo, + lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo ) import BasicTypes ( OccInfo(..) ) -import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply ) +import Unique ( Unique, Uniquable(..), deriveUnique ) +import UniqSet ( elemUniqSet_Directly ) +import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply ) import Var ( Var, Id, TyVar, isTyVar ) import Outputable -import PprCore () -- Instances -import Util ( mapAccumL, foldl2, seqList, ($!) ) +import PprCore () -- Instances +import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv) +import Util ( mapAccumL, foldl2, seqList ) +import FastTypes \end{code} + %************************************************************************ %* * -\subsection{Substitutions} +\subsection{The in-scope set} %* * %************************************************************************ \begin{code} -type InScopeSet = VarEnv Var +data InScopeSet = InScope (VarEnv Var) FastInt + -- The Int# is a kind of hash-value used by uniqAway + -- For example, it might be the size of the set + -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet 1# + +mkInScopeSet :: VarEnv Var -> InScopeSet +mkInScopeSet in_scope = InScope in_scope 1# + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) + (n +# iUnbox (length vs)) + +modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet +-- Exploit the fact that the in-scope "set" is really a map +-- Make old_v map to new_v +modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope + +lookupInScope :: InScopeSet -> Var -> Var +-- It's important to look for a fixed point +-- When we see (case x of y { I# v -> ... }) +-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). +-- When we lookup up an occurrence of x, we map to y, but then +-- we want to look up y in case it has acquired more evaluation information by now. +lookupInScope (InScope in_scope n) v + = go v + where + go v = case lookupVarEnv in_scope v of + Just v' | v == v' -> v' -- Reached a fixed point + | otherwise -> go v' + Nothing -> WARN( mustHaveLocalBinding v, ppr v ) + v +\end{code} + +\begin{code} +uniqAway :: InScopeSet -> Var -> Var +-- (uniqAway in_scope v) finds a unique that is not used in the +-- in-scope set, and gives that to v. It starts with v's current unique, of course, +-- in the hope that it won't have to change it, nad thereafter uses a combination +-- of that and the hash-code found in the in-scope set +uniqAway (InScope set n) var + | not (var `elemVarSet` set) = var -- Nothing to do + | otherwise = try 1# + where + orig_unique = getUnique var + try k +#ifdef DEBUG + | k ># 1000# + = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) +#endif + | uniq `elemUniqSet_Directly` set = try (k +# 1#) +#ifdef DEBUG + | opt_PprStyle_Debug && k ># 3# + = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + setVarUnique var uniq +#endif + | otherwise = setVarUnique var uniq + where + uniq = deriveUnique orig_unique (iBox (n *# k)) +\end{code} + +%************************************************************************ +%* * +\subsection{Substitutions} +%* * +%************************************************************************ + +\begin{code} data Subst = Subst InScopeSet -- In scope SubstEnv -- Substitution itself -- INVARIANT 1: The (domain of the) in-scope set is a superset @@ -83,7 +177,17 @@ data Subst = Subst InScopeSet -- In scope -- -- INVARIANT 2: No variable is both in scope and in the domain of the substitution -- Equivalently, the substitution is idempotent - -- + -- [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 IdSubst = Subst \end{code} @@ -91,11 +195,9 @@ type IdSubst = Subst 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. + new_id has a correctly-substituted type, occ info -* substId adds a binding (DoneVar new_id occ) to the substitution if +* 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 @@ -126,15 +228,6 @@ The general plan about the substitution and in-scope set for Ids is as follows 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} - - \begin{code} isEmptySubst :: Subst -> Bool @@ -172,44 +265,45 @@ lookupIdSubst (Subst in_scope env) v Just res -> res Nothing -> DoneId v' (idOccInfo v') -- We don't use DoneId for LoopBreakers, so the idOccInfo is - -- very important! If isFragileOccInfo returned True for + -- 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 v' = lookupInScope in_scope v -lookupInScope :: InScopeSet -> Var -> Var --- It's important to look for a fixed point --- When we see (case x of y { I# v -> ... }) --- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). --- When we lookup up an occurrence of x, we map to y, but then --- we want to look up y in case it has acquired more evaluation information by now. -lookupInScope in_scope v - = case lookupVarEnv in_scope v of - Just v' | v == v' -> v' -- Reached a fixed point - | otherwise -> lookupInScope in_scope v' - Nothing -> v - isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope - -extendInScope :: Subst -> Var -> Subst -extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env +isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope modifyInScope :: Subst -> Var -> Var -> Subst -modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env +modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet 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 add_in_scope in_scope vs) env +extendInScope :: Subst -> Var -> Subst + -- Add a new variable as in-scope + -- Remember to delete any existing binding in the substitution! +extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) + (env `delSubstEnv` v) + +extendInScopeList :: Subst -> [Var] -> Subst +extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs) + (delSubstEnvList env vs) + +-- The "New" variants are guaranteed to be adding freshly-allocated variables +-- It's not clear that the gain (not needing to delete it from the substitution) +-- is worth the extra proof obligation +extendNewInScope :: Subst -> Var -> Subst +extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env + +extendNewInScopeList :: Subst -> [Var] -> Subst +extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` 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 `add_in_scope` new_bndr) + = Subst (in_scope `extendInScopeSet` new_bndr) (extendSubstEnv env old_bndr subst_result) where subst_result | isId old_bndr = DoneEx (Var new_bndr) @@ -219,7 +313,7 @@ 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 `delVarEnv` new_bndr) (delSubstEnv env old_bndr) + = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr) -- And the "List" forms bindSubstList :: Subst -> [Var] -> [Var] -> Subst @@ -244,6 +338,25 @@ setSubstEnv :: Subst -- Take in-scope part from here setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2 \end{code} +Pretty printing, for debugging only + +\begin{code} +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 + ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t + +instance Outputable SubstEnv where + ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se))))) + where + ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr + +instance Outputable Subst where + ppr (Subst (InScope in_scope _) se) + = ptext SLIT(" braces (fsep (map ppr (rngVarEnv in_scope))) + $$ ptext SLIT(" Subst =") <+> ppr se <> char '>' +\end{code} %************************************************************************ %* * @@ -252,36 +365,58 @@ setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2 %************************************************************************ \begin{code} -type TyVarSubst = Subst -- TyVarSubst are expected to have range elements +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) +mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) + (zipTyEnv tyvars tys) -- 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 emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv) +mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys) + +zipTyEnv tyvars tys +#ifdef DEBUG + | length tyvars /= length tys + = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv + | otherwise +#endif + = 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)) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" \end{code} substTy works with general Substs, so that it can be called from substExpr too. \begin{code} +substTyWith :: [TyVar] -> [Type] -> Type -> Type +substTyWith tvs tys = substTy (mkTyVarSubst tvs tys) + substTy :: Subst -> Type -> Type substTy subst ty | isEmptySubst subst = ty | otherwise = subst_ty subst ty -substClasses :: TyVarSubst -> ClassContext -> ClassContext -substClasses subst theta - | isEmptySubst subst = theta - | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta] +deShadowTy :: Type -> Type -- Remove any shadowing from the type +deShadowTy ty = subst_ty emptySubst ty substTheta :: TyVarSubst -> ThetaType -> ThetaType substTheta subst theta @@ -289,26 +424,30 @@ substTheta subst theta | otherwise = map (substPred subst) theta substPred :: TyVarSubst -> PredType -> PredType -substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys) -substPred subst (IParam n ty) = IParam n (subst_ty subst ty) +substPred = substSourceType + +substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty) +substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) +substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys) 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 (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr - go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - go ty@(TyVarTy tv) = case (lookupSubst subst tv) of + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + + go (SourceTy p) = SourceTy $! (substSourceType subst p) + + 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 (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 + go (ForAllTy tv ty) = case substTyVar subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) \end{code} @@ -325,7 +464,7 @@ substTyVar subst@(Subst in_scope env) old_var -- -- 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 `add_in_scope` new_var) + = (Subst (in_scope `extendInScopeSet` new_var) (delSubstEnv env old_var), new_var) @@ -334,7 +473,7 @@ substTyVar subst@(Subst in_scope env) old_var -- Extending the substitution to do this renaming also -- has the (correct) effect of discarding any existing -- substitution for that variable - = (Subst (in_scope `add_in_scope` new_var) + = (Subst (in_scope `extendInScopeSet` new_var) (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))), new_var) where @@ -393,7 +532,7 @@ substExpr subst expr go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body) where - (subst', bndrs') = substBndrs subst (map fst pairs) + (subst', bndrs') = substRecIds subst (map fst pairs) pairs' = bndrs' `zip` rhss' rhss' = map (substExpr subst' . snd) pairs @@ -412,82 +551,177 @@ substExpr subst expr \end{code} -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 - (c) give it a new unique to avoid name clashes +%************************************************************************ +%* * +\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 = substTyVar subst bndr + | otherwise = subst_id isFragileOcc 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 isFragileOcc 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) old_id + = (Subst (in_scope `extendInScopeSet` new_id) new_env, 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 + = extendSubstEnv env old_id (DoneId new_id occ_info) + | otherwise + = delSubstEnv 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 subst isFragileOcc old_info of + Just new_info -> new_info + Nothing -> old_info +\end{code} + +\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. Hence the calls to +-- simpl_id with keepOccInfo + substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr | isTyVar bndr = substTyVar subst bndr - | otherwise = substId subst bndr + | otherwise = subst_id keepOccInfo subst subst bndr substBndrs :: Subst -> [Var] -> (Subst, [Var]) substBndrs subst bndrs = mapAccumL substBndr subst bndrs +substRecIds :: Subst -> [Id] -> (Subst, [Id]) +-- Substitute a mutually recursive group +substRecIds 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 (subst_id keepOccInfo new_subst) subst bndrs -substIds :: Subst -> [Id] -> (Subst, [Id]) -substIds subst bndrs = mapAccumL substId subst bndrs +keepOccInfo occ = False -- Never fragile +\end{code} -substId :: Subst -> Id -> (Subst, Id) - -- 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 `add_in_scope` new_id) new_env, new_id) +\begin{code} +subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile + -> 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 is_fragile_occ rec_subst subst@(Subst in_scope env) old_id + = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id) where - id_ty = idType old_id - occ_info = idOccInfo 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) + -- id1 is cloned if necessary + id1 = uniqAway in_scope old_id - -- id2 has its IdInfo zapped - id2 = zapFragileIdInfo id1 + -- id2 has its type zapped + id2 = substIdType subst id1 - -- new_id is cloned if necessary - new_id = uniqAway in_scope id2 + -- 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 is_fragile_occ) id2 - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information + -- Extend the substitution if the unique has changed -- 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) + new_env | new_id /= old_id + = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id)) | otherwise = delSubstEnv 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 `add_in_scope` 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) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_env, 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 rec_subst isFragileOcc) id2 + new_env = extendSubstEnv 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 = 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@(Subst in_scope env) us old_id + = subst_clone_id subst subst (old_id, uniqFromSupply us) \end{code} @@ -499,30 +733,50 @@ substAndCloneId subst@(Subst in_scope env) us old_id \begin{code} substIdInfo :: Subst - -> IdInfo -- Get un-substituted ones from here - -> IdInfo -- Substitute it and add it to here - -> IdInfo -- To give this - -- Seq'ing on the returned IdInfo is enough to cause all the - -- substitutions to happen completely - -substIdInfo subst old_info new_info - = info2 - where - info1 | isEmptyCoreRules old_rules = new_info - | otherwise = new_info `setSpecInfo` new_rules + -> (OccInfo -> Bool) -- True <=> zap the occurrence info + -> IdInfo + -> Maybe IdInfo +-- Substitute the +-- rules +-- worker info +-- LBVar info +-- Zap the unfolding +-- Zap the occ info if instructed to do so +-- +-- Seq'ing on the returned IdInfo is enough to cause all the +-- substitutions to happen completely + +substIdInfo subst is_fragile_occ info + | nothing_to_do = Nothing + | otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ) + `setSpecInfo` substRules subst old_rules + `setWorkerInfo` substWorker subst old_wrkr + `setUnfoldingInfo` noUnfolding) -- setSpecInfo does a seq - where - new_rules = substRules subst old_rules - - info2 | not (workerExists old_wrkr) = info1 - | otherwise = info1 `setWorkerInfo` new_wrkr -- setWorkerInfo does a seq - where - new_wrkr = substWorker subst old_wrkr - - old_rules = specInfo old_info - old_wrkr = workerInfo old_info + where + nothing_to_do = not zap_occ && + isEmptyCoreRules old_rules && + not (workerExists old_wrkr) && + not (hasUnfolding (unfoldingInfo info)) + + zap_occ = is_fragile_occ old_occ + old_occ = occInfo info + old_rules = specInfo info + old_wrkr = workerInfo info + +------------------ +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst in_scope env) id + | noTypeSubst 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 +------------------ substWorker :: Subst -> WorkerInfo -> WorkerInfo -- Seq'ing on the returned WorkerInfo is enough to cause all the -- substitutions to happen completely @@ -530,15 +784,21 @@ substWorker :: Subst -> WorkerInfo -> WorkerInfo substWorker subst NoWorker = NoWorker substWorker subst (HasWorker w a) - = case lookupSubst subst w of - Nothing -> HasWorker w a - Just (DoneId w1 _) -> HasWorker w1 a - Just (DoneEx (Var w1)) -> HasWorker w1 a - Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w ) + = case lookupIdSubst subst w of + (DoneId w1 _) -> HasWorker w1 a + (DoneEx (Var w1)) -> HasWorker w1 a + (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w ) NoWorker -- Worker has got substituted away altogether - Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e) + (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 @@ -549,24 +809,23 @@ substRules subst rules substRules subst (Rules rules rhs_fvs) = seqRules new_rules `seq` new_rules where - new_rules = Rules (map do_subst rules) - (subst_fvs (substEnv subst) rhs_fvs) + new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs) - do_subst rule@(BuiltinRule _) = rule - do_subst (Rule name tpl_vars lhs_args rhs) - = Rule name tpl_vars' + 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 (DoneId fv' _) -> 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 = case lookupIdSubst subst fv of + DoneId fv' _ -> unitVarSet fv' + DoneEx expr -> exprFreeVars expr + DoneTy ty -> tyVarsOfType ty + ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr) \end{code}