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