X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=b2be6a1510b23174d968bd096cc8dc94adefed61;hp=e55b6ea5a402de13763ef83b2de78ad16ab6376b;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=e0befe921f5bbfa6daba3f8ff46cdf2a2abad1da diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index e55b6ea..b2be6a1 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplEnv]{Environment stuff for the simplifier} @@ -7,91 +7,88 @@ #include "HsVersions.h" module SimplEnv ( - nullSimplEnv, + nullSimplEnv, combineSimplEnv, pprSimplEnv, -- debugging only ---UNUSED: getInEnvs, - replaceInEnvs, nullInEnvs, - - nullTyVarEnv, extendTyEnv, extendTyEnvList, simplTy, simplTyInId, - extendIdEnvWithAtom, extendIdEnvWithAtomList, - extendIdEnvWithInlining, + extendIdEnvWithAtom, extendIdEnvWithAtoms, extendIdEnvWithClone, extendIdEnvWithClones, lookupId, - extendUnfoldEnvGivenRhs, ---OLD: extendUnfoldEnvWithRecInlinings, - extendUnfoldEnvGivenFormDetails, - extendUnfoldEnvGivenConstructor, - lookForConstructor, - lookupUnfolding, filterUnfoldEnvForInlines, - getSwitchChecker, switchIsSet, + markDangerousOccs, + lookupRhsInfo, lookupOutIdEnv, isEvaluated, + extendEnvGivenBinding, extendEnvGivenNewRhs, + extendEnvForRecBinding, extendEnvGivenRhsInfo, + + lookForConstructor, ---UNUSED: getEnclosingCC, - setEnclosingCC, + getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining, - mkFormSummary, + setEnclosingCC, getEnclosingCC, -- Types - SwitchChecker(..), - SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..), - FormSummary(..), EnclosingCcDetails(..), - InIdEnv(..), IdVal(..), InTypeEnv(..), - UnfoldEnv, UnfoldItem, UnfoldConApp, - - -- re-exported from BinderInfo - BinderInfo(..), - FunOrArg, DuplicationDanger, InsideSCC, -- sigh - - InId(..), InBinder(..), InType(..), InBinding(..), InUniType(..), - OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..), - - InExpr(..), InAtom(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..), - - -- and to make the interface self-sufficient... - BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom, - CoreCaseAlternatives, CoreExpr, Id, - IdEnv(..), UniqFM, Unique, - MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType - - IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId) - IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling + SYN_IE(SwitchChecker), + SimplEnv, + SYN_IE(InIdEnv), SYN_IE(InTypeEnv), + UnfoldConApp, + RhsInfo(..), + + SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), + SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(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) ) where -IMPORT_Trace +IMP_Ubiq(){-uitous-} -import AbsUniType ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType ) -import Bag ( emptyBag, Bag ) -import BasicLit ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only -import BinderInfo -import CmdLineOpts ( switchIsOn, intSwitchSet, - SimplifierSwitch(..), SwitchResult +IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop + +import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, + BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC ) import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) -import CostCentre -import FiniteMap -import Id ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId, - getIdUniType, getIdStrictness, isWorkerId, - isBottomingId +import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) ) +import CoreSyn +import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, + Unfolding(..), SimpleUnfolding(..), FormSummary(..), + mkSimpleUnfolding, + calcUnfoldingGuidance, UnfoldingGuidance(..) ) -import IdEnv -import IdInfo -import MagicUFs -import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) +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 IdInfo ( bottomIsGuaranteed, StrictnessInfo ) +import Literal ( isNoRepLit, Literal{-instances-} ) +import Maybes ( maybeToBool, expectJust ) +import Name ( isLocallyDefined ) import OccurAnal ( occurAnalyseExpr ) -import PlainCore -- for the "Out*" types and things -import Pretty -- debugging only -import SimplUtils ( simplIdWantsToBeINLINEd ) -import TaggedCore -- for the "In*" types and things -import TyVarEnv -import UniqFM ( lookupDirectlyUFM, addToUFM_Directly, ufmToList ) -import UniqSet -import Util +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 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)" \end{code} %************************************************************************ @@ -100,6 +97,27 @@ import Util %* * %************************************************************************ +\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} %************************************************************************ %* * @@ -112,10 +130,10 @@ INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT this? WDP 94/06) This allows us to neglect keeping everything paired with its static environment. -The environment contains bindings for all +The environment contains bindings for all {\em in-scope,} {\em locally-defined} -things. +things. For such things, any unfolding is found in the environment, not in the Id. Unfoldings in the Id itself are used only for imported things @@ -124,511 +142,28 @@ inside the Ids, etc.). \begin{code} data SimplEnv - = SimplEnv - (SwitchChecker SimplifierSwitch) - - 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) - -nullSimplEnv :: SwitchChecker SimplifierSwitch -> 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" - LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] - OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]] - ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] - OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") - [ppr PprDebug c | c <- cs]] - GeneralForm t w e g -> ppCat [ppStr "UF:", - ppr PprDebug t, - ppr PprDebug w, - ppr PprDebug g, ppr PprDebug e] - MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s] - IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd" - ] -\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 OutAtom -- 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@, @UnfoldingDetails@, and @UnfoldingGuidance@ types} -%* * -%************************************************************************ - -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 ConstructorForm; - [UniType] -- a new type so we can make - [OutAtom] -- Ord work on it (instead of on - -- UnfoldingDetails). - -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 (GeneralForm 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} - -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. - -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: - -\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@(GeneralForm 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 - where - new_con_apps - = case uf_details of - ConstructorForm con targs 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 targs 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 _ (ConstructorForm _ _ _) _) = 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 + = 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 -lookup_conapp (UFE _ _ con_apps) con ty_args con_args - = lookupFM con_apps (UCA con ty_args con_args) -modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id - = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps +nullSimplEnv :: SwitchChecker -> SimplEnv --- 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 -\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 } -#ifdef __GLASGOW_HASKELL__ - _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } -#endif - -cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2) - = case cmpId c1 c2 of - LT_ -> LT_ - GT_ -> GT_ - _ -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of - LT_ -> LT_ - GT_ -> GT_ - _ -> cmp_lists cmp_atom as1 as2 - 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 (CoVarAtom x) (CoVarAtom y) = x `cmpId` y - cmp_atom (CoVarAtom _) _ = LT_ - cmp_atom (CoLitAtom x) (CoLitAtom y) -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } -#else - = if x == y then EQ_ elsid if x < y then LT_ else GT_ -#endif - cmp_atom (CoLitAtom _) _ = GT_ -\end{code} - -\begin{code} -data UnfoldingDetails - = NoUnfoldingDetails - - | LiteralForm - BasicLit - - | OtherLiteralForm - [BasicLit] -- It is a literal, but definitely not one of these - - | ConstructorForm - Id -- The constructor - [UniType] -- Type args - [OutAtom] -- Value arguments; NB OutAtoms, already cloned - - | OtherConstructorForm - [Id] -- It definitely isn't one of these constructors - -- This captures the situation in the default branch of - -- a case: case x of - -- c1 ... -> ... - -- c2 ... -> ... - -- v -> default-rhs - -- Then in default-rhs we know that v isn't c1 or c2. - -- - -- NB. In the degenerate: case x of {v -> default-rhs} - -- x will be bound to - -- OtherConstructorForm [] - -- which captures the idea that x is eval'd but we don't - -- know which constructor. - - - | GeneralForm - Bool -- True <=> At most one textual occurrence of the - -- binder in its scope, *or* - -- if we are happy to duplicate this - -- binding. - FormSummary -- Tells whether the template is a WHNF or bottom - TemplateOutExpr -- The template - UnfoldingGuidance -- Tells about the *size* of the template. - - | MagicForm - FAST_STRING - MagicUnfoldingFun - - {-OLD? Nukable? ("Also turgid" SLPJ)-} - | IWantToBeINLINEd -- Means this has an INLINE pragma; - -- Used for things which have a defn in this module - UnfoldingGuidance -- Guidance from the pragma; usually UnfoldAlways. - -data FormSummary - = WhnfForm -- Expression is WHNF - | BottomForm -- Expression is guaranteed to be bottom. We're more gung - -- ho about inlining such things, because it can't waste work - | OtherForm -- Anything else - -instance Outputable FormSummary where - ppr sty WhnfForm = ppStr "WHNF" - ppr sty BottomForm = ppStr "Bot" - ppr sty OtherForm = ppStr "Other" - -mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary -mkFormSummary si expr - | manifestlyWHNF expr = WhnfForm - | bottomIsGuaranteed si = BottomForm - - -- Chances are that the Id will be decorated with strictness info - -- telling that the RHS is definitely bottom. This *might* not be the - -- case, if it's been a while since strictness analysis, but leaving out - -- the test for manifestlyBottom makes things a little more efficient. - -- We can always put it back... - -- | manifestlyBottom expr = BottomForm - - | otherwise = OtherForm -\end{code} - -\begin{code} -data UnfoldingGuidance - = UnfoldNever -- Don't do it! - - | UnfoldAlways -- There is no "original" definition, - -- so you'd better unfold. Or: something - -- so cheap to unfold (e.g., 1#) that - -- you should do it absolutely always. - - | EssentialUnfolding -- Like UnfoldAlways, but you *must* do - -- it absolutely always. - -- This is what we use for data constructors - -- and PrimOps, because we don't feel like - -- generating curried versions "just in case". - - | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and - Int -- those val args are manifestly data constructors - [Bool] -- the val-arg positions marked True - -- (i.e., a simplification will definitely - -- be possible). - Int -- The "size" of the unfolding; to be elaborated - -- later. ToDo - - | BadUnfolding -- This is used by TcPragmas if the *lazy* - -- lintUnfolding test fails - -- It will never escape from the IdInfo as - -- it is caught by getInfo_UF and converted - -- to NoUnfoldingDetails -\end{code} - -\begin{code} -instance Outputable UnfoldingGuidance where - ppr sty UnfoldNever = ppStr "_N_" - ppr sty UnfoldAlways = ppStr "_ALWAYS_" - ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface - ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, - if null cs -- always print *something* - then ppChar 'X' - else ppBesides (map pp_c cs), - ppInt size ] - where - pp_c False = ppChar 'X' - pp_c True = ppChar 'C' -\end{code} - -%************************************************************************ -%* * -\subsection{@mkGenForm@ and @modifyUnfoldingDetails@} -%* * -%************************************************************************ - -\begin{code} -mkGenForm :: Bool -- Ok to Dup code down different case branches, - -- because of either a flag saying so, - -- or alternatively the object is *SMALL* - -> BinderInfo -- - -> FormSummary - -> TemplateOutExpr -- Template - -> UnfoldingGuidance -- Tells about the *size* of the template. - -> UnfoldingDetails - -mkGenForm safe_to_dup occ_info WhnfForm template guidance - = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance - -mkGenForm safe_to_dup occ_info form_summary template guidance - | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences - = GeneralForm True form_summary template guidance - - | otherwise -- Not a WHNF, many occurrences - = NoUnfoldingDetails -\end{code} - -\begin{code} -modifyUnfoldingDetails - :: Bool -- OK to dup - -> BinderInfo -- New occurrence info for the thing - -> UnfoldingDetails - -> UnfoldingDetails - -modifyUnfoldingDetails ok_to_dup occ_info - (GeneralForm only_one form_summary template guidance) - | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance - -{- OLD: - | otherwise = NoUnfoldingDetails - I can't see why we zap bindings which don't claim to be unique --} - -modifyUnfoldingDetails ok_to_dup occ_info other = other -\end{code} - -%************************************************************************ -%* * -\subsubsection{The @EnclosingCcDetails@ type} -%* * -%************************************************************************ - -\begin{code} -data EnclosingCcDetails - = NoEnclosingCcDetails - | EnclosingCC CostCentre -\end{code} - -%************************************************************************ -%* * -\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms} -%* * -%************************************************************************ +nullSimplEnv sw_chkr + = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps -\begin{code} -type InId = Id -- Not yet cloned -type InBinder = (InId, BinderInfo) -type InType = UniType -- Ditto -type InBinding = SimplifiableCoreBinding -type InExpr = SimplifiableCoreExpr -type InAtom = SimplifiableCoreAtom -- same as PlainCoreAtom -type InAlts = SimplifiableCoreCaseAlternatives -type InDefault = SimplifiableCoreCaseDefault -type InArg = CoreArg InId -type InUniType = UniType +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 -type OutId = Id -- Cloned -type OutBinder = Id -type OutType = UniType -- Cloned -type OutBinding = PlainCoreBinding -type OutExpr = PlainCoreExpr -type OutAtom = PlainCoreAtom -type OutAlts = PlainCoreCaseAlternatives -type OutDefault = PlainCoreCaseDefault -type OutArg = CoreArg OutId -type OutUniType = UniType - -type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId - -- An OutExpr with occurrence info attached - -- This is used as a template in GeneralForms. +pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" \end{code} -\begin{code} -type SwitchChecker switch = switch -> SwitchResult -\end{code} - -%************************************************************************ -%* * -\subsection{@SimplEnv@ handling} -%* * -%************************************************************************ %************************************************************************ %* * @@ -637,12 +172,24 @@ type SwitchChecker switch = switch -> SwitchResult %************************************************************************ \begin{code} -getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch -getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr +getSwitchChecker :: SimplEnv -> SwitchChecker +getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _) switch +switchIsSet (SimplEnv chkr _ _ _ _ _) switch = switchIsOn chkr switch + +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +getSimplIntSwitch chkr switch + = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) + + -- Crude, but simple +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 + where + chkr' EssentialUnfoldingsOnly = SwBool True + chkr' other = chkr other \end{code} %************************************************************************ @@ -652,14 +199,13 @@ switchIsSet (SimplEnv chkr _ _ _ _) switch %************************************************************************ \begin{code} --- UNUSED: ---getEnclosingCC :: SimplEnv -> EnclosingCcDetails ---getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc +setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv -setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> 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 (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc - = SimplEnv chkr encl_cc ty_env id_env unfold_env +getEnclosingCC :: SimplEnv -> CostCentre +getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc \end{code} %************************************************************************ @@ -669,40 +215,22 @@ setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc %************************************************************************ \begin{code} -type InTypeEnv = TypeEnv -- Maps InTyVars to OutUniTypes +type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes -extendTyEnv :: SimplEnv -> TyVar -> UniType -> 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 +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 where new_ty_env = addOneToTyVarEnv ty_env tyvar ty -extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs - = SimplEnv chkr encl_cc new_ty_env id_env unfold_env +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 where new_ty_env = growTyVarEnvList ty_env pairs -simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty - -simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id -\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) - --- UNUSED: ---getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) ---getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env) - -replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv -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 +simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty +simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id \end{code} %************************************************************************ @@ -712,132 +240,130 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) %************************************************************************ \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder -> OutAtom - -> SimplEnv - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit) - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id, occ_info) atom@(CoVarAtom 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) +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} - 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. +\begin{code} +lookupId :: SimplEnv -> Id -> OutArg - ok_to_dup = switchIsOn chkr SimplOkToDupCode +lookupId (SimplEnv _ _ _ in_id_env _ _) id + = case (lookupIdEnv in_id_env id) of + Just atom -> atom + Nothing -> VarArg id +\end{code} -extendIdEnvWithAtomList +\begin{code} +extendIdEnvWithAtom :: SimplEnv - -> [(InBinder, OutAtom)] - -> 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 + -> InBinder + -> OutArg{-Val args only, please-} -> 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 +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) + (in_id,occ_info) atom + = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps where - new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr) + 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) -extendIdEnvWithClone - :: SimplEnv - -> InBinder -- Old binder; binderinfo ignored - -> OutId -- Its new clone, as an Id - -> SimplEnv +extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv +extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) -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 - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id)) -extendIdEnvWithClones -- Like extendIdEnvWithClone - :: SimplEnv - -> [InBinder] - -> [OutId] - -> SimplEnv +extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv + +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 + where + new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id) -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 +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 where - new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) - in_ids = [id | (id,_) <- in_binders] - out_vals = [ItsAnAtom (CoVarAtom 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 + new_in_id_env = growIdEnvList in_id_env bindings + bindings = zipEqual "extendIdEnvWithClones" + [id | (id,_) <- in_binders] + (map VarArg out_ids) \end{code} %************************************************************************ %* * -\subsubsection{The @UnfoldEnv@} +\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} -extendUnfoldEnvGivenFormDetails - :: SimplEnv - -> OutId - -> UnfoldingDetails - -> SimplEnv +type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo) -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 +\end{code} -extendUnfoldEnvGivenConstructor -- specialised variant - :: SimplEnv - -> OutId -- bind this to... - -> Id -> [OutId] -- "con args" - -> SimplEnv +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. -extendUnfoldEnvGivenConstructor env var con args - = let - -- conjure up the types to which the con should be applied - scrut_ty = getIdUniType var - (_, ty_args, _) = getUniDataTyCon scrut_ty - in - extendUnfoldEnvGivenFormDetails - env var (ConstructorForm con ty_args (map CoVarAtom args)) +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) + + | OutUnfolding CostCentre + SimpleUnfolding -- Already-simplified unfolding + +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 + = 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) + = (id, occ, new_info) + where + new_info = case (info1, info2) of + (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2) + (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2) + (_, NoRhsInfo) -> info1 + other -> info2 \end{code} -@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS +\begin{code} +isEvaluated :: RhsInfo -> Bool +isEvaluated (OtherLit _) = True +isEvaluated (OtherCon _) = True +isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True +isEvaluated (OutUnfolding _ (SimpleUnfolding 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: @ @@ -848,20 +374,20 @@ due to Andr\'e Santos: 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); + 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 + } 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) + 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 @@ -878,171 +404,194 @@ 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_id_env out_id_env con_apps) + occ_info out_id rhs + = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps where - -- Occurrence-analyse the RHS - (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs + 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) - interesting_fvs = get_interesting_ids unfold_env + -- 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 - details = case rhs of - CoVar v -> panic "CoVars already dealt with" - CoLit lit | isNoRepLit lit -> LiteralForm lit - | otherwise -> panic "non-noRep CoLits already dealt with" - - CoCon con tys args -> ConstructorForm con tys 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 - GeneralForm _ _ _ _ -> 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 - (CoVar _, xs) -> length xs < 10 - _ -> False + 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 + +{- 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... + +(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.) + +Bad news! (f x) is duplicated! Our solution is to only be prepared to +inline RHSs in their own RHSs if they are *values* (lambda or constructor). + +This means that silly x=y bindings in recursive group will never go away. Sigh. ToDo! -} +extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) + (out_id, ((_,occ_info), old_rhs)) + = 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 + (ValueForm, UnfoldNever) -> out_id_env -- No new stuff to put in + (ValueForm, _) -> out_id_env_with_unfolding + other -> out_id_env -- Not a value + + -- 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 + rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs) + form_summary = mkFormSummary old_rhs + guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs) -{- UNUSED: -extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv -extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - new_ids old_rhss - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env +mkSimplUnfoldingGuidance chkr out_id rhs + | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id + = UnfoldAlways + + | otherwise + = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs where - extra_unfold_items - = [ (new_id, UnfoldItem new_id - (GeneralForm True - (mkFormSummary (getIdStrictness new_id) old_rhs) - old_rhs UnfoldAlways) - encl_cc) - | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss, - simplIdWantsToBeINLINEd new_id env - ] - - new_unfold_env = addto_unfold_env unfold_env extra_unfold_items --} + bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold + +extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv +extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) + out_id occ_info rhs_info + = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps + where + new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id + (out_id, occ_info, rhs_info) \end{code} -\begin{code} -lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails -lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var - | not (isLocallyDefined var) -- Imported, so look inside the id - = getIdUnfolding var +\begin{code} +modifyOccInfo out_id_env (uniq, new_occ) + = modifyIdEnv_Directly modify_fn out_id_env uniq + where + modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs) - | otherwise -- Locally defined, so look in the envt. - -- There'll be nothing inside the Id. - = lookup_unfold_env unfold_env var +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 + where + new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms] + modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs) \end{code} -We need to remove any @GeneralForm@ bindings from the UnfoldEnv for -the RHS of an Id which has an INLINE pragma. + + +%************************************************************************ +%* * +\subsubsection{The @ConAppMap@ type} +%* * +%************************************************************************ + +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 + +\begin{code} +type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)] + +data UnfoldConApp + = UCA OutId -- data constructor + [OutArg] -- *value* arguments; see use below +\end{code} \begin{code} -filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv +nullConApps = emptyFM -filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - = SimplEnv chkr encl_cc ty_env id_env new_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_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. + val_args = filter isValArg args -- Literals and Ids + ty_args = [ty | TyArg ty <- args] -- Just types + +extendConApps con_apps id other_rhs = con_apps \end{code} -====================== +\begin{code} +lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args + = case lookupFM con_apps (UCA con val_args) of + Nothing -> Nothing + + Just assocs -> case [id | (tys, id) <- assocs, + and (zipWith eqTy tys ty_args)] + of + [] -> Nothing + (id:_) -> Just id + where + val_args = filter isValArg args -- Literals and Ids + ty_args = [ty | TyArg ty <- args] -- Just types + +\end{code} -In @lookForConstructor@ we used (before Apr 94) to have a special case -for nullary constructors: +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} +\begin{verbatim} = -- Don't re-use nullary constructors; it's a waste. Consider - -- let + -- let -- a = leInt#! p q - -- in + -- in -- case a of -- True -> ... -- False -> False @@ -1052,10 +601,43 @@ for nullary constructors: Nothing \end{verbatim} -but now we only do constructor re-use in let-bindings the special -case isn't necessary any more. + +The main thing about @UnfoldConApp@ is that it has @Ord@ defined on +it, so we can use it for a @FiniteMap@ key. \begin{code} -lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args - = lookup_conapp unfold_env con ty_args con_args +instance Eq UnfoldConApp where + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` 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 + +cmp_app (UCA c1 as1) (UCA c2 as2) + = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 + where + -- ToDo: make an "instance Ord3 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 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" + tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} + + +