DefMethSpec(..),
- CompilerPhase,
- Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
+ CompilerPhase(..), PhaseNum,
+ Activation(..), isActive, isActiveIn,
+ isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlineSpec(..),
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
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]
| 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
`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
maybeUnfoldingTemplate, otherCons, unfoldingArity,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
- isStableUnfolding, isStableUnfolding_maybe,
+ isStableUnfolding, isStableCoreUnfolding_maybe,
isClosedUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
RuleName, IdUnfoldingFun,
-- ** Operations on 'CoreRule's
- seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
+ seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName,
isBuiltinRule, isLocalRule
) where
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
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
\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")
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,
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]
-- * Configuration of the core-to-core passes
CoreToDo(..),
SimplifierMode(..),
- SimplifierSwitch(..),
FloatOutSwitches(..),
getCoreToDo, dumpSimplPhase,
import DynFlags
import StaticFlags
import Rules ( RuleBase )
-import BasicTypes ( CompilerPhase )
+import BasicTypes ( CompilerPhase(..) )
import Annotations
import Id ( Id )
showLintWarnings :: CoreToDo -> Bool
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
-showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
-showLintWarnings _ = True
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
\end{code}
-- as many times as you like.
= CoreDoSimplify -- The core-to-core simplifier.
+ Int -- Max iterations
SimplifierMode
- Int -- Max iterations
- [SimplifierSwitch] -- Each run of the simplifier can take a different
- -- set of simplifier-specific flags.
+
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
coreDumpFlag (CoreDoPasses {}) = Nothing
instance Outputable CoreToDo where
- ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
- <+> ppr md
+ ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier")
+ <+> ppr md
<+> ptext (sLit "max-iterations=") <> int n
ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
\begin{code}
data SimplifierMode -- See comments in SimplMonad
- = SimplGently
- { sm_rules :: Bool -- Whether RULES are enabled
- , sm_inline :: Bool } -- Whether inlining is enabled
-
- | SimplPhase
- { sm_num :: Int -- Phase number; counts downward so 0 is last phase
- , sm_names :: [String] } -- Name(s) of the phase
+ = SimplMode
+ { sm_names :: [String] -- Name(s) of the phase
+ , sm_phase :: CompilerPhase
+ , sm_rules :: Bool -- Whether RULES are enabled
+ , sm_inline :: Bool -- Whether inlining is enabled
+ , sm_case_case :: Bool -- Whether case-of-case is enabled
+ , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
+ }
instance Outputable SimplifierMode where
- ppr (SimplPhase { sm_num = n, sm_names = ss })
- = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
- ppr (SimplGently { sm_rules = r, sm_inline = i })
- = ptext (sLit "gentle") <>
- brackets (pp_flag r (sLit "rules") <> comma <>
- pp_flag i (sLit "inline"))
+ ppr (SimplMode { sm_phase = p, sm_names = ss
+ , sm_rules = r, sm_inline = i
+ , sm_eta_expand = eta, sm_case_case = cc })
+ = ptext (sLit "SimplMode") <+> braces (
+ sep [ ptext (sLit "Phase =") <+> ppr p <+>
+ brackets (text (concat $ intersperse "," ss)) <> comma
+ , pp_flag i (sLit "inline") <> comma
+ , pp_flag r (sLit "rules") <> comma
+ , pp_flag eta (sLit "eta-expand") <> comma
+ , pp_flag cc (sLit "case-of-case") ])
where
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
-
-data SimplifierSwitch
- = NoCaseOfCase
\end{code}
\begin{code}
data FloatOutSwitches = FloatOutSwitches {
- floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
- floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
- -- even if they do not escape a lambda
- floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
+ floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
+ -- doing so will abstract over n or fewer
+ -- value variables
+ -- Nothing <=> float all lambdas to top level,
+ -- regardless of how many free variables
+ -- Just 0 is the vanilla case: float a lambda
+ -- iff it has no free vars
+
+ floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
+ -- even if they do not escape a lambda
+ floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
-- based on arity information.
- }
+ }
instance Outputable FloatOutSwitches where
ppr = pprFloatOutSwitches
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
-pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
- <+> pp_not (floatOutConstants sw) <+> text "constants"
- where
- pp_not True = empty
- pp_not False = text "not"
-
--- | Switches that specify the minimum amount of floating out
--- gentleFloatOutSwitches :: FloatOutSwitches
--- gentleFloatOutSwitches = FloatOutSwitches False False
+pprFloatOutSwitches sw
+ = ptext (sLit "FOS") <+> (braces $
+ sep $ punctuate comma $
+ [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
+ , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
+ , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
\end{code}
getCoreToDo dflags
= core_todo
where
- opt_level = optLevel dflags
- phases = simplPhases dflags
+ opt_level = optLevel dflags
+ phases = simplPhases dflags
max_iter = maxSimplIterations dflags
- strictness = dopt Opt_Strictness dflags
- full_laziness = dopt Opt_FullLaziness dflags
- do_specialise = dopt Opt_Specialise dflags
- do_float_in = dopt Opt_FloatIn dflags
- cse = dopt Opt_CSE dflags
- spec_constr = dopt Opt_SpecConstr dflags
- liberate_case = dopt Opt_LiberateCase dflags
- rule_check = ruleCheck dflags
+ rule_check = ruleCheck dflags
+ strictness = dopt Opt_Strictness dflags
+ full_laziness = dopt Opt_FullLaziness dflags
+ do_specialise = dopt Opt_Specialise dflags
+ do_float_in = dopt Opt_FloatIn dflags
+ cse = dopt Opt_CSE dflags
+ spec_constr = dopt Opt_SpecConstr dflags
+ liberate_case = dopt Opt_LiberateCase dflags
static_args = dopt Opt_StaticArgumentTransformation dflags
+ rules_on = dopt Opt_EnableRewriteRules dflags
+ eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before phase
= runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+ base_mode = SimplMode { sm_phase = panic "base_mode"
+ , sm_names = []
+ , sm_rules = rules_on
+ , sm_eta_expand = eta_expand_on
+ , sm_inline = True
+ , sm_case_case = True }
+
simpl_phase phase names iter
= CoreDoPasses
[ maybe_strictness_before phase
- , CoreDoSimplify (SimplPhase phase names)
- iter []
- , maybe_rule_check phase
+ , CoreDoSimplify iter
+ (base_mode { sm_phase = Phase phase
+ , sm_names = names })
+
+ , maybe_rule_check (Phase phase)
]
vectorisation
-- strictness in the function sumcode' if augment is not inlined
-- before strictness analysis runs
simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
- | phase <- [phases, phases-1 .. 1] ]
+ | phase <- [phases, phases-1 .. 1] ]
-- initial simplify: mk specialiser happy: minimum effort please
- simpl_gently = CoreDoSimplify
- (SimplGently { sm_rules = True, sm_inline = False })
- -- See Note [Gentle mode] and
- -- Note [RULEs enabled in SimplGently] in SimplUtils
- max_iter
- [
-
-
- NoCaseOfCase -- Don't do case-of-case transformations.
- -- This makes full laziness work better
- ]
+ simpl_gently = CoreDoSimplify max_iter
+ (base_mode { sm_phase = InitialPhase
+ , sm_names = ["Gentle"]
+ , sm_rules = True -- Note [RULEs enabled in SimplGently]
+ , sm_inline = False
+ , sm_case_case = False })
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
core_todo =
if opt_level == 0 then
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
- floatOutLambdas = False,
+ floatOutLambdas = Just 0,
floatOutConstants = True,
floatOutPartialApplications = False },
-- Was: gentleFloatOutSwitches
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
- floatOutLambdas = False,
+ floatOutLambdas = floatLamArgs dflags,
floatOutConstants = True,
floatOutPartialApplications = True },
-- nofib/spectral/hartel/wang doubles in speed if you
runWhen do_float_in CoreDoFloatInwards,
- maybe_rule_check 0,
+ maybe_rule_check (Phase 0),
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
runWhen spec_constr CoreDoSpecConstr,
- maybe_rule_check 0,
+ maybe_rule_check (Phase 0),
-- Final clean-up simplification:
simpl_phase 0 ["final"] max_iter
_ -> phase_name s
phase_num :: Int -> Bool
- phase_num n = case mode of
- SimplPhase k _ -> n == k
- _ -> False
+ phase_num n = case sm_phase mode of
+ Phase k -> n == k
+ _ -> False
phase_name :: String -> Bool
- phase_name s = case mode of
- SimplGently {} -> s == "gentle"
- SimplPhase { sm_names = ss } -> s `elem` ss
+ phase_name s = s `elem` sm_names mode
\end{code}
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification. Two reasons:
+
+ * We really want the class-op cancellation to happen:
+ op (df d1 d2) --> $cop3 d1 d2
+ because this breaks the mutual recursion between 'op' and 'df'
+
+ * I wanted the RULE
+ lift String ===> ...
+ to work in Template Haskell when simplifying
+ splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating. So use phase control
+to switch off those rules until after floating.
+
+Currently (Oct10) I think that sm_rules is always True, so we
+could remove it.
+
+
%************************************************************************
%* *
Counting and logging
%
-% (c) The AQUA Project, Glasgow University, 1993-1998
+o% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[SimplMonad]{The simplifier Monad}
-- 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,
-- 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
\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
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
-- 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 )
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}
%************************************************************************
= 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}
-
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
- activeUnfolding, activeUnfInRule, activeRule,
- simplEnvForGHCi, simplEnvForRules, updModeForInlineRules,
+ activeUnfolding, activeRule,
+ getUnfoldingInRuleMatch,
+ simplEnvForGHCi, updModeForInlineRules,
-- The continuation type
SimplCont(..), DupFlag(..), ArgInfo(..),
#include "HsVersions.h"
import SimplEnv
-import CoreMonad ( SimplifierMode(..), Tick(..) )
+import CoreMonad ( SimplifierMode(..), Tick(..) )
import DynFlags
import StaticFlags
import CoreSyn
%************************************************************************
%* *
- Gentle mode
+ SimplifierMode
%* *
%************************************************************************
-Inlining is controlled partly by the SimplifierMode switch. This has two
-settings
-
- SimplGently (a) Simplifying before specialiser/full laziness
- (b) Simplifiying inside InlineRules
- (c) Simplifying the LHS of a rule
- (d) Simplifying a GHCi expression or Template
- Haskell splice
-
- SimplPhase n _ Used at all other times
-
-Note [Gentle mode]
-~~~~~~~~~~~~~~~~~~
-Gentle mode has a separate boolean flag to control
- a) inlining (sm_inline flag)
- b) rules (sm_rules flag)
-A key invariant about Gentle mode is that it is treated as the EARLIEST
-phase.
+The SimplifierMode controls several switches; see its definition in
+CoreMonad
+ sm_rules :: Bool -- Whether RULES are enabled
+ sm_inline :: Bool -- Whether inlining is enabled
+ sm_case_case :: Bool -- Whether case-of-case is enabled
+ sm_eta_expand :: Bool -- Whether eta-expansion is enabled
\begin{code}
simplEnvForGHCi :: SimplEnv
-simplEnvForGHCi = mkSimplEnv allOffSwitchChecker $
- SimplGently { sm_rules = True, sm_inline = False }
+simplEnvForGHCi = mkSimplEnv $
+ SimplMode { sm_names = ["GHCi"]
+ , sm_phase = InitialPhase
+ , sm_rules = True, sm_inline = False
+ , sm_eta_expand = False, sm_case_case = True }
-- Do not do any inlining, in case we expose some unboxed
-- tuple stuff that confuses the bytecode interpreter
-simplEnvForRules :: SimplEnv
-simplEnvForRules = mkSimplEnv allOffSwitchChecker $
- SimplGently { sm_rules = True, sm_inline = False }
-
updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode
-- See Note [Simplifying inside InlineRules]
-updModeForInlineRules _inline_rule_act _current_mode
- = SimplGently { sm_rules = True, sm_inline = True }
+updModeForInlineRules inline_rule_act current_mode
+ = current_mode { sm_phase = phaseFromActivation inline_rule_act
+ , sm_rules = True
+ , sm_inline = True
+ , sm_eta_expand = False }
+ where
+ phaseFromActivation (ActiveAfter n) = Phase n
+ phaseFromActivation _ = InitialPhase
\end{code}
Note [Inlining in gentle mode]
anything, because the byte-code interpreter might get confused about
unboxed tuples and suchlike.
-Note [RULEs enabled in SimplGently]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-RULES are enabled when doing "gentle" simplification. Two reasons:
-
- * We really want the class-op cancellation to happen:
- op (df d1 d2) --> $cop3 d1 d2
- because this breaks the mutual recursion between 'op' and 'df'
-
- * I wanted the RULE
- lift String ===> ...
- to work in Template Haskell when simplifying
- splices, so we get simpler code for literal strings
-
-But watch out: list fusion can prevent floating. So use phase control
-to switch off those rules until after floating.
-
-Currently (Oct10) I think that sm_rules is always True, so we
-could remove it.
-
Note [Simplifying inside InlineRules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside InlineRules (which come from
Second, we do want *do* to some modest rules/inlining stuff in InlineRules,
partly to eliminate senseless crap, and partly to break the recursive knots
-generated by instance declarations. To keep things simple, we always set
-the phase to 'gentle' when processing InlineRules.
+generated by instance declarations.
+
+However, suppose we have
+ {-# INLINE <act> f #-}
+ f = <rhs>
+meaning "inline f in phases p where activation <act>(p) holds".
+Then what inlinings/rules can we apply to the copy of <rhs> captured in
+f's InlineRule? Our model is that literally <rhs> is substituted for
+f when it is inlined. So our conservative plan (implemented by
+updModeForInlineRules) is this:
+
+ -------------------------------------------------------------
+ When simplifying the RHS of an InlineRule, set the phase to the
+ phase in which the InlineRule first becomes active
+ -------------------------------------------------------------
+
+That ensures that
+
+ a) Rules/inlinings that *cease* being active before p will
+ not apply to the InlineRule rhs, consistent with it being
+ inlined in its *original* form in phase p.
+
+ b) Rules/inlinings that only become active *after* p will
+ not apply to the InlineRule rhs, again to be consistent with
+ inlining the *original* rhs in phase p.
+
+For example,
+ {-# INLINE f #-}
+ f x = ...g...
+
+ {-# NOINLINE [1] g #-}
+ g y = ...
+
+ {-# RULE h g = ... #-}
+Here we must not inline g into f's RHS, even when we get to phase 0,
+because when f is later inlined into some other module we want the
+rule for h to fire.
+
+Similarly, consider
+ {-# INLINE f #-}
+ f x = ...g...
+
+ g y = ...
+and suppose that there are auto-generated specialisations and a strictness
+wrapper for g. The specialisations get activation AlwaysActive, and the
+strictness wrapper get activation (ActiveAfter 0). So the strictness
+wrepper fails the test and won't be inlined into f's InlineRule. That
+means f can inline, expose the specialised call to g, so the specialisation
+rules can fire.
A note about wrappers
~~~~~~~~~~~~~~~~~~~~~
continuation.
\begin{code}
-activeUnfolding :: SimplEnv -> IdUnfoldingFun
+activeUnfolding :: SimplEnv -> Id -> Bool
activeUnfolding env
- = case getMode env of
- SimplGently { sm_inline = False } -> active_unfolding_minimal
- SimplGently { sm_inline = True } -> active_unfolding_gentle
- SimplPhase n _ -> active_unfolding n
+ | not (sm_inline mode) = active_unfolding_minimal
+ | otherwise = case sm_phase mode of
+ InitialPhase -> active_unfolding_gentle
+ Phase n -> active_unfolding n
+ where
+ mode = getMode env
-activeUnfInRule :: SimplEnv -> IdUnfoldingFun
+getUnfoldingInRuleMatch :: SimplEnv -> IdUnfoldingFun
-- When matching in RULE, we want to "look through" an unfolding
-- (to see a constructor) if *rules* are on, even if *inlinings*
-- are not. A notable example is DFuns, which really we want to
-- match in rules like (op dfun) in gentle mode. Another example
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
-activeUnfInRule env
- = case getMode env of
- SimplGently { sm_rules = False } -> active_unfolding_minimal
- SimplGently { sm_rules = True } -> active_unfolding_early
- SimplPhase n _ -> active_unfolding n
+getUnfoldingInRuleMatch env id
+ | unf_is_active = idUnfolding id
+ | otherwise = NoUnfolding
where
- active_unfolding_early id
- | isEarlyActive (idInlineActivation id) = idUnfolding id
- | otherwise = idUnfolding id
+ mode = getMode env
+ unf_is_active
+ | not (sm_rules mode) = active_unfolding_minimal id
+ | otherwise = isActive (sm_phase mode) (idInlineActivation id)
-active_unfolding_minimal :: IdUnfoldingFun
+active_unfolding_minimal :: Id -> Bool
-- Compuslory unfoldings only
-- Ignore SimplGently, because we want to inline regardless;
-- the Id has no top-level binding at all
-- But that only really applies to the trivial wrappers (like (:)),
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
-active_unfolding_minimal id
- | isCompulsoryUnfolding unf = unf
- | otherwise = NoUnfolding
- where
- unf = idUnfolding id
+active_unfolding_minimal id = isCompulsoryUnfolding (realIdUnfolding id)
+
+active_unfolding :: PhaseNum -> Id -> Bool
+active_unfolding n id = isActiveIn n (idInlineActivation id)
-active_unfolding_gentle :: IdUnfoldingFun
+active_unfolding_gentle :: Id -> Bool
-- Anything that is early-active
-- See Note [Gentle mode]
active_unfolding_gentle id
- | isStableUnfolding unf
- , isEarlyActive (idInlineActivation id) = unf
+ = isInlinePragma prag
+ && isEarlyActive (inlinePragmaActivation prag)
-- NB: wrappers are not early-active
- | otherwise = NoUnfolding
where
- unf = idUnfolding id
- -- idUnfolding checks for loop-breakers
- -- Things with an INLINE pragma may have
- -- an unfolding *and* be a loop breaker
- -- (maybe the knot is not yet untied)
-
-active_unfolding :: CompilerPhase -> IdUnfoldingFun
-active_unfolding n id
- | isActive n (idInlineActivation id) = idUnfolding id
- | otherwise = NoUnfolding
+ prag = idInlinePragma id
+----------------------
activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
-activeRule dflags env
- | not (dopt Opt_EnableRewriteRules dflags)
- = Nothing -- Rewriting is off
- | otherwise
- = case getMode env of
- SimplGently { sm_rules = rules_on }
- | rules_on -> Just isEarlyActive -- Note [RULEs enabled in SimplGently]
- | otherwise -> Nothing
- SimplPhase n _ -> Just (isActive n)
+activeRule _dflags env
+ | not (sm_rules mode) = Nothing -- Rewriting is off
+ | otherwise = Just (isActive (sm_phase mode))
+ where
+ mode = getMode env
\end{code}
---------------------------------------------------------------
- OLD NOTES, now wrong
- Preserved just for now (Oct 10)
---------------------------------------------------------------
-
- OK, so suppose we have
- {-# INLINE <act> f #-}
- f = <rhs>
- meaning "inline f in phases p where activation <act>(p) holds".
- Then what inlinings/rules can we apply to the copy of <rhs> captured in
- f's InlineRule? Our model is that literally <rhs> is substituted for
- f when it is inlined. So our conservative plan (implemented by
- updModeForInlineRules) is this:
-
- -------------------------------------------------------------
- When simplifying the RHS of an InlineRule,
- If the InlineRule becomes active in phase p, then
- if the current phase is *earlier than* p,
- make no inlinings or rules active when simplifying the RHS
- otherwise
- set the phase to p when simplifying the RHS
-
- -- Treat Gentle as phase "infinity"
- -- If current_phase `earlier than` inline_rule_start_phase
- -- then no_op
- -- else
- -- if current_phase `same phase` inline_rule_start_phase
- -- then current_phase (keep gentle flags)
- -- else inline_rule_start_phase
- -------------------------------------------------------------
-
- That ensures that
-
- a) Rules/inlinings that *cease* being active before p will
- not apply to the InlineRule rhs, consistent with it being
- inlined in its *original* form in phase p.
-
- b) Rules/inlinings that only become active *after* p will
- not apply to the InlineRule rhs, again to be consistent with
- inlining the *original* rhs in phase p.
-
- For example,
- {-# INLINE f #-}
- f x = ...g...
-
- {-# NOINLINE [1] g #-}
- g y = ...
-
- {-# RULE h g = ... #-}
- Here we must not inline g into f's RHS, even when we get to phase 0,
- because when f is later inlined into some other module we want the
- rule for h to fire.
-
- Similarly, consider
- {-# INLINE f #-}
- f x = ...g...
-
- g y = ...
- and suppose that there are auto-generated specialisations and a strictness
- wrapper for g. The specialisations get activation AlwaysActive, and the
- strictness wrapper get activation (ActiveAfter 0). So the strictness
- wrepper fails the test and won't be inlined into f's InlineRule. That
- means f can inline, expose the specialised call to g, so the specialisation
- rules can fire.
-
---------------------------------------------------------------
- END OF OLD NOTES
---------------------------------------------------------------
%************************************************************************
OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
_ -> False
where
- phase = getMode env
- active = case phase of
- SimplGently {} -> isEarlyActive act
- -- See Note [pre/postInlineUnconditionally in gentle mode]
- SimplPhase n _ -> isActive n act
+ mode = getMode env
+ active = isActive (sm_phase mode) act
+ -- See Note [pre/postInlineUnconditionally in gentle mode]
act = idInlineActivation bndr
try_once in_lam int_cxt -- There's one textual occurrence
| not in_lam = isNotTopLevel top_lvl || early_phase
canInlineInLam (Note _ e) = canInlineInLam e
canInlineInLam _ = False
- early_phase = case phase of
- SimplPhase 0 _ -> False
- _ -> True
+ early_phase = case sm_phase mode of
+ Phase 0 -> False
+ _ -> True
-- If we don't have this early_phase test, consider
-- x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
-- Alas!
where
- active = case getMode env of
- SimplGently {} -> isEarlyActive act
- -- See Note [pre/postInlineUnconditionally in gentle mode]
- SimplPhase n _ -> isActive n act
- act = idInlineActivation bndr
+ active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
+ -- See Note [pre/postInlineUnconditionally in gentle mode]
\end{code}
Note [Top level and postInlineUnconditionally]
return (new_arity, new_rhs) }
where
try_expand dflags
- | dopt Opt_DoLambdaEtaExpansion dflags
+ | sm_eta_expand (getMode env) -- Provided eta-expansion is on
, not (exprIsTrivial rhs)
- , not (inGentleMode env) -- In gentle mode don't eta-expansion
- -- because it can clutter up the code
- -- with casts etc that may not be removed
, let new_arity = exprEtaExpandArity dflags rhs
- , new_arity > old_arity
+ , new_arity > rhs_arity
= do { tick (EtaExpansion bndr)
; return (new_arity, etaExpand new_arity rhs) }
| otherwise
- = return (exprArity rhs, rhs)
+ = return (rhs_arity, rhs)
+ rhs_arity = exprArity rhs
old_arity = idArity bndr
_dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
\end{code}
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 )
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}
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}
\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}
; 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)
; 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) ->
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)
projects / ghc-hetmet.git / commitdiff