X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=00f035e51392f62acb750fb5f436fac1272551d1;hb=931a117d6236076788c560fb2e08c538be95bd45;hp=6656d566bbf3b089ec34e7468f78c40edc30d2f5;hpb=6cd71a70ff1abdcfd36130a420405de575f0594d;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 6656d56..00f035e 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -1,93 +1,69 @@ % -% (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} -#include "HsVersions.h" - module SimplEnv ( - nullSimplEnv, combineSimplEnv, - pprSimplEnv, -- debugging only - - extendTyEnv, extendTyEnvList, - simplTy, simplTyInId, - - extendIdEnvWithAtom, extendIdEnvWithAtoms, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, - + InId, InBind, InExpr, InAlt, InArg, InType, InBinder, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - markDangerousOccs, - lookupRhsInfo, lookupOutIdEnv, isEvaluated, - extendEnvGivenBinding, extendEnvGivenNewRhs, - extendEnvGivenRhsInfo, + -- The simplifier mode + setMode, getMode, - lookForConstructor, - - getSwitchChecker, switchIsSet, getSimplIntSwitch, - switchOffInlining, setCaseScrutinee, + -- Switch checker + SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn, setEnclosingCC, getEnclosingCC, - -- Types - SYN_IE(SwitchChecker), - SimplEnv, - SYN_IE(InIdEnv), SYN_IE(InTypeEnv), - UnfoldConApp, - RhsInfo(..), + -- Environments + SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, + getRules, refineSimplEnv, - SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), - SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), + SimplSR(..), mkContEx, substId, - 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 + simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, + simplBinder, simplBinders, addLetIdInfo, + substExpr, substTy, -IMP_Ubiq(){-uitous-} + -- Floats + FloatsWith, FloatsWithExpr, + Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, + allLifted, wrapFloats, floatBinds, + addAuxiliaryBind, + ) where -IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop +#include "HsVersions.h" -import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, - BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC - ) -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, isEmptySpecInfo, + unknownArity, workerExists + ) import CoreSyn -import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, - Unfolding(..), UfExpr, RdrName, - SimpleUnfolding(..), FormSummary(..), - calcUnfoldingGuidance, UnfoldingGuidance(..) - ) -import CoreUtils ( coreExprCc, unTagBinders ) -import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached ) -import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, - applyTypeEnvToId, getInlinePragma, - nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly, - SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) ) -import Literal ( isNoRepLit, Literal{-instances-} ) -import Maybes ( maybeToBool, expectJust ) -import Name ( isLocallyDefined ) -import OccurAnal ( occurAnalyseExpr ) -import Outputable ( PprStyle(..), Outputable(..){-instances-} ) -import PprCore -- various instances -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, - SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} , - SYN_IE(TyVar) - ) -import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_C, ufmToList, Uniquable(..) - ) -import Usage ( SYN_IE(UVar), GenUsage{-instances-} ) -import Util ( SYN_IE(Eager), appEager, returnEager, runEager, - zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) ) - +import Unify ( TypeRefinement ) +import Rules ( RuleBase ) +import CoreUtils ( needsCaseBinding ) +import CostCentre ( CostCentreStack, subsumedCCS ) +import Var +import VarEnv +import VarSet ( isEmptyVarSet ) +import OrdList + +import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) +import qualified Type ( substTy, substTyVarBndr ) + +import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, + isUnLiftedType, seqType, tyVarsOfType ) +import BasicTypes ( OccInfo(..), isFragileOcc ) +import DynFlags ( SimplifierMode(..) ) +import Util ( mapAccumL ) +import Outputable \end{code} %************************************************************************ @@ -97,25 +73,22 @@ import Util ( SYN_IE(Eager), appEager, returnEager, runEager, %************************************************************************ \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} %************************************************************************ @@ -125,660 +98,644 @@ 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. - -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.). - \begin{code} 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 - + = 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} -nullSimplEnv :: SwitchChecker -> SimplEnv -nullSimplEnv sw_chkr - = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps +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 -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 + 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. -pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" -\end{code} + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind +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 -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ \begin{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 (SimplEnv chkr _ _ _ _ _) = chkr - -switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _ _) switch - = switchIsOn chkr switch +getSwitchChecker env = seChkr env -getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int -getSimplIntSwitch chkr switch - = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) +--------------------- +getMode :: SimplEnv -> SimplifierMode +getMode env = seMode env - -- Crude, but simple -setCaseScrutinee :: SimplEnv -> SimplEnv -setCaseScrutinee (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' SimplCaseScrutinee = SwBool True - chkr' other = chkr other -\end{code} +setMode :: SimplifierMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } -@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! +--------------------- +getEnclosingCC :: SimplEnv -> CostCentreStack +getEnclosingCC env = seCC env -We prepare the envt by simply discarding the out_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. +setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv +setEnclosingCC env cc = env {seCC = cc} -\begin{code} -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 nullIdEnv nullConApps -\end{code} +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = env {seIdSubst = extendVarEnv subst var res} -%************************************************************************ -%* * -\subsubsection{The ``enclosing cost-centre''} -%* * -%************************************************************************ +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res + = env {seTvSubst = extendVarEnv subst var res} -\begin{code} -setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env -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 +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} -getEnclosingCC :: SimplEnv -> CostCentre -getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc -\end{code} +setInScope :: SimplEnv -> SimplEnv -> SimplEnv +setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) -%************************************************************************ -%* * -\subsubsection{The @TypeEnv@ part} -%* * -%************************************************************************ +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? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- *delete* it from the substitution when going inside + -- the (\x -> ...)! -\begin{code} -type TypeEnv = TyVarEnv Type -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes +modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv +modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' + = env {seInScope = modifyInScopeSet in_scope v v'} -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps - where - new_ty_env = addOneToTyVarEnv ty_env tyvar ty +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps - where - new_ty_env = growTyVarEnvList ty_env pairs +setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } -simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty) -simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id) -\end{code} +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e -%************************************************************************ -%* * -\subsubsection{The ``Id env'' part} -%* * -%************************************************************************ +isEmptySimplSubst :: SimplEnv -> Bool +isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) + = isEmptyVarEnv tvs && isEmptyVarEnv ids -\begin{code} -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. +--------------------- +getRules :: SimplEnv -> RuleBase +getRules = seExtRules \end{code} -\begin{code} -lookupId :: SimplEnv -> Id -> Eager ans OutArg + GADT stuff -lookupId (SimplEnv _ _ _ in_id_env _ _) id - = case (lookupIdEnv in_id_env id) of - Just atom -> returnEager atom - Nothing -> returnEager (VarArg id) -\end{code} +Given an idempotent substitution, generated by the unifier, use it to +refine the environment \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder - -> OutArg{-Val args only, please-} - -> SimplEnv - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (in_id,occ_info) atom - = case atom of - LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps - VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env - (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps ---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps +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 - 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) --} - -extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv -extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - - -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 -> [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_in_id_env = growIdEnvList in_id_env bindings - bindings = zipEqual "extendIdEnvWithClones" - [id | (id,_) <- in_binders] - (map VarArg out_ids) + 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 @OutIdEnv@} + Substitution of Vars %* * %************************************************************************ -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} -type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo) - -\end{code} - -The "Id" part is just so that we can recover the domain of the mapping, which -IdEnvs don't allow directly. - -The @BinderInfo@ tells about the occurrences of the @OutId@. -Anything that isn't in here should be assumed to occur many times. -We keep this info so we can modify it when something changes. - -The @RhsInfo@ part tells about the value to which the @OutId@ is bound. - \begin{code} -data RhsInfo = NoRhsInfo - | OtherLit [Literal] -- It ain't one of these - | OtherCon [Id] -- It ain't one of these - - | InUnfolding SimplEnv -- Un-simplified unfolding - SimpleUnfolding -- (need to snag envts therefore) - - | OutUnfolding CostCentre - SimpleUnfolding -- Already-simplified unfolding - -lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo) -lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id - -lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo -lookupRhsInfo env id - = case lookupOutIdEnv env id of - Just (_,_,info) -> info - Nothing -> NoRhsInfo - -modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) - -> (OutId, BinderInfo, RhsInfo) -modifyOutEnvItem (id, occ, info1) (_, _, info2) - = 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) +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 + -- 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} -isEvaluated :: RhsInfo -> Bool -isEvaluated (OtherLit _) = True -isEvaluated (OtherCon _) = True -isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True -isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True -isEvaluated other = False -\end{code} +%************************************************************************ +%* * +\section{Substituting an Id binder} +%* * +%************************************************************************ +These functions are in the monad only so that they can be made strict via seq. \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_id_env out_id_env con_apps) - out_id occ_info rhs_info - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps +simplBinders, simplLamBndrs + :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) +simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs +simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr 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) } + +------------- +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 + old_unf = idUnfolding bndr + (env', id1) = substIdBndr env bndr + id2 = id1 `setIdUnfolding` substUnfolding env old_unf + +-------------- +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 - new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id - (out_id, occ_info, rhs_info) + -- id1 is cloned if necessary + id1 = uniqAway in_scope old_id + + -- id2 has its type zapped + id2 = substIdType env id1 + + -- new_id has the final IdInfo + subst = mkCoreSubst env + new_id = maybeModifyIdInfo (substIdInfo subst) 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 \end{code} \begin{code} -modifyOccInfo out_id_env (uniq, new_occ) - = modifyIdEnv_Directly modify_fn out_id_env uniq - where - modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs) +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () -markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps - where - new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms] - modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs) -\end{code} +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids +\end{code} %************************************************************************ %* * -\subsubsection{The @ConAppMap@ type} + Let bindings %* * %************************************************************************ -The @ConAppMap@ maps applications of constructors (to value atoms) -back to an association list that says "if the constructor was applied -to one of these lists-of-Types, then this OutId is your man (in a -non-gender-specific sense)". I.e., this is a reversed mapping for -(part of) the main OutIdEnv - -\begin{code} -type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)] - -data UnfoldConApp - = UCA OutId -- data constructor - [OutArg] -- *value* arguments; see use below -\end{code} +Simplifying let binders +~~~~~~~~~~~~~~~~~~~~~~~ +Rename the binders if necessary, \begin{code} -nullConApps = emptyFM - -extendConApps con_apps id (Con con args) - = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)] +simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +simplNonRecBndr env id + = do { let (env1, id1) = substLetIdBndr env id + ; seqId id1 `seq` return (env1, id1) } + +--------------- +simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) +simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids + = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids + ; seqIds ids1 `seq` return (env1, ids1) } + +--------------- +substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform + -> (SimplEnv, OutBinder) +-- C.f. CoreSubst.substIdBndr +-- Clone Id if necessary, substitute its type +-- Return an Id with completely zapped IdInfo +-- [addLetIdInfo, below, will restore its IdInfo] +-- Augment the subtitution +-- if the unique changed, *or* +-- if there's interesting occurrence info + +substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id + = (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) where - val_args = filter isValArg args -- Literals and Ids - ty_args = [ty | TyArg ty <- args] -- Just types - -extendConApps con_apps id other_rhs = con_apps + 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 (idInfo old_id) + 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} +Add IdInfo back onto a let-bound Id +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer the IdInfo of the original binder to the new binder. +This is crucial, to preserve + strictness + rules + worker info +etc. To do this we must apply the current substitution, +which incorporates earlier substitutions in this very letrec group. + +NB 1. We do this *before* processing the RHS of the binder, so that +its substituted rules are visible in its own RHS. +This is important. Manuel found cases where he really, really +wanted a RULE for a recursive function to apply in that function's +own right-hand side. + +NB 2: We do not transfer the arity (see Subst.substIdInfo) +The arity of an Id should not be visible +in its own RHS, else we eta-reduce + f = \x -> f x +to + f = f +which isn't sound. And it makes the arity in f's IdInfo greater than +the manifest arity, which isn't good. +The arity will get added later. + +NB 3: It's important that we *do* transer the loop-breaker OccInfo, +because that's what stops the Id getting inlined infinitely, in the body +of the letrec. + +NB 4: does no harm for non-recursive bindings + +NB 5: we can't do the addLetIdInfo part before *all* the RHSs because + rec { f = g + h = ... + RULE h Int = f + } +Here, we'll do postInlineUnconditionally on f, and we must "see" that +when substituting in h's RULE. + \begin{code} -lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args - = case lookupFM con_apps (UCA con val_args) of - Nothing -> Nothing - - Just assocs -> case [id | (tys, id) <- assocs, - and (zipWith eqTy tys ty_args)] - of - [] -> Nothing - (id:_) -> Just id +addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder) +addLetIdInfo env in_id out_id + = (modifyInScope env out_id out_id, final_id) + where + final_id = out_id `setIdInfo` new_info + subst = mkCoreSubst env + old_info = idInfo in_id + new_info = case substIdInfo subst old_info of + Nothing -> old_info + Just new_info -> new_info + +substIdInfo :: CoreSubst.Subst -> 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 subst 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.substSpec subst old_rules + `setWorkerInfo` CoreSubst.substWorker subst old_wrkr + `setUnfoldingInfo` noUnfolding) + -- setSpecInfo does a seq + -- setWorkerInfo does a seq where - val_args = filter isValArg args -- Literals and Ids - ty_args = [ty | TyArg ty <- args] -- Just types + nothing_to_do = keep_occ && keep_arity && + isEmptySpecInfo 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 + old_ty = idType id +------------------ +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} -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. +%************************************************************************ +%* * + Impedence matching to type substitution +%* * +%************************************************************************ \begin{code} -instance Eq UnfoldConApp where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } - -instance Ord UnfoldConApp where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app - -cmp_app (UCA c1 as1) (UCA c2 as2) - = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 +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 - -- ToDo: make an "instance Ord3 CoreArg"??? - - cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = x `cmp` y - cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" - cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" - cmp_arg x y - | tag x _LT_ tag y = LT_ - | otherwise = GT_ - where - tag (VarArg _) = ILIT(1) - tag (LitArg _) = ILIT(2) - tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" - tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" -\end{code} - - + 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 +substExpr :: SimplEnv -> CoreExpr -> CoreExpr +substExpr env expr + | isEmptySimplSubst env = expr + | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr +\end{code} -============================ OLD ================================ - This version was used when we use the *simplified* RHS of a - let as the thing's unfolding. The has the nasty property described - in the following comments. Much worse, it can fail to terminate - on recursive things. Consider - - letrec f = \x -> let z = f x' in ... - in - let n = f y - in - case n of { ... } +%************************************************************************ +%* * +\subsection{Floats} +%* * +%************************************************************************ - If we bind n to its *simplified* RHS, we then *re-simplify* it when - we inline n. Then we may well inline f; and then the same thing - happens with z! +\begin{code} +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 Floats = Floats (OrdList OutBind) + InScopeSet -- Environment "inside" all the floats + Bool -- True <=> All bindings are lifted -@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); +allLifted :: Floats -> Bool +allLifted (Floats _ _ is_lifted) = is_lifted - tabulate :: (Int -> x) -> Descr_type -> Array_type x; - tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; +wrapFloats :: Floats -> OutExpr -> OutExpr +wrapFloats (Floats bs _ _) body = foldrOL Let body bs - 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. +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats bs _ _) = isNilOL bs -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. +floatBinds :: Floats -> [OutBind] +floatBinds (Floats bs _ _) = fromOL bs -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. +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} \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_id_env out_id_env con_apps) - occ_info out_id rhs - = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps - where - new_out_id_env = case guidance of - UnfoldNever -> out_id_env -- No new stuff to put in - other -> out_id_env_with_unfolding - - new_con_apps = _scc_ "eegnr.conapps" - extendConApps con_apps out_id rhs - - -- Modify the occ info for rhs's interesting free variables. - out_id_env_with_unfolding = _scc_ "eegnr.modify_occ" - foldl modifyOccInfo env1 full_fv_occ_info - -- NB: full_fv_occ_info *combines* the occurrence of the current binder - -- with the occurrences of its RHS's 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. - - full_fv_occ_info = _scc_ "eegnr.full_fv" - [ (uniq, fv_occ `andBinderInfo` occ_info) - | (uniq, fv_occ) <- ufmToList fv_occ_info - ] - - -- Add an unfolding and rhs_info for the new Id. - -- If the out_id is already in the OutIdEnv (which can happen if - -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs) - -- then just replace the unfolding, leaving occurrence info alone. - env1 = _scc_ "eegnr.modify_out" - addToUFM_C modifyOutEnvItem out_id_env 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 out_id_env v of - Just (_, OneOcc _ _ _ _ _, _) -> True - other -> False - - -- Compute unfolding details - rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template) - form_summary = _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 +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} - - -========================== OLD [removed SLPJ March 97] ==================== - -I removed the attempt to inline recursive bindings when I discovered -a program that made the simplifier loop (nofib/spectral/hartel/typecheck/Main.hs) - -The nasty case is this: - - letrec f = \x -> let z = f x' in ... - - in - let n = f y - in - case n of { ... } - -If we bind n to its *simplified* RHS, we then *re-simplify* it when we -inline n. Then we may well inline f; and then the same thing happens -with z! - -Recursive bindings -~~~~~~~~~~~~~~~~~~ -We need to be pretty careful when extending -the environment with RHS info in recursive groups. - -Here's a nasty example: - - letrec r = f x - t = r - x = ...t... - in - ...t... - -Here, r occurs exactly once, so we may reasonably inline r in t's RHS. -But the pre-simplified t's rhs is an atom, r, so we may also decide to -inline t everywhere. But if we do *both* these reasonable things we get - - letrec r = f x - t = f x - x = ...r... - in - ...t... - -Bad news! (f x) is duplicated! (The t in the body doesn't get -inlined because by the time the recursive group is done we see that -t's RHS isn't an atom.) - -Our solution is this: - (a) we inline un-simplified RHSs, and then simplify - them in a clone-only environment. - (b) we inline only variables and values -This means that - - - r = f x ==> r = f x - t = r ==> t = r - x = ...t... ==> x = ...r... - in in - t r - -Now t is dead, and we're home. - -Most silly x=y bindings in recursive group will go away. But not all: - - let y = 1:x - x = y - -Here, we can't inline x because it's in an argument position. so we'll just replace -with a clone of y. Instead we'll probably inline y (a small value) to give - - let y = 1:x - x = 1:y - -which is OK if not clever. - - - -\begin{code} -{- -extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (out_id, ((_,occ_info), old_rhs)) - = case (form_summary, guidance) of - (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in - (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps - other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable - --- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps - where -{- - new_out_id_env = case (form_summary, guidance) of - (_, UnfoldNever) -> out_id_env -- No new stuff to put in - (ValueForm, _) -> out_id_env_with_unfolding - (VarForm, _) -> out_id_env_with_unfolding - other -> out_id_env -- Not a value or variable --} - -- If there is an unfolding, we add rhs-info for out_id, - -- No need to modify occ info because RHS is pre-simplification - out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id - (out_id, occ_info, rhs_info) - - -- Compute unfolding details - -- Note that we use the "old" environment, that just has clones of the rec-bound vars, - -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once. - -- Only if the thing is still small enough next time round will we inline again. - rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs) - form_summary = mkFormSummary old_rhs - guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs) --} -\end{code}