\section[SimplEnv]{Environment stuff for the simplifier}
\begin{code}
-#include "HsVersions.h"
-
module SimplEnv (
- nullSimplEnv,
- pprSimplEnv, -- debugging only
+ nullSimplEnv,
+ getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
- replaceInEnvs, nullInEnvs,
+ bindTyVar, bindTyVars, simplTy,
- extendTyEnv, extendTyEnvList,
- simplTy, simplTyInId,
+ lookupIdSubst, lookupOutIdEnv,
- extendIdEnvWithAtom, extendIdEnvWithAtomList,
- extendIdEnvWithInlining,
- extendIdEnvWithClone, extendIdEnvWithClones,
- lookupId,
+ bindIdToAtom, bindIdToExpr,
+
+ markDangerousOccs,
+ lookupUnfolding, isEvaluated,
+ extendEnvGivenBinding, extendEnvGivenNewRhs,
+ extendEnvGivenUnfolding,
- extendUnfoldEnvGivenRhs,
- extendUnfoldEnvGivenFormDetails,
- extendUnfoldEnvGivenConstructor,
lookForConstructor,
- lookupUnfolding, filterUnfoldEnvForInlines,
- getSwitchChecker, switchIsSet,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch,
+ switchOffInlining, setCaseScrutinee,
- setEnclosingCC,
+ setEnclosingCC, getEnclosingCC,
-- Types
- SwitchChecker(..),
- SimplEnv, EnclosingCcDetails(..),
- InIdEnv(..), IdVal(..), InTypeEnv(..),
- UnfoldEnv, UnfoldItem, UnfoldConApp,
-
- InId(..), InBinder(..), InBinding(..), InType(..),
- OutId(..), OutBinder(..), OutBinding(..), OutType(..),
+ SwitchChecker,
+ SimplEnv,
+ UnfoldConApp,
+ SubstInfo(..),
- InExpr(..), InAlts(..), InDefault(..), InArg(..),
- OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
+ InId, InBinder, InBinding, InType,
+ OutId, OutBinder, OutBinding, OutType,
- -- and to make the interface self-sufficient...
+ InExpr, InAlts, InDefault, InArg,
+ OutExpr, OutAlts, OutDefault, OutArg
) where
-import Ubiq{-uitous-}
-
-import SmplLoop -- breaks the MagicUFs / SimplEnv loop
+#include "HsVersions.h"
-import BinderInfo ( BinderInfo{-instances-} )
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
+import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
+ okToInline, isOneFunOcc,
+ BinderInfo
+ )
+import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
+ SimplifierSwitch(..), SwitchResult(..)
+ )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
- calcUnfoldingGuidance, UnfoldingGuidance(..),
- mkFormSummary, FormSummary
+import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
+ Unfolding(..), FormSummary(..),
+ calcUnfoldingGuidance )
+import CoreUtils ( coreExprCc )
+import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre,
+ costsAreSubsumed, noCostCentreAttached, subsumedCosts,
+ currentOrSubsumedCosts
)
import FiniteMap -- lots of things
-import Id ( idType, getIdUnfolding, getIdStrictness,
- nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
- addOneToIdEnv, modifyIdEnv,
- IdEnv(..), IdSet(..), GenId )
-import IdInfo ( StrictnessInfo )
-import Literal ( isNoRepLit, Literal{-instances-} )
-import Outputable ( Outputable(..){-instances-} )
+import Id ( getInlinePragma,
+ nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
+ addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
+ IdEnv, IdSet, Id )
+import Literal ( Literal )
+import Maybes ( expectJust )
+import OccurAnal ( occurAnalyseExpr )
import PprCore -- various instances
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType, GenTyVar )
-import Pretty
-import Type ( getAppDataTyCon )
-import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
- growTyVarEnvList,
- TyVarEnv(..), GenTyVar )
-import Unique ( Unique )
-import UniqSet -- lots of things
-import Usage ( UVar(..), GenUsage{-instances-} )
-import Util ( zipEqual, panic, assertPanic )
-
-type TypeEnv = TyVarEnv Type
-addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
-applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)"
-applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)"
-bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
-cmpType = panic "cmpType (SimplEnv)"
-exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
-lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)"
-manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)"
-occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)"
-oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
-oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
-simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
-uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)"
-ufmToList = panic "ufmToList (SimplEnv)"
+import Type ( instantiateTy, Type )
+import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
+ TyVarSet, emptyTyVarSet,
+ TyVar
+ )
+import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
+import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM )
+import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList )
+import Outputable
\end{code}
%************************************************************************
%* *
%************************************************************************
+\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}
%************************************************************************
%* *
data SimplEnv
= SimplEnv
SwitchChecker
+ CostCentre -- The enclosing cost-centre (when profiling)
+ SimplTypeEnv -- Maps old type variables to new clones
+ SimplValEnv -- Maps locally-bound Ids to new clones
+ ConAppMap -- Maps constructor applications back to OutIds
+
+type SimplTypeEnv = (TyVarSet, -- In-scope tyvars (in result)
+ TyVarEnv Type) -- Type substitution
+ -- If t is in the in-scope set, it certainly won't be
+ -- in the domain of the substitution, and vice versa
+
+type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
+ -- Ids (in result), range gives info about them
+ IdEnv SubstInfo) -- Id substitution
+ -- The first envt tells what Ids are in scope; it
+ -- corresponds to the TyVarSet in SimplTypeEnv
+
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
+ --
+ -- Ids in the domain of the substitution are *not* in scope;
+ -- they *must* be substituted for the given OutArg
+
+data SubstInfo
+ = SubstVar OutId -- The Id maps to an already-substituted atom
+ | SubstLit Literal -- ...ditto literal
+ | SubstExpr -- Id maps to an as-yet-unsimplified expression
+ (TyVarEnv Type) -- ...hence we need to capture the substitution
+ (IdEnv SubstInfo) -- environments too
+ SimplifiableCoreExpr
+
+type StuffAboutId = (OutId, -- Always has the same unique as the
+ -- Id that maps to it; but may have better
+ -- IdInfo, and a correctly-substituted type,
+ -- than the occurrences of the Id. So use
+ -- this to replace occurrences
+
+ BinderInfo, -- How it occurs
+ -- We keep this info so we can modify it when
+ -- something changes.
+
+ Unfolding) -- Info about what it is bound to
+\end{code}
- EnclosingCcDetails -- the enclosing cost-centre (when profiling)
-
- InTypeEnv -- For cloning types
- -- Domain is all in-scope type variables
-
- InIdEnv -- IdEnv
- -- Domain is
- -- *all*
- -- *in-scope*,
- -- *locally-defined*
- -- *InIds*
- -- (Could omit the exported top-level guys,
- -- since their names mustn't change; and ditto
- -- the non-exported top-level guys which you
- -- don't want to macro-expand, since their
- -- names need not change.)
- --
- -- Starts off empty
-
- UnfoldEnv -- Domain is any *OutIds*, including imports
- -- where we know something more than the
- -- interface file tells about their value (see
- -- below)
+\begin{code}
nullSimplEnv :: SwitchChecker -> SimplEnv
nullSimplEnv sw_chkr
- = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
-
-pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
- = ppAboves [
- ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
- ppSP, ppStr "** Id Env ** ?????????",
--- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
- ppSP, ppStr "** Unfold Env **",
- ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
- ]
- where
- pp_id_entry (v, idval)
- = ppCat [ppr PprDebug v, ppStr "=>",
- case idval of
- InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
- ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
- ]
-
- pp_uf_entry (UnfoldItem v form encl_cc)
- = ppCat [ppr PprDebug v, ppStr "=>",
- case form of
- NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
- LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
- OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
- [ppr PprDebug l | l <- ls]]
- ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
- OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
- [ppr PprDebug c | c <- cs]]
- GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
- ppr PprDebug g, ppr PprDebug e]
- MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
- ]
+ = SimplEnv sw_chkr subsumedCosts
+ (emptyTyVarSet, emptyTyVarEnv)
+ (nullIdEnv, nullIdEnv)
+ nullConApps
+
+ -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
+ -- for the rhs of top level defs is "OST_CENTRE". Consider
+ -- f = \x -> e
+ -- g = \y -> let v = f y in scc "x" (v ...)
+ -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
+ -- want to inline "v" since its CC is dynamically determined.
+
+
+getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
+getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
+
+setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv
+setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env
+ = SimplEnv chkr encl_cc ty_env in_id_env con_apps
+
+setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
+setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
+ = SimplEnv chkr encl_cc ty_env id_env con_apps
+
+setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
+setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ ty_subst id_subst
+ = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
+
+zapSubstEnvs :: SimplEnv -> SimplEnv
+zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps
\end{code}
-%************************************************************************
-%* *
-\subsubsection{The @IdVal@ type (for the ``IdEnv'')}
-%* *
-%************************************************************************
-
-The unfoldings for imported things are mostly kept within the Id
-itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
-example, suppose \tr{x} is imported, and we have
-\begin{verbatim}
- case x of
- (p,q) -> <body>
-\end{verbatim}
-Then within \tr{<body>}, we know that \tr{x} is a pair with components
-\tr{p} and \tr{q}.
-
-\begin{code}
-type InIdEnv = IdEnv IdVal -- Maps InIds to their value
-
-data IdVal
- = InlineIt InIdEnv InTypeEnv InExpr
- -- No binding of the Id is left;
- -- You *have* to replace any occurences
- -- of the id with this expression.
- -- Rather like a macro, really
- -- NB: the InIdEnv/InTypeEnv is necessary to prevent
- -- name caputure. Consider:
- -- let y = ...
- -- x = ...y...
- -- y = ...
- -- in ...x...
- -- If x gets an InlineIt, we must remember
- -- the correct binding for y.
-
- | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
- -- or (b) if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just bind the variable to that atom, and
- -- elide the let.
-\end{code}
%************************************************************************
%* *
-\subsubsection{The @UnfoldEnv@ type}
+\subsubsection{Command-line switches}
%* *
%************************************************************************
-The @UnfoldEnv@ contains information about the value of some of the
-in-scope identifiers. It obeys the following invariant:
-
- If the @UnfoldEnv@ contains information, it is safe to use it!
-
-In particular, if the @UnfoldEnv@ contains details of an unfolding of
-an Id, then it's safe to use the unfolding. If, for example, the Id
-is used many times, then its unfolding won't be put in the UnfoldEnv
-at all.
-
-The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
-because (a)~it's small, and (b)~we need to search its {\em range} as
-well as its domain.
-
\begin{code}
-data UnfoldItem -- a glorified triple...
- = UnfoldItem OutId -- key: used in lookForConstructor
- UnfoldingDetails -- for that Id
- EnclosingCcDetails -- so that if we do an unfolding,
- -- we can "wrap" it in the CC
- -- that was in force.
-
-data UnfoldConApp -- yet another glorified triple
- = UCA OutId -- same fields as ConForm
- [OutArg]
-
-data UnfoldEnv -- yup, a glorified triple...
- = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
- IdSet -- The Ids in the domain of the env
- -- which have details (GenForm True ...)
- -- i.e., they claim they are duplicatable.
- -- These are the ones we have to worry
- -- about when adding new items to the
- -- unfold env.
- (FiniteMap UnfoldConApp OutId)
- -- Maps applications of constructors (to
- -- types & atoms) back to OutIds that are
- -- bound to them; i.e., this is a reversed
- -- mapping for (part of) the main IdEnv
- -- (1st part of UFE)
-
-null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
-\end{code}
+getSwitchChecker :: SimplEnv -> SwitchChecker
+getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
-The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
-be small, because it contains bindings only for those things whose
-form or unfolding is known. Basically it maps @Id@ to their
-@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
-need to search it associatively, to look for @Id@s which have a given
-constructor form.
+switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
+switchIsSet (SimplEnv chkr _ _ _ _) switch
+ = switchIsOn chkr switch
-We implement it with @IdEnvs@, possibly overkill, but sometimes these
-things silently grow quite big.... Here are some local functions used
-elsewhere in the module:
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-\begin{code}
-grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
-lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
-lookup_unfold_env_encl_cc
- :: UnfoldEnv -> OutId -> EnclosingCcDetails
-
-grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id
- uf_details@(GenForm True _ _ _) encl_cc
- -- Only interested in Ids which have a "dangerous" unfolding; that is
- -- one that claims to have a single occurrence.
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- (interesting_ids `unionUniqSets` singletonUniqSet id)
- con_apps
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- interesting_ids
- new_con_apps
+ -- Crude, but simple
+setCaseScrutinee :: SimplEnv -> SimplEnv
+setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
+ = SimplEnv chkr' encl_cc ty_env id_env con_apps
where
- new_con_apps
- = case uf_details of
- ConForm con vargs
- -> case (lookupFM con_apps entry) of
- Just _ -> con_apps -- unchanged; we hang onto what we have
- Nothing -> addToFM con_apps entry id
- where
- entry = UCA con vargs
-
- not_a_constructor -> con_apps -- unchanged
-
-addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
- = ASSERT(not (any constructor_form_in_those extra_items))
- -- otherwise, we'd need to change con_apps
- UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
- where
- constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
- constructor_form_in_those _ = False
-
-rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-
-get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
-
-foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
- = UFE (foldr fun u_env stuff) interesting_ids con_apps
-
-lookup_unfold_env (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoUnfoldingDetails
- Just (UnfoldItem _ uf _) -> uf
-
-lookup_unfold_env_encl_cc (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoEnclosingCcDetails
- Just (UnfoldItem _ _ encl_cc) -> encl_cc
-
-lookup_conapp (UFE _ _ con_apps) con args
- = lookupFM con_apps (UCA con args)
-
-modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
- = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
-
--- If the current binding claims to be a "unique" one, then
--- we modify it.
-modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
-
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
- = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
+ chkr' SimplCaseScrutinee = SwBool True
+ chkr' other = chkr other
\end{code}
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-\begin{code}
-instance Eq UnfoldConApp where
- a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
- a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
-
-instance Ord UnfoldConApp where
- a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance Ord3 UnfoldConApp where
- cmp = cmp_app
+@switchOffInlining@ is used to prepare the environment for simplifying
+the RHS of an Id that's marked with an INLINE pragma. It is going to
+be inlined wherever they are used, and then all the inlining will take
+effect. Meanwhile, there isn't much point in doing anything to the
+as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
+inlining! because
+ (a) not doing so will inline a worker straight back into its wrapper!
+
+and (b) Consider the following example
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+ Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+ and thence copied multiple times when g is inlined.
+
+ Andy disagrees! Example:
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+ Problem: any won't get deforested, and so if it's exported and
+ the importer doesn't use the inlining, (eg passes it as an arg)
+ then we won't get deforestation at all.
+ We havn't solved this problem yet!
+
+We prepare the envt by simply modifying the id_env, which has
+all the unfolding info. At one point we did it by modifying the chkr so
+that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
+simplifications happening in the body of the RHS.
-cmp_app (UCA c1 as1) (UCA c2 as2)
- = case (c1 `cmp` c2) of
- LT_ -> LT_
- GT_ -> GT_
- _ -> cmp_lists cmp_atom as1 as2
+\begin{code}
+switchOffInlining :: SimplEnv -> SimplEnv
+switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
where
- cmp_lists cmp_item [] [] = EQ_
- cmp_lists cmp_item (x:xs) [] = GT_
- cmp_lists cmp_item [] (y:ys) = LT_
- cmp_lists cmp_item (x:xs) (y:ys)
- = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
-
- cmp_atom (VarArg x) (VarArg y) = x `cmp` y
- cmp_atom (VarArg _) _ = LT_
- cmp_atom (LitArg x) (LitArg y)
- = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
- cmp_atom (LitArg _) _ = GT_
+ forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoUnfolding)
\end{code}
+
%************************************************************************
%* *
-\subsubsection{The @EnclosingCcDetails@ type}
+\subsubsection{The ``enclosing cost-centre''}
%* *
%************************************************************************
\begin{code}
-data EnclosingCcDetails
- = NoEnclosingCcDetails
- | EnclosingCC CostCentre
+setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
+
+setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
+ = SimplEnv chkr encl_cc ty_env id_env con_apps
+
+getEnclosingCC :: SimplEnv -> CostCentre
+getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc
\end{code}
%************************************************************************
%* *
-\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
+\subsubsection{The @TypeEnv@ part}
%* *
%************************************************************************
-\begin{code}
-type InId = Id -- Not yet cloned
-type InBinder = (InId, BinderInfo)
-type InType = Type -- Ditto
-type InBinding = SimplifiableCoreBinding
-type InExpr = SimplifiableCoreExpr
-type InAlts = SimplifiableCoreCaseAlts
-type InDefault = SimplifiableCoreCaseDefault
-type InArg = SimplifiableCoreArg
+These two "bind" functions extend the tyvar substitution.
+They don't affect what tyvars are in scope.
-type OutId = Id -- Cloned
-type OutBinder = Id
-type OutType = Type -- Cloned
-type OutBinding = CoreBinding
-type OutExpr = CoreExpr
-type OutAlts = CoreCaseAlts
-type OutDefault = CoreCaseDefault
-type OutArg = CoreArg
+\begin{code}
+bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv
+bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty
+ = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
+ where
+ new_ty_subst = addToTyVarEnv ty_subst tyvar ty
+bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv
+bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst
+ = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
+ where
+ new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
\end{code}
\begin{code}
-type SwitchChecker = SimplifierSwitch -> SwitchResult
+simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty)
\end{code}
%************************************************************************
%* *
-\subsection{@SimplEnv@ handling}
+\subsubsection{The ``Id env'' part}
%* *
%************************************************************************
-%************************************************************************
-%* *
-\subsubsection{Command-line switches}
-%* *
-%************************************************************************
+notInScope forgets that the specified binder is in scope.
+It is used when we decide to bind a let(rec) bound thing to
+an atom, *after* the Id has been added to the in-scope mapping by simplBinder.
\begin{code}
-getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
+notInScope :: SimplEnv -> OutBinder -> SimplEnv
+notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
+ where
+ new_in_scope_ids = delOneFromIdEnv in_scope_ids id
+\end{code}
-switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _) switch
- = switchIsOn chkr switch
+These "bind" functions extend the Id substitution.
+
+\begin{code}
+bindIdToAtom :: SimplEnv
+ -> InBinder
+ -> OutArg -- Val args only, please
+ -> SimplEnv
+
+bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ (in_id,occ_info) atom
+ = SimplEnv chkr encl_cc ty_env id_env' con_apps
+ where
+ id_env' = case atom of
+ LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit))
+ VarArg id -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info,
+ addOneToIdEnv id_subst in_id (SubstVar id))
+
+bindIdToExpr :: SimplEnv
+ -> InBinder
+ -> SimplifiableCoreExpr
+ -> SimplEnv
+
+bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps)
+ (in_id,occ_info) expr
+ = ASSERT( isOneFunOcc occ_info ) -- Binder occurs just once, safely, so no
+ -- need to adjust occurrence info for RHS,
+ -- unlike bindIdToAtom
+ SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps
+ where
+ id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr)
\end{code}
+
%************************************************************************
%* *
-\subsubsection{The ``enclosing cost-centre''}
+\subsubsection{The @OutIdEnv@}
%* *
%************************************************************************
\begin{code}
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
-
-setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
- = SimplEnv chkr encl_cc ty_env id_env unfold_env
+lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
+lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
+
+lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
+lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
+
+lookupUnfolding :: SimplEnv -> OutId -> Unfolding
+lookupUnfolding env id
+ = case lookupOutIdEnv env id of
+ Just (_,_,info) -> info
+ Nothing -> NoUnfolding
+
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
+modifyOutEnvItem (id, occ, info1) (_, _, info2)
+ = case (info1, info2) of
+ (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
+ (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
+ (_, NoUnfolding) -> (id,occ, info1)
+ other -> (id,occ, info2)
\end{code}
-%************************************************************************
-%* *
-\subsubsection{The @TypeEnv@ part}
-%* *
-%************************************************************************
\begin{code}
-type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
+isEvaluated :: Unfolding -> Bool
+isEvaluated (OtherLit _) = True
+isEvaluated (OtherCon _) = True
+isEvaluated (CoreUnfolding ValueForm _ expr) = True
+isEvaluated other = False
+\end{code}
-extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
-extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
- = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
- where
- new_ty_env = addOneToTyVarEnv ty_env tyvar ty
-extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
-extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
- = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
- where
- new_ty_env = growTyVarEnvList ty_env pairs
-simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
+\begin{code}
+mkSimplUnfoldingGuidance chkr out_id rhs
+ = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
+extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
+extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ out_id occ_info rhs_info
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
+ where
+ new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id
+ (out_id, occ_info, rhs_info)
\end{code}
-@replaceInEnvs@ is used to install saved type and id envs
-when pulling an un-simplified expression out of the environment, which
-was saved with its environments.
\begin{code}
-nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
-
-replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
+modifyOccInfo in_scope_ids uniq new_occ
+ = modifyIdEnv_Directly modify_fn in_scope_ids uniq
+ where
+ modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
-replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (new_ty_env, new_id_env)
- = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
+markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
+ where
+ new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
+ modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
\end{code}
+
%************************************************************************
%* *
-\subsubsection{The ``Id env'' part}
+\subsubsection{The @ConAppMap@ type}
%* *
%************************************************************************
-\begin{code}
-extendIdEnvWithAtom
- :: SimplEnv
- -> InBinder -> OutArg
- -> SimplEnv
+The @ConAppMap@ maps applications of constructors (to value atoms)
+back to an association list that says "if the constructor was applied
+to one of these lists-of-Types, then this OutId is your man (in a
+non-gender-specific sense)". I.e., this is a reversed mapping for
+(part of) the main OutIdEnv
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
+\begin{code}
+type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id, occ_info) atom@(VarArg out_id)
- = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-
- new_unfold_env = modify_unfold_env
- unfold_env
- (modifyItem ok_to_dup occ_info)
- out_id
- -- Modify binding for in_id
- -- NO! modify out_id, because its the info on the
- -- atom that interest's us.
-
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
-
-extendIdEnvWithAtomList
- :: SimplEnv
- -> [(InBinder, OutArg)]
- -> SimplEnv
-extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-
-extendIdEnvWithInlining
- :: SimplEnv -- The Env to modify
- -> SimplEnv -- The Env to record in the inlining. Usually the
- -- same as the previous one, except in the recursive case
- -> InBinder -> InExpr
- -> SimplEnv
-
-extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
- (in_id,occ_info)
- expr
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
- where
- new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
+data UnfoldConApp
+ = UCA OutId -- data constructor
+ [OutArg] -- *value* arguments; see use below
+\end{code}
-extendIdEnvWithClone
- :: SimplEnv
- -> InBinder -- Old binder; binderinfo ignored
- -> OutId -- Its new clone, as an Id
- -> SimplEnv
+\begin{code}
+nullConApps = emptyFM
-extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id,_) out_id
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+extendConApps con_apps id (Con con args)
+ = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
-extendIdEnvWithClones -- Like extendIdEnvWithClone
- :: SimplEnv
- -> [InBinder]
- -> [OutId]
- -> SimplEnv
+extendConApps con_apps id other_rhs = con_apps
+\end{code}
-extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- in_binders out_ids
- = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
+\begin{code}
+lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args)
+ | switchIsSet env SimplReuseCon
+ = case lookupFM con_apps (UCA con val_args) of
+ Nothing -> Nothing
+
+ Just assocs -> case [id | (tys, id) <- assocs,
+ and (zipWith (==) tys ty_args)]
+ of
+ [] -> Nothing
+ (id:_) -> Just id
where
- new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
- in_ids = [id | (id,_) <- in_binders]
- out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
-
-lookupId :: SimplEnv -> Id -> Maybe IdVal
-
-lookupId (SimplEnv _ _ _ id_env _) id
-#ifndef DEBUG
- = lookupIdEnv id_env id
-#else
- = case (lookupIdEnv id_env id) of
- xxx@(Just _) -> xxx
- xxx -> --false!: ASSERT(not (isLocallyDefined id))
- xxx
-#endif
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+lookForConstructor env other = Nothing
\end{code}
-%************************************************************************
-%* *
-\subsubsection{The @UnfoldEnv@}
-%* *
-%************************************************************************
+NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
+for nullary constructors, but now we only do constructor re-use in
+let-bindings the special case isn't necessary any more.
+
+\begin{verbatim}
+ = -- Don't re-use nullary constructors; it's a waste. Consider
+ -- let
+ -- a = leInt#! p q
+ -- in
+ -- case a of
+ -- True -> ...
+ -- False -> False
+ --
+ -- Here the False in the second case will get replace by "a", hardly
+ -- a good idea
+ Nothing
+\end{verbatim}
+
+
+The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
+it, so we can use it for a @FiniteMap@ key.
\begin{code}
-extendUnfoldEnvGivenFormDetails
- :: SimplEnv
- -> OutId
- -> UnfoldingDetails
- -> SimplEnv
-
-extendUnfoldEnvGivenFormDetails
- env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- id details
- = case details of
- NoUnfoldingDetails -> env
- good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
- where
- new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
-
-extendUnfoldEnvGivenConstructor -- specialised variant
- :: SimplEnv
- -> OutId -- bind this to...
- -> Id -> [OutId] -- "con <tys-to-be-invented> args"
- -> SimplEnv
-
-extendUnfoldEnvGivenConstructor env var con args
- = let
- -- conjure up the types to which the con should be applied
- scrut_ty = idType var
- (_, ty_args, _) = getAppDataTyCon scrut_ty
- in
- extendUnfoldEnvGivenFormDetails
- env var (ConForm con (map VarArg args))
+instance Eq UnfoldConApp where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord UnfoldConApp where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmp_app a b
+
+cmp_app (UCA c1 as1) (UCA c2 as2)
+ = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
+ where
+ -- ToDo: make an "instance Ord CoreArg"???
+
+ cmp_arg (VarArg x) (VarArg y) = x `compare` y
+ cmp_arg (LitArg x) (LitArg y) = x `compare` y
+ cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs"
+ cmp_arg x y
+ | tag x _LT_ tag y = LT
+ | otherwise = GT
+ where
+ tag (VarArg _) = ILIT(1)
+ tag (LitArg _) = ILIT(2)
+ tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
\end{code}
inside a lambda.
\begin{code}
-extendUnfoldEnvGivenRhs
- :: SimplEnv
- -> InBinder
- -> OutId -- Note: *must* be an "out" Id (post-cloning)
- -> OutExpr -- Its rhs (*simplified*)
- -> SimplEnv
-
-extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- binder@(_,occ_info) out_id rhs
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
+extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenNewRhs env out_id rhs
+ = extendEnvGivenBinding env noBinderInfo out_id rhs
+
+extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ occ_info out_id rhs
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
where
+ new_in_scope_ids | okToInline (whnfOrBottom form)
+ (couldBeSmallEnoughToInline out_id guidance)
+ occ_info
+ = env_with_unfolding
+ | otherwise
+ = in_scope_ids
+ -- Don't bother to munge the OutIdEnv unless there is some possibility
+ -- that the thing might be inlined. We check this by calling okToInline suitably.
+
+ new_con_apps = _scc_ "eegnr.conapps"
+ extendConApps con_apps out_id rhs
+
+ -- Modify the occ info for rhs's interesting free variables.
+ -- That's to take account of:
+ -- let a = \x -> BIG in
+ -- let b = \f -> f a
+ -- in ...b...b...b...
+ -- Here "a" occurs exactly once. "b" simplifies to a small value.
+ -- So "b" will be inlined at each call site, and there's a good chance
+ -- that "a" will too. So we'd better modify "a"s occurrence info to
+ -- record the fact that it can now occur many times by virtue that "b" can.
+ env_with_unfolding = _scc_ "eegnr.modify_occ"
+ foldl zap env1 (ufmToList fv_occ_info)
+ zap env (uniq,_) = modifyOccInfo env uniq occ_info
+
+
+ -- Add an unfolding and rhs_info for the new Id.
+ -- If the out_id is already in the OutIdEnv (which should be the
+ -- case because it was put there by simplBinder)
+ -- then just replace the unfolding, leaving occurrence info alone.
+ env1 = _scc_ "eegnr.modify_out"
+ addToUFM_C modifyOutEnvItem in_scope_ids out_id
+ (out_id, occ_info, rhs_info)
+
-- Occurrence-analyse the RHS
- (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
+ -- The "interesting" free variables we want occurrence info for are those
+ -- in the OutIdEnv that have only a single occurrence right now.
+ (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
+ occurAnalyseExpr is_interesting rhs_w_cc
- interesting_fvs = get_interesting_ids unfold_env
+ is_interesting v = _scc_ "eegnr.mkidset"
+ case lookupIdEnv in_scope_ids v of
+ Just (_, occ, _) -> isOneOcc occ
+ other -> False
-- Compute unfolding details
- details = case rhs of
- Var v -> panic "Vars already dealt with"
- Lit lit | isNoRepLit lit -> LitForm lit
- | otherwise -> panic "non-noRep Lits already dealt with"
-
- Con con args -> ConForm con args
-
- other -> mkGenForm ok_to_dup occ_info
- (mkFormSummary (getIdStrictness out_id) rhs)
- template guidance
-
- -- Compute resulting unfold env
- new_unfold_env = case details of
- NoUnfoldingDetails -> unfold_env
- GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
- other -> unfold_env1
-
- -- Add unfolding to unfold env
- unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
-
- -- Modify unfoldings of free vars of rhs, based on their
- -- occurrence info in the rhs [see notes above]
- unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
-
- modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
- modify (u, occ_info) env
- = case (lookupDirectlyUFM env u) of
- Nothing -> env -- ToDo: can this happen?
- Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
-
- -- Compute unfolding guidance
- guidance = if simplIdWantsToBeINLINEd out_id env
- then UnfoldAlways
- else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
-
- bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
- Nothing -> uNFOLDING_CREATION_THRESHOLD
- Just xx -> xx
-
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
- || exprSmallEnoughToDup rhs
- -- [Andy] added, Jun 95
-
-{- Reinstated AJG Jun 95; This is needed
- --example that does not (currently) work
- --without this extention
-
- --let f = g x
- --in
- -- case <exp> of
- -- True -> h i f
- -- False -> f
- -- ==>
- -- case <exp> of
- -- True -> h i f
- -- False -> g x
--}
-{- OLD:
- Omitted SLPJ Feb 95; should, I claim, be unnecessary
- -- is_really_small looks for things like f a b c
- -- but making sure there are not *too* many arguments.
- -- (This is brought to you by *ANDY* Magic Constants, Inc.)
- is_really_small
- = case collectArgs new_rhs of
- (Var _, xs) -> length xs < 10
- _ -> False
--}
-\end{code}
-
-\begin{code}
-lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
-
-lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
- | not (isLocallyDefined var) -- Imported, so look inside the id
- = getIdUnfolding var
-
- | otherwise -- Locally defined, so look in the envt.
- -- There'll be nothing inside the Id.
- = lookup_unfold_env unfold_env var
-\end{code}
-
-We need to remove any @GenForm@ bindings from the UnfoldEnv for
-the RHS of an Id which has an INLINE pragma.
-
-\begin{code}
-filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
-
-filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
- where
- new_unfold_env = null_unfold_env
- -- This version is really simple. INLINEd things are going to
- -- be inlined wherever they are used, and then all the
- -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
- -- much point in doing anything to the as-yet-un-INLINEd rhs.
-
- -- Andy disagrees! Example:
- -- all xs = foldr (&&) True xs
- -- any p = all . map p {-# INLINE any #-}
- --
- -- Problem: any won't get deforested, and so if it's exported and
- -- the importer doesn't use the inlining, (eg passes it as an arg)
- -- then we won't get deforestation at all.
- --
- -- So he'd like not to filter the unfold env at all. But that's a disaster:
- -- Suppose we have:
- --
- -- let f = \pq -> BIG
- -- in
- -- let g = \y -> f y y
- -- {-# INLINE g #-}
- -- in ...g...g...g...g...g...
- --
- -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- -- and thence copied multiple times when g is inlined.
-\end{code}
-
-======================
-
-In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors:
-
-\begin{verbatim}
- = -- Don't re-use nullary constructors; it's a waste. Consider
- -- let
- -- a = leInt#! p q
- -- in
- -- case a of
- -- True -> ...
- -- False -> False
- --
- -- Here the False in the second case will get replace by "a", hardly
- -- a good idea
- Nothing
-\end{verbatim}
-
-but now we only do constructor re-use in let-bindings the special
-case isn't necessary any more.
-
-\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
- = lookup_conapp unfold_env con args
+ rhs_info = CoreUnfolding form guidance template
+ form = _scc_ "eegnr.form_sum"
+ mkFormSummary rhs
+ guidance = _scc_ "eegnr.guidance"
+ mkSimplUnfoldingGuidance chkr out_id rhs
+
+ -- Attach a cost centre to the RHS if necessary
+ rhs_w_cc | currentOrSubsumedCosts encl_cc
+ || not (noCostCentreAttached (coreExprCc rhs))
+ = rhs
+ | otherwise
+ = SCC encl_cc rhs
\end{code}