[Git][ghc/ghc][wip/zliu41/sm_builtin_rules] sm_builtin_rules
Ziyang Liu (@zliu41)
gitlab at gitlab.haskell.org
Sun Jun 11 13:35:54 UTC 2023
Ziyang Liu pushed to branch wip/zliu41/sm_builtin_rules at Glasgow Haskell Compiler / GHC
Commits:
a780d7c1 by Ziyang Liu at 2023-06-11T15:35:45+02:00
sm_builtin_rules
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -138,6 +138,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
late_specialise = gopt Opt_LateSpecialise dflags
static_args = gopt Opt_StaticArgumentTransformation dflags
rules_on = gopt Opt_EnableRewriteRules dflags
+ builtin_rules_on = gopt Opt_EnableBuiltinRules dflags
ww_on = gopt Opt_WorkerWrapper dflags
static_ptrs = xopt LangExt.StaticPointers dflags
profiling = ways dflags `hasWay` WayProf
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -239,34 +239,36 @@ 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_names :: ![String] -- ^ Name(s) of the phase
- , sm_rules :: !Bool -- ^ Whether RULES are enabled
- , sm_inline :: !Bool -- ^ Whether inlining is enabled
- , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled
- , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?
- , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
- , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled
- , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled
- , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
+ { sm_phase :: !CompilerPhase
+ , sm_names :: ![String] -- ^ Name(s) of the phase
+ , sm_rules :: !Bool -- ^ Whether RULES are enabled
+ , sm_builtin_rules :: !Bool -- ^ Whether built-in rules are enabled
+ , sm_inline :: !Bool -- ^ Whether inlining is enabled
+ , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled
+ , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?
+ , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
+ , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled
+ , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled
+ , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
, sm_do_eta_reduction :: !Bool
- , sm_arity_opts :: !ArityOpts
- , sm_rule_opts :: !RuleOpts
- , sm_case_folding :: !Bool
- , sm_case_merge :: !Bool
- , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
+ , sm_arity_opts :: !ArityOpts
+ , sm_rule_opts :: !RuleOpts
+ , sm_case_folding :: !Bool
+ , sm_case_merge :: !Bool
+ , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
}
instance Outputable SimplMode where
ppr (SimplMode { sm_phase = p , sm_names = ss
- , sm_rules = r, sm_inline = i
- , sm_cast_swizzle = cs
+ , sm_rules = r, sm_builtin_rules = br
+ , sm_inline = i, sm_cast_swizzle = cs
, sm_eta_expand = eta, sm_case_case = cc })
= text "SimplMode" <+> braces (
sep [ text "Phase =" <+> ppr p <+>
brackets (text (concat $ intersperse "," ss)) <> comma
, pp_flag i (text "inline") <> comma
, pp_flag r (text "rules") <> comma
+ , pp_flag br (text "builtin-rules") <> comma
, pp_flag eta (text "eta-expand") <> comma
, pp_flag cs (text "cast-swizzle") <> comma
, pp_flag cc (text "case-of-case") ])
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2484,7 +2484,8 @@ tryRules env rules fn args call_cont
-}
| Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)
- (activeRule (seMode env)) fn
+ (activeRule (seMode env))
+ (sm_builtin_rules (seMode env)) fn
(argInfoAppArgs args) rules
-- Fire a rule for the function
= do { logger <- getLogger
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1822,7 +1822,7 @@ specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-> CompilerPhase -- Look up rules as if we were in this phase
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
specLookupRule env fn args phase rules
- = lookupRule ropts in_scope_env is_active fn args rules
+ = lookupRule ropts in_scope_env is_active True fn args rules
where
dflags = se_dflags env
in_scope = getSubstInScope (se_subst env)
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -523,6 +523,7 @@ map.
-- successful.
lookupRule :: RuleOpts -> InScopeEnv
-> (Activation -> Bool) -- When rule is active
+ -> Bool -- Whether builtin rules are active
-> Id -- Function head
-> [CoreExpr] -- Args
-> [CoreRule] -- Rules
@@ -530,7 +531,7 @@ lookupRule :: RuleOpts -> InScopeEnv
-- See Note [Extra args in the target]
-- See comments on matchRule
-lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
+lookupRule opts rule_env@(ISE in_scope _) is_active builtin_is_active fn args rules
= -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
case go [] rules of
[] -> Nothing
@@ -547,7 +548,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
go ms [] = ms
go ms (r:rs)
- | Just e <- matchRule opts rule_env is_active fn args' rough_args r
+ | Just e <- matchRule opts rule_env is_active builtin_is_active fn args' rough_args r
= go ((r,mkTicks ticks e):ms) rs
| otherwise
= -- pprTrace "match failed" (ppr r $$ ppr args $$
@@ -645,7 +646,7 @@ start, in general eta expansion wastes work. SLPJ July 99
-}
------------------------------------
-matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
+matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) -> Bool
-> Id -> [CoreExpr] -> [Maybe Name]
-> CoreRule -> Maybe CoreExpr
@@ -674,14 +675,13 @@ matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
-- NB: The 'surplus' argument e4 in the input is simply dropped.
-- See Note [Extra args in the target]
-matchRule opts rule_env _is_active fn args _rough_args
+matchRule opts rule_env _is_active builtin_is_active fn args _rough_args
(BuiltinRule { ru_try = match_fn })
--- Built-in rules can't be switched off, it seems
- = case match_fn opts rule_env fn args of
- Nothing -> Nothing
- Just expr -> Just expr
+ = if builtin_is_active
+ then match_fn opts rule_env fn args
+ else Nothing
-matchRule _ rule_env is_active _ args rough_args
+matchRule _ rule_env is_active _ _ args rough_args
(Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops
, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })
| not (is_active act) = Nothing
@@ -1870,7 +1870,7 @@ ruleAppCheck_help env fn args rules
rule_info opts rule
| Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))
- noBlackList fn args rough_args rule
+ noBlackList True fn args rough_args rule
= text "matches (which is very peculiar!)"
rule_info _ (BuiltinRule {}) = text "does not match"
=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -61,6 +61,7 @@ initSimplMode dflags phase name = SimplMode
{ sm_names = [name]
, sm_phase = phase
, sm_rules = gopt Opt_EnableRewriteRules dflags
+ , sm_builtin_rules = gopt Opt_EnableRewriteRules dflags
, sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
, sm_cast_swizzle = True
, sm_inline = True
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -1273,7 +1273,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
-- to 'build' but don't run the simplifier passes that
-- would rewrite them back to cons cells! This seems
-- silly, and matters for the GHCi debugger.
-
+ , ([0,1,2], Opt_EnableBuiltinRules)
, ([1,2], Opt_FloatIn)
, ([1,2], Opt_FullLaziness)
, ([1,2], Opt_IgnoreAsserts)
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -271,6 +271,7 @@ data GeneralFlag
| Opt_UnboxSmallStrictFields
| Opt_DictsCheap
| Opt_EnableRewriteRules -- Apply rewrite rules during simplification
+ | Opt_EnableBuiltinRules -- Apply built-in rules during simplification
| Opt_EnableThSpliceWarnings -- Enable warnings for TH splices
| Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
@@ -516,6 +517,7 @@ optimisationFlags = EnumSet.fromList
, Opt_UnboxSmallStrictFields
, Opt_DictsCheap
, Opt_EnableRewriteRules
+ , Opt_EnableBuiltinRules
, Opt_RegsGraph
, Opt_RegsIterative
, Opt_PedanticBottoms
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2340,6 +2340,7 @@ fFlagsDeps = [
flagSpec "eager-blackholing" Opt_EagerBlackHoling,
flagSpec "embed-manifest" Opt_EmbedManifest,
flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules,
+ flagSpec "enable-builtin-rules" Opt_EnableBuiltinRules,
flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings,
flagSpec "error-spans" Opt_ErrorSpans,
flagSpec "excess-precision" Opt_ExcessPrecision,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a780d7c119072b702aea81d2927048f1bcbd791d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a780d7c119072b702aea81d2927048f1bcbd791d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230611/f868d71c/attachment-0001.html>
More information about the ghc-commits
mailing list