X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=5049a9fdc933ad78a9a203224537ec5a066b8e27;hb=fc9bacdece12574a9ba9d2de2a74783da19f2ac4;hp=31e6eff1758895040bd383fd8d62035e9d2882f5;hpb=aa4f16def50ad9cbe5fff935a5cb91156150f5f1;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 31e6eff..5049a9f 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -1,76 +1,67 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % -\section[SimplEnv]{Environment stuff for the simplifier} +\section[SimplMonad]{The simplifier Monad} \begin{code} module SimplEnv ( - nullSimplEnv, - getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, + InId, InBind, InExpr, InAlt, InArg, InType, InBinder, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - bindTyVar, bindTyVars, simplTy, + -- The simplifier mode + setMode, getMode, - lookupIdSubst, lookupOutIdEnv, - - bindIdToAtom, bindIdToExpr, - - markDangerousOccs, - lookupRhsInfo, isEvaluated, - extendEnvGivenBinding, extendEnvGivenNewRhs, - extendEnvGivenRhsInfo, - - lookForConstructor, - - getSwitchChecker, switchIsSet, getSimplIntSwitch, - switchOffInlining, setCaseScrutinee, + -- Switch checker + SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn, setEnclosingCC, getEnclosingCC, - -- Types - SwitchChecker, - SimplEnv, - UnfoldConApp, - RhsInfo(..), + -- Environments + SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, + getRules, refineSimplEnv, + + SimplSR(..), mkContEx, substId, - InId, InBinder, InBinding, InType, - OutId, OutBinder, OutBinding, OutType, + simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs, + simplBinder, simplBinders, + simplIdInfo, substExpr, substTy, - InExpr, InAlts, InDefault, InArg, - OutExpr, OutAlts, OutDefault, OutArg + -- Floats + FloatsWith, FloatsWithExpr, + Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, + allLifted, wrapFloats, floatBinds, + addAuxiliaryBind, ) where #include "HsVersions.h" -import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, - okToInline, isOneFunOcc, - BinderInfo - ) -import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, - SimplifierSwitch(..), SwitchResult(..) - ) +import SimplMonad +import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) +import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, + arityInfo, setArityInfo, workerInfo, setWorkerInfo, + unfoldingInfo, setUnfoldingInfo, + unknownArity, workerExists + ) import CoreSyn -import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, - Unfolding(..), SimpleUnfolding(..), FormSummary(..), - calcUnfoldingGuidance ) -import CoreUtils ( coreExprCc ) -import CostCentre ( CostCentre, subsumedCosts, costsAreSubsumed, noCostCentreAttached ) -import FiniteMap -- lots of things -import Id ( getInlinePragma, - nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, - addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly, - IdEnv, IdSet, Id ) -import Literal ( Literal{-instances-} ) -import Maybes ( expectJust ) -import OccurAnal ( occurAnalyseExpr ) -import PprCore -- various instances -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 Unify ( TypeRefinement ) +import Rules ( RuleBase ) +import CoreUtils ( needsCaseBinding ) +import CostCentre ( CostCentreStack, subsumedCCS ) +import Var +import VarEnv +import VarSet ( isEmptyVarSet, elemVarSetByKey, mkVarSet ) +import OrdList + +import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker ) +import qualified Type ( substTy, substTyVarBndr ) + +import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, + isUnLiftedType, seqType, tyVarsOfType ) +import BasicTypes ( OccInfo(..), isFragileOcc ) +import CmdLineOpts ( SimplifierMode(..) ) import Outputable \end{code} @@ -81,25 +72,22 @@ import Outputable %************************************************************************ \begin{code} +type InBinder = CoreBndr 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 InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type OutBinder = CoreBndr type OutId = Id -- Cloned -type OutBinder = Id +type OutTyVar = TyVar -- Cloned type OutType = Type -- Cloned -type OutBinding = CoreBinding +type OutBind = CoreBind type OutExpr = CoreExpr -type OutAlts = CoreCaseAlts -type OutDefault = CoreCaseDefault +type OutAlt = CoreAlt type OutArg = CoreArg - -type SwitchChecker = SimplifierSwitch -> SwitchResult \end{code} %************************************************************************ @@ -109,544 +97,584 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult %************************************************************************ -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. +\begin{code} +data SimplEnv + = SimplEnv { + seMode :: SimplifierMode, + seChkr :: SwitchChecker, + seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + + -- Rules from other modules + seExtRules :: RuleBase, + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + seInScope :: InScopeSet, -- OutVars only + + -- The current substitution + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seIdSubst :: SimplIdSubst -- InId |--> OutExpr + } + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + +data SimplSR + = DoneEx OutExpr -- Completed term + | DoneId OutId OccInfo -- Completed term variable, with occurrence info + | ContEx TvSubstEnv -- A suspended substitution + SimplIdSubst + InExpr +\end{code} -The environment contains bindings for all - {\em in-scope,} - {\em locally-defined} -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 -(otherwise we get trouble because we have to simplify the unfoldings -inside the Ids, etc.). +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences -\begin{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 - = SubstArg OutArg -- The Id maps to an already-substituted atom - | 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 + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. - BinderInfo, -- How it occurs - -- We keep this info so we can modify it when - -- something changes. + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind - RhsInfo) -- Info about what it is bound to -\end{code} +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Indeed, we do so when we want to pass fragile OccInfo to the + occurrences of the variable; we add a substitution + x77 -> DoneId x77 occ + to record x's occurrence information.] + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id occ) to the substitution if + EITHER the Id's unique has changed + OR the Id has interesting occurrence information + So in effect you can only get to interesting occurrence information + by looking up the *old* Id; it's not really attached to the new id + at all. + + Note, though that the substitution isn't necessarily extended + if the type changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get mapped + to the full-adorned binder, which is also the one put in the binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synomyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var + + +Note [GADT type refinement] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to a GADT pattern match that refines the in-scope types, we + a) Refine the types of the Ids in the in-scope set, seInScope. + For exmaple, consider + data T a where + Foo :: T (Bool -> Bool) + + (\ (x::T a) (y::a) -> case x of { Foo -> y True } + + Technically this is well-typed, but exprType will barf on the + (y True) unless we refine the type on y's occurrence. + + b) Refine the range of the type substitution, seTvSubst. + Very similar reason to (a). + + NB: we don't refine the range of the SimplIdSubst, because it's always + interpreted relative to the seInScope (see substId) + +For (b) we need to be a little careful. Specifically, we compose the refinement +with the type substitution. Suppose + The substitution was [a->b, b->a] + and the refinement was [b->Int] + Then we want [a->Int, b->a] + +But also if + The substitution was [a->b] + and the refinement was [b->Int] + Then we want [a->Int, b->Int] + becuase b might be both an InTyVar and OutTyVar -The @RhsInfo@ part tells about the value to which the @OutId@ is bound. \begin{code} -data RhsInfo = NoRhsInfo - | OtherLit [Literal] -- It ain't one of these - | OtherCon [Id] -- It ain't one of these - | OutUnfolding CostCentre - SimpleUnfolding -- Already-simplified unfolding -\end{code} +mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv +mkSimplEnv mode switches rules + = SimplEnv { seChkr = switches, seCC = subsumedCCS, + seMode = mode, seInScope = emptyInScopeSet, + seExtRules = rules, + seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } + -- The top level "enclosing CC" is "SUBSUMED". + +--------------------- +getSwitchChecker :: SimplEnv -> SwitchChecker +getSwitchChecker env = seChkr env +--------------------- +getMode :: SimplEnv -> SimplifierMode +getMode env = seMode env -\begin{code} -nullSimplEnv :: SwitchChecker -> SimplEnv +setMode :: SimplifierMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } -nullSimplEnv sw_chkr - = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullConApps +--------------------- +getEnclosingCC :: SimplEnv -> CostCentreStack +getEnclosingCC env = seCC env -getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv) -getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env) +setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv +setEnclosingCC env cc = env {seCC = cc} -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 +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = env {seIdSubst = extendVarEnv subst var res} -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 +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res + = env {seTvSubst = extendVarEnv subst var res} -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 -\end{code} +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ +setInScope :: SimplEnv -> SimplEnv -> SimplEnv +setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) -\begin{code} -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs + = env { seInScope = in_scope `extendInScopeSetList` vs, + seIdSubst = id_subst `delVarEnvList` vs } -- Why delete? -switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _) switch - = switchIsOn chkr switch +modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv +modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' + = env {seInScope = modifyInScopeSet in_scope v v'} -getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int -getSimplIntSwitch chkr switch - = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} - -- 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 - chkr' SimplCaseScrutinee = SwBool True - chkr' other = chkr other -\end{code} +setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } -@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! +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e -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. +isEmptySimplSubst :: SimplEnv -> Bool +isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) + = isEmptyVarEnv tvs && isEmptyVarEnv ids -\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 - forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoRhsInfo) +--------------------- +getRules :: SimplEnv -> RuleBase +getRules = seExtRules \end{code} + GADT stuff -%************************************************************************ -%* * -\subsubsection{The ``enclosing cost-centre''} -%* * -%************************************************************************ +Given an idempotent substitution, generated by the unifier, use it to +refine the environment \begin{code} -setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv - -setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc - | costsAreSubsumed encl_cc - = env - | otherwise - = 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 +refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv +-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes +refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope }) + (refine_tv_subst, all_bound_here) + = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst, + seInScope = in_scope' } + where + in_scope' + | all_bound_here = in_scope + -- The tvs are the tyvars bound here. If only they + -- are refined, there's no need to do anything + | otherwise = mapInScopeSet refine_id in_scope + + refine_id v -- Only refine its type; any rules will get + -- refined if they are used (I hope) + | isId v = setIdType v (Type.substTy refine_subst (idType v)) + | otherwise = v + refine_subst = TvSubst in_scope refine_tv_subst \end{code} %************************************************************************ %* * -\subsubsection{The @TypeEnv@ part} + Substitution of Vars %* * %************************************************************************ -These two "bind" functions extend the tyvar substitution. -They don't affect what tyvars are in scope. \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 +substId :: SimplEnv -> Id -> SimplSR +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + | not (isLocalId v) + = DoneId v NoOccInfo + | otherwise -- A local Id + = case lookupVarEnv ids v of + Just (DoneId v occ) -> DoneId (refine v) occ + Just res -> res + Nothing -> let v' = refine v + in DoneId v' (idOccInfo v') + -- We don't put LoopBreakers in the substitution (unless then need + -- to be cloned for name-clash rasons), so the idOccInfo is + -- very important! If isFragileOcc returned True for + -- loop breakers we could avoid this call, but at the expense + -- of adding more to the substitution, and building new Ids + -- a bit more often than really necessary 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 + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with a different type (we only use the + -- substitution if the unique changes). + refine v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! \end{code} -\begin{code} -simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty) -\end{code} %************************************************************************ %* * -\subsubsection{The ``Id env'' part} +\section{Substituting an Id binder} %* * %************************************************************************ -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. + +These functions are in the monad only so that they can be made strict via seq. \begin{code} -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 +simplBinders, simplLamBndrs, simplLetBndrs + :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) +simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs +simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs +simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs + +------------- +simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr env bndr + ; seqId id `seq` return (env', id) } + +------------- +simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) +simplLetBndr env id = do { let (env', id') = substLetId env id + ; seqId id' `seq` return (env', id') } + +------------- +simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) +-- Used for lambda binders. These sometimes have unfoldings added by +-- the worker/wrapper pass that must be preserved, becuase they can't +-- be reconstructed from context. For example: +-- f x = case x of (a,b) -> fw a b x +-- fw a b x{=(a,b)} = ... +-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. +simplLamBndr env bndr + | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case + | otherwise = seqId id2 `seq` return (env', id2) where - new_in_scope_ids = delOneFromIdEnv in_scope_ids id + old_unf = idUnfolding bndr + (env', id1) = substIdBndr env bndr + id2 = id1 `setIdUnfolding` substUnfolding env old_unf + +------------- +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () \end{code} -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 (in_scope_ids', id_subst') con_apps +substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform + -> (SimplEnv, Id) -- Transformed pair + +-- Returns with: +-- * Unique changed if necessary +-- * Type substituted +-- * Unfolding zapped +-- * Rules, worker, lbvar info all substituted +-- * Fragile occurrence info zapped +-- * The in-scope set extended with the returned Id +-- * The substitution extended with a DoneId if unique changed +-- In this case, the var in the DoneId is the same as the +-- var returned + +substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) + old_id + = (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) where - id_subst' = addOneToIdEnv id_subst in_id (SubstArg atom) - in_scope_ids' = case atom of - LitArg _ -> in_scope_ids - VarArg out_id -> modifyOccInfo in_scope_ids (uniqueOf out_id) occ_info - -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 + -- id1 is cloned if necessary + id1 = uniqAway in_scope old_id + + -- id2 has its type zapped + id2 = substIdType env id1 + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_env, when dealing with a mutually-recursive group + new_id = maybeModifyIdInfo (substIdInfo env) id2 + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delSubstEnv + new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id)) + | otherwise + = delVarEnv id_subst old_id + +substLetId :: SimplEnv -> Id -> (SimplEnv, Id) +-- A variant for let-bound Ids +-- Clone Id if necessary +-- Substitute its type +-- Return an Id with completely zapped IdInfo +-- [A subsequent substIdInfo will restore its IdInfo] +-- Augment the subtitution +-- if the unique changed, *or* +-- if there's interesting occurrence info + +substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id + = (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) where - id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr) + old_info = idInfo old_id + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + new_id = setIdInfo id2 vanillaIdInfo + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + occ_info = occInfo old_info + new_subst | new_id /= old_id || isFragileOcc occ_info + = extendVarEnv id_subst old_id (DoneId new_id occ_info) + | otherwise + = delVarEnv id_subst old_id \end{code} %************************************************************************ %* * -\subsubsection{The @OutIdEnv@} + Impedence matching to type substitution %* * %************************************************************************ \begin{code} -lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo -lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id - -lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo) -lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id - -lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo -lookupRhsInfo env id - = case lookupOutIdEnv env id of - Just (_,_,info) -> info - Nothing -> NoRhsInfo - -modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) -modifyOutEnvItem (id, occ, info1) (_, _, info2) - = case (info1, info2) of - (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2)) - (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2)) - (_, NoRhsInfo) -> (id,occ, info1) - other -> (id,occ, info2) -\end{code} +substTy :: SimplEnv -> Type -> Type +substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty + = Type.substTy (TvSubst in_scope tv_env) ty + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv + = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') + +-- When substituting in rules etc we can get CoreSubst to do the work +-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match +-- here. I think the this will not usually result in a lot of work; +-- the substitutions are typically small, and laziness will avoid work in many cases. + +mkCoreSubst :: SimplEnv -> CoreSubst.Subst +mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) + = mk_subst tv_env id_env + where + mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) + fiddle (DoneEx e) = e + fiddle (DoneId v occ) = Var v + fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e -\begin{code} -isEvaluated :: RhsInfo -> Bool -isEvaluated (OtherLit _) = True -isEvaluated (OtherCon _) = True -isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True -isEvaluated other = False +substExpr :: SimplEnv -> CoreExpr -> CoreExpr +substExpr env expr + | isEmptySimplSubst env = expr + | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr \end{code} +%************************************************************************ +%* * +\section{IdInfo substitution} +%* * +%************************************************************************ \begin{code} -mkSimplUnfoldingGuidance chkr out_id rhs - = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs - -extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv -extendEnvGivenRhsInfo 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 +simplIdInfo :: SimplEnv -> IdInfo -> IdInfo + -- Used by the simplifier to compute new IdInfo for a let(rec) binder, + -- subsequent to simplLetId having zapped its IdInfo +simplIdInfo env old_info + = case substIdInfo env old_info of + Just new_info -> new_info + Nothing -> old_info + +substIdInfo :: SimplEnv + -> IdInfo + -> Maybe IdInfo +-- Substitute the +-- rules +-- worker info +-- Zap the unfolding +-- Keep only 'robust' OccInfo +-- Zap Arity +-- +-- Seq'ing on the returned IdInfo is enough to cause all the +-- substitutions to happen completely + +substIdInfo env info + | nothing_to_do = Nothing + | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) + `setArityInfo` (if keep_arity then old_arity else unknownArity) + `setSpecInfo` CoreSubst.substRules subst old_rules + `setWorkerInfo` CoreSubst.substWorker subst old_wrkr + `setUnfoldingInfo` noUnfolding) + -- setSpecInfo does a seq + -- setWorkerInfo does a seq where - new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id - (out_id, occ_info, rhs_info) -\end{code} - - -\begin{code} -modifyOccInfo in_scope_ids uniq new_occ - = modifyIdEnv_Directly modify_fn in_scope_ids uniq + subst = mkCoreSubst env + nothing_to_do = keep_occ && keep_arity && + isEmptyCoreRules old_rules && + not (workerExists old_wrkr) && + not (hasUnfolding (unfoldingInfo info)) + + keep_occ = not (isFragileOcc old_occ) + keep_arity = old_arity == unknownArity + old_arity = arityInfo info + old_occ = occInfo info + old_rules = specInfo info + old_wrkr = workerInfo info + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + -- The tyVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself where - modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs) + old_ty = idType id -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) +------------------ +substUnfolding env NoUnfolding = NoUnfolding +substUnfolding env (OtherCon cons) = OtherCon cons +substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) +substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g \end{code} %************************************************************************ %* * -\subsubsection{The @ConAppMap@ type} +\subsection{Floats} %* * %************************************************************************ -The @ConAppMap@ maps applications of constructors (to value atoms) -back to an association list that says "if the constructor was applied -to one of these lists-of-Types, then this OutId is your man (in a -non-gender-specific sense)". I.e., this is a reversed mapping for -(part of) the main OutIdEnv - \begin{code} -type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)] +type FloatsWithExpr = FloatsWith OutExpr +type FloatsWith a = (Floats, a) + -- We return something equivalent to (let b in e), but + -- in pieces to avoid the quadratic blowup when floating + -- incrementally. Comments just before simplExprB in Simplify.lhs -data UnfoldConApp - = UCA OutId -- data constructor - [OutArg] -- *value* arguments; see use below -\end{code} +data Floats = Floats (OrdList OutBind) + InScopeSet -- Environment "inside" all the floats + Bool -- True <=> All bindings are lifted -\begin{code} -nullConApps = emptyFM +allLifted :: Floats -> Bool +allLifted (Floats _ _ is_lifted) = is_lifted -extendConApps con_apps id (Con con args) - = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)] - where - val_args = filter isValArg args -- Literals and Ids - ty_args = [ty | TyArg ty <- args] -- Just types +wrapFloats :: Floats -> OutExpr -> OutExpr +wrapFloats (Floats bs _ _) body = foldrOL Let body bs -extendConApps con_apps id other_rhs = con_apps -\end{code} +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats bs _ _) = isNilOL bs -\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 - val_args = filter isValArg args -- Literals and Ids - ty_args = [ty | TyArg ty <- args] -- Just types +floatBinds :: Floats -> [OutBind] +floatBinds (Floats bs _ _) = fromOL bs -lookForConstructor env other = Nothing +flattenFloats :: Floats -> Floats +-- Flattens into a single Rec group +flattenFloats (Floats bs is is_lifted) + = ASSERT2( is_lifted, ppr (fromOL bs) ) + Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted \end{code} -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} -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" +emptyFloats :: SimplEnv -> Floats +emptyFloats env = Floats nilOL (getInScope env) True + +unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats +-- A single non-rec float; extend the in-scope set +unitFloat env var rhs = Floats (unitOL (NonRec var rhs)) + (extendInScopeSet (getInScope env) var) + (not (isUnLiftedType (idType var))) + +addFloats :: SimplEnv -> Floats + -> (SimplEnv -> SimplM (FloatsWith a)) + -> SimplM (FloatsWith a) +addFloats env (Floats b1 is1 l1) thing_inside + | isNilOL b1 + = thing_inside env + | otherwise + = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) -> + returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res) + +addLetBind :: OutBind -> Floats -> Floats +addLetBind bind (Floats binds in_scope lifted) + = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind) + +is_lifted_bind (Rec _) = True +is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b)) + +-- addAuxiliaryBind * takes already-simplified things (bndr and rhs) +-- * extends the in-scope env +-- * assumes it's a let-bindable thing +addAuxiliaryBind :: SimplEnv -> OutBind + -> (SimplEnv -> SimplM (FloatsWith a)) + -> SimplM (FloatsWith a) + -- Extends the in-scope environment as well as wrapping the bindings +addAuxiliaryBind env bind thing_inside + = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } ) + thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) -> + returnSmpl (addLetBind bind floats, x) \end{code} -@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS -of a new binding. There is a horrid case we have to take care about, -due to Andr\'e Santos: -@ - type Array_type b = Array Int b; - type Descr_type = (Int,Int); - - tabulate :: (Int -> x) -> Descr_type -> Array_type x; - tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; - - f_iaamain a_xs= - let { - f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; - f_aareorder a_index a_ar= - let { - f_aareorder' a_i= a_ar ! (a_index ! a_i) - } in tabulate f_aareorder' (bounds a_ar); - r_index=tabulate ((+) 1) (1,1); - arr = listArray (1,1) a_xs; - arg = f_aareorder r_index arr - } in elems arg -@ -Now, when the RHS of arg gets simplified, we inline f_aareorder to get -@ - arg = let f_aareorder' a_i = arr ! (r_index ! a_i) - in tabulate f_aareorder' (bounds arr) -@ -Note that r_index is not inlined, because it was bound to a_index which -occurs inside a lambda. - -Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...), -then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence -analyse it, we won't spot the inside-lambda property of r_index, so r_index -will get inlined inside the lambda. AARGH. - -Solution: when we occurrence-analyse the new RHS we have to go back -and modify the info recorded in the UnfoldEnv for the free vars -of the RHS. In the example we'd go back and record that r_index is now used -inside a lambda. - -\begin{code} -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 - -- 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 - - is_interesting v = _scc_ "eegnr.mkidset" - case lookupIdEnv in_scope_ids v of - Just (_, occ, _) -> isOneOcc occ - other -> False - - -- Compute unfolding details - rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template) - form = _scc_ "eegnr.form_sum" - mkFormSummary rhs - guidance = _scc_ "eegnr.guidance" - mkSimplUnfoldingGuidance chkr out_id rhs - - -- Compute cost centre for thing - unf_cc | noCostCentreAttached expr_cc = encl_cc - | otherwise = expr_cc - where - expr_cc = coreExprCc rhs -\end{code}