X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=00f035e51392f62acb750fb5f436fac1272551d1;hb=931a117d6236076788c560fb2e08c538be95bd45;hp=ade1cfa03fafb9e365f7db65492ce5d58d18563f;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ade1cfa..00f035e 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -1,92 +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, - pprSimplEnv, -- debugging only - - replaceInEnvs, nullInEnvs, - - extendTyEnv, extendTyEnvList, - simplTy, simplTyInId, + InId, InBind, InExpr, InAlt, InArg, InType, InBinder, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - extendIdEnvWithAtom, extendIdEnvWithAtomList, - extendIdEnvWithInlining, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, + -- The simplifier mode + setMode, getMode, - extendUnfoldEnvGivenRhs, - extendUnfoldEnvGivenFormDetails, - extendUnfoldEnvGivenConstructor, - lookForConstructor, - lookupUnfolding, filterUnfoldEnvForInlines, + -- Switch checker + SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn, - getSwitchChecker, switchIsSet, + setEnclosingCC, getEnclosingCC, - setEnclosingCC, + -- Environments + SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, + getRules, refineSimplEnv, - -- Types - SwitchChecker(..), - SimplEnv, EnclosingCcDetails(..), - InIdEnv(..), IdVal(..), InTypeEnv(..), - UnfoldEnv, UnfoldItem, UnfoldConApp, + SimplSR(..), mkContEx, substId, - InId(..), InBinder(..), InBinding(..), InType(..), - OutId(..), OutBinder(..), OutBinding(..), OutType(..), + simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, + simplBinder, simplBinders, addLetIdInfo, + substExpr, substTy, - InExpr(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) + -- Floats + FloatsWith, FloatsWithExpr, + Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, + allLifted, wrapFloats, floatBinds, + addAuxiliaryBind, ) where -import Ubiq{-uitous-} - -import SmplLoop -- breaks the MagicUFs / SimplEnv loop +#include "HsVersions.h" -import BinderInfo ( BinderInfo{-instances-} ) -import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) -import CmdLineOpts ( switchIsOn, intSwitchSet, 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 ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, - calcUnfoldingGuidance, UnfoldingGuidance(..), - mkFormSummary, FormSummary - ) -import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup ) -import FiniteMap -- lots of things -import Id ( idType, getIdUnfolding, getIdStrictness, - applyTypeEnvToId, - nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, - IdEnv(..), IdSet(..), GenId ) -import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) -import Literal ( isNoRepLit, Literal{-instances-} ) -import Name ( isLocallyDefined ) -import OccurAnal ( occurAnalyseExpr ) -import Outputable ( Outputable(..){-instances-} ) -import PprCore -- various instances -import PprStyle ( PprStyle(..) ) -import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy ) -import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, - growTyVarEnvList, - TyVarEnv(..), GenTyVar{-instance Eq-} - ) -import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) -import UniqSet -- lots of things -import Usage ( UVar(..), GenUsage{-instances-} ) -import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic ) - -type TypeEnv = TyVarEnv Type -cmpType = panic "cmpType (SimplEnv)" -oneSafeOcc = panic "oneSafeOcc (SimplEnv)" -oneTextualOcc = panic "oneTextualOcc (SimplEnv)" -simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" +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} %************************************************************************ @@ -95,6 +72,24 @@ simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" %* * %************************************************************************ +\begin{code} +type InBinder = CoreBndr +type InId = Id -- Not yet cloned +type InType = Type -- Ditto +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg + +type OutBinder = CoreBndr +type OutId = Id -- Cloned +type OutTyVar = TyVar -- Cloned +type OutType = Type -- Cloned +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg +\end{code} %************************************************************************ %* * @@ -103,768 +98,644 @@ simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" %************************************************************************ -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) -The environment contains bindings for all - {\em in-scope,} - {\em locally-defined} -things. + -- Rules from other modules + seExtRules :: RuleBase, -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.). + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + seInScope :: InScopeSet, -- OutVars only -\begin{code} -data SimplEnv - = SimplEnv - SwitchChecker - - EnclosingCcDetails -- the enclosing cost-centre (when profiling) - - InTypeEnv -- For cloning types - -- Domain is all in-scope type variables - - InIdEnv -- IdEnv - -- Domain is - -- *all* - -- *in-scope*, - -- *locally-defined* - -- *InIds* - -- (Could omit the exported top-level guys, - -- since their names mustn't change; and ditto - -- the non-exported top-level guys which you - -- don't want to macro-expand, since their - -- names need not change.) - -- - -- Starts off empty - - UnfoldEnv -- Domain is any *OutIds*, including imports - -- where we know something more than the - -- interface file tells about their value (see - -- below) - -nullSimplEnv :: SwitchChecker -> SimplEnv - -nullSimplEnv sw_chkr - = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env - -pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) - = ppAboves [ - ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env, - ppSP, ppStr "** Id Env ** ?????????", --- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ], - ppSP, ppStr "** Unfold Env **", - ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ] - ] - where - pp_id_entry (v, idval) - = ppCat [ppr PprDebug v, ppStr "=>", - case idval of - InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e] - ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a] - ] - - pp_uf_entry (UnfoldItem v form encl_cc) - = ppCat [ppr PprDebug v, ppStr "=>", - case form of - NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" - LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] - OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") - [ppr PprDebug l | l <- ls]] - ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] - OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") - [ppr PprDebug c | c <- cs]] - GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w, - ppr PprDebug g, ppr PprDebug e] - MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s] - ] + -- 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} -%************************************************************************ -%* * -\subsubsection{The @IdVal@ type (for the ``IdEnv'')} -%* * -%************************************************************************ -The unfoldings for imported things are mostly kept within the Id -itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For -example, suppose \tr{x} is imported, and we have -\begin{verbatim} - case x of - (p,q) -> -\end{verbatim} -Then within \tr{}, we know that \tr{x} is a pair with components -\tr{p} and \tr{q}. +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 + + 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. + + 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 + \begin{code} -type InIdEnv = IdEnv IdVal -- Maps InIds to their value - -data IdVal - = InlineIt InIdEnv InTypeEnv InExpr - -- No binding of the Id is left; - -- You *have* to replace any occurences - -- of the id with this expression. - -- Rather like a macro, really - -- NB: the InIdEnv/InTypeEnv is necessary to prevent - -- name caputure. Consider: - -- let y = ... - -- x = ...y... - -- y = ... - -- in ...x... - -- If x gets an InlineIt, we must remember - -- the correct binding for y. - - | ItsAnAtom OutArg -- Used either (a) to record the cloned Id - -- or (b) if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just bind the variable to that atom, and - -- elide the let. -\end{code} +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 -%************************************************************************ -%* * -\subsubsection{The @UnfoldEnv@ type} -%* * -%************************************************************************ +--------------------- +getMode :: SimplEnv -> SimplifierMode +getMode env = seMode env -The @UnfoldEnv@ contains information about the value of some of the -in-scope identifiers. It obeys the following invariant: +setMode :: SimplifierMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } - If the @UnfoldEnv@ contains information, it is safe to use it! +--------------------- +getEnclosingCC :: SimplEnv -> CostCentreStack +getEnclosingCC env = seCC env -In particular, if the @UnfoldEnv@ contains details of an unfolding of -an Id, then it's safe to use the unfolding. If, for example, the Id -is used many times, then its unfolding won't be put in the UnfoldEnv -at all. +setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv +setEnclosingCC env cc = env {seCC = cc} -The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list -because (a)~it's small, and (b)~we need to search its {\em range} as -well as its domain. +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = env {seIdSubst = extendVarEnv subst var res} -\begin{code} -data UnfoldItem -- a glorified triple... - = UnfoldItem OutId -- key: used in lookForConstructor - UnfoldingDetails -- for that Id - EnclosingCcDetails -- so that if we do an unfolding, - -- we can "wrap" it in the CC - -- that was in force. - -data UnfoldConApp -- yet another glorified pair - = UCA OutId -- data constructor - [OutArg] -- *value* arguments; see use below - -data UnfoldEnv -- yup, a glorified triple... - = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem - IdSet -- The Ids in the domain of the env - -- which have details (GenForm True ...) - -- i.e., they claim they are duplicatable. - -- These are the ones we have to worry - -- about when adding new items to the - -- unfold env. - (FiniteMap UnfoldConApp [([Type], OutId)]) - -- Maps applications of constructors (to - -- value atoms) back to an association list - -- that says "if the constructor was applied - -- to one of these lists-of-Types, then - -- this OutId is your man (in a non-gender-specific - -- sense)". I.e., this is a reversed - -- mapping for (part of) the main IdEnv - -- (1st part of UFE) - -null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM -\end{code} +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res + = env {seTvSubst = extendVarEnv subst var res} -The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will -be small, because it contains bindings only for those things whose -form or unfolding is known. Basically it maps @Id@ to their -@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also -need to search it associatively, to look for @Id@s which have a given -constructor form. +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env -We implement it with @IdEnvs@, possibly overkill, but sometimes these -things silently grow quite big.... Here are some local functions used -elsewhere in the module: +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} -\begin{code} -grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv -lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -lookup_unfold_env_encl_cc - :: UnfoldEnv -> OutId -> EnclosingCcDetails - -grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env - -grow_unfold_env (UFE u_env interesting_ids con_apps) id - uf_details@(GenForm True _ _ _) encl_cc - -- Only interested in Ids which have a "dangerous" unfolding; that is - -- one that claims to have a single occurrence. - = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - (addOneToUniqSet interesting_ids id) - con_apps - -grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc - = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - interesting_ids - new_con_apps - where - new_con_apps - = case uf_details of - ConForm con args -> snd (lookup_conapp_help con_apps con args id) - not_a_constructor -> con_apps -- unchanged - -addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items - = ASSERT(not (any constructor_form_in_those extra_items)) - -- otherwise, we'd need to change con_apps - UFE (growIdEnvList u_env extra_items) interesting_ids con_apps - where - constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True - constructor_form_in_those _ = False - -rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env - -get_interesting_ids (UFE _ interesting_ids _) = interesting_ids - -foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff - = UFE (foldr fun u_env stuff) interesting_ids con_apps - -lookup_unfold_env (UFE u_env _ _) id - = case (lookupIdEnv u_env id) of - Nothing -> NoUnfoldingDetails - Just (UnfoldItem _ uf _) -> uf - -lookup_unfold_env_encl_cc (UFE u_env _ _) id - = case (lookupIdEnv u_env id) of - Nothing -> NoEnclosingCcDetails - Just (UnfoldItem _ _ encl_cc) -> encl_cc - -lookup_conapp (UFE _ _ con_apps) con args - = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp")) - --- Returns two things; we just fst or snd the one we want: -lookup_conapp_help con_apps con args outid - = case (span notValArg args) of { (ty_args, val_args) -> - let - entry = UCA con val_args - arg_tys = [ t | TyArg t <- ty_args ] - in - case (lookupFM con_apps entry) of - Nothing -> (Nothing, - addToFM con_apps entry [(arg_tys, outid)]) - Just assocs - -> ASSERT(not (null assocs)) - case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of - [o] -> (Just o, - con_apps) -- unchanged; we hang onto what we have - [] -> (Nothing, - addToFM con_apps entry ((arg_tys, outid) : assocs)) - _ -> panic "grow_unfold_env:dup in assoc list" - } - where - eq_tys ts1 ts2 - = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False } +setInScope :: SimplEnv -> SimplEnv -> SimplEnv +setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) + +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 -> ...)! - cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types - = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-} +modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv +modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' + = env {seInScope = modifyInScopeSet in_scope v v'} -modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id - = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} --- If the current binding claims to be a "unique" one, then --- we modify it. -modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem +setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } -modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) - = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e + +isEmptySimplSubst :: SimplEnv -> Bool +isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) + = isEmptyVarEnv tvs && isEmptyVarEnv ids + +--------------------- +getRules :: SimplEnv -> RuleBase +getRules = seExtRules \end{code} -The main thing about @UnfoldConApp@ is that it has @Ord@ defined on -it, so we can use it for a @FiniteMap@ key. + GADT stuff + +Given an idempotent substitution, generated by the unifier, use it to +refine the environment + \begin{code} -instance Eq UnfoldConApp where - a == b = case cmp_app a b of { EQ_ -> True; _ -> False } - a /= b = case cmp_app a b of { EQ_ -> False; _ -> True } - -instance Ord UnfoldConApp where - a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app - -cmp_app (UCA c1 as1) (UCA c2 as2) - = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 +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 - -- ToDo: make an "instance Ord3 CoreArg"??? - - cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } - cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" - cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" - cmp_arg x y - | tag x _LT_ tag y = LT_ - | otherwise = GT_ - where - tag (VarArg _) = ILIT(1) - tag (LitArg _) = ILIT(2) - tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" - tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" + 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 @EnclosingCcDetails@ type} + Substitution of Vars %* * %************************************************************************ + \begin{code} -data EnclosingCcDetails - = NoEnclosingCcDetails - | EnclosingCC CostCentre +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} + %************************************************************************ %* * -\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms} +\section{Substituting an Id binder} %* * %************************************************************************ -\begin{code} -type InId = Id -- Not yet cloned -type InBinder = (InId, BinderInfo) -type InType = Type -- Ditto -type InBinding = SimplifiableCoreBinding -type InExpr = SimplifiableCoreExpr -type InAlts = SimplifiableCoreCaseAlts -type InDefault = SimplifiableCoreCaseDefault -type InArg = SimplifiableCoreArg -type OutId = Id -- Cloned -type OutBinder = Id -type OutType = Type -- Cloned -type OutBinding = CoreBinding -type OutExpr = CoreExpr -type OutAlts = CoreCaseAlts -type OutDefault = CoreCaseDefault -type OutArg = CoreArg - -\end{code} +These functions are in the monad only so that they can be made strict via seq. \begin{code} -type SwitchChecker = SimplifierSwitch -> SwitchResult +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 + -- 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} -%************************************************************************ -%* * -\subsection{@SimplEnv@ handling} -%* * -%************************************************************************ - -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ \begin{code} -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () -switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool -switchIsSet (SimplEnv chkr _ _ _ _) switch - = switchIsOn chkr switch +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids \end{code} + %************************************************************************ %* * -\subsubsection{The ``enclosing cost-centre''} + Let bindings %* * %************************************************************************ -\begin{code} -setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv +Simplifying let binders +~~~~~~~~~~~~~~~~~~~~~~~ +Rename the binders if necessary, -setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc - = SimplEnv chkr encl_cc ty_env id_env unfold_env +\begin{code} +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 + 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} -%************************************************************************ -%* * -\subsubsection{The @TypeEnv@ part} -%* * -%************************************************************************ +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} -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes - -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty - = SimplEnv chkr encl_cc new_ty_env id_env unfold_env +addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder) +addLetIdInfo env in_id out_id + = (modifyInScope env out_id out_id, final_id) where - new_ty_env = addOneToTyVarEnv ty_env tyvar ty - -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs - = SimplEnv chkr encl_cc new_ty_env id_env unfold_env + 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 + 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 - new_ty_env = growTyVarEnvList ty_env pairs + old_ty = idType id -simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty -simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env 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} -@replaceInEnvs@ is used to install saved type and id envs -when pulling an un-simplified expression out of the environment, which -was saved with its environments. - -\begin{code} -nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv) - -replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv - -replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (new_ty_env, new_id_env) - = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env -\end{code} %************************************************************************ %* * -\subsubsection{The ``Id env'' part} + Impedence matching to type substitution %* * %************************************************************************ \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder -> OutArg{-Val args only, please-} - -> SimplEnv - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit) - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) - -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id, occ_info) atom@(VarArg out_id) - = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) - - new_unfold_env = modify_unfold_env - unfold_env - (modifyItem ok_to_dup occ_info) - out_id - -- Modify binding for in_id - -- NO! modify out_id, because its the info on the - -- atom that interest's us. - - ok_to_dup = switchIsOn chkr SimplOkToDupCode - -#ifdef DEBUG -extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!" -#endif - -extendIdEnvWithAtomList - :: SimplEnv - -> [(InBinder, OutArg)] - -> SimplEnv -extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - -extendIdEnvWithInlining - :: SimplEnv -- The Env to modify - -> SimplEnv -- The Env to record in the inlining. Usually the - -- same as the previous one, except in the recursive case - -> InBinder -> InExpr - -> SimplEnv - -extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env) - ~(SimplEnv _ _ inline_ty_env inline_id_env _ ) - (in_id,occ_info) - expr - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env +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 - new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr) + mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) -extendIdEnvWithClone - :: SimplEnv - -> InBinder -- Old binder; binderinfo ignored - -> OutId -- Its new clone, as an Id - -> SimplEnv - -extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id,_) out_id - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id)) + fiddle (DoneEx e) = e + fiddle (DoneId v occ) = Var v + fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e -extendIdEnvWithClones -- Like extendIdEnvWithClone - :: SimplEnv - -> [InBinder] - -> [OutId] - -> SimplEnv - -extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) - in_binders out_ids - = SimplEnv chkr encl_cc ty_env new_id_env unfold_env - where - new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals) - in_ids = [id | (id,_) <- in_binders] - out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids] - -lookupId :: SimplEnv -> Id -> Maybe IdVal - -lookupId (SimplEnv _ _ _ id_env _) id -#ifndef DEBUG - = lookupIdEnv id_env id -#else - = case (lookupIdEnv id_env id) of - xxx@(Just _) -> xxx - xxx -> --false!: ASSERT(not (isLocallyDefined id)) - xxx -#endif +substExpr :: SimplEnv -> CoreExpr -> CoreExpr +substExpr env expr + | isEmptySimplSubst env = expr + | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr \end{code} + %************************************************************************ %* * -\subsubsection{The @UnfoldEnv@} +\subsection{Floats} %* * %************************************************************************ \begin{code} -extendUnfoldEnvGivenFormDetails - :: SimplEnv - -> OutId - -> UnfoldingDetails - -> SimplEnv - -extendUnfoldEnvGivenFormDetails - env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - id details - = case details of - NoUnfoldingDetails -> env - good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc - -extendUnfoldEnvGivenConstructor -- specialised variant - :: SimplEnv - -> OutId -- bind this to... - -> Id -> [OutId] -- "con args" - -> SimplEnv - -extendUnfoldEnvGivenConstructor env var con args - = let - -- conjure up the types to which the con should be applied - scrut_ty = idType var - (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty - in - extendUnfoldEnvGivenFormDetails - env var (ConForm con (map VarArg args)) -\end{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); - - 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. +allLifted :: Floats -> Bool +allLifted (Floats _ _ is_lifted) = is_lifted -\begin{code} -extendUnfoldEnvGivenRhs - :: SimplEnv - -> InBinder - -> OutId -- Note: *must* be an "out" Id (post-cloning) - -> OutExpr -- Its rhs (*simplified*) - -> SimplEnv - -extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - binder@(_,occ_info) out_id rhs - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - -- Occurrence-analyse the RHS - (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs - - interesting_fvs = get_interesting_ids unfold_env - - -- Compute unfolding details - details = case rhs of - Var v -> panic "Vars already dealt with" - Lit lit | isNoRepLit lit -> LitForm lit - | otherwise -> panic "non-noRep Lits already dealt with" - - Con con args -> ConForm con args - - other -> mkGenForm ok_to_dup occ_info - (mkFormSummary (getIdStrictness out_id) rhs) - template guidance - - -- Compute resulting unfold env - new_unfold_env = case details of - NoUnfoldingDetails -> unfold_env - GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} - other -> unfold_env1 - - -- Add unfolding to unfold env - unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc - - -- Modify unfoldings of free vars of rhs, based on their - -- occurrence info in the rhs [see notes above] - unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info) - - modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem - modify (u, occ_info) env - = case (lookupUFM_Directly env u) of - Nothing -> env -- ToDo: can this happen? - Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) - - -- Compute unfolding guidance - guidance = if simplIdWantsToBeINLINEd out_id env - then UnfoldAlways - else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs - - bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of - Nothing -> uNFOLDING_CREATION_THRESHOLD - Just xx -> xx - - ok_to_dup = switchIsOn chkr SimplOkToDupCode - || exprSmallEnoughToDup rhs - -- [Andy] added, Jun 95 - -{- Reinstated AJG Jun 95; This is needed - --example that does not (currently) work - --without this extention - - --let f = g x - --in - -- case of - -- True -> h i f - -- False -> f - -- ==> - -- case of - -- True -> h i f - -- False -> g x --} -{- OLD: - Omitted SLPJ Feb 95; should, I claim, be unnecessary - -- is_really_small looks for things like f a b c - -- but making sure there are not *too* many arguments. - -- (This is brought to you by *ANDY* Magic Constants, Inc.) - is_really_small - = case collectArgs new_rhs of - (Var _, _, _, xs) -> length xs < 10 - _ -> False --} -\end{code} +wrapFloats :: Floats -> OutExpr -> OutExpr +wrapFloats (Floats bs _ _) body = foldrOL Let body bs -\begin{code} -lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats bs _ _) = isNilOL bs -lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var - | not (isLocallyDefined var) -- Imported, so look inside the id - = getIdUnfolding var +floatBinds :: Floats -> [OutBind] +floatBinds (Floats bs _ _) = fromOL bs - | otherwise -- Locally defined, so look in the envt. - -- There'll be nothing inside the Id. - = lookup_unfold_env unfold_env var +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} -We need to remove any @GenForm@ bindings from the UnfoldEnv for -the RHS of an Id which has an INLINE pragma. - \begin{code} -filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv - -filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - new_unfold_env = null_unfold_env - -- This version is really simple. INLINEd things are going to - -- be inlined wherever they are used, and then all the - -- UnfoldEnv stuff will take effect. Meanwhile, there isn't - -- much point in doing anything to the as-yet-un-INLINEd rhs. - - -- Andy disagrees! Example: - -- all xs = foldr (&&) True xs - -- any p = all . map p {-# INLINE any #-} - -- - -- Problem: any won't get deforested, and so if it's exported and - -- the importer doesn't use the inlining, (eg passes it as an arg) - -- then we won't get deforestation at all. - -- - -- So he'd like not to filter the unfold env at all. But that's a disaster: - -- Suppose we have: - -- - -- let f = \pq -> BIG - -- in - -- let g = \y -> f y y - -- {-# INLINE g #-} - -- in ...g...g...g...g...g... - -- - -- Now, if that's the ONLY occurrence of f, it will be inlined inside g, - -- and thence copied multiple times when g is inlined. +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} -====================== - -In @lookForConstructor@ we used (before Apr 94) to have a special case -for nullary constructors: - -\begin{verbatim} - = -- Don't re-use nullary constructors; it's a waste. Consider - -- let - -- a = leInt#! p q - -- in - -- case a of - -- True -> ... - -- False -> False - -- - -- Here the False in the second case will get replace by "a", hardly - -- a good idea - Nothing -\end{verbatim} -but now we only do constructor re-use in let-bindings the special -case isn't necessary any more. - -\begin{code} -lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args - = lookup_conapp unfold_env con args -\end{code}