\section[SimplEnv]{Environment stuff for the simplifier}
\begin{code}
-#include "HsVersions.h"
-
module SimplEnv (
- nullSimplEnv, combineSimplEnv,
- pprSimplEnv, -- debugging only
+ nullSimplEnv,
+ getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
+ emptySubstEnvs, getSubstEnvs,
- extendTyEnv, extendTyEnvList,
- simplTy, simplTyInId,
+ bindTyVar, bindTyVars, simplTy,
- extendIdEnvWithAtom, extendIdEnvWithAtoms,
- extendIdEnvWithClone, extendIdEnvWithClones,
- lookupId,
+ lookupIdSubst, lookupOutIdEnv,
+ bindIdToAtom, bindIdToExpr,
markDangerousOccs,
- lookupRhsInfo, lookupOutIdEnv, isEvaluated,
+ lookupUnfolding, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvForRecBinding, extendEnvGivenRhsInfo,
+ extendEnvGivenUnfolding,
lookForConstructor,
- getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch,
+ switchOffInlining, setCaseScrutinee,
setEnclosingCC, getEnclosingCC,
-- Types
- SYN_IE(SwitchChecker),
- SimplEnv,
- SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
+ SwitchChecker,
+ SimplEnv, SubstEnvs,
UnfoldConApp,
- RhsInfo(..),
+ SubstInfo(..),
- SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType),
- SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
+ InId, InBinder, InBinding, InType,
+ OutId, OutBinder, OutBinding, OutType,
- SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg),
- SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
+ InExpr, InAlts, InDefault, InArg,
+ OutExpr, OutAlts, OutDefault, OutArg
) where
-IMP_Ubiq(){-uitous-}
-
-IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
+#include "HsVersions.h"
-import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo,
- BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
+import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
+ isOneFunOcc,
+ BinderInfo
)
import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
SimplifierSwitch(..), SwitchResult(..)
)
import CoreSyn
-import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
- Unfolding(..), UfExpr, RdrName,
- SimpleUnfolding(..), FormSummary(..),
- calcUnfoldingGuidance, UnfoldingGuidance(..)
+import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
+ okToInline,
+ Unfolding(..), FormSummary(..),
+ calcUnfoldingGuidance )
+import CoreUtils ( coreExprCc )
+import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre,
+ costsAreSubsumed, noCostCentreAttached, subsumedCosts,
+ currentOrSubsumedCosts
)
-import CoreUtils ( coreExprCc, unTagBinders )
-import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
import FiniteMap -- lots of things
-import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
- applyTypeEnvToId,
- nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
- addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
- SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
-import Literal ( isNoRepLit, Literal{-instances-} )
-import Maybes ( maybeToBool, expectJust )
-import Name ( isLocallyDefined )
+import Id ( IdEnv, IdSet, Id,
+ getInlinePragma,
+ nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv,
+ addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
+ idMustBeINLINEd
+ )
+import Literal ( Literal )
+import Maybes ( expectJust )
import OccurAnal ( occurAnalyseExpr )
-import Outputable ( Outputable(..){-instances-} )
import PprCore -- various instances
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType, GenTyVar )
-import Pretty
-import Type ( eqTy, applyTypeEnvToTy )
-import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
- SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
- )
-import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_C, ufmToList, eltsUFM
+import Type ( instantiateTy, Type )
+import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
+ TyVarSet, emptyTyVarSet,
+ TyVar
)
---import UniqSet -- lots of things
-import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
-import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
-
-type TypeEnv = TyVarEnv Type
-cmpType = panic "cmpType (SimplEnv)"
+import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
+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
+
+type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo)
+
+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 noCostCentre nullTyVarEnv 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
+
+getSubstEnvs :: SimplEnv -> SubstEnvs
+getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst)
+
+emptySubstEnvs :: SubstEnvs
+emptySubstEnvs = (emptyTyVarEnv, nullIdEnv)
+
+setSubstEnvs :: SimplEnv -> SubstEnvs -> 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
+
+combineEnvs :: SimplEnv -- Get substitution from here
+ -> SimplEnv -- Get in-scope info from here
+ -> SimplEnv
+combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _)
+ (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
+ = 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
= expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-- Crude, but simple
+setCaseScrutinee :: SimplEnv -> SimplEnv
+setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps)
+ = SimplEnv chkr' encl_cc ty_env id_env con_apps
+ where
+ chkr' SimplCaseScrutinee = SwBool True
+ chkr' other = chkr other
+\end{code}
+
+@switchOffInlining@ is used to prepare the environment for simplifying
+the RHS of an Id that's marked with an INLINE pragma. It is going to
+be inlined wherever they are used, and then all the inlining will take
+effect. Meanwhile, there isn't much point in doing anything to the
+as-yet-un-INLINEd rhs. Furthermore, it's very important to switch off
+inlining! because
+ (a) not doing so will inline a worker straight back into its wrapper!
+
+and (b) Consider the following example
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+ Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+ and thence copied multiple times when g is inlined.
+
+ Andy disagrees! Example:
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+ Problem: any won't get deforested, and so if it's exported and
+ the importer doesn't use the inlining, (eg passes it as an arg)
+ then we won't get deforestation at all.
+ We havn't solved this problem yet!
+
+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.
+
+6/98 update:
+
+We don't prevent inlining from happening for identifiers
+that are marked as must-be-inlined. An example of where
+doing this is crucial is:
+
+ class Bar a => Foo a where
+ ...g....
+ {-# INLINE f #-}
+ f :: Foo a => a -> b
+ f x = ....Foo_sc1...
+
+If `f' needs to peer inside Foo's superclass, Bar, it refers
+to the appropriate super class selector, which is marked as
+must-inlineable. We don't generate any code for a superclass
+selector, so failing to inline it in the RHS of `f' will
+leave a reference to a non-existent id, with bad consequences.
+
+\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 out_id_env con_apps
+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
- chkr' EssentialUnfoldingsOnly = SwBool True
- chkr' other = chkr other
+ forget (id, binder_info, rhs_info)
+ | idMustBeINLINEd id = (id, binder_info, rhs_info)
+ | otherwise = (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 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
+\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 = addOneToTyVarEnv ty_env tyvar ty
+ new_ty_subst = addToTyVarEnv ty_subst 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
+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 = growTyVarEnvList ty_env pairs
+ new_ty_subst = ty_subst `plusTyVarEnv` extra_subst
+\end{code}
-simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
-simplTyInId (SimplEnv _ _ ty_env _ _ _) id = 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 -> OutArg
-
-lookupId (SimplEnv _ _ _ in_id_env _ _) id
- = case (lookupIdEnv in_id_env id) of
- Just atom -> atom
- Nothing -> 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 SimplEnv -- Un-simplified unfolding
- SimpleUnfolding -- (need to snag envts therefore)
+lookupIdSubst :: SimplEnv -> InId -> Maybe SubstInfo
+lookupIdSubst (SimplEnv _ _ _ (_, id_subst) _) id = lookupIdEnv id_subst id
- | OutUnfolding CostCentre
- SimpleUnfolding -- Already-simplified unfolding
+lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId, BinderInfo, Unfolding)
+lookupOutIdEnv (SimplEnv _ _ _ (in_scope_ids, _) _) id = lookupIdEnv in_scope_ids id
-lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
-lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
-
-lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
-lookupRhsInfo env id
+lookupUnfolding :: SimplEnv -> OutId -> Unfolding
+lookupUnfolding env id
= case lookupOutIdEnv env id of
Just (_,_,info) -> info
- Nothing -> NoRhsInfo
-
-modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
- -> (OutId, BinderInfo, RhsInfo)
-modifyOutEnvItem (id, occ, info1) (_, _, info2)
- = case (info1, info2) of
- (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
- (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
- (_, NoRhsInfo) -> (id,occ, info1)
- other -> (id,occ, info2)
-
---(id, occ, new_info)
-{-
- where
- new_info = case (info1, info2) of
+ Nothing -> NoUnfolding
+
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) -- Existing
+ -> (OutId, BinderInfo, Unfolding) -- New
+ -> (OutId, BinderInfo, Unfolding)
+modifyOutEnvItem (_, _, info1) (id, occ, info2)
+ = (id, occ, case (info1, info2) of
(OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
(OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
- (_, NoRhsInfo) -> info1
- other -> info2
--}
+ (_, NoUnfolding) -> info1
+ other -> info2)
\end{code}
\begin{code}
-isEvaluated :: RhsInfo -> Bool
+isEvaluated :: Unfolding -> Bool
isEvaluated (OtherLit _) = True
isEvaluated (OtherCon _) = True
-isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
-isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
+isEvaluated (CoreUnfolding ValueForm _ expr) = True
isEvaluated other = False
\end{code}
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
-of a new binding. There is a horrid case we have to take care about,
-due to Andr\'e Santos:
-@
- type Array_type b = Array Int b;
- type Descr_type = (Int,Int);
- tabulate :: (Int -> x) -> Descr_type -> Array_type x;
- tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
-
- f_iaamain a_xs=
- let {
- f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
- f_aareorder a_index a_ar=
- let {
- f_aareorder' a_i= a_ar ! (a_index ! a_i)
- } in tabulate f_aareorder' (bounds a_ar);
- r_index=tabulate ((+) 1) (1,1);
- arr = listArray (1,1) a_xs;
- arg = f_aareorder r_index arr
- } in elems arg
-@
-Now, when the RHS of arg gets simplified, we inline f_aareorder to get
-@
- arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
- in tabulate f_aareorder' (bounds arr)
-@
-Note that r_index is not inlined, because it was bound to a_index which
-occurs inside a lambda.
-
-Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
-then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
-analyse it, we won't spot the inside-lambda property of r_index, so r_index
-will get inlined inside the lambda. AARGH.
-
-Solution: when we occurrence-analyse the new RHS we have to go back
-and modify the info recorded in the UnfoldEnv for the free vars
-of the RHS. In the example we'd go back and record that r_index is now used
-inside a lambda.
\begin{code}
-extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenNewRhs env out_id rhs
- = extendEnvGivenBinding env noBinderInfo out_id rhs
-
-extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
-extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- occ_info out_id rhs
- = let
- s_env = SimplEnv chkr encl_cc ty_env in_id_env out_id_env new_con_apps
- s_env_uf = SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding new_con_apps
- in
- case guidance of
- -- Cheap and nasty hack to force strict insertion.
- UnfoldNever ->
- if isEmptyFM new_con_apps then s_env else s_env
- other ->
- if isEmptyFM new_con_apps then s_env_uf else s_env_uf
- where
- new_con_apps = extendConApps con_apps out_id rhs
-{-
- new_out_id_env = case guidance of
- UnfoldNever -> out_id_env -- No new stuff to put in
- other -> out_id_env_with_unfolding
--}
- -- If there is an unfolding, we add rhs-info for out_id,
- -- *and* modify the occ info for rhs's interesting free variables.
- --
- -- If the out_id is already in the OutIdEnv, then just replace the
- -- unfolding, leaving occurrence info alone (this must then
- -- be a call via extendEnvGivenNewRhs).
- out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info
- -- full_fv_occ_info combines the occurrence of the current binder
- -- with the occurrences of its RHS's free variables.
- full_fv_occ_info = [ (uniq, fv_occ `andBinderInfo` occ_info)
- | (uniq,fv_occ) <- ufmToList fv_occ_info
- ]
- env1 = addToUFM_C modifyOutEnvItem out_id_env out_id
- (out_id, occ_info, rhs_info)
-
- -- Occurrence-analyse the RHS
- -- The "interesting" free variables we want occurrence info for are those
- -- in the OutIdEnv that have only a single occurrence right now.
- (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
- interesting_fvs = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
-
- -- Compute unfolding details
- rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
- form_summary = mkFormSummary rhs
-
- guidance = mkSimplUnfoldingGuidance chkr out_id rhs
-
- -- Compute cost centre for thing
- unf_cc | noCostCentreAttached expr_cc = encl_cc
- | otherwise = expr_cc
- where
- expr_cc = coreExprCc rhs
-\end{code}
-
-
-
-Recursive bindings
-~~~~~~~~~~~~~~~~~~
-We need to be pretty careful when extending
-the environment with RHS info in recursive groups.
-
-Here's a nasty example:
-
- letrec r = f x
- t = r
- x = ...t...
- in
- ...t...
-
-Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
-But the pre-simplified t's rhs is an atom, r, so we may also decide to
-inline t everywhere. But if we do *both* these reasonable things we get
-
- letrec r = f x
- t = f x
- x = ...r...
- in
- ...t...
-
-Bad news! (f x) is duplicated! (The t in the body doesn't get
-inlined because by the time the recursive group is done we see that
-t's RHS isn't an atom.)
-
-Our solution is this:
- (a) we inline un-simplified RHSs, and then simplify
- them in a clone-only environment.
- (b) we inline only variables and values
-This means that
-
-
- r = f x ==> r = f x
- t = r ==> t = r
- x = ...t... ==> x = ...r...
- in in
- t r
-
-Now t is dead, and we're home.
-
-Most silly x=y bindings in recursive group will go away. But not all:
-
- let y = 1:x
- x = y
-
-Here, we can't inline x because it's in an argument position. so we'll just replace
-with a clone of y. Instead we'll probably inline y (a small value) to give
-
- let y = 1:x
- x = 1:y
-
-which is OK if not clever.
-
-\begin{code}
-extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- (out_id, ((_,occ_info), old_rhs))
- = case (form_summary, guidance) of
- (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
- (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
- (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
- other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable
-
--- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
- where
-{-
- new_out_id_env = case (form_summary, guidance) of
- (_, UnfoldNever) -> out_id_env -- No new stuff to put in
- (ValueForm, _) -> out_id_env_with_unfolding
- (VarForm, _) -> out_id_env_with_unfolding
- other -> out_id_env -- Not a value or variable
--}
- -- If there is an unfolding, we add rhs-info for out_id,
- -- No need to modify occ info because RHS is pre-simplification
- out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
- (out_id, occ_info, rhs_info)
-
- -- Compute unfolding details
- -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
- -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once.
- -- Only if the thing is still small enough next time round will we inline again.
- rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
- form_summary = mkFormSummary old_rhs
- guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
-
-
-mkSimplUnfoldingGuidance chkr out_id rhs
- = case calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs of
- UnfoldNever -> UnfoldNever
- v -> v
- where
- inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
-
-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 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}
-
%************************************************************************
%* *
\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
Just assocs -> case [id | (tys, id) <- assocs,
- and (zipWith eqTy tys ty_args)]
+ and (zipWith (==) tys ty_args)]
of
[] -> Nothing
(id:_) -> Just id
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
\begin{code}
instance Eq UnfoldConApp where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord UnfoldConApp where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance Ord3 UnfoldConApp where
- cmp = cmp_app
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmp_app a b
cmp_app (UCA c1 as1) (UCA c2 as2)
- = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
+ = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
where
- -- ToDo: make an "instance Ord3 CoreArg"???
+ -- ToDo: make an "instance Ord CoreArg"???
- cmp_arg (VarArg x) (VarArg y) = x `cmp` y
- cmp_arg (LitArg x) (LitArg y) = x `cmp` y
- cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
- cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
+ cmp_arg (VarArg x) (VarArg y) = x `compare` y
+ cmp_arg (LitArg x) (LitArg y) = x `compare` y
+ cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs"
cmp_arg x y
- | tag x _LT_ tag y = LT_
- | otherwise = GT_
+ | tag x _LT_ tag y = LT
+ | otherwise = GT
where
tag (VarArg _) = ILIT(1)
tag (LitArg _) = ILIT(2)
tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
- tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
\end{code}
+@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
+of a new binding. There is a horrid case we have to take care about,
+due to Andr\'e Santos:
+@
+ type Array_type b = Array Int b;
+ type Descr_type = (Int,Int);
+
+ tabulate :: (Int -> x) -> Descr_type -> Array_type x;
+ tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
+
+ f_iaamain a_xs=
+ let {
+ f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
+ f_aareorder a_index a_ar=
+ let {
+ f_aareorder' a_i= a_ar ! (a_index ! a_i)
+ } in tabulate f_aareorder' (bounds a_ar);
+ r_index=tabulate ((+) 1) (1,1);
+ arr = listArray (1,1) a_xs;
+ arg = f_aareorder r_index arr
+ } in elems arg
+@
+Now, when the RHS of arg gets simplified, we inline f_aareorder to get
+@
+ arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
+ in tabulate f_aareorder' (bounds arr)
+@
+Note that r_index is not inlined, because it was bound to a_index which
+occurs inside a lambda.
+
+Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
+then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
+analyse it, we won't spot the inside-lambda property of r_index, so r_index
+will get inlined inside the lambda. AARGH.
+
+Solution: when we occurrence-analyse the new RHS we have to go back
+and modify the info recorded in the UnfoldEnv for the free vars
+of the RHS. In the example we'd go back and record that r_index is now used
+inside a lambda.
+\begin{code}
+extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenNewRhs env out_id rhs
+ = extendEnvGivenBinding env noBinderInfo out_id rhs
+
+extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
+extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
+ occ_info out_id rhs
+ = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
+ where
+ new_in_scope_ids | okToInline out_id
+ (whnfOrBottom form)
+ (couldBeSmallEnoughToInline out_id guidance)
+ occ_info
+ = env_with_unfolding
+ | otherwise
+ = in_scope_ids
+ -- Don't bother to munge the OutIdEnv unless there is some possibility
+ -- that the thing might be inlined. We check this by calling okToInline suitably.
+
+ new_con_apps = _scc_ "eegnr.conapps"
+ extendConApps con_apps out_id rhs
+
+ -- Modify the occ info for rhs's interesting free variables.
+ -- That's to take account of:
+ -- let a = \x -> BIG in
+ -- let b = \f -> f a
+ -- in ...b...b...b...
+ -- Here "a" occurs exactly once. "b" simplifies to a small value.
+ -- So "b" will be inlined at each call site, and there's a good chance
+ -- that "a" will too. So we'd better modify "a"s occurrence info to
+ -- record the fact that it can now occur many times by virtue that "b" can.
+ env_with_unfolding = _scc_ "eegnr.modify_occ"
+ foldl zap env1 (ufmToList fv_occ_info)
+ zap env (uniq,_) = modifyOccInfo env uniq occ_info
+
+
+ -- Add an unfolding and rhs_info for the new Id.
+ -- If the out_id is already in the OutIdEnv (which should be the
+ -- case because it was put there by simplBinder)
+ -- then just replace the unfolding, leaving occurrence info alone.
+ env1 = _scc_ "eegnr.modify_out"
+ addToUFM_C modifyOutEnvItem in_scope_ids out_id
+ (out_id, occ_info, rhs_info)
+
+ -- Occurrence-analyse the RHS
+ -- The "interesting" free variables we want occurrence info for are those
+ -- in the OutIdEnv that have only a single occurrence right now.
+ (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
+ occurAnalyseExpr is_interesting rhs_w_cc
+
+ is_interesting v = _scc_ "eegnr.mkidset"
+ case lookupIdEnv in_scope_ids v of
+ Just (_, occ, _) -> isOneOcc occ
+ other -> False
+
+ -- Compute unfolding details
+ rhs_info = CoreUnfolding form guidance template
+ form = _scc_ "eegnr.form_sum"
+ mkFormSummary rhs
+ guidance = _scc_ "eegnr.guidance"
+ calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+
+ -- Attach a cost centre to the RHS if necessary
+ rhs_w_cc | currentOrSubsumedCosts encl_cc
+ || not (noCostCentreAttached (coreExprCc rhs))
+ = rhs
+ | otherwise
+ = Note (SCC encl_cc) rhs
+\end{code}
projects / ghc-hetmet.git / blobdiff