Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2da84b7a by sheaf at 2025-09-01T23:03:23-04:00 Only use active rules when simplifying rule RHSs When we are simplifying the RHS of a rule, we make sure to only apply rewrites from rules that are active throughout the original rule's range of active phases. For example, if a rule is always active, we only fire rules that are themselves always active when simplifying the RHS. Ditto for inline activations. This is achieved by setting the simplifier phase to a range of phases, using the new SimplPhaseRange constructor. Then: 1. When simplifying the RHS of a rule, or of a stable unfolding, we set the simplifier phase to a range of phases, computed from the activation of the RULE/unfolding activation, using the function 'phaseFromActivation'. The details are explained in Note [What is active in the RHS of a RULE?] in GHC.Core.Opt.Simplify.Utils. 2. The activation check for other rules and inlinings is then: does the activation of the other rule/inlining cover the whole phase range set in sm_phase? This continues to use the 'isActive' function, which now accounts for phase ranges. On the way, this commit also moves the exact-print SourceText annotation from the Activation datatype to the ActivationAnn type. This keeps the main Activation datatype free of any extra cruft. Fixes #26323 - - - - - 28 changed files: - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Inline.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Utils/Binary.hs - hie.yaml - testsuite/tests/perf/compiler/T4007.stdout - testsuite/tests/simplCore/should_compile/T15056.stderr - testsuite/tests/simplCore/should_compile/T15445.stderr - + testsuite/tests/simplCore/should_compile/T26323b.hs - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/simplCore/should_run/T26323.hs - + testsuite/tests/simplCore/should_run/T26323.stdout - testsuite/tests/simplCore/should_run/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -10,7 +10,7 @@ import GHC.Core ( CoreProgram ) import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches ) import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) -import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Basic ( CompilerPhase ) import GHC.Unit.Module.ModGuts import GHC.Utils.Outputable as Outputable @@ -52,8 +52,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoSpecialising | CoreDoSpecConstr | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -12,6 +12,7 @@ module GHC.Core.Opt.Simplify.Env ( -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract + SimplPhase(..), isActive, seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, seOptCoercionOpts, sePhase, sePlatform, sePreInline, @@ -145,7 +146,7 @@ here is between "freely set by the caller" and "internally managed by the pass". Note that it doesn't matter for the decision procedure wheter a value is altered throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline, sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the -definitions of `updModeForStableUnfoldings` and `updModeForRules` in +definitions of `updModeForStableUnfoldings` and `updModeForRule{LHS,RHS}` in GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the caller of the Simplify pass needs to provide the initial values for those fields. @@ -250,7 +251,7 @@ seNames env = sm_names (seMode env) seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePhase :: SimplEnv -> CompilerPhase +sePhase :: SimplEnv -> SimplPhase sePhase env = sm_phase (seMode env) sePlatform :: SimplEnv -> Platform @@ -270,7 +271,7 @@ seUnfoldingOpts env = sm_uf_opts (seMode env) -- See Note [The environments of the Simplify pass] data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - { sm_phase :: !CompilerPhase + { sm_phase :: !SimplPhase -- ^ The phase of the simplifier , sm_names :: ![String] -- ^ Name(s) of the phase , sm_rules :: !Bool -- ^ Whether RULES are enabled , sm_inline :: !Bool -- ^ Whether inlining is enabled @@ -288,13 +289,76 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options } +-- | See Note [SimplPhase] +data SimplPhase + -- | A simplifier phase: InitialPhase, Phase 2, Phase 1, Phase 0, FinalPhase + = SimplPhase CompilerPhase + -- | Simplifying the RHS of a rule or of a stable unfolding: the range of + -- phases of the activation of the rule/stable unfolding. + -- + -- _Invariant:_ 'simplStartPhase' is not a later phase than 'simplEndPhase'. + -- Equivalently, 'SimplPhaseRange' is always a non-empty interval of phases. + -- + -- See Note [What is active in the RHS of a RULE?] in GHC.Core.Opt.Simplify.Utils. + | SimplPhaseRange + { simplStartPhase :: CompilerPhase + , simplEndPhase :: CompilerPhase + } + + deriving Eq + +instance Outputable SimplPhase where + ppr (SimplPhase p) = ppr p + ppr (SimplPhaseRange s e) = brackets $ ppr s <> text "..." <> ppr e + +-- | Is this activation active in this simplifier phase? +-- +-- For a phase range, @isActive simpl_phase_range act@ is true if and only if +-- @act@ is active throughout the entire range, as per +-- Note [What is active in the RHS of a RULE?] in GHC.Core.Opt.Simplify.Utils. +-- +-- See Note [SimplPhase]. +isActive :: SimplPhase -> Activation -> Bool +isActive (SimplPhase p) act = isActiveInPhase p act +isActive (SimplPhaseRange start end) act = + -- To check whether the activation is active throughout the whole phase range, + -- it's sufficient to check the endpoints of the phase range, because an + -- activation can never have gaps (all activations are phase intervals). + isActiveInPhase start act && isActiveInPhase end act + +{- Note [SimplPhase] +~~~~~~~~~~~~~~~~~~~~ +In general, the simplifier is invoked in successive phases: + + InitialPhase, Phase 2, Phase 1, Phase 0, FinalPhase + +This allows us to control which rules, specialisations and inlinings are +active at any given point. For example, + + {-# RULE "myRule" [1] lhs = rhs #-} + +starts being active in Phase 1, and stays active thereafter. Thus it is active +in Phase 1, Phase 0, FinalPhase, but not active in InitialPhase or Phase 2. + +This simplifier phase is stored in the sm_phase field of SimplMode, usin +the 'SimplPhase' constructor. This allows us to determine which rules/inlinings +are active. + +When we invoke the simplifier on the RHS of a rule, such as 'rhs' above, instead +of setting the simplifier mode to a single phase, we use a phase range +corresponding to the range of phases in which the rule is active, with the +'SimplPhaseRange' constructor. This allows us to check whether other rules or +inlinings are active throughout the whole activation of the rule. +See Note [What is active in the RHS of a RULE?] in GHC.Core.Opt.Simplify.Utils. +-} + instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p , sm_names = ss + ppr (SimplMode { sm_phase = phase , sm_names = ss , sm_rules = r, sm_inline = i , sm_cast_swizzle = cs , sm_eta_expand = eta, sm_case_case = cc }) = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> + sep [ text "Phase =" <+> ppr phase <+> brackets (text (concat $ intersperse "," ss)) <> comma , pp_flag i (text "inline") <> comma , pp_flag r (text "rules") <> comma @@ -312,9 +376,8 @@ data FloatEnable -- Controls local let-floating | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only | FloatEnabled -- Do local let-floating on all bindings -{- -Note [Local floating] -~~~~~~~~~~~~~~~~~~~~~ +{- Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~~~~ The Simplifier can perform local let-floating: it floats let-bindings out of the RHS of let-bindings. See Let-floating: moving bindings to give faster programs (ICFP'96) ===================================== compiler/GHC/Core/Opt/Simplify/Inline.hs ===================================== @@ -29,7 +29,7 @@ import GHC.Core.FVs( exprFreeIds ) import GHC.Types.Id import GHC.Types.Var.Env( InScopeSet, lookupInScope ) import GHC.Types.Var.Set -import GHC.Types.Basic ( Arity, RecFlag(..), isActive ) +import GHC.Types.Basic ( Arity, RecFlag(..) ) import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable @@ -124,7 +124,7 @@ activeUnfolding mode id | isCompulsoryUnfolding (realIdUnfolding id) = True -- Even sm_inline can't override compulsory unfoldings | otherwise - = isActive (sm_phase mode) (idInlineActivation id) + = isActive (sm_phase mode) (idInlineActivation id) && sm_inline mode -- `or` isStableUnfolding (realIdUnfolding id) -- Inline things when ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2458,7 +2458,11 @@ tryInlining env logger var cont | not (logHasDumpFlag logger Opt_D_verbose_core2core) = when (isExternalName (idName var)) $ log_inlining $ - sep [text "Inlining done:", nest 4 (ppr var)] + sep [text "Inlining done:", nest 4 (ppr var)] + -- $$ nest 2 (vcat + -- [ text "Simplifier phase:" <+> ppr (sePhase env) + -- , text "Unfolding activation:" <+> ppr (idInlineActivation var) + -- ]) | otherwise = log_inlining $ sep [text "Inlining done: " <> ppr var, @@ -2645,6 +2649,8 @@ tryRules env rules fn args = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat [ text "Rule:" <+> ftext (ruleName rule) , text "Module:" <+> printRuleModule rule + --, text "Simplifier phase:" <+> ppr (sePhase env) + --, text "Rule activation:" <+> ppr (ruleActivation rule) , text "Full arity:" <+> ppr (ruleArity rule) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) , text "After: " <+> pprCoreExpr rule_rhs ] @@ -4790,9 +4796,12 @@ simplRules env mb_new_id rules bind_cxt rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] BC_Let {} -> mkBoringStop rhs_ty BC_Join _ cont -> assertPpr join_ok bad_join_msg cont - lhs_env = updMode updModeForRules env' - rhs_env = updMode (updModeForStableUnfoldings act) env' - -- See Note [Simplifying the RHS of a RULE] + + -- See Note [Simplifying rules] and Note [What is active in the RHS of a RULE?] + -- in GHC.Core.Opt.Simplify.Utils. + lhs_env = updMode updModeForRuleLHS env' + rhs_env = updMode (updModeForRuleRHS act) env' + -- Force this to avoid retaining reference to old Id !fn_name' = case mb_new_id of Just id -> idName id @@ -4816,12 +4825,3 @@ simplRules env mb_new_id rules bind_cxt , ru_rhs = occurAnalyseExpr rhs' }) } -- Remember to occ-analyse, to drop dead code. -- See Note [OccInfo in unfoldings and rules] in GHC.Core - -{- Note [Simplifying the RHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can simplify the RHS of a RULE much as we do the RHS of a stable -unfolding. We used to use the much more conservative updModeForRules -for the RHS as well as the LHS, but that seems more conservative -than necesary. Allowing some inlining might, for example, eliminate -a binding. --} ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -15,7 +15,7 @@ module GHC.Core.Opt.Simplify.Utils ( preInlineUnconditionally, postInlineUnconditionally, activeRule, getUnfoldingInRuleMatch, - updModeForStableUnfoldings, updModeForRules, + updModeForStableUnfoldings, updModeForRuleLHS, updModeForRuleRHS, -- The BindContext type BindContext(..), bindContextLevel, @@ -719,7 +719,7 @@ the LHS. This is a pretty pathological example, so I'm not losing sleep over it, but the simplest solution was to check sm_inline; if it is False, -which it is on the LHS of a rule (see updModeForRules), then don't +which it is on the LHS of a rule (see updModeForRuleLHS), then don't make use of the strictness info for the function. -} @@ -1069,22 +1069,22 @@ Reason for (b): we want to inline integerCompare here updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode -- See Note [The environments of the Simplify pass] +-- See Note [Simplifying inside stable unfoldings] updModeForStableUnfoldings unf_act current_mode - = current_mode { sm_phase = phaseFromActivation unf_act - , sm_eta_expand = False - , sm_inline = True } - -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules] - -- sm_rules: just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules - where - phaseFromActivation (ActiveAfter _ n) = Phase n - phaseFromActivation _ = InitialPhase + = current_mode + { sm_phase = phaseFromActivation (sm_phase current_mode) unf_act + -- See Note [What is active in the RHS of a RULE?] + , sm_eta_expand = False + -- See Note [Eta expansion in stable unfoldings and rules] + , sm_inline = True + -- sm_rules: just inherit; sm_rules might be "off" because of -fno-enable-rewrite-rules + } -updModeForRules :: SimplMode -> SimplMode +updModeForRuleLHS :: SimplMode -> SimplMode -- See Note [Simplifying rules] -- See Note [The environments of the Simplify pass] -updModeForRules current_mode - = current_mode { sm_phase = InitialPhase +updModeForRuleLHS current_mode + = current_mode { sm_phase = SimplPhase InitialPhase -- doesn't matter , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] , sm_rules = False @@ -1092,8 +1092,34 @@ updModeForRules current_mode -- See Note [Cast swizzling on rule LHSs] , sm_eta_expand = False } +updModeForRuleRHS :: Activation -> SimplMode -> SimplMode +updModeForRuleRHS rule_act current_mode = + current_mode + -- See Note [What is active in the RHS of a RULE?] + { sm_phase = phaseFromActivation (sm_phase current_mode) rule_act + , sm_eta_expand = False + -- See Note [Eta expansion in stable unfoldings and rules] + } + +-- | Compute the phase range to set the 'SimplMode' to +-- when simplifying the RHS of a rule or of a stable unfolding. +-- +-- See Note [What is active in the RHS of a RULE?] +phaseFromActivation + :: SimplPhase -- ^ the current simplifier phase + -> Activation -- ^ the activation of the RULE or stable unfolding + -> SimplPhase +phaseFromActivation p act + | isNeverActive act + = p + | otherwise + = SimplPhaseRange act_start act_end + where + act_start = beginPhase act + act_end = endPhase act + {- Note [Simplifying rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying a rule LHS, refrain from /any/ inlining or applying of other RULES. Doing anything to the LHS is plain confusing, because it means that what the rule matches is not what the user @@ -1136,7 +1162,7 @@ where `cv` is a coercion variable. Critically, we really only want coercion /variables/, not general coercions, on the LHS of a RULE. So we don't want to swizzle this to (\x. blah) |> (Refl xty `FunCo` CoVar cv) -So we switch off cast swizzling in updModeForRules. +So we switch off cast swizzling in updModeForRuleLHS. Note [Eta expansion in stable unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1200,6 +1226,62 @@ 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 [What is active in the RHS of a RULE?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have either a RULE or an inline pragma with an explicit activation: + + {-# RULE "R" [p] lhs = rhs #-} + {-# INLINE [p] foo #-} + +We should do some modest rules/inlining stuff in the right-hand sides, partly to +eliminate senseless crap, and partly to break the recursive knots generated by +instance declarations. However, we have to be careful about precisely which +rules/inlinings are active. In particular: + + a) Rules/inlinings that *cease* being active before p should not apply. + b) Rules/inlinings that only become active *after* p should also not apply. + +In the rest of this Note, we will focus on rules, but everything applies equally +to the RHSs of stable unfoldings. + +Our carefully crafted plan is as follows: + + ------------------------------------------------------------- + When simplifying the RHS of a RULE R with activation range A, + fire only other rules R' that are active throughout all of A. + ------------------------------------------------------------- + +Reason: R might fire in any phase in A. Then R' can fire only if R' is active +in that phase. If not, it's not safe to unconditionally fire R' in the RHS of R. + +This plan is implemented by: + + 1. Setting the simplifier phase to the range of phases + corresponding to the start/end phases of the rule's activation. + 2. When checking whether another rule is active, we use the function + isActive :: SimplPhase -> Activation -> Bool + from GHC.Core.Opt.Simplify.Env, which checks whether the other rule is + active throughout the whole range of phases. + +However, if the rule whose RHS we are simplifying is never active, instead of +setting the phase range to an empty interval, we keep the current simplifier +phase. This special case avoids firing ALL rules in the RHS of a never-active +rule. + +You might wonder about a situation such as the following: + + module M1 where + {-# RULES "r1" [1] lhs1 = rhs1 #-} + {-# RULES "r2" [2] lhs2 = rhs2 #-} + + Current simplifier phase: 1 + +It looks tempting to use "r1" when simplifying the RHS of "r2", yet we +**must not** do so: for any module M that imports M1, we are going to start +simplification in M starting at InitialPhase, and we will see the +fully simplified rules RHSs imported from M1. +Conclusion: stick to the plan. + Note [Simplifying inside stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take care with simplification inside stable unfoldings (which come from @@ -1216,33 +1298,9 @@ and thence copied multiple times when g is inlined. HENCE we treat any occurrence in a stable unfolding as a multiple occurrence, not a single one; see OccurAnal.addRuleUsage. -Second, we do want *do* to some modest rules/inlining stuff in stable -unfoldings, partly to eliminate senseless crap, and partly to break -the recursive knots 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 stable unfolding? Our model is that literally <rhs> is substituted for -f when it is inlined. So our conservative plan (implemented by -updModeForStableUnfoldings) is this: - - ------------------------------------------------------------- - When simplifying the RHS of a stable unfolding, set the phase - to the phase in which the stable unfolding first becomes active - ------------------------------------------------------------- - -That ensures that - - a) Rules/inlinings that *cease* being active before p will - not apply to the stable unfolding, 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 stable unfolding, again to be consistent with - inlining the *original* rhs in phase p. +Second, we must be careful when simplifying the RHS that we do not apply RULES +which are not active over the whole active range of the stable unfolding. +This is all explained in Note [What is active in the RHS of a RULE?]. For example, {-# INLINE f #-} @@ -1291,8 +1349,7 @@ getUnfoldingInRuleMatch env = ISE in_scope id_unf where in_scope = seInScope env - phase = sePhase env - id_unf = whenActiveUnfoldingFun (isActive phase) + id_unf = whenActiveUnfoldingFun (isActive (sePhase env)) -- When sm_rules was off we used to test for a /stable/ unfolding, -- but that seems wrong (#20941) @@ -1468,7 +1525,8 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env one_occ _ = False pre_inline_unconditionally = sePreInline env - active = isActive (sePhase env) (inlinePragmaActivation inline_prag) + active = isActive (sePhase env) + $ inlinePragmaActivation inline_prag -- See Note [pre/postInlineUnconditionally in gentle mode] inline_prag = idInlinePragma bndr @@ -1505,7 +1563,10 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- not ticks. Counting ticks cannot be duplicated, and non-counting -- ticks around a Lam will disappear anyway. - early_phase = sePhase env /= FinalPhase + early_phase = + case sePhase env of + SimplPhase p -> p /= FinalPhase + SimplPhaseRange _start end -> end /= FinalPhase -- 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 @@ -1516,9 +1577,8 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- -- On the other hand, I have seen cases where top-level fusion is -- lost if we don't inline top level thing (e.g. string constants) - -- Hence the test for phase zero (which is the phase for all the final - -- simplifications). Until phase zero we take no special notice of - -- top level things, but then we become more leery about inlining + -- Hence the final phase test: until the final phase, we take no special + -- notice of top level things, but then we become more leery about inlining -- them. -- -- What exactly to check in `early_phase` above is the subject of #17910. @@ -1645,8 +1705,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs occ_info = idOccInfo old_bndr unfolding = idUnfolding bndr uf_opts = seUnfoldingOpts env - phase = sePhase env - active = isActive phase (idInlineActivation bndr) + active = isActive (sePhase env) $ idInlineActivation bndr -- See Note [pre/postInlineUnconditionally in gentle mode] {- Note [Inline small things to avoid creating a thunk] ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -19,18 +19,23 @@ import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_ma import GHC.Core.Predicate import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) -import GHC.Core.Opt.Monad +import GHC.Core.DataCon (dataConTyCon) + import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules +import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable , mkCast, exprType, exprIsHNF , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs import GHC.Core.Opt.Arity( collectBindersPushingCo ) +import GHC.Core.Opt.Monad +import GHC.Core.Opt.Simplify.Env ( SimplPhase(..), isActive ) import GHC.Builtin.Types ( unboxedUnitTy ) @@ -64,9 +69,6 @@ import GHC.Core.Unfold import Data.List( partition ) -- import Data.List.NonEmpty ( NonEmpty (..) ) -import GHC.Core.Subst (substTickish) -import GHC.Core.TyCon (tyConClass_maybe) -import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1609,7 +1611,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag - is_active = isActive (beginPhase inl_act) :: Activation -> Bool + is_active :: Activation -> Bool + is_active = isActive (SimplPhaseRange (beginPhase inl_act) (endPhase inl_act)) -- is_active: inl_act is the activation we are going to put in the new -- SPEC rule; so we want to see if it is covered by another rule with -- that same activation. ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -921,10 +921,8 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl -- The phase /after/ the rule is first active get_rule_phase rule = nextPhase (beginPhase (ruleActivation rule)) -{- -Note [Demand on the worker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +{- Note [Demand on the worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the original function is called once, according to its demand info, then so is the worker. This is important so that the occurrence analyser can attach OneShot annotations to the worker’s lambda binders. ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -1902,7 +1902,7 @@ ruleCheckProgram :: RuleOpts -- ^ Rule options -> (Id -> [CoreRule]) -- ^ Rules for an Id -> CoreProgram -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram ropts phase rule_pat rules binds +ruleCheckProgram ropts curr_phase rule_pat rules binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -1912,9 +1912,9 @@ ruleCheckProgram ropts phase rule_pat rules binds ] where line = text (replicate 20 '-') - env = RuleCheckEnv { rc_is_active = isActive phase - , rc_id_unf = idUnfolding -- Not quite right - -- Should use activeUnfolding + is_active = isActiveInPhase curr_phase + env = RuleCheckEnv { rc_is_active = is_active + , rc_id_unf = whenActiveUnfoldingFun is_active , rc_pattern = rule_pat , rc_rules = rules , rc_ropts = ropts ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Core.Lint import GHC.Core.Lint.Interactive import GHC.Core.Opt.Pipeline.Types import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) -import GHC.Core.Opt.Simplify.Env ( SimplMode(..) ) +import GHC.Core.Opt.Simplify.Env ( SimplMode(..), SimplPhase(..) ) import GHC.Core.Opt.Monad import GHC.Core.Coercion @@ -114,9 +114,9 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig 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 cfg) = case sm_phase (so_mode cfg) of - InitialPhase -> False - _ -> True +showLintWarnings (CoreDoSimplify cfg) + | SimplPhase InitialPhase <- sm_phase (so_mode cfg) + = False showLintWarnings _ = True perPassFlags :: DynFlags -> CoreToDo -> LintFlags ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -10,7 +10,7 @@ import GHC.Prelude import GHC.Core.Rules ( RuleBase ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) -import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) ) +import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..), SimplPhase(..) ) import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) import GHC.Driver.Config ( initOptCoercionOpts ) @@ -59,7 +59,7 @@ initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode initSimplMode dflags phase name = SimplMode { sm_names = [name] - , sm_phase = phase + , sm_phase = SimplPhase phase , sm_rules = gopt Opt_EnableRewriteRules dflags , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags , sm_cast_swizzle = True ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -734,13 +734,14 @@ instance NoAnn AnnSpecSig where data ActivationAnn = ActivationAnn { aa_openc :: EpToken "[", + aa_phase :: SourceText, aa_closec :: EpToken "]", aa_tilde :: Maybe (EpToken "~"), aa_val :: Maybe EpaLocation } deriving (Data, Eq) instance NoAnn ActivationAnn where - noAnn = ActivationAnn noAnn noAnn noAnn noAnn + noAnn = ActivationAnn noAnn NoSourceText noAnn noAnn noAnn -- | Optional namespace specifier for fixity signatures, ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1189,11 +1189,11 @@ repRuleMatch ConLike = dataCon conLikeDataConName repRuleMatch FunLike = dataCon funLikeDataConName repPhases :: Activation -> MetaM (Core TH.Phases) -repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i - ; dataCon' beforePhaseDataConName [arg] } -repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i - ; dataCon' fromPhaseDataConName [arg] } -repPhases _ = dataCon allPhasesDataConName +repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName rep_complete_sig :: [LocatedN Name] -> Maybe (LocatedN Name) ===================================== compiler/GHC/Parser.y ===================================== @@ -1949,7 +1949,7 @@ rule :: { LRuleDecl GhcPs } , rd_bndrs = ruleBndrsOrDef $3 , rd_lhs = $4, rd_rhs = $6 }) } --- Rules can be specified to be NeverActive, unlike inline/specialize pragmas +-- Rules can be specified to be never active, unlike inline/specialize pragmas rule_activation :: { (ActivationAnn, Maybe Activation) } -- See Note [%shift: rule_activation -> {- empty -}] : {- empty -} %shift { (noAnn, Nothing) } @@ -1973,14 +1973,14 @@ rule_activation_marker :: { (Maybe (EpToken "~")) } rule_explicit_activation :: { ( ActivationAnn , Activation) } -- In brackets - : '[' INTEGER ']' { ( ActivationAnn (epTok $1) (epTok $3) Nothing (Just (glR $2)) - , ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } + : '[' INTEGER ']' { ( ActivationAnn (epTok $1) (getINTEGERs $2) (epTok $3) Nothing (Just (glR $2)) + , ActiveAfter (fromInteger (il_value (getINTEGER $2)))) } | '[' rule_activation_marker INTEGER ']' - { ( ActivationAnn (epTok $1) (epTok $4) $2 (Just (glR $3)) - , ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } + { ( ActivationAnn (epTok $1) (getINTEGERs $3) (epTok $4) $2 (Just (glR $3)) + , ActiveBefore (fromInteger (il_value (getINTEGER $3)))) } | '[' rule_activation_marker ']' - { ( ActivationAnn (epTok $1) (epTok $3) $2 Nothing - , NeverActive) } + { ( ActivationAnn (epTok $1) NoSourceText (epTok $3) $2 Nothing + , NeverActive ) } rule_foralls :: { Maybe (RuleBndrs GhcPs) } : 'forall' rule_vars '.' 'forall' rule_vars '.' @@ -2825,11 +2825,11 @@ activation :: { (ActivationAnn,Maybe Activation) } | explicit_activation { (fst $1,Just (snd $1)) } explicit_activation :: { (ActivationAnn, Activation) } -- In brackets - : '[' INTEGER ']' { (ActivationAnn (epTok $1) (epTok $3) Nothing (Just (glR $2)) - ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } + : '[' INTEGER ']' { (ActivationAnn (epTok $1) (getINTEGERs $2) (epTok $3) Nothing (Just (glR $2)) + ,ActiveAfter (fromInteger (il_value (getINTEGER $2)))) } | '[' rule_activation_marker INTEGER ']' - { (ActivationAnn (epTok $1) (epTok $4) $2 (Just (glR $3)) - ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } + { (ActivationAnn (epTok $1) (getINTEGERs $3) (epTok $4) $2 (Just (glR $3)) + ,ActiveBefore (fromInteger (il_value (getINTEGER $3)))) } ----------------------------------------------------------------------------- -- Expressions ===================================== compiler/GHC/Tc/Deriv/Generics.hs ===================================== @@ -44,7 +44,6 @@ import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader -import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic import GHC.Types.SrcLoc @@ -379,7 +378,7 @@ mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) max_fields = maximum $ 0 :| map dataConSourceArity datacons inline1 f = L loc'' . InlineSig noAnn (L loc' f) - $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 } + $ alwaysInlinePragma { inl_act = ActiveAfter 1 } -- The topmost M1 (the datatype metadata) has the exact same type -- across all cases of a from/to definition, and can be factored out ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -998,8 +998,8 @@ cvtRuleMatch TH.FunLike = Hs.FunLike cvtPhases :: TH.Phases -> Activation -> Activation cvtPhases AllPhases dflt = dflt -cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i -cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i +cvtPhases (FromPhase i) _ = ActiveAfter i +cvtPhases (BeforePhase i) _ = ActiveBefore i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -84,11 +84,13 @@ module GHC.Types.Basic ( DefMethSpec(..), SwapFlag(..), flipSwap, unSwap, notSwapped, isSwapped, pickSwap, - CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase, + CompilerPhase(..), + PhaseNum, nextPhase, laterPhase, - Activation(..), isActive, competesWith, + Activation(..), isActiveInPhase, competesWith, isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase, activateAfterInitial, activateDuringFinal, activeAfter, + beginPhase, endPhase, laterThanPhase, RuleMatchInfo(..), isConLike, isFunLike, InlineSpec(..), noUserInlineSpec, @@ -1464,52 +1466,76 @@ The CompilerPhase says which phase the simplifier is running in: The phase sequencing is done by GHC.Opt.Simplify.Driver -} --- | Phase Number -type PhaseNum = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase +-- | Compilation phase number, as can be written by users in INLINE pragmas, +-- SPECIALISE pragmas, and RULES. +-- +-- - phases decrease towards zero +-- - zero is the last phase +-- +-- Does not include GHC internal "initial" and "final" phases; see 'CompilerPhase'. +type PhaseNum = Int +-- | Compilation phase number, including the user-specifiable 'PhaseNum' +-- and the GHC internal "initial" and "final" phases. data CompilerPhase - = InitialPhase -- The first phase -- number = infinity! - | Phase PhaseNum -- User-specificable phases - | FinalPhase -- The last phase -- number = -infinity! - deriving Eq + = InitialPhase -- ^ The first phase; number = infinity! + | Phase PhaseNum -- ^ User-specifiable phases + | FinalPhase -- ^ The last phase; number = -infinity! + deriving (Eq, Data) instance Outputable CompilerPhase where ppr (Phase n) = int n - ppr InitialPhase = text "InitialPhase" - ppr FinalPhase = text "FinalPhase" + ppr InitialPhase = text "initial" + ppr FinalPhase = text "final" --- See Note [Pragma source text] +-- | An activation is a range of phases throughout which something is active +-- (like an INLINE pragma, SPECIALISE pragma, or RULE). data Activation = AlwaysActive - | ActiveBefore SourceText PhaseNum -- Active only *strictly before* this phase - | ActiveAfter SourceText PhaseNum -- Active in this phase and later - | FinalActive -- Active in final phase only + -- | Active only *strictly before* this phase + | ActiveBefore PhaseNum + -- | Active in this phase and later phases + | ActiveAfter PhaseNum + -- | Active in the final phase only + | FinalActive | NeverActive deriving( Eq, Data ) -- Eq used in comparing rules in GHC.Hs.Decls beginPhase :: Activation -> CompilerPhase --- First phase in which the Activation is active --- or FinalPhase if it is never active +-- ^ First phase in which the 'Activation' is active, +-- or 'FinalPhase' if it is never active beginPhase AlwaysActive = InitialPhase beginPhase (ActiveBefore {}) = InitialPhase -beginPhase (ActiveAfter _ n) = Phase n +beginPhase (ActiveAfter n) = Phase n beginPhase FinalActive = FinalPhase beginPhase NeverActive = FinalPhase +endPhase :: Activation -> CompilerPhase +-- ^ Last phase in which the 'Activation' is active, +-- or 'InitialPhase' if it is never active +endPhase AlwaysActive = FinalPhase +endPhase (ActiveBefore n) = + if nextPhase InitialPhase == Phase n + then InitialPhase + else Phase $ n + 1 +endPhase (ActiveAfter {}) = FinalPhase +endPhase FinalActive = FinalPhase +endPhase NeverActive = InitialPhase + activeAfter :: CompilerPhase -> Activation --- (activeAfter p) makes an Activation that is active in phase p and after --- Invariant: beginPhase (activeAfter p) = p +-- ^ @activeAfter p@ makes an 'Activation' that is active in phase @p@ and after +-- +-- Invariant: @beginPhase (activeAfter p) = p@ activeAfter InitialPhase = AlwaysActive -activeAfter (Phase n) = ActiveAfter NoSourceText n +activeAfter (Phase n) = ActiveAfter n activeAfter FinalPhase = FinalActive nextPhase :: CompilerPhase -> CompilerPhase --- Tells you the next phase after this one --- Currently we have just phases [2,1,0,FinalPhase,FinalPhase,...] --- Where FinalPhase means GHC's internal simplification steps +-- ^ Tells you the next phase after this one +-- +-- Currently we have just phases @[2,1,0,FinalPhase,FinalPhase,...]@, +-- where FinalPhase means GHC's internal simplification steps -- after all rules have run nextPhase InitialPhase = Phase 2 nextPhase (Phase 0) = FinalPhase @@ -1517,37 +1543,45 @@ nextPhase (Phase n) = Phase (n-1) nextPhase FinalPhase = FinalPhase laterPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase --- Returns the later of two phases +-- ^ Returns the later of two phases laterPhase (Phase n1) (Phase n2) = Phase (n1 `min` n2) laterPhase InitialPhase p2 = p2 laterPhase FinalPhase _ = FinalPhase laterPhase p1 InitialPhase = p1 laterPhase _ FinalPhase = FinalPhase +-- | @p1 `laterThanOrEqualPhase` p2@ computes whether @p1@ happens (strictly) +-- after @p2@. +laterThanPhase :: CompilerPhase -> CompilerPhase -> Bool +p1 `laterThanPhase` p2 = toNum p1 < toNum p2 + where + toNum :: CompilerPhase -> Int + toNum InitialPhase = maxBound + toNum (Phase i) = i + toNum FinalPhase = minBound + activateAfterInitial :: Activation --- Active in the first phase after the initial phase +-- ^ Active in the first phase after the initial phase activateAfterInitial = activeAfter (nextPhase InitialPhase) activateDuringFinal :: Activation --- Active in the final simplification phase (which is repeated) +-- ^ Active in the final simplification phase (which is repeated) activateDuringFinal = FinalActive -isActive :: CompilerPhase -> Activation -> Bool -isActive InitialPhase act = activeInInitialPhase act -isActive (Phase p) act = activeInPhase p act -isActive FinalPhase act = activeInFinalPhase act +isActiveInPhase :: CompilerPhase -> Activation -> Bool +isActiveInPhase InitialPhase act = activeInInitialPhase act +isActiveInPhase (Phase p) act = activeInPhase p act +isActiveInPhase FinalPhase act = activeInFinalPhase act activeInInitialPhase :: Activation -> Bool -activeInInitialPhase AlwaysActive = True -activeInInitialPhase (ActiveBefore {}) = True -activeInInitialPhase _ = False +activeInInitialPhase act = beginPhase act == InitialPhase activeInPhase :: PhaseNum -> Activation -> Bool -activeInPhase _ AlwaysActive = True -activeInPhase _ NeverActive = False -activeInPhase _ FinalActive = False -activeInPhase p (ActiveAfter _ n) = p <= n -activeInPhase p (ActiveBefore _ n) = p > n +activeInPhase _ AlwaysActive = True +activeInPhase _ NeverActive = False +activeInPhase _ FinalActive = False +activeInPhase p (ActiveAfter n) = p <= n +activeInPhase p (ActiveBefore n) = p > n activeInFinalPhase :: Activation -> Bool activeInFinalPhase AlwaysActive = True @@ -1562,25 +1596,19 @@ isNeverActive _ = False isAlwaysActive AlwaysActive = True isAlwaysActive _ = False -competesWith :: Activation -> Activation -> Bool +-- | @act1 `competesWith` act2@ returns whether @act1@ is active in the phase +-- when @act2@ __becomes__ active. +-- +-- This answers the question: might @act1@ fire first? +-- +-- NB: this is not the same as computing whether @act1@ and @act2@ are +-- ever active at the same time. +-- -- See Note [Competing activations] -competesWith AlwaysActive _ = True - -competesWith NeverActive _ = False -competesWith _ NeverActive = False - -competesWith FinalActive FinalActive = True -competesWith FinalActive _ = False - -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) FinalActive = False -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b - -competesWith (ActiveAfter {}) AlwaysActive = False -competesWith (ActiveAfter {}) FinalActive = True -competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b +competesWith :: Activation -> Activation -> Bool +competesWith NeverActive _ = False +competesWith _ NeverActive = False -- See Wrinkle [Never active rules] +competesWith act1 act2 = isActiveInPhase (beginPhase act2) act1 {- Note [Competing activations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1595,8 +1623,20 @@ It's too conservative to ensure that the two are never simultaneously active. For example, a rule might be always active, and an inlining might switch on in phase 2. We could switch off the rule, but it does no harm. --} + Wrinkle [Never active rules] + + Rules can be declared as "never active" by users, using the syntax: + + {-# RULE "blah" [~] ... #-} + + (This feature exists solely for compiler plugins, by making it possible + to define a RULE that is never run by GHC, but is nevertheless parsed, + typechecked etc, so that it is available to the plugin.) + + We should not warn about competing rules, so make sure that 'competesWith' + always returns 'False' when its second argument is 'NeverActive'. +-} {- ********************************************************************* * * @@ -1855,26 +1895,36 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore _ n) = brackets (char '~' <> int n) - ppr (ActiveAfter _ n) = brackets (int n) - ppr FinalActive = text "[final]" + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore n) = brackets (char '~' <> int n) + ppr (ActiveAfter n) = brackets (int n) + ppr FinalActive = text "[final]" + +instance Binary CompilerPhase where + put_ bh InitialPhase = putByte bh 0 + put_ bh (Phase i) = do { putByte bh 1; put_ bh i } + put_ bh FinalPhase = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return InitialPhase + 1 -> do { p <- get bh; return (Phase p) } + _ -> return FinalPhase instance Binary Activation where put_ bh NeverActive = putByte bh 0 - put_ bh FinalActive = + put_ bh FinalActive = do putByte bh 1 put_ bh AlwaysActive = putByte bh 2 - put_ bh (ActiveBefore src aa) = do + put_ bh (ActiveBefore aa) = do putByte bh 3 - put_ bh src put_ bh aa - put_ bh (ActiveAfter src ab) = do + put_ bh (ActiveAfter ab) = do putByte bh 4 - put_ bh src put_ bh ab get bh = do h <- getByte bh @@ -1882,19 +1932,21 @@ instance Binary Activation where 0 -> return NeverActive 1 -> return FinalActive 2 -> return AlwaysActive - 3 -> do src <- get bh - aa <- get bh - return (ActiveBefore src aa) - _ -> do src <- get bh - ab <- get bh - return (ActiveAfter src ab) - + 3 -> do aa <- get bh + return (ActiveBefore aa) + _ -> do ab <- get bh + return (ActiveAfter ab) +instance NFData CompilerPhase where + rnf = \case + InitialPhase -> () + FinalPhase -> () + Phase i -> rnf i instance NFData Activation where rnf = \case AlwaysActive -> () NeverActive -> () - ActiveBefore src aa -> rnf src `seq` rnf aa - ActiveAfter src ab -> rnf src `seq` rnf ab + ActiveBefore aa -> rnf aa + ActiveAfter ab -> rnf ab FinalActive -> () instance Outputable RuleMatchInfo where ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Core.Class import GHC.Core.DataCon import GHC.Types.Literal -import GHC.Types.SourceText import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) import GHC.Types.Name.Set import GHC.Types.Name @@ -1926,8 +1925,7 @@ seqId = pcRepPolyId seqName ty concs info `setArityInfo` arity inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter - NoSourceText 0 + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0 -- Make 'seq' not inline-always, so that simpleOptExpr -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the -- LHS of rules. That way we can have rules for 'seq'; ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1869,172 +1869,6 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) --- instance Binary TupleSort where --- put_ bh BoxedTuple = putByte bh 0 --- put_ bh UnboxedTuple = putByte bh 1 --- put_ bh ConstraintTuple = putByte bh 2 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return BoxedTuple --- 1 -> do return UnboxedTuple --- _ -> do return ConstraintTuple - --- instance Binary Activation where --- put_ bh NeverActive = do --- putByte bh 0 --- put_ bh FinalActive = do --- putByte bh 1 --- put_ bh AlwaysActive = do --- putByte bh 2 --- put_ bh (ActiveBefore src aa) = do --- putByte bh 3 --- put_ bh src --- put_ bh aa --- put_ bh (ActiveAfter src ab) = do --- putByte bh 4 --- put_ bh src --- put_ bh ab --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return NeverActive --- 1 -> do return FinalActive --- 2 -> do return AlwaysActive --- 3 -> do src <- get bh --- aa <- get bh --- return (ActiveBefore src aa) --- _ -> do src <- get bh --- ab <- get bh --- return (ActiveAfter src ab) - --- instance Binary InlinePragma where --- put_ bh (InlinePragma s a b c d) = do --- put_ bh s --- put_ bh a --- put_ bh b --- put_ bh c --- put_ bh d - --- get bh = do --- s <- get bh --- a <- get bh --- b <- get bh --- c <- get bh --- d <- get bh --- return (InlinePragma s a b c d) - --- instance Binary RuleMatchInfo where --- put_ bh FunLike = putByte bh 0 --- put_ bh ConLike = putByte bh 1 --- get bh = do --- h <- getByte bh --- if h == 1 then return ConLike --- else return FunLike - --- instance Binary InlineSpec where --- put_ bh NoUserInlinePrag = putByte bh 0 --- put_ bh Inline = putByte bh 1 --- put_ bh Inlinable = putByte bh 2 --- put_ bh NoInline = putByte bh 3 - --- get bh = do h <- getByte bh --- case h of --- 0 -> return NoUserInlinePrag --- 1 -> return Inline --- 2 -> return Inlinable --- _ -> return NoInline - --- instance Binary RecFlag where --- put_ bh Recursive = do --- putByte bh 0 --- put_ bh NonRecursive = do --- putByte bh 1 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return Recursive --- _ -> do return NonRecursive - --- instance Binary OverlapMode where --- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s --- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s --- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s --- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s --- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s --- get bh = do --- h <- getByte bh --- case h of --- 0 -> (get bh) >>= \s -> return $ NoOverlap s --- 1 -> (get bh) >>= \s -> return $ Overlaps s --- 2 -> (get bh) >>= \s -> return $ Incoherent s --- 3 -> (get bh) >>= \s -> return $ Overlapping s --- 4 -> (get bh) >>= \s -> return $ Overlappable s --- _ -> panic ("get OverlapMode" ++ show h) - - --- instance Binary OverlapFlag where --- put_ bh flag = do put_ bh (overlapMode flag) --- put_ bh (isSafeOverlap flag) --- get bh = do --- h <- get bh --- b <- get bh --- return OverlapFlag { overlapMode = h, isSafeOverlap = b } - --- instance Binary FixityDirection where --- put_ bh InfixL = do --- putByte bh 0 --- put_ bh InfixR = do --- putByte bh 1 --- put_ bh InfixN = do --- putByte bh 2 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return InfixL --- 1 -> do return InfixR --- _ -> do return InfixN - --- instance Binary Fixity where --- put_ bh (Fixity src aa ab) = do --- put_ bh src --- put_ bh aa --- put_ bh ab --- get bh = do --- src <- get bh --- aa <- get bh --- ab <- get bh --- return (Fixity src aa ab) - --- instance Binary WarningTxt where --- put_ bh (WarningTxt s w) = do --- putByte bh 0 --- put_ bh s --- put_ bh w --- put_ bh (DeprecatedTxt s d) = do --- putByte bh 1 --- put_ bh s --- put_ bh d - --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do s <- get bh --- w <- get bh --- return (WarningTxt s w) --- _ -> do s <- get bh --- d <- get bh --- return (DeprecatedTxt s d) - --- instance Binary StringLiteral where --- put_ bh (StringLiteral st fs _) = do --- put_ bh st --- put_ bh fs --- get bh = do --- st <- get bh --- fs <- get bh --- return (StringLiteral st fs Nothing) - newtype BinLocated a = BinLocated { unBinLocated :: Located a } instance Binary a => Binary (BinLocated a) where ===================================== hie.yaml ===================================== @@ -5,4 +5,4 @@ # cradle: {bios: {program: "./hadrian/hie-bios.bat"}} # # The format is documented here - https://github.com/mpickering/hie-bios -cradle: {bios: {program: "./hadrian/hie-bios"}} +cradle: {bios: {program: "./hadrian/hie-bios.bat"}} ===================================== testsuite/tests/perf/compiler/T4007.stdout ===================================== @@ -1,6 +1,9 @@ Rule fired: Class op foldr (BUILTIN) Rule fired: Class op return (BUILTIN) Rule fired: unpack (GHC.Internal.Base) +Rule fired: repeat (GHC.Internal.List) +Rule fired: take (GHC.Internal.List) +Rule fired: fold/build (GHC.Internal.Base) Rule fired: fold/build (GHC.Internal.Base) Rule fired: Class op >> (BUILTIN) Rule fired: SPEC/T4007 sequence__c @IO @_ @_ (T4007) ===================================== testsuite/tests/simplCore/should_compile/T15056.stderr ===================================== @@ -5,4 +5,5 @@ Rule fired: Class op + (BUILTIN) Rule fired: +# (BUILTIN) Rule fired: Class op foldr (BUILTIN) Rule fired: Class op enumFromTo (BUILTIN) +Rule fired: eftInt (GHC.Internal.Enum) Rule fired: fold/build (GHC.Internal.Base) ===================================== testsuite/tests/simplCore/should_compile/T15445.stderr ===================================== @@ -6,9 +6,11 @@ Rule fired: USPEC $fShowList @Int (GHC.Internal.Show) Rule fired: Class op >> (BUILTIN) Rule fired: USPEC plusTwoRec @Int (T15445a) Rule fired: Class op enumFromTo (BUILTIN) +Rule fired: eftInt (GHC.Internal.Enum) Rule fired: Class op show (BUILTIN) Rule fired: USPEC plusTwoRec @Int (T15445a) Rule fired: Class op enumFromTo (BUILTIN) +Rule fired: eftInt (GHC.Internal.Enum) Rule fired: Class op show (BUILTIN) Rule fired: eftIntList (GHC.Internal.Enum) Rule fired: ># (BUILTIN) ===================================== testsuite/tests/simplCore/should_compile/T26323b.hs ===================================== @@ -0,0 +1,24 @@ +module T26323b where + +f :: Int -> Int +f _ = 0 +{-# NOINLINE f #-} + +g :: Int -> Int +g _ = 1 +{-# NOINLINE g #-} + +h :: Int -> Int +h _ = 2 +{-# NOINLINE h #-} + +-- These two RULES loop, but that's OK because they are never active +-- at the same time. +{-# RULES "t1" [1] forall x. g x = f x #-} +{-# RULES "t2" [~1] forall x. f x = g x #-} + +-- Make sure we don't fire "t1" and "t2" in a loop in the RHS of a never-active rule. +{-# RULES "t" [~] forall x. h x = f x #-} + +test :: Int +test = f 4 + g 5 + h 6 ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -537,6 +537,7 @@ test('T25389', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeab test('T24359a', normal, compile, ['-O -ddump-rules']) test('T24606', [grep_errmsg(r'fAlternativeRWST')], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-idinfo -dsuppress-coercions -dsuppress-coercion-types']) test('T25713', [grep_errmsg('W:::')], compile, ['-O -ddump-simpl']) +test('T26323b', normal, compile, ['-O']) test('T25883', normal, compile_grep_core, ['']) test('T25883b', normal, compile_grep_core, ['']) ===================================== testsuite/tests/simplCore/should_run/T26323.hs ===================================== @@ -0,0 +1,32 @@ +module Main where + +f :: Int -> Int +f x = g x +{-# INLINE [1] f #-} + +g :: Int -> Int +g x = 0 +{-# NOINLINE g #-} + +h :: Int -> Int +h _ = 1 +{-# NOINLINE h #-} + +{-# RULES "r1" [2] forall x. g x = h x #-} +{-# RULES "r2" [~1] forall x. h x = 2 #-} + +test :: Int +test = f 3 + +main :: IO () +main = print test + -- we should get + -- + -- f 3 + -- ==> inline in phase 1 + -- g 3 + -- ==> use 'r1' in phase 1 + -- h 3 + -- = 1 + -- + -- Here rule 'r2' should never fire, so we SHOULD NOT rewrite 'h 3' to '2'. ===================================== testsuite/tests/simplCore/should_run/T26323.stdout ===================================== @@ -0,0 +1 @@ +1 ===================================== testsuite/tests/simplCore/should_run/all.T ===================================== @@ -93,6 +93,7 @@ test('T17151', [], multimod_compile_and_run, ['T17151', '']) test('T18012', normal, compile_and_run, ['']) test('T17744', normal, compile_and_run, ['']) test('T18638', normal, compile_and_run, ['']) +test('T26323', normal, compile_and_run, ['-O']) test('NumConstantFolding8', normal, compile_and_run, ['']) test('NumConstantFolding16', normal, compile_and_run, ['']) test('NumConstantFolding32', normal, compile_and_run, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2010,25 +2010,27 @@ instance ExactPrint (RuleDecl GhcPs) where markActivation :: (Monad m, Monoid w) => ActivationAnn -> Activation -> EP w m ActivationAnn -markActivation (ActivationAnn o c t v) act = do +markActivation (ActivationAnn o src c t v) act = do case act of - ActiveBefore src phase -> do + ActiveBefore phase -> do o' <- markEpToken o -- '[' t' <- mapM markEpToken t -- ~ v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v c' <- markEpToken c -- ']' - return (ActivationAnn o' c' t' v') - ActiveAfter src phase -> do + return (ActivationAnn o' src c' t' v') + ActiveAfter phase -> do o' <- markEpToken o -- '[' v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v c' <- markEpToken c -- ']' - return (ActivationAnn o' c' t v') + return (ActivationAnn o' src c' t v') NeverActive -> do o' <- markEpToken o -- '[' t' <- mapM markEpToken t -- ~ c' <- markEpToken c -- ']' - return (ActivationAnn o' c' t' v) - _ -> return (ActivationAnn o c t v) + return (ActivationAnn o' src c' t' v) + + -- Other activations don't have corresponding source syntax + _ -> return (ActivationAnn o src c t v) -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2da84b7a83f723dc6531cdad5ef3c7e6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2da84b7a83f723dc6531cdad5ef3c7e6... You're receiving this email because of your account on gitlab.haskell.org.