Support turning off builtin ruleswip/zliu41/spec/patch/925

8 files changed, 36 insertions, 30 deletions

diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 70c40aab42..262b0d686e 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -165,17 +165,18 @@ pprPassDetails _ = Outputable.empty
 
 data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad
   = SimplMode
-        { sm_names        :: [String]       -- ^ Name(s) of the phase
-        , sm_phase        :: CompilerPhase
-        , sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options
-        , 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
-        , sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?
-        , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled
-        , sm_logger       :: !Logger
-        , sm_dflags       :: DynFlags
+        { sm_names         :: [String]       -- ^ Name(s) of the phase
+        , sm_phase         :: CompilerPhase
+        , sm_uf_opts       :: !UnfoldingOpts -- ^ Unfolding options
+        , sm_rules         :: !Bool          -- ^ Whether RULES are enabled
+        , sm_builtin_rules :: !Bool
+        , 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
+        , sm_cast_swizzle  :: !Bool          -- ^ Do we swizzle casts past lambdas?
+        , sm_pre_inline    :: !Bool          -- ^ Whether pre-inlining is enabled
+        , sm_logger        :: !Logger
+        , sm_dflags        :: DynFlags
             -- Just for convenient non-monadic access; we don't override these.
             --
             -- Used for:
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 34f283f7ed..4f5ab970cc 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -148,6 +148,7 @@ getCoreToDo logger dflags
     late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
     late_specialise = gopt Opt_LateSpecialise             dflags
     static_args   = gopt Opt_StaticArgumentTransformation dflags
+    builtin_rules_on = gopt Opt_EnableBuiltinRules        dflags
     rules_on      = gopt Opt_EnableRewriteRules           dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
     pre_inline_on = gopt Opt_SimplPreInlining             dflags
@@ -168,6 +169,7 @@ getCoreToDo logger dflags
                           , sm_logger       = logger
                           , sm_uf_opts      = unfoldingOpts dflags
                           , sm_rules        = rules_on
+                          , sm_builtin_rules = builtin_rules_on
                           , sm_eta_expand   = eta_expand_on
                           , sm_cast_swizzle = True
                           , sm_inline       = True
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 7fe17442f7..6886d35c9a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -2248,7 +2248,7 @@ tryRules env rules fn args call_cont
 -}
 
   | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)
-                                        (activeRule (getMode env)) fn
+                                        (activeRule (getMode env)) (sm_builtin_rules (getMode env)) fn
                                         (argInfoAppArgs args) rules
   -- Fire a rule for the function
   = do { checkedTick (RuleFired (ruleName rule))
@@ -4202,4 +4202,3 @@ for the RHS as well as the LHS, but that seems more conservative
 than necesary.  Allowing some inlining might, for example, eliminate
 a binding.
 -}
-
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index d607ecfaf2..6b1907724a 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -868,6 +868,7 @@ simplEnvForGHCi logger dflags
                            , sm_dflags = dflags
                            , sm_uf_opts = uf_opts
                            , sm_rules  = rules_on
+                           , sm_builtin_rules = builtin_rules_on
                            , sm_inline = False
                               -- Do not do any inlining, in case we expose some
                               -- unboxed tuple stuff that confuses the bytecode
@@ -878,10 +879,11 @@ simplEnvForGHCi logger dflags
                            , sm_pre_inline = pre_inline_on
                            }
   where
-    rules_on      = gopt Opt_EnableRewriteRules   dflags
-    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
-    pre_inline_on = gopt Opt_SimplPreInlining     dflags
-    uf_opts       = unfoldingOpts                 dflags
+    builtin_rules_on = gopt Opt_EnableBuiltinRules dflags
+    rules_on         = gopt Opt_EnableRewriteRules   dflags
+    eta_expand_on    = gopt Opt_DoLambdaEtaExpansion dflags
+    pre_inline_on    = gopt Opt_SimplPreInlining     dflags
+    uf_opts          = unfoldingOpts                 dflags
 
 updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
 updModeForStableUnfoldings unf_act current_mode
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 47c72fabf1..af443ed9d0 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1461,7 +1461,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
     already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
     already_covered ropts new_rules args      -- Note [Specialisations already covered]
        = isJust (lookupRule ropts (in_scope, realIdUnfolding)
-                            (const True) fn args
+                            (const True) True fn args
                             (new_rules ++ existing_rules))
          -- NB: we look both in the new_rules (generated by this invocation
          --     of specCalls), and in existing_rules (passed in to specCalls)
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 1a345f237a..cf47bc9164 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -381,12 +381,13 @@ pprRuleBase rules = pprUFM rules $ \rss ->
 -- successful.
 lookupRule :: RuleOpts -> InScopeEnv
            -> (Activation -> Bool)      -- When rule is active
+           -> Bool -- Whether builtin rules are active
            -> Id -> [CoreExpr]
            -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 
 -- See Note [Extra args in the target]
 -- See comments on matchRule
-lookupRule opts rule_env@(in_scope,_) is_active fn args rules
+lookupRule opts rule_env@(in_scope,_) is_active builtin_is_active fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
         []     -> Nothing
@@ -403,7 +404,7 @@ lookupRule opts rule_env@(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 $$
@@ -490,7 +491,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
 
@@ -516,14 +517,13 @@ matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 
-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
@@ -1560,7 +1560,7 @@ ruleAppCheck_help env fn args rules
 
     rule_info opts rule
         | Just _ <- matchRule opts (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"
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 5280f0ad45..34f790344c 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -181,6 +181,7 @@ data GeneralFlag
    | Opt_UnboxStrictFields
    | Opt_UnboxSmallStrictFields
    | Opt_DictsCheap
+   | Opt_EnableBuiltinRules
    | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification
    | Opt_EnableThSpliceWarnings         -- Enable warnings for TH splices
    | Opt_RegsGraph                      -- do graph coloring register allocation
@@ -399,6 +400,7 @@ optimisationFlags = EnumSet.fromList
    , Opt_UnboxStrictFields
    , Opt_UnboxSmallStrictFields
    , Opt_DictsCheap
+   , Opt_EnableBuiltinRules
    , Opt_EnableRewriteRules
    , Opt_RegsGraph
    , Opt_RegsIterative
@@ -543,4 +545,3 @@ data Language = Haskell98 | Haskell2010 | GHC2021
 
 instance Outputable Language where
     ppr = text . show
-
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 06d8005818..0b47e0bd74 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3330,6 +3330,7 @@ fFlagsDeps = [
   flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,
   flagSpec "eager-blackholing"                Opt_EagerBlackHoling,
   flagSpec "embed-manifest"                   Opt_EmbedManifest,
+  flagSpec "enable-builtin-rules"             Opt_EnableBuiltinRules,
   flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,
   flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,
   flagSpec "error-spans"                      Opt_ErrorSpans,
@@ -3894,7 +3895,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
     , ([1,2],   Opt_CSE)
     , ([1,2],   Opt_StgCSE)
     , ([2],     Opt_StgLiftLams)
-
+    , ([0,1,2], Opt_EnableBuiltinRules)
     , ([1,2],   Opt_EnableRewriteRules)
           -- Off for -O0.   Otherwise we desugar list literals
           -- to 'build' but don't run the simplifier passes that