%
-% (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}
%************************************************************************
%* *
%************************************************************************
+\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}
%************************************************************************
%* *
%************************************************************************
-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) -> <body>
-\end{verbatim}
-Then within \tr{<body>}, 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 <tys-to-be-invented> args"
- -> SimplEnv
-
-extendUnfoldEnvGivenConstructor env var con args
- = let
- -- conjure up the types to which the con should be applied
- scrut_ty = idType var
- (_, ty_args, _) = 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 <exp> of
- -- True -> h i f
- -- False -> f
- -- ==>
- -- case <exp> of
- -- True -> h i f
- -- False -> g x
--}
-{- OLD:
- Omitted SLPJ Feb 95; should, I claim, be unnecessary
- -- is_really_small looks for things like f a b c
- -- but making sure there are not *too* many arguments.
- -- (This is brought to you by *ANDY* Magic Constants, Inc.)
- is_really_small
- = case collectArgs new_rhs of
- (Var _, _, _, xs) -> length xs < 10
- _ -> False
--}
-\end{code}
+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}
projects / ghc-hetmet.git / blobdiff