From c177e43f99dcd525b78ee0ac8f16c3d42c618e1f Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 16 Nov 2010 17:37:19 +0000 Subject: [PATCH] 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. --- compiler/basicTypes/BasicTypes.lhs | 37 +++-- compiler/basicTypes/MkId.lhs | 1 + compiler/coreSyn/CoreSyn.lhs | 23 ++- compiler/coreSyn/CoreUnfold.lhs | 141 +++++++++-------- compiler/simplCore/CoreMonad.lhs | 178 +++++++++++++--------- compiler/simplCore/SimplEnv.lhs | 28 +--- compiler/simplCore/SimplMonad.lhs | 108 +------------ compiler/simplCore/SimplUtils.lhs | 296 ++++++++++++++---------------------- compiler/simplCore/Simplify.lhs | 19 ++- 9 files changed, 348 insertions(+), 483 deletions(-) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 499d7be..f077882 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -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 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 4c41d28..29c1f4c 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 1181931..2dda733 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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 diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index e54acc0..5a00869 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -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] diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index d821d40..0b8ea1e 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -10,7 +10,6 @@ module CoreMonad ( -- * Configuration of the core-to-core passes CoreToDo(..), SimplifierMode(..), - SimplifierSwitch(..), FloatOutSwitches(..), getCoreToDo, dumpSimplPhase, @@ -63,7 +62,7 @@ import Module ( PackageId, Module ) import DynFlags import StaticFlags import Rules ( RuleBase ) -import BasicTypes ( CompilerPhase ) +import BasicTypes ( CompilerPhase(..) ) import Annotations import Id ( Id ) @@ -186,8 +185,8 @@ displayLintResults dflags pass warns errs binds 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} @@ -204,10 +203,9 @@ data CoreToDo -- These are diff core-to-core passes, -- 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 @@ -254,8 +252,8 @@ coreDumpFlag CoreDoGlomBinds = Nothing 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) @@ -279,50 +277,56 @@ instance Outputable CoreToDo where \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} @@ -337,30 +341,41 @@ getCoreToDo :: DynFlags -> [CoreToDo] 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 @@ -380,21 +395,18 @@ getCoreToDo dflags -- 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 @@ -421,7 +433,7 @@ getCoreToDo dflags runWhen full_laziness $ CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = False, + floatOutLambdas = Just 0, floatOutConstants = True, floatOutPartialApplications = False }, -- Was: gentleFloatOutSwitches @@ -467,7 +479,7 @@ getCoreToDo dflags runWhen full_laziness $ CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = False, + floatOutLambdas = floatLamArgs dflags, floatOutConstants = True, floatOutPartialApplications = True }, -- nofib/spectral/hartel/wang doubles in speed if you @@ -484,7 +496,7 @@ getCoreToDo dflags 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. @@ -497,7 +509,7 @@ getCoreToDo dflags runWhen spec_constr CoreDoSpecConstr, - maybe_rule_check 0, + maybe_rule_check (Phase 0), -- Final clean-up simplification: simpl_phase 0 ["final"] max_iter @@ -532,17 +544,35 @@ dumpSimplPhase dflags mode _ -> 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 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 865acdc..9f424cd 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -1,5 +1,5 @@ % -% (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,19 +218,15 @@ 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 diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 10bc70d..1781d56 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -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} - diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 1618525..a2fe28d 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -10,8 +10,9 @@ module SimplUtils ( -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeUnfInRule, activeRule, - simplEnvForGHCi, simplEnvForRules, updModeForInlineRules, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + simplEnvForGHCi, updModeForInlineRules, -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), @@ -29,7 +30,7 @@ module SimplUtils ( #include "HsVersions.h" import SimplEnv -import CoreMonad ( SimplifierMode(..), Tick(..) ) +import CoreMonad ( SimplifierMode(..), Tick(..) ) import DynFlags import StaticFlags import CoreSyn @@ -454,44 +455,37 @@ interestingArgContext rules call_cont %************************************************************************ %* * - 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] @@ -531,25 +525,6 @@ running it, we don't want to use -O2. Indeed, we don't want to inline 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 @@ -568,8 +543,55 @@ one; see OccurAnal.addRuleUsage. 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 f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's InlineRule? Our model is that literally 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 ~~~~~~~~~~~~~~~~~~~~~ @@ -583,31 +605,32 @@ mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf 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 @@ -618,113 +641,31 @@ active_unfolding_minimal :: IdUnfoldingFun -- 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 f #-} - f = - meaning "inline f in phases p where activation (p) holds". - Then what inlinings/rules can we apply to the copy of captured in - f's InlineRule? Our model is that literally 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 --------------------------------------------------------------- %************************************************************************ @@ -848,11 +789,9 @@ preInlineUnconditionally env top_lvl bndr rhs 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 @@ -884,9 +823,9 @@ preInlineUnconditionally env top_lvl bndr rhs 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 @@ -1014,11 +953,8 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- 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] @@ -1147,18 +1083,16 @@ tryEtaExpand env bndr rhs 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} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 8d314ae..df80c4a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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) -- 1.7.10.4