X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=cffa0954d8eb72d030011ef8de8728c632b1ed47;hb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;hp=d9d92791ff71eaa78e9272a880fa4e7edf6eecbe;hpb=c77080dd41381bdbdd2fbaa1472a458e415fc429;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index d9d9279..cffa095 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -23,8 +23,8 @@ module Subst ( bindSubst, unBindSubst, bindSubstList, unBindSubstList, -- Binders - substBndr, substBndrs, substTyVar, substId, substIds, - substAndCloneId, substAndCloneIds, + simplBndr, simplBndrs, simplLetId, simplIdInfo, + substAndCloneId, substAndCloneIds, substAndCloneRecIds, -- Type stuff mkTyVarSubst, mkTopTyVarSubst, @@ -37,31 +37,37 @@ module Subst ( #include "HsVersions.h" import CmdLineOpts ( opt_PprStyle_Debug ) -import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, +import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreRules(..), CoreRule(..), - emptyCoreRules, isEmptyCoreRules, seqRules + isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding ) -import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) -import TypeRep ( Type(..), TyNote(..), - ) -- friend +import CoreFVs ( exprFreeVars ) +import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( ThetaType, PredType(..), ClassContext, - tyVarsOfType, tyVarsOfTypes, mkAppTy + tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy ) import VarSet import VarEnv -import Var ( setVarUnique, isId ) -import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) -import IdInfo ( IdInfo, isFragileOcc, +import Var ( setVarUnique, isId, mustHaveLocalBinding ) +import Id ( idType, idInfo, setIdInfo, setIdType, + 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 Unique ( Uniquable(..), deriveUnique ) +import BasicTypes ( OccInfo(..) ) +import Unique ( Unique, Uniquable(..), deriveUnique ) import UniqSet ( elemUniqSet_Directly ) -import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply ) +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} @@ -72,7 +78,7 @@ import Util ( mapAccumL, foldl2, seqList, ($!) ) %************************************************************************ \begin{code} -data InScopeSet = InScope (VarEnv Var) Int# +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 @@ -87,8 +93,9 @@ 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) - (case length vs of { I# l -> n +# l }) +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 @@ -131,17 +138,17 @@ uniqAway (InScope set n) var try k #ifdef DEBUG | k ># 1000# - = pprPanic "uniqAway loop:" (ppr (I# k) <+> text "tries" <+> ppr var <+> int (I# n)) + = 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 (I# k) <+> text "tries" <+> ppr var <+> int (I# n)) + = 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 (I# (n *# k)) + uniq = deriveUnique orig_unique (iBox (n *# k)) \end{code} @@ -168,7 +175,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} @@ -176,11 +193,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 @@ -232,10 +247,12 @@ zapSubstEnv :: Subst -> Subst zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv extendSubst :: Subst -> Var -> SubstResult -> Subst -extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r) +extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } ) + Subst in_scope (extendSubstEnv env v r) extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst -extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r) +extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r ) + Subst in_scope (extendSubstEnvList env v r) lookupSubst :: Subst -> Var -> Maybe SubstResult lookupSubst (Subst _ env) v = lookupSubstEnv env v @@ -321,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} %************************************************************************ %* * @@ -345,7 +381,8 @@ mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst 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)) +zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) ) + 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. @@ -374,11 +411,11 @@ subst_ty subst ty where go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args + + go (PredTy p) = PredTy $! (substPred 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 (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 (FunTy arg res) = (FunTy $! (go arg)) $! (go res) go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) @@ -388,6 +425,8 @@ subst_ty subst ty go (ForAllTy tv ty) = case substTyVar subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + + go (UsageTy u ty) = mkUTy (go u) $! (go ty) \end{code} Here is where we invent a new binder if necessary. @@ -471,7 +510,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 @@ -490,82 +529,159 @@ 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 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 + +simplLetId :: Subst -> Id -> (Subst, Id) +-- Clone Id if necessary +-- Substitute its type +-- Return an Id with completely zapped IdInfo +-- Augment the subtitution if the unique changed or if there's +-- interesting occurrence info +-- [A subsequent substIdInfo will restore its IdInfo] +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 -> Id -> Id + -- Used by the simplifier to compute new IdInfo for a let(rec) binder, + -- subsequent to simplLetId having zapped its IdInfo +simplIdInfo subst old_info bndr + = case substIdInfo subst isFragileOcc old_info of + Just new_info -> bndr `setIdInfo` new_info + Nothing -> bndr `setIdInfo` 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 +\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 || isFragileOcc 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 `extendInScopeSet` 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 - id2 = zapFragileIdInfo id1 - new_id = setVarUnique id2 (uniqFromSupply us1) - (us1,new_us) = splitUniqSupply us + 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 (length ids) 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 (length ids) 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} @@ -577,29 +693,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 + `setLBVarInfo` substLBVar subst old_lbv + `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) && + hasNoLBVarInfo old_lbv && + not (hasUnfolding (unfoldingInfo info)) + + zap_occ = is_fragile_occ old_occ + old_occ = occInfo info + old_rules = specInfo info + old_wrkr = workerInfo info + old_lbv = lbvarInfo 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 @@ -644,4 +781,9 @@ substVarSet subst fvs DoneEx expr -> exprFreeVars expr DoneTy ty -> tyVarsOfType ty ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr) + +substLBVar subst NoLBVarInfo = NoLBVarInfo +substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1 + where + ty1 = substTy subst ty \end{code}