X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=b2be6a1510b23174d968bd096cc8dc94adefed61;hp=5406e3da09e28c2d08f6df0e348c178d7ccee315;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84 diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 5406e3d..b2be6a1 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -7,63 +7,68 @@ #include "HsVersions.h" module SimplEnv ( - nullSimplEnv, + nullSimplEnv, combineSimplEnv, pprSimplEnv, -- debugging only - replaceInEnvs, nullInEnvs, - extendTyEnv, extendTyEnvList, simplTy, simplTyInId, - extendIdEnvWithAtom, extendIdEnvWithAtomList, - extendIdEnvWithInlining, + extendIdEnvWithAtom, extendIdEnvWithAtoms, extendIdEnvWithClone, extendIdEnvWithClones, lookupId, - extendUnfoldEnvGivenRhs, - extendUnfoldEnvGivenFormDetails, - extendUnfoldEnvGivenConstructor, + + markDangerousOccs, + lookupRhsInfo, lookupOutIdEnv, isEvaluated, + extendEnvGivenBinding, extendEnvGivenNewRhs, + extendEnvForRecBinding, extendEnvGivenRhsInfo, + lookForConstructor, - lookupUnfolding, filterUnfoldEnvForInlines, - getSwitchChecker, switchIsSet, + getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining, - setEnclosingCC, + setEnclosingCC, getEnclosingCC, -- Types - SwitchChecker(..), - SimplEnv, EnclosingCcDetails(..), - InIdEnv(..), IdVal(..), InTypeEnv(..), - UnfoldEnv, UnfoldItem, UnfoldConApp, + SYN_IE(SwitchChecker), + SimplEnv, + SYN_IE(InIdEnv), SYN_IE(InTypeEnv), + UnfoldConApp, + RhsInfo(..), - InId(..), InBinder(..), InBinding(..), InType(..), - OutId(..), OutBinder(..), OutBinding(..), OutType(..), + SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), + SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), - InExpr(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) + 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 Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import SmplLoop -- breaks the MagicUFs / SimplEnv loop +IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop -import BinderInfo ( BinderInfo{-instances-} ) +import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, + BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC + ) import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) +import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, - calcUnfoldingGuidance, UnfoldingGuidance(..), - mkFormSummary, FormSummary +import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, + Unfolding(..), SimpleUnfolding(..), FormSummary(..), + mkSimpleUnfolding, + calcUnfoldingGuidance, UnfoldingGuidance(..) ) -import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup ) +import CoreUtils ( coreExprCc, unTagBinders ) +import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached ) import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, +import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, - IdEnv(..), IdSet(..), GenId ) + 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 Outputable ( Outputable(..){-instances-} ) @@ -71,22 +76,19 @@ import PprCore -- various instances import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) import Pretty -import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy ) -import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, - growTyVarEnvList, - TyVarEnv(..), GenTyVar{-instance Eq-} +import Type ( eqTy, applyTypeEnvToTy ) +import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, + SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) -import UniqSet -- lots of things -import Usage ( UVar(..), GenUsage{-instances-} ) +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)" -oneSafeOcc = panic "oneSafeOcc (SimplEnv)" -oneTextualOcc = panic "oneTextualOcc (SimplEnv)" -simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" \end{code} %************************************************************************ @@ -95,6 +97,27 @@ simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (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} %************************************************************************ %* * @@ -121,348 +144,26 @@ inside the Ids, etc.). data SimplEnv = SimplEnv SwitchChecker + CostCentre -- The enclosing cost-centre (when profiling) + InTypeEnv -- Maps old type variables to new clones + InIdEnv -- Maps locally-bound Ids to new clones + OutIdEnv -- Info about the values of OutIds + ConAppMap -- Maps constructor applications back to OutIds - 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 -> 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] - ] -\end{code} - -%************************************************************************ -%* * -\subsubsection{The @IdVal@ type (for the ``IdEnv'')} -%* * -%************************************************************************ + = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps -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}. +combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv +combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) + new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ ) + = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -\begin{code} -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. +pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" \end{code} -%************************************************************************ -%* * -\subsubsection{The @UnfoldEnv@ type} -%* * -%************************************************************************ - -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 pair - = UCA OutId -- data constructor - [OutArg] -- *value* arguments; see use below - -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 [([Type], OutId)]) - -- 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 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@(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)) - (addOneToUniqSet interesting_ids 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 - ConForm con args -> snd (lookup_conapp_help con_apps con args id) - 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 - = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp")) - --- Returns two things; we just fst or snd the one we want: -lookup_conapp_help con_apps con args outid - = case (span notValArg args) of { (ty_args, val_args) -> - let - entry = UCA con val_args - arg_tys = [ t | TyArg t <- ty_args ] - in - case (lookupFM con_apps entry) of - Nothing -> (Nothing, - addToFM con_apps entry [(arg_tys, outid)]) - Just assocs - -> ASSERT(not (null assocs)) - case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of - [o] -> (Just o, - con_apps) -- unchanged; we hang onto what we have - [] -> (Nothing, - addToFM con_apps entry ((arg_tys, outid) : assocs)) - _ -> panic "grow_unfold_env:dup in assoc list" - } - where - eq_tys ts1 ts2 - = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False } - - cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types - = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-} - -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 -\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 - -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) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } - 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} - -%************************************************************************ -%* * -\subsubsection{The @EnclosingCcDetails@ type} -%* * -%************************************************************************ - -\begin{code} -data EnclosingCcDetails - = NoEnclosingCcDetails - | EnclosingCC CostCentre -\end{code} - -%************************************************************************ -%* * -\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms} -%* * -%************************************************************************ - -\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 - -\end{code} - -\begin{code} -type SwitchChecker = SimplifierSwitch -> SwitchResult -\end{code} - -%************************************************************************ -%* * -\subsection{@SimplEnv@ handling} -%* * -%************************************************************************ %************************************************************************ %* * @@ -472,11 +173,23 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult \begin{code} getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr +getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _) switch +switchIsSet (SimplEnv chkr _ _ _ _ _) switch = switchIsOn chkr switch + +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +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} %************************************************************************ @@ -486,10 +199,13 @@ switchIsSet (SimplEnv chkr _ _ _ _) switch %************************************************************************ \begin{code} -setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv +setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv + +setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc + = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -setEnclosingCC (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} %************************************************************************ @@ -502,33 +218,19 @@ setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes 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 +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,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 +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) - -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} %************************************************************************ @@ -538,135 +240,129 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) %************************************************************************ \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder -> OutArg{-Val args only, please-} - -> SimplEnv - -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) - -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. +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} - ok_to_dup = switchIsOn chkr SimplOkToDupCode +\begin{code} +lookupId :: SimplEnv -> Id -> OutArg -#ifdef DEBUG -extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!" -#endif +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, 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 + -> 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 (VarArg 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 (zipEqual "extendIdEnvWithClones" in_ids 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 + 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