From 2317c27bc0ca18dec43eacf87a6cf22cdf01f0f7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 28 Feb 2006 13:31:57 +0000 Subject: [PATCH] Simplify the IdInfo before any RHSs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Simplfy (i.e. substitute) the IdInfo of a recursive group of Ids before looking at the RHSs of *any* of them. That way, the rules are available throughout the letrec, which means we don't have to be careful about function to put first. Before, we just simplified the IdInfo of f before looking at f's RHS, but that's not so good when f and g both have RULES, and both rules mention the other. This change makes things simpler, but shouldn't change performance. --- ghc/compiler/coreSyn/CoreSubst.lhs | 2 +- ghc/compiler/simplCore/OccurAnal.lhs | 14 +- ghc/compiler/simplCore/SimplEnv.lhs | 243 ++++++++++++++++++++-------------- ghc/compiler/simplCore/Simplify.lhs | 63 ++------- 4 files changed, 169 insertions(+), 153 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreSubst.lhs b/ghc/compiler/coreSyn/CoreSubst.lhs index 24bf7df..c432d55 100644 --- a/ghc/compiler/coreSyn/CoreSubst.lhs +++ b/ghc/compiler/coreSyn/CoreSubst.lhs @@ -254,7 +254,7 @@ substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2 -- Extend the substitution if the unique has changed - -- See the notes with substTyVarBndr for the delSubstEnv + -- 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} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 0b7cf3b..ad3eee0 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -22,11 +22,10 @@ import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial, isDefaultAlt ) import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, idOccInfo, setIdOccInfo, isLocalId, - isExportedId, idArity, idSpecialisation, + isExportedId, idArity, idType, idUnique, Id ) import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt ) -import IdInfo ( isEmptySpecInfo ) import VarSet import VarEnv @@ -320,9 +319,14 @@ reOrderRec env (CyclicSCC (bind : binds)) | inlineCandidate bndr rhs = 2 -- Likely to be inlined - | not (isEmptySpecInfo (idSpecialisation bndr)) = 1 - -- Avoid things with specialisations; we'd like - -- to take advantage of them in the subsequent bindings +-- NOT NEEDED ANY MORE [Feb06] +-- We make all rules available in all bindings, by substituting +-- the IdInfo before looking at any RHSs. I'm just leaving this +-- snippet in as a commment so we can find it again if necessary. +-- +-- | not (isEmptySpecInfo (idSpecialisation bndr)) = 1 +-- -- Avoid things with specialisations; we'd like +-- -- to take advantage of them in the subsequent bindings | otherwise = 0 diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index df56ea7..0f5d467 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -25,9 +25,9 @@ module SimplEnv ( SimplSR(..), mkContEx, substId, - simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs, + simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, - simplIdInfo, substExpr, substTy, + substExpr, substTy, -- Floats FloatsWith, FloatsWithExpr, @@ -61,7 +61,8 @@ import qualified Type ( substTy, substTyVarBndr ) import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, isUnLiftedType, seqType, tyVarsOfType ) import BasicTypes ( OccInfo(..), isFragileOcc ) -import DynFlags ( SimplifierMode(..) ) +import DynFlags ( SimplifierMode(..) ) +import Util ( mapAccumL ) import Outputable \end{code} @@ -278,7 +279,12 @@ addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv -- The new Ids are guaranteed to be freshly allocated addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs = env { seInScope = in_scope `extendInScopeSetList` vs, - seIdSubst = id_subst `delVarEnvList` vs } -- Why delete? + seIdSubst = id_subst `delVarEnvList` vs } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- *delete* it from the substitution when going inside + -- the (\x -> ...)! modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' @@ -374,11 +380,10 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v These functions are in the monad only so that they can be made strict via seq. \begin{code} -simplBinders, simplLamBndrs, simplLetBndrs +simplBinders, simplLamBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs -simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs ------------- simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) @@ -394,11 +399,6 @@ simplBinder env bndr ; seqId id `seq` return (env', id) } ------------- -simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) -simplLetBndr env id = do { let (env', id') = substLetId env id - ; seqId id' `seq` return (env', id') } - -------------- simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) -- Used for lambda binders. These sometimes have unfoldings added by -- the worker/wrapper pass that must be preserved, becuase they can't @@ -414,17 +414,7 @@ simplLamBndr env bndr (env', id1) = substIdBndr env bndr id2 = id1 `setIdUnfolding` substUnfolding env old_unf -------------- -seqTyVar :: TyVar -> () -seqTyVar b = b `seq` () - -seqId :: Id -> () -seqId id = seqType (idType id) `seq` - idInfo id `seq` - () -\end{code} - -\begin{code} +-------------- substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform -> (SimplEnv, Id) -- Transformed pair @@ -450,10 +440,9 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) -- id2 has its type zapped id2 = substIdType env id1 - -- new_id has the right IdInfo - -- The lazy-set is because we're in a loop here, with - -- rec_env, when dealing with a mutually-recursive group - new_id = maybeModifyIdInfo (substIdInfo env) id2 + -- new_id has the final IdInfo + subst = mkCoreSubst env + new_id = maybeModifyIdInfo (substIdInfo subst) id2 -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delSubstEnv @@ -461,94 +450,116 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id)) | otherwise = delVarEnv id_subst old_id +\end{code} + + +\begin{code} +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids +\end{code} + + +%************************************************************************ +%* * + Let bindings +%* * +%************************************************************************ -substLetId :: SimplEnv -> Id -> (SimplEnv, Id) --- A variant for let-bound Ids --- Clone Id if necessary --- Substitute its type +Simplifying let binders +~~~~~~~~~~~~~~~~~~~~~~~ +Rename the binders if necessary, and substitute their IdInfo, +and re-attach it. The resulting binders therefore have all +their RULES, which is important in a mutually recursive group + +We must transfer the IdInfo of the original binder to the new binder. +This is crucial, to preserve + strictness + rules + worker info +etc. To do this we must apply the current substitution, +which incorporates earlier substitutions in this very letrec group. + +NB 1. We do this *before* processing the RHS of the binder, so that +its substituted rules are visible in its own RHS. +This is important. Manuel found cases where he really, really +wanted a RULE for a recursive function to apply in that function's +own right-hand side. + +NB 2: We do not transfer the arity (see Subst.substIdInfo) +The arity of an Id should not be visible +in its own RHS, else we eta-reduce + f = \x -> f x +to + f = f +which isn't sound. And it makes the arity in f's IdInfo greater than +the manifest arity, which isn't good. +The arity will get added later. + +NB 3: It's important that we *do* transer the loop-breaker OccInfo, +because that's what stops the Id getting inlined infinitely, in the body +of the letrec. + +NB 4: does no harm for non-recursive bindings + +\begin{code} +simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +simplNonRecBndr env id + = do { let subst = mkCoreSubst env + (env1, id1) = substLetIdBndr subst env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) +simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids + = do { let -- Notice the knot here; we need the result to make + -- a substitution for the IdInfo. c.f. CoreSubst.substIdBndr + (env1, ids1) = mapAccumL (substLetIdBndr subst) env ids + subst = mkCoreSubst env1 + ; seqIds ids1 `seq` return (env1, ids1) } + +--------------- +substLetIdBndr :: CoreSubst.Subst -- Substitution to use for the IdInfo (knot-tied) + -> SimplEnv -> InBinder -- Env and binder to transform + -> (SimplEnv, OutBinder) +-- C.f. CoreSubst.substIdBndr +-- 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 +-- +-- The difference between SimplEnv.substIdBndr above is +-- a) the rec_subst +-- b) the hackish "interesting occ info" part (due to vanish) -substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id +substLetIdBndr rec_subst env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id = (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) where - old_info = idInfo old_id - id1 = uniqAway in_scope old_id - id2 = substIdType env id1 - new_id = setIdInfo id2 vanillaIdInfo + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2 -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information -- See the notes with substTyVarBndr for the delSubstEnv - occ_info = occInfo old_info + occ_info = occInfo (idInfo old_id) new_subst | new_id /= old_id || isFragileOcc occ_info = extendVarEnv id_subst old_id (DoneId new_id occ_info) | otherwise = delVarEnv id_subst old_id -\end{code} - - -%************************************************************************ -%* * - Impedence matching to type substitution -%* * -%************************************************************************ - -\begin{code} -substTy :: SimplEnv -> Type -> Type -substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty - = Type.substTy (TvSubst in_scope tv_env) ty - -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv - = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of - (TvSubst in_scope' tv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') - --- When substituting in rules etc we can get CoreSubst to do the work --- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match --- here. I think the this will not usually result in a lot of work; --- the substitutions are typically small, and laziness will avoid work in many cases. - -mkCoreSubst :: SimplEnv -> CoreSubst.Subst -mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) - = mk_subst tv_env id_env - where - mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) - - fiddle (DoneEx e) = e - fiddle (DoneId v occ) = Var v - fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e - -substExpr :: SimplEnv -> CoreExpr -> CoreExpr -substExpr env expr - | isEmptySimplSubst env = expr - | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr -\end{code} - -%************************************************************************ -%* * -\section{IdInfo substitution} -%* * -%************************************************************************ - -\begin{code} -simplIdInfo :: SimplEnv -> IdInfo -> IdInfo - -- Used by the simplifier to compute new IdInfo for a let(rec) binder, - -- subsequent to simplLetId having zapped its IdInfo -simplIdInfo env old_info - = case substIdInfo env old_info of - Just new_info -> new_info - Nothing -> old_info - -substIdInfo :: SimplEnv - -> IdInfo - -> Maybe IdInfo +substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo -- Substitute the -- rules -- worker info @@ -559,7 +570,7 @@ substIdInfo :: SimplEnv -- Seq'ing on the returned IdInfo is enough to cause all the -- substitutions to happen completely -substIdInfo env info +substIdInfo 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) @@ -569,7 +580,6 @@ substIdInfo env info -- setSpecInfo does a seq -- setWorkerInfo does a seq where - subst = mkCoreSubst env nothing_to_do = keep_occ && keep_arity && isEmptySpecInfo old_rules && not (workerExists old_wrkr) && @@ -603,6 +613,45 @@ substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rh %************************************************************************ %* * + Impedence matching to type substitution +%* * +%************************************************************************ + +\begin{code} +substTy :: SimplEnv -> Type -> Type +substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty + = Type.substTy (TvSubst in_scope tv_env) ty + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv + = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') + +-- When substituting in rules etc we can get CoreSubst to do the work +-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match +-- here. I think the this will not usually result in a lot of work; +-- the substitutions are typically small, and laziness will avoid work in many cases. + +mkCoreSubst :: SimplEnv -> CoreSubst.Subst +mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) + = mk_subst tv_env id_env + where + mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) + + fiddle (DoneEx e) = e + fiddle (DoneId v occ) = Var v + fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e + +substExpr :: SimplEnv -> CoreExpr -> CoreExpr +substExpr env expr + | isEmptySimplSubst env = expr + | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr +\end{code} + + +%************************************************************************ +%* * \subsection{Floats} %* * %************************************************************************ diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 223d61a..0c857c6 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -233,7 +233,7 @@ simplTopBinds env binds -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. - simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> freeTick SimplifierDone `thenSmpl_` returnSmpl (floatBinds floats) @@ -308,16 +308,10 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let = -- Don't use simplBinder because that doesn't keep -- fragile occurrence info in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr1) -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> + simplNonRecBndr env bndr `thenSmpl` \ (env, bndr2) -> + simplStrictArg AnRhs env rhs rhs_se (idType bndr2) cont_ty $ \ env2 rhs1 -> -- Now complete the binding and simplify the body - let - -- simplLetBndr doesn't deal with the IdInfo, so we must - -- do so here (c.f. simplLazyBind) - bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) - env2 = modifyInScope env1 bndr2 bndr2 - in if needsCaseBinding bndr_ty rhs1 then thing_inside env2 `thenSmpl` \ (floats, body) -> @@ -329,7 +323,7 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep -- fragile occurrence info in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside @@ -465,43 +459,12 @@ simplLazyBind :: SimplEnv -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM (FloatsWith SimplEnv) -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = let -- Transfer the IdInfo of the original binder to the new binder - -- This is crucial: we must preserve - -- strictness - -- rules - -- worker info - -- etc. To do this we must apply the current substitution, - -- which incorporates earlier substitutions in this very letrec group. - -- - -- NB 1. We do this *before* processing the RHS of the binder, so that - -- its substituted rules are visible in its own RHS. - -- This is important. Manuel found cases where he really, really - -- wanted a RULE for a recursive function to apply in that function's - -- own right-hand side. - -- - -- NB 2: We do not transfer the arity (see Subst.substIdInfo) - -- The arity of an Id should not be visible - -- in its own RHS, else we eta-reduce - -- f = \x -> f x - -- to - -- f = f - -- which isn't sound. And it makes the arity in f's IdInfo greater than - -- the manifest arity, which isn't good. - -- The arity will get added later. - -- - -- NB 3: It's important that we *do* transer the loop-breaker OccInfo, - -- because that's what stops the Id getting inlined infinitely, in the body - -- of the letrec. - - -- NB 4: does no harm for non-recursive bindings - - bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) - env1 = modifyInScope env bndr2 bndr2 - rhs_env = setInScope rhs_se env1 +simplLazyBind env top_lvl is_rec bndr bndr2 rhs rhs_se + = let + rhs_env = setInScope rhs_se env is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkRhsStop (idType bndr1) + rhs_cont = mkRhsStop (idType bndr2) in -- Simplify the RHS; note the mkRhsStop, which tells -- the simplifier that this is the RHS of a let. @@ -510,7 +473,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- If any of the floats can't be floated, give up now -- (The allLifted predicate says True for empty floats.) if (not ok_float_unlifted && not (allLifted floats)) then - completeLazyBind env1 top_lvl bndr bndr2 + completeLazyBind env top_lvl bndr bndr2 (wrapFloats floats rhs1) else @@ -521,7 +484,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- If the result is a PAP, float the floats out, else wrap them -- By this time it's already been ANF-ised (if necessary) if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case - completeLazyBind env1 top_lvl bndr bndr2 rhs2 + completeLazyBind env top_lvl bndr bndr2 rhs2 else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then -- WARNING: long dodgy argument coming up @@ -562,12 +525,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ppr (filter demanded_float (floatBinds floats)) ) tick LetFloatFromLet `thenSmpl_` ( - addFloats env1 floats $ \ env2 -> + addFloats env floats $ \ env2 -> addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> completeLazyBind env3 top_lvl bndr bndr2 rhs2) else - completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) + completeLazyBind env top_lvl bndr bndr2 (wrapFloats floats rhs1) #ifdef DEBUG demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) @@ -756,7 +719,7 @@ simplExprF env (Case scrut bndr case_ty alts) cont case_ty' = substTy env case_ty -- c.f. defn of simplExpr simplExprF env (Let (Rec pairs) body) cont - = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down -- 1.7.10.4