X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=c15a7b3f0a2015aa58484b8c0b89f978bb04f2e9;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=6712d6a55bed17d3ff67dca79ea7e0bddd5577e1;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 6712d6a..c15a7b3 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -4,94 +4,81 @@ \section[SimplEnv]{Environment stuff for the simplifier} \begin{code} -#include "HsVersions.h" - module SimplEnv ( - nullSimplEnv, - pprSimplEnv, -- debugging only + nullSimplEnv, + getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs, + emptySubstEnvs, getSubstEnvs, - replaceInEnvs, nullInEnvs, + bindTyVar, bindTyVars, simplTy, - extendTyEnv, extendTyEnvList, - simplTy, simplTyInId, + lookupIdSubst, lookupOutIdEnv, - extendIdEnvWithAtom, extendIdEnvWithAtomList, - extendIdEnvWithInlining, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, + bindIdToAtom, bindIdToExpr, + + markDangerousOccs, + lookupUnfolding, isEvaluated, + extendEnvGivenBinding, extendEnvGivenNewRhs, + extendEnvGivenUnfolding, - extendUnfoldEnvGivenRhs, - extendUnfoldEnvGivenFormDetails, - extendUnfoldEnvGivenConstructor, lookForConstructor, - lookupUnfolding, filterUnfoldEnvForInlines, - getSwitchChecker, switchIsSet, + getSwitchChecker, switchIsSet, getSimplIntSwitch, + switchOffInlining, setCaseScrutinee, - setEnclosingCC, + setEnclosingCC, getEnclosingCC, -- Types - SwitchChecker(..), - SimplEnv, EnclosingCcDetails(..), - InIdEnv(..), IdVal(..), InTypeEnv(..), - UnfoldEnv, UnfoldItem, UnfoldConApp, - - InId(..), InBinder(..), InBinding(..), InType(..), - OutId(..), OutBinder(..), OutBinding(..), OutType(..), + SwitchChecker, + SimplEnv, SubstEnvs, + UnfoldConApp, + SubstInfo(..), - InExpr(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) + InId, InBinder, InBinding, InType, + OutId, OutBinder, OutBinding, OutType, - -- and to make the interface self-sufficient... + InExpr, InAlts, InDefault, InArg, + OutExpr, OutAlts, OutDefault, OutArg ) where -import Ubiq{-uitous-} - -import SmplLoop -- breaks the MagicUFs / SimplEnv loop +#include "HsVersions.h" -import BinderInfo ( BinderInfo{-instances-} ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) +import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, + isOneFunOcc, + BinderInfo + ) +import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, + SimplifierSwitch(..), SwitchResult(..) + ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, - calcUnfoldingGuidance, UnfoldingGuidance(..), - mkFormSummary, FormSummary +import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, + okToInline, + Unfolding(..), FormSummary(..), + calcUnfoldingGuidance ) +import CoreUtils ( coreExprCc ) +import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, + costsAreSubsumed, noCostCentreAttached, subsumedCosts, + currentOrSubsumedCosts ) import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, - nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, - IdEnv(..), IdSet(..), GenId ) -import IdInfo ( StrictnessInfo ) -import Literal ( isNoRepLit, Literal{-instances-} ) -import Outputable ( Outputable(..){-instances-} ) +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 PprCore -- various instances -import PprStyle ( PprStyle(..) ) -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( getAppDataTyCon ) -import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, - growTyVarEnvList, - TyVarEnv(..), GenTyVar ) -import Unique ( Unique ) -import UniqSet -- lots of things -import Usage ( UVar(..), GenUsage{-instances-} ) -import Util ( zipEqual, panic, assertPanic ) - -type TypeEnv = TyVarEnv Type -addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)" -applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)" -applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)" -bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)" -cmpType = panic "cmpType (SimplEnv)" -exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)" -lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)" -manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)" -occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)" -oneSafeOcc = panic "oneSafeOcc (SimplEnv)" -oneTextualOcc = panic "oneTextualOcc (SimplEnv)" -simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" -uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)" -ufmToList = panic "ufmToList (SimplEnv)" +import Type ( instantiateTy, Type ) +import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, + TyVarSet, emptyTyVarSet, + TyVar + ) +import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) +import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM ) +import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList ) +import Outputable \end{code} %************************************************************************ @@ -100,6 +87,27 @@ ufmToList = panic "ufmToList (SimplEnv)" %* * %************************************************************************ +\begin{code} +type InId = Id -- Not yet cloned +type InBinder = (InId, BinderInfo) +type InType = Type -- Ditto +type InBinding = SimplifiableCoreBinding +type InExpr = SimplifiableCoreExpr +type InAlts = SimplifiableCoreCaseAlts +type InDefault = SimplifiableCoreCaseDefault +type InArg = SimplifiableCoreArg + +type OutId = Id -- Cloned +type OutBinder = Id +type OutType = Type -- Cloned +type OutBinding = CoreBinding +type OutExpr = CoreExpr +type OutAlts = CoreCaseAlts +type OutDefault = CoreCaseDefault +type OutArg = CoreArg + +type SwitchChecker = SimplifierSwitch -> SwitchResult +\end{code} %************************************************************************ %* * @@ -126,523 +134,452 @@ inside the Ids, etc.). 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 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 + + 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} - EnclosingCcDetails -- the enclosing cost-centre (when profiling) - - InTypeEnv -- For cloning types - -- Domain is all in-scope type variables - - InIdEnv -- IdEnv - -- Domain is - -- *all* - -- *in-scope*, - -- *locally-defined* - -- *InIds* - -- (Could omit the exported top-level guys, - -- since their names mustn't change; and ditto - -- the non-exported top-level guys which you - -- don't want to macro-expand, since their - -- names need not change.) - -- - -- Starts off empty - - UnfoldEnv -- Domain is any *OutIds*, including imports - -- where we know something more than the - -- interface file tells about their value (see - -- below) +\begin{code} nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr - = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env - -pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) - = ppAboves [ - ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env, - ppSP, ppStr "** Id Env ** ?????????", --- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ], - ppSP, ppStr "** Unfold Env **", - ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ] - ] - where - pp_id_entry (v, idval) - = ppCat [ppr PprDebug v, ppStr "=>", - case idval of - InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e] - ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a] - ] - - pp_uf_entry (UnfoldItem v form encl_cc) - = ppCat [ppr PprDebug v, ppStr "=>", - case form of - NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" - LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] - OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") - [ppr PprDebug l | l <- ls]] - ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] - OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") - [ppr PprDebug c | c <- cs]] - GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w, - ppr PprDebug g, ppr PprDebug e] - MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s] - ] + = 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} -%************************************************************************ -%* * -\subsubsection{The @IdVal@ type (for the ``IdEnv'')} -%* * -%************************************************************************ - -The unfoldings for imported things are mostly kept within the Id -itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For -example, suppose \tr{x} is imported, and we have -\begin{verbatim} - case x of - (p,q) -> -\end{verbatim} -Then within \tr{}, we know that \tr{x} is a pair with components -\tr{p} and \tr{q}. - -\begin{code} -type InIdEnv = IdEnv IdVal -- Maps InIds to their value - -data IdVal - = InlineIt InIdEnv InTypeEnv InExpr - -- No binding of the Id is left; - -- You *have* to replace any occurences - -- of the id with this expression. - -- Rather like a macro, really - -- NB: the InIdEnv/InTypeEnv is necessary to prevent - -- name caputure. Consider: - -- let y = ... - -- x = ...y... - -- y = ... - -- in ...x... - -- If x gets an InlineIt, we must remember - -- the correct binding for y. - - | ItsAnAtom OutArg -- Used either (a) to record the cloned Id - -- or (b) 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} %************************************************************************ %* * -\subsubsection{The @UnfoldEnv@ type} +\subsubsection{Command-line switches} %* * %************************************************************************ -The @UnfoldEnv@ contains information about the value of some of the -in-scope identifiers. It obeys the following invariant: - - If the @UnfoldEnv@ contains information, it is safe to use it! - -In particular, if the @UnfoldEnv@ contains details of an unfolding of -an Id, then it's safe to use the unfolding. If, for example, the Id -is used many times, then its unfolding won't be put in the UnfoldEnv -at all. - -The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list -because (a)~it's small, and (b)~we need to search its {\em range} as -well as its domain. - \begin{code} -data UnfoldItem -- a glorified triple... - = UnfoldItem OutId -- key: used in lookForConstructor - UnfoldingDetails -- for that Id - EnclosingCcDetails -- so that if we do an unfolding, - -- we can "wrap" it in the CC - -- that was in force. - -data UnfoldConApp -- yet another glorified triple - = UCA OutId -- same fields as ConForm - [OutArg] - -data UnfoldEnv -- yup, a glorified triple... - = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem - IdSet -- The Ids in the domain of the env - -- which have details (GenForm True ...) - -- i.e., they claim they are duplicatable. - -- These are the ones we have to worry - -- about when adding new items to the - -- unfold env. - (FiniteMap UnfoldConApp OutId) - -- Maps applications of constructors (to - -- types & atoms) back to OutIds that are - -- bound to them; i.e., this is a reversed - -- mapping for (part of) the main IdEnv - -- (1st part of UFE) - -null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM -\end{code} +getSwitchChecker :: SimplEnv -> SwitchChecker +getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr -The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will -be small, because it contains bindings only for those things whose -form or unfolding is known. Basically it maps @Id@ to their -@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also -need to search it associatively, to look for @Id@s which have a given -constructor form. +switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool +switchIsSet (SimplEnv chkr _ _ _ _) switch + = switchIsOn chkr switch -We implement it with @IdEnvs@, possibly overkill, but sometimes these -things silently grow quite big.... Here are some local functions used -elsewhere in the module: +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +getSimplIntSwitch chkr switch + = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) -\begin{code} -grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv -lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -lookup_unfold_env_encl_cc - :: UnfoldEnv -> OutId -> EnclosingCcDetails - -grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env - -grow_unfold_env (UFE u_env interesting_ids con_apps) id - uf_details@(GenForm True _ _ _) encl_cc - -- Only interested in Ids which have a "dangerous" unfolding; that is - -- one that claims to have a single occurrence. - = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - (interesting_ids `unionUniqSets` singletonUniqSet id) - con_apps - -grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc - = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - interesting_ids - new_con_apps + -- 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 - new_con_apps - = case uf_details of - ConForm con vargs - -> case (lookupFM con_apps entry) of - Just _ -> con_apps -- unchanged; we hang onto what we have - Nothing -> addToFM con_apps entry id - where - entry = UCA con vargs - - not_a_constructor -> con_apps -- unchanged - -addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items - = ASSERT(not (any constructor_form_in_those extra_items)) - -- otherwise, we'd need to change con_apps - UFE (growIdEnvList u_env extra_items) interesting_ids con_apps - where - constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True - constructor_form_in_those _ = False - -rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env - -get_interesting_ids (UFE _ interesting_ids _) = interesting_ids - -foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff - = UFE (foldr fun u_env stuff) interesting_ids con_apps - -lookup_unfold_env (UFE u_env _ _) id - = case (lookupIdEnv u_env id) of - Nothing -> NoUnfoldingDetails - Just (UnfoldItem _ uf _) -> uf - -lookup_unfold_env_encl_cc (UFE u_env _ _) id - = case (lookupIdEnv u_env id) of - Nothing -> NoEnclosingCcDetails - Just (UnfoldItem _ _ encl_cc) -> encl_cc - -lookup_conapp (UFE _ _ con_apps) con args - = lookupFM con_apps (UCA con args) - -modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id - = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps - --- If the current binding claims to be a "unique" one, then --- we modify it. -modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem - -modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) - = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc + chkr' SimplCaseScrutinee = SwBool True + chkr' other = chkr other \end{code} -The main thing about @UnfoldConApp@ is that it has @Ord@ defined on -it, so we can use it for a @FiniteMap@ key. -\begin{code} -instance Eq UnfoldConApp where - a == b = case cmp_app a b of { EQ_ -> True; _ -> False } - a /= b = case cmp_app a b of { EQ_ -> False; _ -> True } - -instance Ord UnfoldConApp where - a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app +@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. -cmp_app (UCA c1 as1) (UCA c2 as2) - = case (c1 `cmp` c2) of - LT_ -> LT_ - GT_ -> GT_ - _ -> cmp_lists cmp_atom as1 as2 +\begin{code} +switchOffInlining :: SimplEnv -> SimplEnv +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 - cmp_lists cmp_item [] [] = EQ_ - cmp_lists cmp_item (x:xs) [] = GT_ - cmp_lists cmp_item [] (y:ys) = LT_ - cmp_lists cmp_item (x:xs) (y:ys) - = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other } - - cmp_atom (VarArg x) (VarArg y) = x `cmp` y - cmp_atom (VarArg _) _ = LT_ - cmp_atom (LitArg x) (LitArg y) - = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } - cmp_atom (LitArg _) _ = GT_ + forget (id, binder_info, rhs_info) + | idMustBeINLINEd id = (id, binder_info, rhs_info) + | otherwise = (id, noBinderInfo, NoUnfolding) \end{code} + %************************************************************************ %* * -\subsubsection{The @EnclosingCcDetails@ type} +\subsubsection{The ``enclosing cost-centre''} %* * %************************************************************************ \begin{code} -data EnclosingCcDetails - = NoEnclosingCcDetails - | EnclosingCC CostCentre +setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv + +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 id_env con_apps) = encl_cc \end{code} %************************************************************************ %* * -\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms} +\subsubsection{The @TypeEnv@ part} %* * %************************************************************************ -\begin{code} -type InId = Id -- Not yet cloned -type InBinder = (InId, BinderInfo) -type InType = Type -- Ditto -type InBinding = SimplifiableCoreBinding -type InExpr = SimplifiableCoreExpr -type InAlts = SimplifiableCoreCaseAlts -type InDefault = SimplifiableCoreCaseDefault -type InArg = SimplifiableCoreArg +These two "bind" functions extend the tyvar substitution. +They don't affect what tyvars are in scope. -type OutId = Id -- Cloned -type OutBinder = Id -type OutType = Type -- Cloned -type OutBinding = CoreBinding -type OutExpr = CoreExpr -type OutAlts = CoreCaseAlts -type OutDefault = CoreCaseDefault -type OutArg = CoreArg +\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_subst = addToTyVarEnv ty_subst tyvar ty +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_subst = ty_subst `plusTyVarEnv` extra_subst \end{code} \begin{code} -type SwitchChecker = SimplifierSwitch -> SwitchResult +simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty) \end{code} %************************************************************************ %* * -\subsection{@SimplEnv@ handling} +\subsubsection{The ``Id env'' part} %* * %************************************************************************ -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ +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} -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr - -switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _) switch - = switchIsOn chkr switch +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_scope_ids = delOneFromIdEnv in_scope_ids id \end{code} -%************************************************************************ -%* * -\subsubsection{The ``enclosing cost-centre''} -%* * -%************************************************************************ +These "bind" functions extend the Id substitution. \begin{code} -setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv - -setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc - = SimplEnv chkr encl_cc ty_env id_env unfold_env +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 + 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 + id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr) \end{code} + %************************************************************************ %* * -\subsubsection{The @TypeEnv@ part} +\subsubsection{The @OutIdEnv@} %* * %************************************************************************ \begin{code} -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes +lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo +lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id + +lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding) +lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id + +lookupUnfolding :: SimplEnv -> OutId -> Unfolding +lookupUnfolding env id + = case lookupOutIdEnv env id of + Just (_,_,info) -> info + 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) + (_, NoUnfolding) -> info1 + other -> info2) +\end{code} -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty - = SimplEnv chkr encl_cc new_ty_env id_env unfold_env - where - new_ty_env = addOneToTyVarEnv ty_env tyvar ty -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs - = SimplEnv chkr encl_cc new_ty_env id_env unfold_env - where - new_ty_env = growTyVarEnvList ty_env pairs +\begin{code} +isEvaluated :: Unfolding -> Bool +isEvaluated (OtherLit _) = True +isEvaluated (OtherCon _) = True +isEvaluated (CoreUnfolding ValueForm _ expr) = True +isEvaluated other = False +\end{code} -simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty -simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id + +\begin{code} +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 (new_in_scope_ids, id_subst) con_apps + where + new_in_scope_ids = addToUFM in_scope_ids out_id (out_id, occ_info, rhs_info) \end{code} -@replaceInEnvs@ is used to install saved type and id envs -when pulling an un-simplified expression out of the environment, which -was saved with its environments. \begin{code} -nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv) - -replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv +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) -replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (new_ty_env, new_id_env) - = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env +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_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 ``Id env'' part} +\subsubsection{The @ConAppMap@ type} %* * %************************************************************************ -\begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder -> OutArg - -> SimplEnv +The @ConAppMap@ maps applications of constructors (to value atoms) +back to an association list that says "if the constructor was applied +to one of these lists-of-Types, then this OutId is your man (in a +non-gender-specific sense)". I.e., this is a reversed mapping for +(part of) the main OutIdEnv -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit) - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) +\begin{code} +type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)] -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id, occ_info) atom@(VarArg out_id) - = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) - - new_unfold_env = modify_unfold_env - unfold_env - (modifyItem ok_to_dup occ_info) - out_id - -- Modify binding for in_id - -- NO! modify out_id, because its the info on the - -- atom that interest's us. - - ok_to_dup = switchIsOn chkr SimplOkToDupCode - -extendIdEnvWithAtomList - :: SimplEnv - -> [(InBinder, OutArg)] - -> SimplEnv -extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - -extendIdEnvWithInlining - :: SimplEnv -- The Env to modify - -> SimplEnv -- The Env to record in the inlining. Usually the - -- same as the previous one, except in the recursive case - -> InBinder -> InExpr - -> SimplEnv - -extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env) - ~(SimplEnv _ _ inline_ty_env inline_id_env _ ) - (in_id,occ_info) - expr - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr) +data UnfoldConApp + = UCA OutId -- data constructor + [OutArg] -- *value* arguments; see use below +\end{code} -extendIdEnvWithClone - :: SimplEnv - -> InBinder -- Old binder; binderinfo ignored - -> OutId -- Its new clone, as an Id - -> SimplEnv +\begin{code} +nullConApps = emptyFM -extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id,_) out_id - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env +extendConApps con_apps id (Con con args) + = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)] where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id)) + val_args = filter isValArg args -- Literals and Ids + ty_args = [ty | TyArg ty <- args] -- Just types -extendIdEnvWithClones -- Like extendIdEnvWithClone - :: SimplEnv - -> [InBinder] - -> [OutId] - -> SimplEnv +extendConApps con_apps id other_rhs = con_apps +\end{code} -extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) - in_binders out_ids - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env +\begin{code} +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 (==) tys ty_args)] + of + [] -> Nothing + (id:_) -> Just id where - new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) - in_ids = [id | (id,_) <- in_binders] - out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids] - -lookupId :: SimplEnv -> Id -> Maybe IdVal - -lookupId (SimplEnv _ _ _ id_env _) id -#ifndef DEBUG - = lookupIdEnv id_env id -#else - = case (lookupIdEnv id_env id) of - xxx@(Just _) -> xxx - xxx -> --false!: ASSERT(not (isLocallyDefined id)) - xxx -#endif + val_args = filter isValArg args -- Literals and Ids + ty_args = [ty | TyArg ty <- args] -- Just types + +lookForConstructor env other = Nothing \end{code} -%************************************************************************ -%* * -\subsubsection{The @UnfoldEnv@} -%* * -%************************************************************************ +NB: In @lookForConstructor@ we used (before Apr 94) to have a special case +for nullary constructors, but now we only do constructor re-use in +let-bindings the special case isn't necessary any more. + +\begin{verbatim} + = -- Don't re-use nullary constructors; it's a waste. Consider + -- let + -- a = leInt#! p q + -- in + -- case a of + -- True -> ... + -- False -> False + -- + -- Here the False in the second case will get replace by "a", hardly + -- a good idea + Nothing +\end{verbatim} + + +The main thing about @UnfoldConApp@ is that it has @Ord@ defined on +it, so we can use it for a @FiniteMap@ key. \begin{code} -extendUnfoldEnvGivenFormDetails - :: SimplEnv - -> OutId - -> UnfoldingDetails - -> SimplEnv - -extendUnfoldEnvGivenFormDetails - env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - id details - = case details of - NoUnfoldingDetails -> env - good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc - -extendUnfoldEnvGivenConstructor -- specialised variant - :: SimplEnv - -> OutId -- bind this to... - -> Id -> [OutId] -- "con args" - -> SimplEnv - -extendUnfoldEnvGivenConstructor env var con args - = let - -- conjure up the types to which the con should be applied - scrut_ty = idType var - (_, ty_args, _) = getAppDataTyCon scrut_ty - in - extendUnfoldEnvGivenFormDetails - env var (ConForm con (map VarArg args)) +instance Eq UnfoldConApp where + 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 `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) + = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2 + where + -- ToDo: make an "instance Ord CoreArg"??? + + 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 + where + tag (VarArg _) = ILIT(1) + tag (LitArg _) = ILIT(2) + tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" \end{code} @@ -687,163 +624,72 @@ of the RHS. In the example we'd go back and record that r_index is now used inside a lambda. \begin{code} -extendUnfoldEnvGivenRhs - :: SimplEnv - -> InBinder - -> OutId -- Note: *must* be an "out" Id (post-cloning) - -> OutExpr -- Its rhs (*simplified*) - -> SimplEnv - -extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - binder@(_,occ_info) out_id rhs - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env +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 - (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs 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 - interesting_fvs = get_interesting_ids unfold_env + is_interesting v = _scc_ "eegnr.mkidset" + case lookupIdEnv in_scope_ids v of + Just (_, occ, _) -> isOneOcc occ + other -> False -- Compute unfolding details - details = case rhs of - Var v -> panic "Vars already dealt with" - Lit lit | isNoRepLit lit -> LitForm lit - | otherwise -> panic "non-noRep Lits already dealt with" - - Con con args -> ConForm con args - - other -> mkGenForm ok_to_dup occ_info - (mkFormSummary (getIdStrictness out_id) rhs) - template guidance - - -- Compute resulting unfold env - new_unfold_env = case details of - NoUnfoldingDetails -> unfold_env - GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} - other -> unfold_env1 - - -- Add unfolding to unfold env - unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc - - -- Modify unfoldings of free vars of rhs, based on their - -- occurrence info in the rhs [see notes above] - unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info) - - modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem - modify (u, occ_info) env - = case (lookupDirectlyUFM env u) of - Nothing -> env -- ToDo: can this happen? - Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) - - -- Compute unfolding guidance - guidance = if simplIdWantsToBeINLINEd out_id env - then UnfoldAlways - else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs - - bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of - Nothing -> uNFOLDING_CREATION_THRESHOLD - Just xx -> xx - - ok_to_dup = switchIsOn chkr SimplOkToDupCode - || exprSmallEnoughToDup rhs - -- [Andy] added, Jun 95 - -{- Reinstated AJG Jun 95; This is needed - --example that does not (currently) work - --without this extention - - --let f = g x - --in - -- case of - -- True -> h i f - -- False -> f - -- ==> - -- case of - -- True -> h i f - -- False -> g x --} -{- OLD: - Omitted SLPJ Feb 95; should, I claim, be unnecessary - -- is_really_small looks for things like f a b c - -- but making sure there are not *too* many arguments. - -- (This is brought to you by *ANDY* Magic Constants, Inc.) - is_really_small - = case collectArgs new_rhs of - (Var _, xs) -> length xs < 10 - _ -> False --} -\end{code} - -\begin{code} -lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails - -lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var - | not (isLocallyDefined var) -- Imported, so look inside the id - = getIdUnfolding var - - | otherwise -- Locally defined, so look in the envt. - -- There'll be nothing inside the Id. - = lookup_unfold_env unfold_env var -\end{code} - -We need to remove any @GenForm@ bindings from the UnfoldEnv for -the RHS of an Id which has an INLINE pragma. - -\begin{code} -filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv - -filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - new_unfold_env = null_unfold_env - -- This version is really simple. INLINEd things are going to - -- be inlined wherever they are used, and then all the - -- UnfoldEnv stuff will take effect. Meanwhile, there isn't - -- much point in doing anything to the as-yet-un-INLINEd rhs. - - -- 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. - -- - -- So he'd like not to filter the unfold env at all. But that's a disaster: - -- Suppose we have: - -- - -- 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. -\end{code} - -====================== - -In @lookForConstructor@ we used (before Apr 94) to have a special case -for nullary constructors: - -\begin{verbatim} - = -- Don't re-use nullary constructors; it's a waste. Consider - -- let - -- a = leInt#! p q - -- in - -- case a of - -- True -> ... - -- False -> False - -- - -- Here the False in the second case will get replace by "a", hardly - -- a good idea - Nothing -\end{verbatim} - -but now we only do constructor re-use in let-bindings the special -case isn't necessary any more. - -\begin{code} -lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args - = lookup_conapp unfold_env con args + 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}