\begin{code}
module SimplEnv (
- nullSimplEnv, combineSimplEnv,
- pprSimplEnv, -- debugging only
+ nullSimplEnv,
+ getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
- extendTyEnv, extendTyEnvList, extendTyEnvEnv,
- simplTy, simplTyInId,
+ bindTyVar, bindTyVars, simplTy,
- extendIdEnvWithAtom, extendIdEnvWithAtoms,
- extendIdEnvWithClone, extendIdEnvWithClones,
- lookupId,
+ lookupIdSubst, lookupOutIdEnv,
+ bindIdToAtom, bindIdToExpr,
markDangerousOccs,
- lookupRhsInfo, lookupOutIdEnv, isEvaluated,
+ lookupUnfolding, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvGivenRhsInfo, extendEnvGivenInlining,
+ extendEnvGivenUnfolding,
lookForConstructor,
-- Types
SwitchChecker,
SimplEnv,
- InIdEnv, InTypeEnv,
UnfoldConApp,
- RhsInfo(..),
+ SubstInfo(..),
InId, InBinder, InBinding, InType,
OutId, OutBinder, OutBinding, OutType,
#include "HsVersions.h"
import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
- okToInline,
- BinderInfo {-instances, too-}
+ okToInline, isOneFunOcc,
+ BinderInfo
)
import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
SimplifierSwitch(..), SwitchResult(..)
)
import CoreSyn
import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
- Unfolding(..), SimpleUnfolding(..), FormSummary(..),
+ Unfolding(..), FormSummary(..),
calcUnfoldingGuidance )
import CoreUtils ( coreExprCc )
-import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached )
+import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre,
+ costsAreSubsumed, noCostCentreAttached, subsumedCosts,
+ currentOrSubsumedCosts
+ )
import FiniteMap -- lots of things
-import Id ( applyTypeEnvToId, getInlinePragma,
- nullIdEnv, growIdEnvList, lookupIdEnv,
+import Id ( getInlinePragma,
+ nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
- IdEnv, IdSet, GenId, Id )
-import Literal ( Literal{-instances-} )
+ IdEnv, IdSet, Id )
+import Literal ( Literal )
import Maybes ( expectJust )
import OccurAnal ( occurAnalyseExpr )
import PprCore -- various instances
-import PprType ( GenType, GenTyVar )
import Type ( instantiateTy, Type )
-import TyVar ( emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
- TyVarEnv, GenTyVar{-instance Eq-} ,
+import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
+ TyVarSet, emptyTyVarSet,
TyVar
)
import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
-import UniqFM ( addToUFM, addToUFM_C, ufmToList )
+import UniqFM ( addToUFM, addToUFM_C, ufmToList, mapUFM )
import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList )
import Outputable
\end{code}
= SimplEnv
SwitchChecker
CostCentre -- The enclosing cost-centre (when profiling)
- InTypeEnv -- Maps old type variables to new clones
- InIdEnv -- Maps locally-bound Ids to new clones
- OutIdEnv -- Info about the values of OutIds
+ SimplTypeEnv -- Maps old type variables to new clones
+ SimplValEnv -- Maps locally-bound Ids to new clones
ConAppMap -- Maps constructor applications back to OutIds
+type SimplTypeEnv = (TyVarSet, -- In-scope tyvars (in result)
+ TyVarEnv Type) -- Type substitution
+ -- If t is in the in-scope set, it certainly won't be
+ -- in the domain of the substitution, and vice versa
+
+type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
+ -- Ids (in result), range gives info about them
+ IdEnv SubstInfo) -- Id substitution
+ -- The first envt tells what Ids are in scope; it
+ -- corresponds to the TyVarSet in SimplTypeEnv
+
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
+ --
+ -- Ids in the domain of the substitution are *not* in scope;
+ -- they *must* be substituted for the given OutArg
+
+data SubstInfo
+ = SubstVar OutId -- The Id maps to an already-substituted atom
+ | SubstLit Literal -- ...ditto literal
+ | SubstExpr -- Id maps to an as-yet-unsimplified expression
+ (TyVarEnv Type) -- ...hence we need to capture the substitution
+ (IdEnv SubstInfo) -- environments too
+ SimplifiableCoreExpr
+
+type StuffAboutId = (OutId, -- Always has the same unique as the
+ -- Id that maps to it; but may have better
+ -- IdInfo, and a correctly-substituted type,
+ -- than the occurrences of the Id. So use
+ -- this to replace occurrences
-nullSimplEnv :: SwitchChecker -> SimplEnv
+ BinderInfo, -- How it occurs
+ -- We keep this info so we can modify it when
+ -- something changes.
+
+ Unfolding) -- Info about what it is bound to
+\end{code}
-nullSimplEnv sw_chkr
- = SimplEnv sw_chkr subsumedCosts emptyTyVarEnv nullIdEnv nullIdEnv nullConApps
-combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
-combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
- new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
- = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
+\begin{code}
+nullSimplEnv :: SwitchChecker -> SimplEnv
-pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
+nullSimplEnv sw_chkr
+ = SimplEnv sw_chkr subsumedCosts
+ (emptyTyVarSet, emptyTyVarEnv)
+ (nullIdEnv, nullIdEnv)
+ nullConApps
+
+ -- The top level "enclosing CC" is "SUBSUMED". But the enclosing CC
+ -- for the rhs of top level defs is "OST_CENTRE". Consider
+ -- f = \x -> e
+ -- g = \y -> let v = f y in scc "x" (v ...)
+ -- Here we want to inline "f", since its CC is SUBSUMED, but we don't
+ -- want to inline "v" since its CC is dynamically determined.
+
+
+getEnvs :: SimplEnv -> (SimplTypeEnv, SimplValEnv)
+getEnvs (SimplEnv _ _ ty_env id_env _) = (ty_env, id_env)
+
+setTyEnv :: SimplEnv -> SimplTypeEnv -> SimplEnv
+setTyEnv (SimplEnv chkr encl_cc _ in_id_env con_apps) ty_env
+ = SimplEnv chkr encl_cc ty_env in_id_env con_apps
+
+setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
+setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
+ = SimplEnv chkr encl_cc ty_env id_env con_apps
+
+setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
+setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ ty_subst id_subst
+ = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
+
+zapSubstEnvs :: SimplEnv -> SimplEnv
+zapSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ = SimplEnv chkr encl_cc (in_scope_tyvars, emptyTyVarEnv) (in_scope_ids, nullIdEnv) con_apps
\end{code}
\begin{code}
getSwitchChecker :: SimplEnv -> SwitchChecker
-getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
+getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-switchIsSet (SimplEnv chkr _ _ _ _ _) switch
+switchIsSet (SimplEnv chkr _ _ _ _) switch
= switchIsOn chkr switch
getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-- Crude, but simple
setCaseScrutinee :: SimplEnv -> SimplEnv
-setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
+setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
+ = SimplEnv chkr' encl_cc ty_env id_env con_apps
where
chkr' SimplCaseScrutinee = SwBool True
chkr' other = chkr other
then we won't get deforestation at all.
We havn't solved this problem yet!
-We prepare the envt by simply discarding the out_id_env, which has
+We prepare the envt by simply modifying the id_env, which has
all the unfolding info. At one point we did it by modifying the chkr so
that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
simplifications happening in the body of the RHS.
\begin{code}
switchOffInlining :: SimplEnv -> SimplEnv
-switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
+switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps
+ where
+ forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoUnfolding)
\end{code}
+
%************************************************************************
%* *
\subsubsection{The ``enclosing cost-centre''}
\begin{code}
setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
-setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
- = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
+setEnclosingCC env@(SimplEnv chkr _ ty_env id_env con_apps) encl_cc
+ = SimplEnv chkr encl_cc ty_env id_env con_apps
getEnclosingCC :: SimplEnv -> CostCentre
-getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
+getEnclosingCC (SimplEnv chkr encl_cc ty_env id_env con_apps) = encl_cc
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-type TypeEnv = TyVarEnv Type
-type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
+These two "bind" functions extend the tyvar substitution.
+They don't affect what tyvars are in scope.
-extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
-extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
- = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
- where
- new_ty_env = addToTyVarEnv ty_env tyvar ty
-
-extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
-extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
- = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
+\begin{code}
+bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv
+bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) tyvar ty
+ = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
where
- new_ty_env = growTyVarEnvList ty_env pairs
+ new_ty_subst = addToTyVarEnv ty_subst tyvar ty
-extendTyEnvEnv :: SimplEnv -> TypeEnv -> SimplEnv
-extendTyEnvEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) new_ty_env
- = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
+bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv
+bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) id_env con_apps) extra_subst
+ = SimplEnv chkr encl_cc (tyvars, new_ty_subst) id_env con_apps
where
- new_ty_env = ty_env `plusTyVarEnv` new_ty_env
+ new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
+\end{code}
-simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (instantiateTy ty_env ty)
-simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
+\begin{code}
+simplTy (SimplEnv _ _ (_, ty_subst) _ _) ty = returnEager (instantiateTy ty_subst ty)
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-type InIdEnv = IdEnv OutArg -- Maps InIds to their value
- -- Usually this is just the cloned Id, but if
- -- if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just bind the variable to that atom, and
- -- elide the let.
-\end{code}
-
-\begin{code}
-lookupId :: SimplEnv -> Id -> Eager ans OutArg
-
-lookupId (SimplEnv _ _ _ in_id_env _ _) id
- = case (lookupIdEnv in_id_env id) of
- Just atom -> returnEager atom
- Nothing -> returnEager (VarArg id)
-\end{code}
+notInScope forgets that the specified binder is in scope.
+It is used when we decide to bind a let(rec) bound thing to
+an atom, *after* the Id has been added to the in-scope mapping by simplBinder.
\begin{code}
-extendIdEnvWithAtom
- :: SimplEnv
- -> InBinder
- -> OutArg{-Val args only, please-}
- -> SimplEnv
-
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- (in_id,occ_info) atom
- = case atom of
- LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
- VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
- (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
+notInScope :: SimplEnv -> OutBinder -> SimplEnv
+notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) id
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
where
- new_in_id_env = addOneToIdEnv in_id_env in_id atom
-{-
- new_out_id_env = case atom of
- LitArg _ -> out_id_env
- VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
--}
-
-extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
-extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-
+ new_in_scope_ids = delOneFromIdEnv in_scope_ids id
+\end{code}
-extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
+These "bind" functions extend the Id substitution.
-extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- (in_id,_) out_id
- = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
+\begin{code}
+bindIdToAtom :: SimplEnv
+ -> InBinder
+ -> OutArg -- Val args only, please
+ -> SimplEnv
+
+bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ (in_id,occ_info) atom
+ = SimplEnv chkr encl_cc ty_env id_env' con_apps
where
- new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
-
-extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
-extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- in_binders out_ids
- = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
+ id_env' = case atom of
+ LitArg lit -> (in_scope_ids, addOneToIdEnv id_subst in_id (SubstLit lit))
+ VarArg id -> (modifyOccInfo in_scope_ids (uniqueOf id) occ_info,
+ addOneToIdEnv id_subst in_id (SubstVar id))
+
+bindIdToExpr :: SimplEnv
+ -> InBinder
+ -> SimplifiableCoreExpr
+ -> SimplEnv
+
+bindIdToExpr (SimplEnv chkr encl_cc ty_env@(_, ty_subst) (in_scope_ids, id_subst) con_apps)
+ (in_id,occ_info) expr
+ = ASSERT( isOneFunOcc occ_info ) -- Binder occurs just once, safely, so no
+ -- need to adjust occurrence info for RHS,
+ -- unlike bindIdToAtom
+ SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst') con_apps
where
- new_in_id_env = growIdEnvList in_id_env bindings
- bindings = zipEqual "extendIdEnvWithClones"
- [id | (id,_) <- in_binders]
- (map VarArg out_ids)
+ id_subst' = addOneToIdEnv id_subst in_id (SubstExpr ty_subst id_subst expr)
\end{code}
+
%************************************************************************
%* *
\subsubsection{The @OutIdEnv@}
%* *
%************************************************************************
-
-The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
-both locally-bound ones, and perhaps some imported ones too.
-
-\begin{code}
-type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
-
-\end{code}
-
-The "Id" part is just so that we can recover the domain of the mapping, which
-IdEnvs don't allow directly.
-
-The @BinderInfo@ tells about the occurrences of the @OutId@.
-Anything that isn't in here should be assumed to occur many times.
-We keep this info so we can modify it when something changes.
-
-The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
-
\begin{code}
-data RhsInfo = NoRhsInfo
- | OtherLit [Literal] -- It ain't one of these
- | OtherCon [Id] -- It ain't one of these
-
- -- InUnfolding is used for let(rec) bindings that
- -- are *definitely* going to be inlined.
- -- We record the un-simplified RHS and drop the binding
- | InUnfolding SimplEnv -- Un-simplified unfolding
- SimplifiableCoreExpr -- (need to snag envts therefore)
-
- | OutUnfolding CostCentre
- SimpleUnfolding -- Already-simplified unfolding
+lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
+lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
-lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
-lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
+lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
+lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
-lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
-lookupRhsInfo env id
+lookupUnfolding :: SimplEnv -> OutId -> Unfolding
+lookupUnfolding env id
= case lookupOutIdEnv env id of
Just (_,_,info) -> info
- Nothing -> NoRhsInfo
+ Nothing -> NoUnfolding
-modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
+ -> (OutId, BinderInfo, Unfolding)
modifyOutEnvItem (id, occ, info1) (_, _, info2)
= case (info1, info2) of
(OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
(OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
- (_, NoRhsInfo) -> (id,occ, info1)
+ (_, NoUnfolding) -> (id,occ, info1)
other -> (id,occ, info2)
\end{code}
\begin{code}
-isEvaluated :: RhsInfo -> Bool
+isEvaluated :: Unfolding -> Bool
isEvaluated (OtherLit _) = True
isEvaluated (OtherCon _) = True
-isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
+isEvaluated (CoreUnfolding ValueForm _ expr) = True
isEvaluated other = False
\end{code}
mkSimplUnfoldingGuidance chkr out_id rhs
= calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
-extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
+extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
out_id occ_info rhs_info
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
where
- new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
- (out_id, occ_info, rhs_info)
+ new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id
+ (out_id, occ_info, rhs_info)
\end{code}
\begin{code}
-modifyOccInfo out_id_env (uniq, new_occ)
- = modifyIdEnv_Directly modify_fn out_id_env uniq
+modifyOccInfo in_scope_ids uniq new_occ
+ = modifyIdEnv_Directly modify_fn in_scope_ids uniq
where
modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
-markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+markDangerousOccs (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) atoms
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps
where
- new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
+ new_in_scope_ids = foldl (modifyIdEnv modify_fn) in_scope_ids [v | VarArg v <- atoms]
modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
\end{code}
-\begin{code}
-extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv
-extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- id occ_info rhs
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
- where
- new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs)
-\end{code}
-
%************************************************************************
%* *
\subsubsection{The @ConAppMap@ type}
\end{code}
\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
+lookForConstructor env@(SimplEnv _ _ _ _ con_apps) (Con con args)
+ | switchIsSet env SimplReuseCon
= case lookupFM con_apps (UCA con val_args) of
Nothing -> Nothing
val_args = filter isValArg args -- Literals and Ids
ty_args = [ty | TyArg ty <- args] -- Just types
+lookForConstructor env other = Nothing
\end{code}
NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
= extendEnvGivenBinding env noBinderInfo out_id rhs
extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
occ_info out_id rhs
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
where
- new_out_id_env | okToInline (whnfOrBottom form)
- (couldBeSmallEnoughToInline guidance)
- occ_info
- = out_id_env_with_unfolding
- | otherwise
- = out_id_env
- -- Don't bother to extend the OutIdEnv unless there is some possibility
+ new_in_scope_ids | okToInline (whnfOrBottom form)
+ (couldBeSmallEnoughToInline out_id guidance)
+ occ_info
+ = env_with_unfolding
+ | otherwise
+ = in_scope_ids
+ -- Don't bother to munge the OutIdEnv unless there is some possibility
-- that the thing might be inlined. We check this by calling okToInline suitably.
new_con_apps = _scc_ "eegnr.conapps"
extendConApps con_apps out_id rhs
-- Modify the occ info for rhs's interesting free variables.
- out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
- foldl modifyOccInfo env1 full_fv_occ_info
- -- NB: full_fv_occ_info *combines* the occurrence of the current binder
- -- with the occurrences of its RHS's free variables. That's to take
- -- account of:
- -- let a = \x -> BIG in
- -- let b = \f -> f a
- -- in ...b...b...b...
- -- Here "a" occurs exactly once. "b" simplifies to a small value.
- -- So "b" will be inlined at each call site, and there's a good chance
- -- that "a" will too. So we'd better modify "a"s occurrence info to
- -- record the fact that it can now occur many times by virtue that "b" can.
-
- full_fv_occ_info = _scc_ "eegnr.full_fv"
- [ (uniq, fv_occ `andBinderInfo` occ_info)
- | (uniq, fv_occ) <- ufmToList fv_occ_info
- ]
+ -- That's to take account of:
+ -- let a = \x -> BIG in
+ -- let b = \f -> f a
+ -- in ...b...b...b...
+ -- Here "a" occurs exactly once. "b" simplifies to a small value.
+ -- So "b" will be inlined at each call site, and there's a good chance
+ -- that "a" will too. So we'd better modify "a"s occurrence info to
+ -- record the fact that it can now occur many times by virtue that "b" can.
+ env_with_unfolding = _scc_ "eegnr.modify_occ"
+ foldl zap env1 (ufmToList fv_occ_info)
+ zap env (uniq,_) = modifyOccInfo env uniq occ_info
+
-- Add an unfolding and rhs_info for the new Id.
- -- If the out_id is already in the OutIdEnv (which can happen if
- -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
+ -- If the out_id is already in the OutIdEnv (which should be the
+ -- case because it was put there by simplBinder)
-- then just replace the unfolding, leaving occurrence info alone.
env1 = _scc_ "eegnr.modify_out"
- addToUFM_C modifyOutEnvItem out_id_env out_id
+ addToUFM_C modifyOutEnvItem in_scope_ids out_id
(out_id, occ_info, rhs_info)
-- Occurrence-analyse the RHS
-- The "interesting" free variables we want occurrence info for are those
-- in the OutIdEnv that have only a single occurrence right now.
(fv_occ_info, template) = _scc_ "eegnr.occ-anal"
- occurAnalyseExpr is_interesting rhs
+ occurAnalyseExpr is_interesting rhs_w_cc
is_interesting v = _scc_ "eegnr.mkidset"
- case lookupIdEnv out_id_env v of
+ case lookupIdEnv in_scope_ids v of
Just (_, occ, _) -> isOneOcc occ
other -> False
-- Compute unfolding details
- rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
+ rhs_info = CoreUnfolding form guidance template
form = _scc_ "eegnr.form_sum"
mkFormSummary rhs
guidance = _scc_ "eegnr.guidance"
mkSimplUnfoldingGuidance chkr out_id rhs
- -- Compute cost centre for thing
- unf_cc | noCostCentreAttached expr_cc = encl_cc
- | otherwise = expr_cc
- where
- expr_cc = coreExprCc rhs
+ -- Attach a cost centre to the RHS if necessary
+ rhs_w_cc | currentOrSubsumedCosts encl_cc
+ || not (noCostCentreAttached (coreExprCc rhs))
+ = rhs
+ | otherwise
+ = SCC encl_cc rhs
\end{code}
projects / ghc-hetmet.git / blobdiff