X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=c15a7b3f0a2015aa58484b8c0b89f978bb04f2e9;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=b170ad36e127c454be92ab98c653b8786ca678f2;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index b170ad3..c15a7b3 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -4,91 +4,81 @@ \section[SimplEnv]{Environment stuff for the simplifier} \begin{code} -#include "HsVersions.h" - module SimplEnv ( - nullSimplEnv, combineSimplEnv, - pprSimplEnv, -- debugging only + nullSimplEnv, + getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs, + emptySubstEnvs, getSubstEnvs, - extendTyEnv, extendTyEnvList, - simplTy, simplTyInId, + bindTyVar, bindTyVars, simplTy, - extendIdEnvWithAtom, extendIdEnvWithAtoms, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, + lookupIdSubst, lookupOutIdEnv, + bindIdToAtom, bindIdToExpr, markDangerousOccs, - lookupRhsInfo, lookupOutIdEnv, isEvaluated, + lookupUnfolding, isEvaluated, extendEnvGivenBinding, extendEnvGivenNewRhs, - extendEnvForRecBinding, extendEnvGivenRhsInfo, + extendEnvGivenUnfolding, lookForConstructor, - getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining, + getSwitchChecker, switchIsSet, getSimplIntSwitch, + switchOffInlining, setCaseScrutinee, setEnclosingCC, getEnclosingCC, -- Types - SYN_IE(SwitchChecker), - SimplEnv, - SYN_IE(InIdEnv), SYN_IE(InTypeEnv), + SwitchChecker, + SimplEnv, SubstEnvs, UnfoldConApp, - RhsInfo(..), + SubstInfo(..), - SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), - SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), + InId, InBinder, InBinding, InType, + OutId, OutBinder, OutBinding, OutType, - SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg), - SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg) + InExpr, InAlts, InDefault, InArg, + OutExpr, OutAlts, OutDefault, OutArg ) where -IMP_Ubiq(){-uitous-} - -IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop +#include "HsVersions.h" -import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, - BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC +import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, + isOneFunOcc, + BinderInfo ) import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, SimplifierSwitch(..), SwitchResult(..) ) import CoreSyn -import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, - Unfolding(..), UfExpr, RdrName, - SimpleUnfolding(..), FormSummary(..), - calcUnfoldingGuidance, UnfoldingGuidance(..) +import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, + okToInline, + Unfolding(..), FormSummary(..), + calcUnfoldingGuidance ) +import CoreUtils ( coreExprCc ) +import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, + costsAreSubsumed, noCostCentreAttached, subsumedCosts, + currentOrSubsumedCosts ) -import CoreUtils ( coreExprCc, unTagBinders ) -import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached ) import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, - applyTypeEnvToId, - nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly, - SYN_IE(IdEnv), SYN_IE(IdSet), GenId ) -import Literal ( isNoRepLit, Literal{-instances-} ) -import Maybes ( maybeToBool, expectJust ) -import Name ( isLocallyDefined ) +import Id ( IdEnv, IdSet, Id, + getInlinePragma, + nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, + addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly, + idMustBeINLINEd + ) +import Literal ( Literal ) +import Maybes ( expectJust ) import OccurAnal ( occurAnalyseExpr ) -import Outputable ( Outputable(..){-instances-} ) import PprCore -- various instances -import PprStyle ( PprStyle(..) ) -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( eqTy, applyTypeEnvToTy ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, - SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} - ) -import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_C, ufmToList, eltsUFM +import Type ( instantiateTy, Type ) +import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, + TyVarSet, emptyTyVarSet, + TyVar ) ---import UniqSet -- lots of things -import Usage ( SYN_IE(UVar), GenUsage{-instances-} ) -import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic ) - -type TypeEnv = TyVarEnv Type -cmpType = panic "cmpType (SimplEnv)" +import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) +import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM ) +import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList ) +import Outputable \end{code} %************************************************************************ @@ -145,23 +135,102 @@ 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 + 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 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 + +type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo) + +data SubstInfo + = SubstVar OutId -- The Id maps to an already-substituted atom + | SubstLit Literal -- ...ditto literal + | 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 -nullSimplEnv :: SwitchChecker -> SimplEnv + BinderInfo, -- How it occurs + -- We keep this info so we can modify it when + -- something changes. + + Unfolding) -- Info about what it is bound to +\end{code} -nullSimplEnv sw_chkr - = SimplEnv sw_chkr noCostCentre nullTyVarEnv 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 +\begin{code} +nullSimplEnv :: SwitchChecker -> SimplEnv -pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" +nullSimplEnv sw_chkr + = SimplEnv sw_chkr subsumedCosts + (emptyTyVarSet, emptyTyVarEnv) + (nullIdEnv, nullIdEnv) + nullConApps + + -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC + -- for the rhs of top level defs is "OST_CENTRE". Consider + -- f = \x -> e + -- g = \y -> let v = f y in scc "x" (v ...) + -- Here we want to inline "f", since its CC is SUBSUMED, but we don't + -- want to inline "v" since its CC is dynamically determined. + + +getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv) +getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, 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 + +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 + +getSubstEnvs :: SimplEnv -> SubstEnvs +getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst) + +emptySubstEnvs :: SubstEnvs +emptySubstEnvs = (emptyTyVarEnv, nullIdEnv) + +setSubstEnvs :: SimplEnv -> SubstEnvs -> 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 + +combineEnvs :: SimplEnv -- Get substitution from here + -> SimplEnv -- Get in-scope info from here + -> SimplEnv +combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) + (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps) + = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps + +zapSubstEnvs :: SimplEnv -> SimplEnv +zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps) + = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps \end{code} @@ -173,10 +242,10 @@ pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimp \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 @@ -184,14 +253,75 @@ getSimplIntSwitch chkr switch = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) -- Crude, but simple +setCaseScrutinee :: SimplEnv -> SimplEnv +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 +\end{code} + +@switchOffInlining@ is used to prepare the environment for simplifying +the RHS of an Id that's marked with an INLINE pragma. It is going to +be inlined wherever they are used, and then all the inlining will take +effect. Meanwhile, there isn't much point in doing anything to the +as-yet-un-INLINEd rhs. Furthermore, it's very important to switch off +inlining! because + (a) not doing so will inline a worker straight back into its wrapper! + +and (b) Consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... + + Now, if that's the ONLY occurrence of f, it will be inlined inside g, + and thence copied multiple times when g is inlined. + + Andy disagrees! Example: + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} + + Problem: any won't get deforested, and so if it's exported and + the importer doesn't use the inlining, (eg passes it as an arg) + then we won't get deforestation at all. + We havn't solved this problem yet! + +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. + +6/98 update: + +We don't prevent inlining from happening for identifiers +that are marked as must-be-inlined. An example of where +doing this is crucial is: + + class Bar a => Foo a where + ...g.... + {-# INLINE f #-} + f :: Foo a => a -> b + f x = ....Foo_sc1... + +If `f' needs to peer inside Foo's superclass, Bar, it refers +to the appropriate super class selector, which is marked as +must-inlineable. We don't generate any code for a superclass +selector, so failing to inline it in the RHS of `f' will +leave a reference to a non-existent id, with bad consequences. + +\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 out_id_env con_apps +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 - chkr' EssentialUnfoldingsOnly = SwBool True - chkr' other = chkr other + forget (id, binder_info, rhs_info) + | idMustBeINLINEd id = (id, binder_info, rhs_info) + | otherwise = (id, noBinderInfo, NoUnfolding) \end{code} + %************************************************************************ %* * \subsubsection{The ``enclosing cost-centre''} @@ -201,11 +331,11 @@ 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 + = 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} %************************************************************************ @@ -214,23 +344,25 @@ getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = en %* * %************************************************************************ -\begin{code} -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes +These two "bind" functions extend the tyvar substitution. +They don't affect what tyvars are in scope. -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +\begin{code} +bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv +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_env = addOneToTyVarEnv ty_env tyvar ty + new_ty_subst = addToTyVarEnv ty_subst tyvar ty -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv +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_env = growTyVarEnvList ty_env pairs + new_ty_subst = ty_subst `plusTyVarEnv` extra_subst +\end{code} -simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty -simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id +\begin{code} +simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty) \end{code} %************************************************************************ @@ -239,364 +371,116 @@ simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id %* * %************************************************************************ -\begin{code} -type InIdEnv = IdEnv OutArg -- Maps InIds to their value - -- Usually this is just the cloned Id, but if - -- if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just bind the variable to that atom, and - -- elide the let. -\end{code} - -\begin{code} -lookupId :: SimplEnv -> Id -> OutArg - -lookupId (SimplEnv _ _ _ in_id_env _ _) id - = case (lookupIdEnv in_id_env id) of - Just atom -> atom - Nothing -> 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} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder - -> OutArg{-Val args only, please-} - -> SimplEnv - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env 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 ---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps +notInScope :: SimplEnv -> OutBinder -> SimplEnv +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_id_env = addOneToIdEnv in_id_env in_id atom -{- - new_out_id_env = case atom of - LitArg _ -> out_id_env - VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info) --} - -extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv -extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - + new_in_scope_ids = delOneFromIdEnv in_scope_ids id +\end{code} -extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv +These "bind" functions extend the Id substitution. -extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (in_id,_) out_id - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps +\begin{code} +bindIdToAtom :: SimplEnv + -> InBinder + -> OutArg -- Val args only, please + -> SimplEnv + +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 id_env' con_apps where - new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id) - -extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv -extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - in_binders out_ids - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps + id_env' = case atom of + LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit)) + VarArg id -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info, + addOneToIdEnv id_subst in_id (SubstVar id)) + +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 = growIdEnvList in_id_env bindings - bindings = zipEqual "extendIdEnvWithClones" - [id | (id,_) <- in_binders] - (map VarArg out_ids) + id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr) \end{code} + %************************************************************************ %* * \subsubsection{The @OutIdEnv@} %* * %************************************************************************ - -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 SimplEnv -- Un-simplified unfolding - SimpleUnfolding -- (need to snag envts therefore) +lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo +lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id - | OutUnfolding CostCentre - SimpleUnfolding -- Already-simplified unfolding +lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding) +lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id -lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo) -lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id - -lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo -lookupRhsInfo env id +lookupUnfolding :: SimplEnv -> OutId -> Unfolding +lookupUnfolding env id = case lookupOutIdEnv env id of Just (_,_,info) -> info - Nothing -> NoRhsInfo - -modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) -modifyOutEnvItem (id, occ, info1) (_, _, info2) - = case (info1, info2) of - (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2)) - (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2)) - (_, NoRhsInfo) -> (id,occ, info1) - other -> (id,occ, info2) - ---(id, occ, new_info) -{- - where - new_info = case (info1, info2) of + Nothing -> NoUnfolding + +modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) -- Existing + -> (OutId, BinderInfo, Unfolding) -- New + -> (OutId, BinderInfo, Unfolding) +modifyOutEnvItem (_, _, info1) (id, occ, info2) + = (id, occ, case (info1, info2) of (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2) (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2) - (_, NoRhsInfo) -> info1 - other -> info2 --} + (_, NoUnfolding) -> info1 + other -> info2) \end{code} \begin{code} -isEvaluated :: RhsInfo -> Bool +isEvaluated :: Unfolding -> Bool isEvaluated (OtherLit _) = True isEvaluated (OtherCon _) = True -isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True -isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True +isEvaluated (CoreUnfolding ValueForm _ expr) = True isEvaluated other = False \end{code} -@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS -of a new binding. There is a horrid case we have to take care about, -due to Andr\'e Santos: -@ - type Array_type b = Array Int b; - type Descr_type = (Int,Int); - tabulate :: (Int -> x) -> Descr_type -> Array_type x; - tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; - - f_iaamain a_xs= - let { - f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; - f_aareorder a_index a_ar= - let { - f_aareorder' a_i= a_ar ! (a_index ! a_i) - } in tabulate f_aareorder' (bounds a_ar); - r_index=tabulate ((+) 1) (1,1); - arr = listArray (1,1) a_xs; - arg = f_aareorder r_index arr - } in elems arg -@ -Now, when the RHS of arg gets simplified, we inline f_aareorder to get -@ - arg = let f_aareorder' a_i = arr ! (r_index ! a_i) - in tabulate f_aareorder' (bounds arr) -@ -Note that r_index is not inlined, because it was bound to a_index which -occurs inside a lambda. - -Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...), -then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence -analyse it, we won't spot the inside-lambda property of r_index, so r_index -will get inlined inside the lambda. AARGH. - -Solution: when we occurrence-analyse the new RHS we have to go back -and modify the info recorded in the UnfoldEnv for the free vars -of the RHS. In the example we'd go back and record that r_index is now used -inside a lambda. \begin{code} -extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv -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) - occ_info out_id rhs - = let - s_env = SimplEnv chkr encl_cc ty_env in_id_env out_id_env new_con_apps - s_env_uf = SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding new_con_apps - in - case guidance of - -- Cheap and nasty hack to force strict insertion. - UnfoldNever -> - if isEmptyFM new_con_apps then s_env else s_env - other -> - if isEmptyFM new_con_apps then s_env_uf else s_env_uf - where - new_con_apps = extendConApps con_apps out_id rhs -{- - new_out_id_env = case guidance of - UnfoldNever -> out_id_env -- No new stuff to put in - other -> out_id_env_with_unfolding --} - -- If there is an unfolding, we add rhs-info for out_id, - -- *and* modify the occ info for rhs's interesting free variables. - -- - -- If the out_id is already in the OutIdEnv, then just replace the - -- unfolding, leaving occurrence info alone (this must then - -- be a call via extendEnvGivenNewRhs). - out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info - -- full_fv_occ_info combines the occurrence of the current binder - -- with the occurrences of its RHS's free variables. - full_fv_occ_info = [ (uniq, fv_occ `andBinderInfo` occ_info) - | (uniq,fv_occ) <- ufmToList fv_occ_info - ] - env1 = addToUFM_C modifyOutEnvItem out_id_env out_id - (out_id, occ_info, rhs_info) - - -- Occurrence-analyse the RHS - -- The "interesting" free variables we want occurrence info for are those - -- in the OutIdEnv that have only a single occurrence right now. - (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs - interesting_fvs = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env] - - -- Compute unfolding details - rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template) - form_summary = mkFormSummary rhs - - guidance = mkSimplUnfoldingGuidance chkr out_id rhs - - -- Compute cost centre for thing - unf_cc | noCostCentreAttached expr_cc = encl_cc - | otherwise = expr_cc - where - expr_cc = coreExprCc rhs -\end{code} - - - -Recursive bindings -~~~~~~~~~~~~~~~~~~ -We need to be pretty careful when extending -the environment with RHS info in recursive groups. - -Here's a nasty example: - - letrec r = f x - t = r - x = ...t... - in - ...t... - -Here, r occurs exactly once, so we may reasonably inline r in t's RHS. -But the pre-simplified t's rhs is an atom, r, so we may also decide to -inline t everywhere. But if we do *both* these reasonable things we get - - letrec r = f x - t = f x - x = ...r... - in - ...t... - -Bad news! (f x) is duplicated! (The t in the body doesn't get -inlined because by the time the recursive group is done we see that -t's RHS isn't an atom.) - -Our solution is this: - (a) we inline un-simplified RHSs, and then simplify - them in a clone-only environment. - (b) we inline only variables and values -This means that - - - r = f x ==> r = f x - t = r ==> t = r - x = ...t... ==> x = ...r... - in in - t r - -Now t is dead, and we're home. - -Most silly x=y bindings in recursive group will go away. But not all: - - let y = 1:x - x = y - -Here, we can't inline x because it's in an argument position. so we'll just replace -with a clone of y. Instead we'll probably inline y (a small value) to give - - let y = 1:x - x = 1:y - -which is OK if not clever. - -\begin{code} -extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (out_id, ((_,occ_info), old_rhs)) - = case (form_summary, guidance) of - (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in - (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable - --- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps - where -{- - new_out_id_env = case (form_summary, guidance) of - (_, UnfoldNever) -> out_id_env -- No new stuff to put in - (ValueForm, _) -> out_id_env_with_unfolding - (VarForm, _) -> out_id_env_with_unfolding - other -> out_id_env -- Not a value or variable --} - -- If there is an unfolding, we add rhs-info for out_id, - -- No need to modify occ info because RHS is pre-simplification - out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id - (out_id, occ_info, rhs_info) - - -- Compute unfolding details - -- Note that we use the "old" environment, that just has clones of the rec-bound vars, - -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once. - -- Only if the thing is still small enough next time round will we inline again. - rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs) - form_summary = mkFormSummary old_rhs - guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs) - - -mkSimplUnfoldingGuidance chkr out_id rhs - = case calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs of - UnfoldNever -> UnfoldNever - v -> v - where - inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id - -extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv -extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) +extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv +extendEnvGivenUnfolding 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 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} - %************************************************************************ %* * \subsubsection{The @ConAppMap@ type} @@ -630,12 +514,13 @@ extendConApps con_apps id other_rhs = con_apps \end{code} \begin{code} -lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args +lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args) + | switchIsSet env SimplReuseCon = case lookupFM con_apps (UCA con val_args) of Nothing -> Nothing Just assocs -> case [id | (tys, id) <- assocs, - and (zipWith eqTy tys ty_args)] + and (zipWith (==) tys ty_args)] of [] -> Nothing (id:_) -> Just id @@ -643,6 +528,7 @@ lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args val_args = filter isValArg args -- Literals and Ids ty_args = [ty | TyArg ty <- args] -- Just types +lookForConstructor env other = Nothing \end{code} NB: In @lookForConstructor@ we used (before Apr 94) to have a special case @@ -669,37 +555,141 @@ it, so we can use it for a @FiniteMap@ key. \begin{code} instance Eq UnfoldConApp where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord UnfoldConApp where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmp_app a b cmp_app (UCA c1 as1) (UCA c2 as2) - = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 + = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2 where - -- ToDo: make an "instance Ord3 CoreArg"??? + -- ToDo: make an "instance Ord CoreArg"??? - cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = x `cmp` y - cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" - cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" + cmp_arg (VarArg x) (VarArg y) = x `compare` y + cmp_arg (LitArg x) (LitArg y) = x `compare` y + cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs" cmp_arg x y - | tag x _LT_ tag y = LT_ - | otherwise = GT_ + | tag x _LT_ tag y = LT + | otherwise = GT where tag (VarArg _) = ILIT(1) tag (LitArg _) = ILIT(2) tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" - tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} +@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS +of a new binding. There is a horrid case we have to take care about, +due to Andr\'e Santos: +@ + type Array_type b = Array Int b; + type Descr_type = (Int,Int); + + tabulate :: (Int -> x) -> Descr_type -> Array_type x; + tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; + + f_iaamain a_xs= + let { + f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; + f_aareorder a_index a_ar= + let { + f_aareorder' a_i= a_ar ! (a_index ! a_i) + } in tabulate f_aareorder' (bounds a_ar); + r_index=tabulate ((+) 1) (1,1); + arr = listArray (1,1) a_xs; + arg = f_aareorder r_index arr + } in elems arg +@ +Now, when the RHS of arg gets simplified, we inline f_aareorder to get +@ + arg = let f_aareorder' a_i = arr ! (r_index ! a_i) + in tabulate f_aareorder' (bounds arr) +@ +Note that r_index is not inlined, because it was bound to a_index which +occurs inside a lambda. + +Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...), +then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence +analyse it, we won't spot the inside-lambda property of r_index, so r_index +will get inlined inside the lambda. AARGH. + +Solution: when we occurrence-analyse the new RHS we have to go back +and modify the info recorded in the UnfoldEnv for the free vars +of the RHS. In the example we'd go back and record that r_index is now used +inside a lambda. +\begin{code} +extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv +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_scope_ids, id_subst) con_apps) + occ_info out_id rhs + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps + where + new_in_scope_ids | okToInline out_id + (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. + -- 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 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 in_scope_ids out_id + (out_id, occ_info, rhs_info) + + -- Occurrence-analyse the RHS + -- The "interesting" free variables we want occurrence info for are those + -- in the OutIdEnv that have only a single occurrence right now. + (fv_occ_info, template) = _scc_ "eegnr.occ-anal" + occurAnalyseExpr is_interesting rhs_w_cc + + is_interesting v = _scc_ "eegnr.mkidset" + case lookupIdEnv in_scope_ids v of + Just (_, occ, _) -> isOneOcc occ + other -> False + + -- Compute unfolding details + rhs_info = CoreUnfolding form guidance template + form = _scc_ "eegnr.form_sum" + mkFormSummary rhs + guidance = _scc_ "eegnr.guidance" + calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs + + -- Attach a cost centre to the RHS if necessary + rhs_w_cc | currentOrSubsumedCosts encl_cc + || not (noCostCentreAttached (coreExprCc rhs)) + = rhs + | otherwise + = Note (SCC encl_cc) rhs +\end{code}