Commit c177e43f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactoring of the way that inlinings and rules are activated

Principally, the SimplifierMode now carries several (currently
four) flags in *all* phases, not just the "Gentle" phase.
This makes things simpler and more uniform.

As usual I did more refactoring than I had intended.

This stuff should go into 7.0.2 in due course, once
we've checked it solves the DPH performance problems.
parent a0f04208
......@@ -59,8 +59,9 @@ module BasicTypes(
DefMethSpec(..),
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
CompilerPhase(..), PhaseNum,
Activation(..), isActive, isActiveIn,
isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlineSpec(..),
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
......@@ -637,14 +638,22 @@ failed Failed = True
When a rule or inlining is active
\begin{code}
type CompilerPhase = Int -- Compilation phase
-- Phases decrease towards zero
-- Zero is the last phase
type PhaseNum = Int -- Compilation phase
-- Phases decrease towards zero
-- Zero is the last phase
data CompilerPhase
= Phase PhaseNum
| InitialPhase -- The first phase -- number = infinity!
instance Outputable CompilerPhase where
ppr (Phase n) = int n
ppr InitialPhase = ptext (sLit "InitialPhase")
data Activation = NeverActive
| AlwaysActive
| ActiveBefore CompilerPhase -- Active only *before* this phase
| ActiveAfter CompilerPhase -- Active in this phase and later
| ActiveBefore PhaseNum -- Active only *before* this phase
| ActiveAfter PhaseNum -- Active in this phase and later
deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls
data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma]
......@@ -830,10 +839,16 @@ instance Outputable InlinePragma where
| otherwise = ppr info
isActive :: CompilerPhase -> Activation -> Bool
isActive _ NeverActive = False
isActive _ AlwaysActive = True
isActive p (ActiveAfter n) = p <= n
isActive p (ActiveBefore n) = p > n
isActive InitialPhase AlwaysActive = True
isActive InitialPhase (ActiveBefore {}) = True
isActive InitialPhase _ = False
isActive (Phase p) act = isActiveIn p act
isActiveIn :: PhaseNum -> Activation -> Bool
isActiveIn _ NeverActive = False
isActiveIn _ AlwaysActive = True
isActiveIn p (ActiveAfter n) = p <= n
isActiveIn p (ActiveBefore n) = p > n
isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
isNeverActive NeverActive = True
......
......@@ -300,6 +300,7 @@ mkDataConIds wrap_name wkr_name data_con
`setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig
......
......@@ -49,7 +49,7 @@ module CoreSyn (
maybeUnfoldingTemplate, otherCons, unfoldingArity,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isStableUnfolding_maybe,
isStableUnfolding, isStableCoreUnfolding_maybe,
isClosedUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
......@@ -70,7 +70,7 @@ module CoreSyn (
RuleName, IdUnfoldingFun,
-- ** Operations on 'CoreRule's
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName,
isBuiltinRule, isLocalRule
) where
......@@ -384,9 +384,9 @@ ruleArity (Rule {ru_args = args}) = length args
ruleName :: CoreRule -> RuleName
ruleName = ru_name
ruleActivation_maybe :: CoreRule -> Maybe Activation
ruleActivation_maybe (BuiltinRule { }) = Nothing
ruleActivation_maybe (Rule { ru_act = act }) = Just act
ruleActivation :: CoreRule -> Activation
ruleActivation (BuiltinRule { }) = AlwaysActive
ruleActivation (Rule { ru_act = act }) = act
-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
ruleIdName :: CoreRule -> Name
......@@ -669,15 +669,10 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
expandUnfolding_maybe _ = Nothing
isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
| isStableSource src
= Just (src, unsat_ok)
where
unsat_ok = case guide of
UnfWhen unsat_ok _ -> unsat_ok
_ -> needSaturated
isStableUnfolding_maybe _ = Nothing
isStableCoreUnfolding_maybe :: Unfolding -> Maybe UnfoldingSource
isStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src })
| isStableSource src = Just src
isStableCoreUnfolding_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
......
......@@ -730,13 +730,12 @@ StrictAnal.addStrictnessInfoToTopId
\begin{code}
callSiteInline :: DynFlags
-> Id -- The Id
-> Unfolding -- Its unfolding (if active)
-> Bool -- True <=> unfolding is active
-> Bool -- True if there are are no arguments at all (incl type args)
-> [ArgSummary] -- One for each value arg; True if it is interesting
-> CallCtxt -- True <=> continuation is interesting
-> Maybe CoreExpr -- Unfolding, if any
instance Outputable ArgSummary where
ppr TrivArg = ptext (sLit "TrivArg")
ppr NonTrivArg = ptext (sLit "NonTrivArg")
......@@ -765,67 +764,32 @@ instance Outputable CallCtxt where
ppr CaseCtxt = ptext (sLit "CaseCtxt")
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
callSiteInline dflags id unfolding lone_variable arg_infos cont_info
= case unfolding of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
DFunUnfolding {} -> Nothing ; -- Never unfold a DFun
CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top,
uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } ->
callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
= case idUnfolding id of
-- idUnfolding checks for loop-breakers, returning NoUnfolding
-- Things with an INLINE pragma may have an unfolding *and*
-- be a loop breaker (maybe the knot is not yet untied)
CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
, uf_is_cheap = is_cheap, uf_arity = uf_arity
, uf_guidance = guidance }
| active_unfolding -> tryUnfolding dflags id lone_variable
arg_infos cont_info unf_template is_top
is_cheap uf_arity guidance
| otherwise -> Nothing
NoUnfolding -> Nothing
OtherCon {} -> Nothing
DFunUnfolding {} -> Nothing -- Never unfold a DFun
tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
-> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding dflags id lone_variable
arg_infos cont_info unf_template is_top
is_cheap uf_arity guidance
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
let
n_val_args = length arg_infos
saturated = n_val_args >= uf_arity
result | yes_or_no = Just unf_template
| otherwise = Nothing
interesting_args = any nonTriv arg_infos
-- NB: (any nonTriv arg_infos) looks at the
-- over-saturated args too which is "wrong";
-- but if over-saturated we inline anyway.
-- some_benefit is used when the RHS is small enough
-- and the call has enough (or too many) value
-- arguments (ie n_val_args >= arity). But there must
-- be *something* interesting about some argument, or the
-- result context, to make it worth inlining
some_benefit
| not saturated = interesting_args -- Under-saturated
-- Note [Unsaturated applications]
| n_val_args > uf_arity = True -- Over-saturated
| otherwise = interesting_args -- Saturated
|| interesting_saturated_call
interesting_saturated_call
= case cont_info of
BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables]
ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
ValAppCtxt -> True -- Note [Cast then apply]
(yes_or_no, extra_doc)
= case guidance of
UnfNever -> (False, empty)
UnfWhen unsat_ok boring_ok
-> (enough_args && (boring_ok || some_benefit), empty )
where -- See Note [INLINE for small functions]
enough_args = saturated || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
-> ( is_cheap && some_benefit && small_enough
, (text "discounted size =" <+> int discounted_size) )
where
discounted_size = size - discount
small_enough = discounted_size <= opt_UF_UseThreshold
discount = computeDiscount uf_arity arg_discounts
res_discount arg_infos cont_info
in
if (dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags) then
pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
| dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
= pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
(vcat [text "arg infos" <+> ppr arg_infos,
text "uf arity" <+> ppr uf_arity,
text "interesting continuation" <+> ppr cont_info,
......@@ -834,10 +798,57 @@ callSiteInline dflags id unfolding lone_variable arg_infos cont_info
text "guidance" <+> ppr guidance,
extra_doc,
text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
result
else
result
}
result
| otherwise = result
where
n_val_args = length arg_infos
saturated = n_val_args >= uf_arity
result | yes_or_no = Just unf_template
| otherwise = Nothing
interesting_args = any nonTriv arg_infos
-- NB: (any nonTriv arg_infos) looks at the
-- over-saturated args too which is "wrong";
-- but if over-saturated we inline anyway.
-- some_benefit is used when the RHS is small enough
-- and the call has enough (or too many) value
-- arguments (ie n_val_args >= arity). But there must
-- be *something* interesting about some argument, or the
-- result context, to make it worth inlining
some_benefit
| not saturated = interesting_args -- Under-saturated
-- Note [Unsaturated applications]
| n_val_args > uf_arity = True -- Over-saturated
| otherwise = interesting_args -- Saturated
|| interesting_saturated_call
interesting_saturated_call
= case cont_info of
BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables]
ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
ValAppCtxt -> True -- Note [Cast then apply]
(yes_or_no, extra_doc)
= case guidance of
UnfNever -> (False, empty)
UnfWhen unsat_ok boring_ok
-> (enough_args && (boring_ok || some_benefit), empty )
where -- See Note [INLINE for small functions]
enough_args = saturated || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
-> ( is_cheap && some_benefit && small_enough
, (text "discounted size =" <+> int discounted_size) )
where
discounted_size = size - discount
small_enough = discounted_size <= opt_UF_UseThreshold
discount = computeDiscount uf_arity arg_discounts
res_discount arg_infos cont_info
\end{code}
Note [RHS of lets]
......
This diff is collapsed.
%
% (c) The AQUA Project, Glasgow University, 1993-1998
o% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}
......@@ -12,18 +12,14 @@ module SimplEnv (
-- The simplifier mode
setMode, getMode, updMode,
-- Switch checker
SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
isAmongSimpl, intSwitchSet, switchIsOn,
setEnclosingCC, getEnclosingCC,
setEnclosingCC, getEnclosingCC,
-- Environments
SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules, inGentleMode,
getSimplRules,
SimplSR(..), mkContEx, substId, lookupRecBndr,
......@@ -106,8 +102,7 @@ data SimplEnv
-- wrt the original expression
seMode :: SimplifierMode,
seChkr :: SwitchChecker,
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
-- The current substitution
seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
......@@ -223,18 +218,14 @@ seIdSubst:
\begin{code}
mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv
mkSimplEnv switches mode
= SimplEnv { seChkr = switches, seCC = subsumedCCS,
mkSimplEnv :: SimplifierMode -> SimplEnv
mkSimplEnv mode
= SimplEnv { seCC = subsumedCCS,
seMode = mode, seInScope = emptyInScopeSet,
seFloats = emptyFloats,
seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
---------------------
getSwitchChecker :: SimplEnv -> SwitchChecker
getSwitchChecker env = seChkr env
---------------------
getMode :: SimplEnv -> SimplifierMode
getMode env = seMode env
......@@ -245,11 +236,6 @@ setMode mode env = env { seMode = mode }
updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
updMode upd env = env { seMode = upd (seMode env) }
inGentleMode :: SimplEnv -> Bool
inGentleMode env = case seMode env of
SimplGently {} -> True
_other -> False
---------------------
getEnclosingCC :: SimplEnv -> CostCentreStack
getEnclosingCC env = seCC env
......
......@@ -16,11 +16,7 @@ module SimplMonad (
-- Counting
SimplCount, tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
-- Switch checker
SwitchChecker, SwitchResult(..), getSimplIntSwitch,
isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
plusSimplCount, isZeroSimplCount
) where
import Id ( Id, mkSysLocal )
......@@ -29,14 +25,8 @@ import FamInstEnv ( FamInstEnv )
import Rules ( RuleBase )
import UniqSupply
import DynFlags ( DynFlags )
import Maybes ( expectJust )
import CoreMonad
import FastString
import Outputable
import FastTypes
import Data.Array
import Data.Array.Base (unsafeAt)
\end{code}
%************************************************************************
......@@ -162,99 +152,3 @@ freeTick t
= SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
in sc' `seq` ((), us, sc'))
\end{code}
%************************************************************************
%* *
\subsubsection{Command-line switches}
%* *
%************************************************************************
\begin{code}
type SwitchChecker = SimplifierSwitch -> SwitchResult
data SwitchResult
= SwBool Bool -- on/off
| SwString FastString -- nothing or a String
| SwInt Int -- nothing or an Int
allOffSwitchChecker :: SwitchChecker
allOffSwitchChecker _ = SwBool False
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
-- in the list; defaults right at the end.
= let
tidied_on_switches = foldl rm_dups [] on_switches
-- The fold*l* ensures that we keep the latest switches;
-- ie the ones that occur earliest in the list.
sw_tbl :: Array Int SwitchResult
sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
all_undefined)
// defined_elems
all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
defined_elems = map mk_assoc_elem tidied_on_switches
in
-- (avoid some unboxing, bounds checking, and other horrible things:)
\ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
where
mk_assoc_elem k
= (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
-- cannot have duplicates if we are going to use the array thing
rm_dups switches_so_far switch
= if switch `is_elem` switches_so_far
then switches_so_far
else switch : switches_so_far
where
_ `is_elem` [] = False
sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
|| sw `is_elem` ss
\end{code}
\begin{code}
getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
getSimplIntSwitch chkr switch
= expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
switchIsOn lookup_fn switch
= case (lookup_fn switch) of
SwBool False -> False
_ -> True
intSwitchSet :: (switch -> SwitchResult)
-> (Int -> switch)
-> Maybe Int
intSwitchSet lookup_fn switch
= case (lookup_fn (switch (panic "intSwitchSet"))) of
SwInt int -> Just int
_ -> Nothing
\end{code}
These things behave just like enumeration types.
\begin{code}
instance Eq SimplifierSwitch where
a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
instance Ord SimplifierSwitch where
a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
tagOf_SimplSwitch NoCaseOfCase = _ILIT(1)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
lAST_SIMPL_SWITCH_TAG :: Int
lAST_SIMPL_SWITCH_TAG = 2
\end{code}
This diff is collapsed.
......@@ -24,7 +24,7 @@ import Coercion
import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import CoreMonad ( Tick(..), SimplifierMode(..) )
import CoreSyn
import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
......@@ -237,7 +237,7 @@ simplTopBinds env0 binds0
trace_bind False _ = \x -> x
simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
where
(env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
......@@ -272,7 +272,7 @@ simplRecBind env0 top_lvl pairs0
go env [] = return env
go env ((old_bndr, new_bndr, rhs) : pairs)
= do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
= do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
; go env' pairs }
\end{code}
......@@ -284,18 +284,17 @@ It assumes the binder has already been simplified, but not its IdInfo.
\begin{code}
simplRecOrTopPair :: SimplEnv
-> TopLevelFlag
-> TopLevelFlag -> RecFlag
-> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM SimplEnv -- Returns an env that includes the binding
simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
| preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
= do { tick (PreInlineUnconditionally old_bndr)
; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
| otherwise
= simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
-- May not actually be recursive, but it doesn't matter
= simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
\end{code}
......@@ -902,7 +901,7 @@ simplExprF' env (Type ty) cont
; rebuild env (Type ty') cont }
simplExprF' env (Case scrut bndr _ alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
| sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
......@@ -1355,7 +1354,7 @@ tryRules env rules fn args call_cont
; case activeRule dflags env of {
Nothing -> return Nothing ; -- No rules apply
Just act_fn ->
case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of {
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->
......@@ -1508,7 +1507,7 @@ rebuildCase env scrut case_bndr alts cont
Nothing -> missingAlt env case_bndr alts cont
Just (_, bs, rhs) -> simple_rhs bs rhs }
| Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
| Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
-- Works when the scrutinee is a variable with a known unfolding
-- as well as when it's an explicit constructor application
= do { tick (KnownBranch case_bndr)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment