From aa4f16def50ad9cbe5fff935a5cb91156150f5f1 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 11 Mar 1998 23:27:21 +0000 Subject: [PATCH] [project @ 1998-03-11 23:27:12 by simonpj] More simplifier modifications; may not even compile; will fix first thing tomorrow --- ghc/compiler/absCSyn/PprAbsC.lhs | 2 - ghc/compiler/coreSyn/CoreUnfold.lhs | 4 +- ghc/compiler/simplCore/BinderInfo.lhs | 79 +++------ ghc/compiler/simplCore/SimplEnv.lhs | 310 ++++++++++++++++----------------- ghc/compiler/simplCore/SimplVar.lhs | 29 ++- ghc/compiler/simplCore/Simplify.lhs | 42 +++-- 6 files changed, 220 insertions(+), 246 deletions(-) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 8483c9b..070cc7e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -19,8 +19,6 @@ module PprAbsC ( #include "HsVersions.h" import IO ( Handle ) --- import Char ( Char, isDigit, isPrint ) --- import GlaExts ( Addr(..) ) import AbsCSyn import ClosureInfo diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 8a1cb92..4c76eaf 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -518,9 +518,9 @@ certain that every use can be inlined. So, notably, any ArgOccs rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc \begin{code} -inlineUnconditionally :: Bool -> Id -> BinderInfo -> Bool +inlineUnconditionally :: Bool -> (Id,BinderInfo) -> Bool -inlineUnconditionally ok_to_dup id occ_info +inlineUnconditionally ok_to_dup (id, occ_info) | idMustNotBeINLINEd id = False | isOneFunOcc occ_info diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 8a4b922..eb3110e 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -47,19 +47,19 @@ data BinderInfo | ManyOcc -- Everything else besides DeadCode and OneOccs - Int -- number of arguments on stack when called; this is a minimum guarantee + !Int -- number of arguments on stack when called; this is a minimum guarantee | OneOcc -- Just one occurrence (or one each in -- mutually-exclusive case alts). - FunOrArg -- How it occurs + !FunOrArg -- How it occurs - DuplicationDanger + !DuplicationDanger - InsideSCC + !InsideSCC - Int -- Number of mutually-exclusive case alternatives + !Int -- Number of mutually-exclusive case alternatives -- in which it occurs -- Note that we only worry about the case-alt counts @@ -67,7 +67,7 @@ data BinderInfo -- time we *use* the info; we could be more clever for -- other cases if we really had to. (WDP/PS) - Int -- number of arguments on stack when called; minimum guarantee + !Int -- number of arguments on stack when called; minimum guarantee -- In general, we are feel free to substitute unless -- (a) is in an argument position (ArgOcc) @@ -188,73 +188,52 @@ addBinderInfo, orBinderInfo addBinderInfo DeadCode info2 = info2 addBinderInfo info1 DeadCode = info1 addBinderInfo info1 info2 - = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of - (I# i#) -> ManyOcc (I# i#) - -- ManyOcc min (getBinderInfoArity info1) (getBinderInfoArity info2)) + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) --- (orBinderInfo orig new) is used when combining occurrence --- info from branches of a case +-- (orBinderInfo orig new) is used in two situations: +-- First, when a variable whose occurrence info +-- is currently "orig" is bound to a variable whose occurrence info is "new" +-- eg (\new -> e) orig +-- What we want to do is to *worsen* orig's info to take account of new's +-- +-- Second, when combining occurrence info from branches of a case orBinderInfo DeadCode info2 = info2 orBinderInfo info1 DeadCode = info1 orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) (OneOcc posn2 dup2 scc2 n_alts2 ar_2) = let - -- Seriously maligned in order to make it stricter, - -- let's hope it is worth it.. posn = combine_posns posn1 posn2 scc = combine_sccs scc1 scc2 dup = combine_dups dup1 dup2 alts = n_alts1 + n_alts2 ar = min ar_1 ar_2 + in + OneOcc posn dup scc alts ar - -- No CSE, please! - cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } - cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } - cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } - cont4 = case ar of { (I# 0#) -> cont5; _ -> cont5 } - cont5 = OneOcc posn dup scc alts ar - in - case posn of { FunOcc -> cont1; _ -> cont1 } orBinderInfo info1 info2 - = case (min (getBinderInfoArity info1) (getBinderInfoArity info2)) of - (I# i#) -> ManyOcc (I# i#) + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) --- (andBinderInfo orig new) is used in two situations: --- First, when a variable whose occurrence info --- is currently "orig" is bound to a variable whose occurrence info is "new" --- eg (\new -> e) orig --- What we want to do is to *worsen* orig's info to take account of new's --- --- second, when completing a let-binding +-- (andBinderInfo orig new) is used +-- when completing a let-binding -- let new = ...orig... --- we compute the way orig occurs in (...orig...), and then use orBinderInfo +-- we compute the way orig occurs in (...orig...), and then use andBinderInfo -- to worsen this info by the way new occurs in the let body; then we use -- that to worsen orig's currently recorded occurrence info. andBinderInfo DeadCode info2 = DeadCode andBinderInfo info1 DeadCode = DeadCode -andBinderInfo (OneOcc posn1 dup1 scc1 (I# n_alts1#) (I# ar_1#)) - (OneOcc posn2 dup2 scc2 (I# n_alts2#) ar_2) +andBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) + (OneOcc posn2 dup2 scc2 n_alts2 ar_2) = let - -- Perversly maligned in order to make it stricter. - posn = combine_posns posn1 posn2 - scc = combine_sccs scc1 scc2 - dup = combine_dups dup1 dup2 - alts = I# (n_alts1# +# n_alts2#) - - -- No CSE, please! - cont1 = case scc of { InsideSCC -> cont2; _ -> cont2 } - cont2 = case dup of { DupDanger -> cont3; _ -> cont3 } - cont3 = case alts of { (I# 0#) -> cont4; _ -> cont4 } - cont4 = OneOcc posn dup scc alts (I# ar_1#) + posn = combine_posns posn1 posn2 + scc = combine_sccs scc1 scc2 + dup = combine_dups dup1 dup2 + alts = n_alts1 + n_alts2 in - case posn of {FunOcc -> cont1; _ -> cont1} + OneOcc posn dup scc alts ar_1 -andBinderInfo info1 info2 = - case getBinderInfoArity info1 of - (I# i#) -> ManyOcc (I# i#) - --ManyOcc (getBinderInfoArity info1) +andBinderInfo info1 info2 = ManyOcc (getBinderInfoArity info1) combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn @@ -262,7 +241,7 @@ combine_posns _ _ = ArgOcc combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo combine_dups _ DupDanger = DupDanger -combine_dups _ _ = NoDupDanger +combine_dups _ _ = NoDupDanger combine_sccs InsideSCC _ = InsideSCC -- Too paranoid?? ToDo combine_sccs _ InsideSCC = InsideSCC diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 9e59327..31e6eff 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -5,19 +5,19 @@ \begin{code} module SimplEnv ( - nullSimplEnv, combineSimplEnv, - pprSimplEnv, -- debugging only + nullSimplEnv, + getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, bindTyVar, bindTyVars, simplTy, - lookupId, bindIdToAtom, + lookupIdSubst, lookupOutIdEnv, - getSubstEnvs, setTyEnv, setIdEnv, notInScope, + bindIdToAtom, bindIdToExpr, markDangerousOccs, - lookupRhsInfo, lookupOutIdEnv, isEvaluated, + lookupRhsInfo, isEvaluated, extendEnvGivenBinding, extendEnvGivenNewRhs, - extendEnvGivenRhsInfo, extendEnvGivenInlining, + extendEnvGivenRhsInfo, lookForConstructor, @@ -29,7 +29,6 @@ module SimplEnv ( -- Types SwitchChecker, SimplEnv, - InIdEnv, InTypeEnv, UnfoldConApp, RhsInfo(..), @@ -43,8 +42,8 @@ module SimplEnv ( #include "HsVersions.h" import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, - okToInline, - BinderInfo {-instances, too-} + okToInline, isOneFunOcc, + BinderInfo ) import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, SimplifierSwitch(..), SwitchResult(..) @@ -54,7 +53,7 @@ import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, Unfolding(..), SimpleUnfolding(..), FormSummary(..), calcUnfoldingGuidance ) import CoreUtils ( coreExprCc ) -import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached ) +import CostCentre ( CostCentre, subsumedCosts, costsAreSubsumed, noCostCentreAttached ) import FiniteMap -- lots of things import Id ( getInlinePragma, nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, @@ -70,7 +69,7 @@ import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarE TyVar ) import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) -import UniqFM ( addToUFM, addToUFM_C, ufmToList ) +import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM ) import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList ) import Outputable \end{code} @@ -125,54 +124,85 @@ Id. Unfoldings in the Id itself are used only for imported things inside the Ids, etc.). \begin{code} -type InTypeEnv = (TyVarSet, -- In-scope tyvars (in result) - TyVarEnv Type) -- Type substitution +data SimplEnv + = SimplEnv + SwitchChecker + CostCentre -- The enclosing cost-centre (when profiling) + SimplTypeEnv -- Maps old type variables to new clones + SimplValEnv -- Maps locally-bound Ids to new clones + ConAppMap -- Maps constructor applications back to OutIds + +type SimplTypeEnv = (TyVarSet, -- In-scope tyvars (in result) + TyVarEnv Type) -- Type substitution -- If t is in the in-scope set, it certainly won't be -- in the domain of the substitution, and vice versa -type InIdEnv = (IdEnv Id, -- In-scope Ids (in result) - IdEnv OutArg) -- Id substitution - -- The in-scope set is represented by an IdEnv, because - -- we use it to propagate pragma info etc from binding - -- site to occurrences. +type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope + -- Ids (in result), range gives info about them + IdEnv SubstInfo) -- Id substitution + -- The first envt tells what Ids are in scope; it + -- corresponds to the TyVarSet in SimplTypeEnv -- The substitution usually maps an Id to its clone, -- but if the orig defn is a let-binding, and -- the RHS of the let simplifies to an atom, -- we just add the binding to the substitution and elide the let. + -- + -- Ids in the domain of the substitution are *not* in scope; + -- they *must* be substituted for the given OutArg + +data SubstInfo + = SubstArg OutArg -- The Id maps to an already-substituted atom + | SubstExpr -- Id maps to an as-yet-unsimplified expression + (TyVarEnv Type) -- ...hence we need to capture the substitution + (IdEnv SubstInfo) -- environments too + SimplifiableCoreExpr + +type StuffAboutId = (OutId, -- Always has the same unique as the + -- Id that maps to it; but may have better + -- IdInfo, and a correctly-substituted type, + -- than the occurrences of the Id. So use + -- this to replace occurrences -data SimplEnv - = SimplEnv - SwitchChecker - CostCentre -- The enclosing cost-centre (when profiling) - InTypeEnv -- Maps old type variables to new clones - InIdEnv -- Maps locally-bound Ids to new clones - OutIdEnv -- Info about the values of OutIds - ConAppMap -- Maps constructor applications back to OutIds + BinderInfo, -- How it occurs + -- We keep this info so we can modify it when + -- something changes. + RhsInfo) -- Info about what it is bound to +\end{code} + +The @RhsInfo@ part tells about the value to which the @OutId@ is bound. +\begin{code} +data RhsInfo = NoRhsInfo + | OtherLit [Literal] -- It ain't one of these + | OtherCon [Id] -- It ain't one of these + | OutUnfolding CostCentre + SimpleUnfolding -- Already-simplified unfolding +\end{code} + + +\begin{code} nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr - = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullIdEnv nullConApps - -combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv -combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) - new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ ) - = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps + = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullConApps -pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" +getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv) +getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env) -getSubstEnvs :: SimplEnv -> (InTypeEnv, InIdEnv) -getSubstEnvs (SimplEnv _ _ ty_env in_id_env _ _) = (ty_env, in_id_env) +setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv +setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env + = SimplEnv chkr encl_cc ty_env in_id_env con_apps -setTyEnv :: SimplEnv -> InTypeEnv -> SimplEnv -setTyEnv (SimplEnv chkr encl_cc _ in_id_env out_id_env con_apps) ty_env - = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps +setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv +setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env + = SimplEnv chkr encl_cc ty_env id_env con_apps -setIdEnv :: SimplEnv -> InIdEnv -> SimplEnv -setIdEnv (SimplEnv chkr encl_cc ty_env _ out_id_env con_apps) id_env - = SimplEnv chkr encl_cc ty_env id_env out_id_env con_apps +setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv +setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps) + ty_subst id_subst + = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps \end{code} @@ -184,10 +214,10 @@ setIdEnv (SimplEnv chkr encl_cc ty_env _ out_id_env con_apps) id_env \begin{code} getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr +getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _ _) switch +switchIsSet (SimplEnv chkr _ _ _ _) switch = switchIsOn chkr switch getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int @@ -196,8 +226,8 @@ getSimplIntSwitch chkr switch -- Crude, but simple setCaseScrutinee :: SimplEnv -> SimplEnv -setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps +setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps) + = SimplEnv chkr' encl_cc ty_env id_env con_apps where chkr' SimplCaseScrutinee = SwBool True chkr' other = chkr other @@ -230,17 +260,20 @@ and (b) Consider the following example then we won't get deforestation at all. We havn't solved this problem yet! -We prepare the envt by simply discarding the out_id_env, which has +We prepare the envt by simply modifying the id_env, which has all the unfolding info. At one point we did it by modifying the chkr so that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important, simplifications happening in the body of the RHS. \begin{code} switchOffInlining :: SimplEnv -> SimplEnv -switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps +switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) + = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps + where + forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoRhsInfo) \end{code} + %************************************************************************ %* * \subsubsection{The ``enclosing cost-centre''} @@ -250,11 +283,14 @@ switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) \begin{code} setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv -setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc - = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps +setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc + | costsAreSubsumed encl_cc + = env + | otherwise + = SimplEnv chkr encl_cc ty_env id_env con_apps getEnclosingCC :: SimplEnv -> CostCentre -getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc +getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc \end{code} %************************************************************************ @@ -268,20 +304,20 @@ They don't affect what tyvars are in scope. \begin{code} bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv -bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) tyvar ty - = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps +bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps where new_ty_subst = addToTyVarEnv ty_subst tyvar ty bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv -bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) extra_subst - = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps +bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps where new_ty_subst = ty_subst `plusTyVarEnv` extra_subst \end{code} \begin{code} -simplTy (SimplEnv _ _ (_, ty_subst) _ _ _) ty = returnEager (instantiateTy ty_subst ty) +simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty) \end{code} %************************************************************************ @@ -290,25 +326,14 @@ simplTy (SimplEnv _ _ (_, ty_subst) _ _ _) ty = returnEager (instantiateTy ty_su %* * %************************************************************************ -\begin{code} -lookupId :: SimplEnv -> Id -> Eager ans OutArg - -lookupId (SimplEnv _ _ _ (in_scope_ids, id_subst) _ _) id - = case lookupIdEnv id_subst id of - Just atom -> returnEager atom - Nothing -> case lookupIdEnv in_scope_ids id of - Just id' -> returnEager (VarArg id') - Nothing -> returnEager (VarArg id) -\end{code} - notInScope forgets that the specified binder is in scope. It is used when we decide to bind a let(rec) bound thing to an atom, *after* the Id has been added to the in-scope mapping by simplBinder. \begin{code} notInScope :: SimplEnv -> OutBinder -> SimplEnv -notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) id - = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) out_id_env con_apps +notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps where new_in_scope_ids = delOneFromIdEnv in_scope_ids id \end{code} @@ -321,15 +346,28 @@ bindIdToAtom :: SimplEnv -> OutArg -- Val args only, please -> SimplEnv -bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) - (in_id,occ_info) atom - = case atom of - LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps - VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env - (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) - con_apps +bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) + (in_id,occ_info) atom + = SimplEnv chkr encl_cc ty_env (in_scope_ids', id_subst') con_apps + where + id_subst' = addOneToIdEnv id_subst in_id (SubstArg atom) + in_scope_ids' = case atom of + LitArg _ -> in_scope_ids + VarArg out_id -> modifyOccInfo in_scope_ids (uniqueOf out_id) occ_info + +bindIdToExpr :: SimplEnv + -> InBinder + -> SimplifiableCoreExpr + -> SimplEnv + +bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps) + (in_id,occ_info) expr + = ASSERT( isOneFunOcc occ_info ) -- Binder occurs just once, safely, so no + -- need to adjust occurrence info for RHS, + -- unlike bindIdToAtom + SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps where - new_in_id_env = (in_scope_ids, addOneToIdEnv id_subst in_id atom) + id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr) \end{code} @@ -339,39 +377,12 @@ bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env c %* * %************************************************************************ - -The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s; -both locally-bound ones, and perhaps some imported ones too. - \begin{code} -type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo) -\end{code} - -The "Id" part is just so that we can recover the domain of the mapping, which -IdEnvs don't allow directly. - -The @BinderInfo@ tells about the occurrences of the @OutId@. -Anything that isn't in here should be assumed to occur many times. -We keep this info so we can modify it when something changes. - -The @RhsInfo@ part tells about the value to which the @OutId@ is bound. - -\begin{code} -data RhsInfo = NoRhsInfo - | OtherLit [Literal] -- It ain't one of these - | OtherCon [Id] -- It ain't one of these - - -- InUnfolding is used for let(rec) bindings that - -- are *definitely* going to be inlined. - -- We record the un-simplified RHS and drop the binding - | InUnfolding SimplEnv -- Un-simplified unfolding - SimplifiableCoreExpr -- (need to snag envts therefore) - - | OutUnfolding CostCentre - SimpleUnfolding -- Already-simplified unfolding +lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo +lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo) -lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id +lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo lookupRhsInfo env id @@ -406,39 +417,29 @@ mkSimplUnfoldingGuidance chkr out_id rhs = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv -extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) +extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) out_id occ_info rhs_info - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps where - new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id - (out_id, occ_info, rhs_info) + new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id + (out_id, occ_info, rhs_info) \end{code} \begin{code} -modifyOccInfo out_id_env (uniq, new_occ) - = modifyIdEnv_Directly modify_fn out_id_env uniq +modifyOccInfo in_scope_ids uniq new_occ + = modifyIdEnv_Directly modify_fn in_scope_ids uniq where modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs) -markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps +markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps where - new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms] + new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms] modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs) \end{code} -\begin{code} -extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv -extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - id occ_info rhs - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps - where - new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs) -\end{code} - - %************************************************************************ %* * \subsubsection{The @ConAppMap@ type} @@ -472,7 +473,7 @@ extendConApps con_apps id other_rhs = con_apps \end{code} \begin{code} -lookForConstructor env@(SimplEnv _ _ _ _ _ con_apps) (Con con args) +lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args) | switchIsSet env SimplReuseCon = case lookupFM con_apps (UCA con val_args) of Nothing -> Nothing @@ -587,47 +588,42 @@ extendEnvGivenNewRhs env out_id rhs = extendEnvGivenBinding env noBinderInfo out_id rhs extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv -extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) +extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) occ_info out_id rhs - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps where - new_out_id_env | okToInline (whnfOrBottom form) - (couldBeSmallEnoughToInline out_id guidance) - occ_info - = out_id_env_with_unfolding - | otherwise - = out_id_env - -- Don't bother to extend the OutIdEnv unless there is some possibility + new_in_scope_ids | okToInline (whnfOrBottom form) + (couldBeSmallEnoughToInline out_id guidance) + occ_info + = env_with_unfolding + | otherwise + = in_scope_ids + -- Don't bother to munge the OutIdEnv unless there is some possibility -- that the thing might be inlined. We check this by calling okToInline suitably. new_con_apps = _scc_ "eegnr.conapps" extendConApps con_apps out_id rhs -- Modify the occ info for rhs's interesting free variables. - out_id_env_with_unfolding = _scc_ "eegnr.modify_occ" - foldl modifyOccInfo env1 full_fv_occ_info - -- NB: full_fv_occ_info *combines* the occurrence of the current binder - -- with the occurrences of its RHS's free variables. That's to take - -- account of: - -- let a = \x -> BIG in - -- let b = \f -> f a - -- in ...b...b...b... - -- Here "a" occurs exactly once. "b" simplifies to a small value. - -- So "b" will be inlined at each call site, and there's a good chance - -- that "a" will too. So we'd better modify "a"s occurrence info to - -- record the fact that it can now occur many times by virtue that "b" can. - - full_fv_occ_info = _scc_ "eegnr.full_fv" - [ (uniq, fv_occ `andBinderInfo` occ_info) - | (uniq, fv_occ) <- ufmToList fv_occ_info - ] + -- That's to take account of: + -- let a = \x -> BIG in + -- let b = \f -> f a + -- in ...b...b...b... + -- Here "a" occurs exactly once. "b" simplifies to a small value. + -- So "b" will be inlined at each call site, and there's a good chance + -- that "a" will too. So we'd better modify "a"s occurrence info to + -- record the fact that it can now occur many times by virtue that "b" can. + env_with_unfolding = _scc_ "eegnr.modify_occ" + foldl zap env1 (ufmToList fv_occ_info) + zap env (uniq,_) = modifyOccInfo env uniq occ_info + -- Add an unfolding and rhs_info for the new Id. - -- If the out_id is already in the OutIdEnv (which can happen if - -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs) + -- If the out_id is already in the OutIdEnv (which should be the + -- case because it was put there by simplBinder) -- then just replace the unfolding, leaving occurrence info alone. env1 = _scc_ "eegnr.modify_out" - addToUFM_C modifyOutEnvItem out_id_env out_id + addToUFM_C modifyOutEnvItem in_scope_ids out_id (out_id, occ_info, rhs_info) -- Occurrence-analyse the RHS @@ -637,7 +633,7 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con occurAnalyseExpr is_interesting rhs is_interesting v = _scc_ "eegnr.mkidset" - case lookupIdEnv out_id_env v of + case lookupIdEnv in_scope_ids v of Just (_, occ, _) -> isOneOcc occ other -> False diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index c3db663..f35b42d 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -69,16 +69,8 @@ completeVar env var args result_ty remaining_args result_ty - -- If there's an InUnfolding it means that there's no - -- let-binding left for the thing, so we'd better inline it! - | must_unfold - = let - Just (_, _, InUnfolding rhs_env rhs) = info_from_env - in - unfold var rhs_env rhs args result_ty - - -- Conditional unfolding. There's a binding for the + -- Look for an unfolding. There's a binding for the -- thing, but perhaps we want to inline it anyway | ( maybeToBool maybe_unfolding_info && (not essential_unfoldings_only || idMustBeINLINEd var) @@ -93,10 +85,14 @@ completeVar env var args result_ty | otherwise - = returnSmpl (mkGenApp (Var var) args) + = returnSmpl (mkGenApp (Var var') args) where - info_from_env = lookupOutIdEnv env var + info_from_env = lookupOutIdEnv env var + var' = case info_from_env of + Just (var', _, _) -> var' + Nothing -> var + unfolding_from_id = getIdUnfolding var ---------- Magic unfolding stuff @@ -104,12 +100,7 @@ completeVar env var args result_ty MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn env args other -> Nothing - (Just magic_result) = maybe_magic_result - - ---------- Unfolding stuff - must_unfold = case info_from_env of - Just (_, _, InUnfolding _ _) -> True - other -> False + Just magic_result = maybe_magic_result maybe_unfolding_info = case (info_from_env, unfolding_from_id) of @@ -230,7 +221,7 @@ simplBinder env (id, _) returnSmpl (env', id3) ) where - ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getSubstEnvs env + ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env empty_ty_subst = isEmptyTyVarEnv ty_subst not_in_scope = not (id `elemIdEnv` in_scope_ids) @@ -262,7 +253,7 @@ simplTyBinder env tyvar in returnSmpl (env', tyvar') where - ((tyvars, ty_subst), (ids, id_subst)) = getSubstEnvs env + ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar]) simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2e7b083..37e42fc 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -246,17 +246,21 @@ Check if there's a macro-expansion, and if so rattle on. Otherwise do the more sophisticated stuff. \begin{code} -simplExpr env (Var v) args result_ty - = case (runEager $ lookupId env v) of - LitArg lit -- A boring old literal +simplExpr env (Var var) args result_ty + = case (runEager $ lookupIdSubst env var) of + + Just (SubstExpr ty_subst id_subst expr) + -> simplExpr (setSubstEnvs env ty_subst id_subst) expr args result_ty + + Just (SubstArg (LitArg lit)) -- A boring old literal -> ASSERT( null args ) returnSmpl (Lit lit) - VarArg var -- More interesting! An id! - -> completeVar env var args result_ty - -- Either Id is in the local envt, or it's a global. - -- In either case we don't need to apply the type - -- environment to it. + Just (SubstArg (VarArg var')) -- More interesting! An id! + -> completeVar env var' args result_ty + + Nothing -- Not in the substitution; hand off to completeVar + -> completeVar env var args result_ty \end{code} Literals @@ -370,7 +374,7 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty -- on the arguments we've already beta-reduced into the body of the lambda = ASSERT( null args ) -- Value lambda must match value argument! let - new_env = markDangerousOccs env (take n orig_args) + new_env = markDangerousOccs env orig_args in simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty `thenSmpl` \ (expr', arity) -> @@ -884,11 +888,11 @@ Notice that let to case occurs only if x is used strictly in its body \begin{code} -- Dead code is now discarded by the occurrence analyser, -simplNonRec env binder@(id,occ_info) rhs body_c body_ty - | inlineUnconditionally ok_to_dup id occ_info +simplNonRec env binder@(id,_) rhs body_c body_ty + | inlineUnconditionally ok_to_dup binder = -- The binder is used in definitely-inline way in the body -- So add it to the environment, drop the binding, and continue - body_c (extendEnvGivenInlining env id occ_info rhs) + body_c (bindIdToExpr env binder rhs) | idWantsToBeINLINEd id = complete_bind env rhs -- Don't mess about with floating or let-to-case on @@ -1191,8 +1195,8 @@ simplRec env pairs body_c body_ty simplRecursiveGroup env new_ids [] = returnSmpl ([], env) -simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs) - | inlineUnconditionally ok_to_dup id occ_info +simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs) + | inlineUnconditionally ok_to_dup binder = -- Single occurrence, so drop binding and extend env with the inlining -- This is a little delicate, because what if the unique occurrence -- is *before* this binding? This'll never happen, because @@ -1202,7 +1206,7 @@ simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs -- If these claims aren't right Core Lint will spot an unbound -- variable. A quick fix is to delete this clause for simplRecursiveGroup let - new_env = extendEnvGivenInlining env new_id occ_info rhs + new_env = bindIdToExpr env binder rhs in simplRecursiveGroup new_env new_ids pairs @@ -1324,7 +1328,13 @@ simplArg :: SimplEnv -> InArg -> Eager ans OutArg simplArg env (LitArg lit) = returnEager (LitArg lit) simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' -> returnEager (TyArg ty') -simplArg env (VarArg id) = lookupId env id +simplArg env arg@(VarArg id) + = case lookupIdSubst env id of + Just (SubstArg arg') -> returnEager arg' + Just (SubstExpr _) -> panic "simplArg" + Nothing -> case lookupOutIdEnv env id of + Just (id', _, _) -> returnEager (VarArg id') + Nothing -> returnEager arg \end{code} %************************************************************************ -- 1.7.10.4