[Git][ghc/ghc][wip/T21851] Fire RULES in the Specialiser

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Tue Oct 11 12:00:16 UTC 2022



Simon Peyton Jones pushed to branch wip/T21851 at Glasgow Haskell Compiler / GHC


Commits:
91ef98bc by Simon Peyton Jones at 2022-10-11T13:02:07+01:00
Fire RULES in the Specialiser

A draft patch for #21851

- - - - -


16 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Unit/External.hs
- libraries/base/GHC/Real.hs
- testsuite/tests/simplCore/should_compile/T21851.stderr
- + testsuite/tests/simplCore/should_compile/T21851c.hs
- + testsuite/tests/simplCore/should_compile/T21851d.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core.hs
=====================================
@@ -84,9 +84,8 @@ module GHC.Core (
         IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,
 
         -- * Core rule data types
-        CoreRule(..), RuleBase,
-        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
-        RuleEnv(..), RuleOpts, mkRuleEnv, emptyRuleEnv,
+        CoreRule(..),
+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts,
 
         -- ** Operations on 'CoreRule's
         ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -104,7 +103,6 @@ import GHC.Core.Coercion
 import GHC.Core.Rules.Config ( RuleOpts )
 import GHC.Types.Name
 import GHC.Types.Name.Set
-import GHC.Types.Name.Env( NameEnv )
 import GHC.Types.Literal
 import GHC.Types.Tickish
 import GHC.Core.DataCon
@@ -1061,6 +1059,12 @@ has two major consequences
    M.  But it's painful, because it means we need to keep track of all
    the orphan modules below us.
 
+ * The "visible orphan modules" are all the orphan module in the transitive
+   closure of the imports of this module.
+
+ * During instance lookup, we filter orphan instances depending on
+   whether or not the instance is in a visible orphan module.
+
  * A non-orphan is not finger-printed separately.  Instead, for
    fingerprinting purposes it is treated as part of the entity it
    mentions on the LHS.  For example
@@ -1075,12 +1079,20 @@ has two major consequences
 
 Orphan-hood is computed
   * For class instances:
-      when we make a ClsInst
-    (because it is needed during instance lookup)
+    when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance
+      (because it is needed during instance lookup)
+    See Note [When exactly is an instance decl an orphan?]
+        in GHC.Core.InstEnv
+
+  * For rules
+    when we generate a CoreRule (GHC.Core.Rules.mkRule)
+
+  * For family instances:
+    when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)
+
+Orphan-hood is persisted into interface files, in ClsInst, FamInst,
+and CoreRules.
 
-  * For rules and family instances:
-       when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)
-                     or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)
 -}
 
 {-
@@ -1095,49 +1107,6 @@ GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the
 representation.
 -}
 
--- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
-type RuleBase = NameEnv [CoreRule]
-        -- The rules are unordered;
-        -- we sort out any overlaps on lookup
-
--- | A full rule environment which we can apply rules from.  Like a 'RuleBase',
--- but it also includes the set of visible orphans we use to filter out orphan
--- rules which are not visible (even though we can see them...)
-data RuleEnv
-    = RuleEnv { re_base          :: [RuleBase] -- See Note [Why re_base is a list]
-              , re_visible_orphs :: ModuleSet
-              }
-
-mkRuleEnv :: RuleBase -> [Module] -> RuleEnv
-mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs)
-
-emptyRuleEnv :: RuleEnv
-emptyRuleEnv = RuleEnv [] emptyModuleSet
-
-{-
-Note [Why re_base is a list]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In Note [Overall plumbing for rules], it is explained that the final
-RuleBase which we must consider is combined from 4 different sources.
-
-During simplifier runs, the fourth source of rules is constantly being updated
-as new interfaces are loaded into the EPS. Therefore just before we check to see
-if any rules match we get the EPS RuleBase and combine it with the existing RuleBase
-and then perform exactly 1 lookup into the new map.
-
-It is more efficient to avoid combining the environments and store the uncombined
-environments as we can instead perform 1 lookup into each environment and then combine
-the results.
-
-Essentially we use the identity:
-
-> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)
->   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2
-
-The latter being more efficient as we don't construct an intermediate
-map.
--}
 
 -- | A 'CoreRule' is:
 --


=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -319,7 +319,9 @@ mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan
 {-
 Note [When exactly is an instance decl an orphan?]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  (see GHC.Iface.Make.instanceToIfaceInst, which implements this)
+(See GHC.Iface.Make.instanceToIfaceInst, which implements this.)
+See Note [Orphans] in GHC.Core
+
 Roughly speaking, an instance is an orphan if its head (after the =>)
 mentions nothing defined in this module.
 


=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -19,10 +19,10 @@ module GHC.Core.Opt.Monad (
 
     -- ** Reading from the monad
     getHscEnv, getModule,
-    getRuleBase, getExternalRuleBase,
+    initRuleEnv, getExternalRuleBase,
     getDynFlags, getPackageFamInstEnv,
     getInteractiveContext,
-    getVisibleOrphanMods, getUniqMask,
+    getUniqMask,
     getPrintUnqualified, getSrcSpanM,
 
     -- ** Writing to the monad
@@ -45,7 +45,7 @@ import GHC.Prelude hiding ( read )
 import GHC.Driver.Session
 import GHC.Driver.Env
 
-import GHC.Core
+import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )
 import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )
 
 import GHC.Types.Annotations
@@ -113,12 +113,11 @@ pprFloatOutSwitches sw
 
 data CoreReader = CoreReader {
         cr_hsc_env             :: HscEnv,
-        cr_rule_base           :: RuleBase,
+        cr_rule_base           :: RuleBase,  -- Home package table rules
         cr_module              :: Module,
         cr_print_unqual        :: PrintUnqualified,
         cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                              -- are at least tagged with the right source file
-        cr_visible_orphan_mods :: !ModuleSet,
         cr_uniq_mask           :: !Char      -- Mask for creating unique values
 }
 
@@ -180,19 +179,17 @@ runCoreM :: HscEnv
          -> RuleBase
          -> Char -- ^ Mask
          -> Module
-         -> ModuleSet
          -> PrintUnqualified
          -> SrcSpan
          -> CoreM a
          -> IO (a, SimplCount)
-runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m
+runCoreM hsc_env rule_base mask mod print_unqual loc m
   = liftM extract $ runIOEnv reader $ unCoreM m
   where
     reader = CoreReader {
             cr_hsc_env = hsc_env,
             cr_rule_base = rule_base,
             cr_module = mod,
-            cr_visible_orphan_mods = orph_imps,
             cr_print_unqual = print_unqual,
             cr_loc = loc,
             cr_uniq_mask = mask
@@ -244,15 +241,18 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 getHscEnv :: CoreM HscEnv
 getHscEnv = read cr_hsc_env
 
-getRuleBase :: CoreM RuleBase
-getRuleBase = read cr_rule_base
+getHomeRuleBase :: CoreM RuleBase
+getHomeRuleBase = read cr_rule_base
+
+initRuleEnv :: ModGuts -> CoreM RuleEnv
+initRuleEnv guts
+  = do { hpt_rules <- getHomeRuleBase
+       ; eps_rules <- getExternalRuleBase
+       ; return (mkRuleEnv guts eps_rules hpt_rules) }
 
 getExternalRuleBase :: CoreM RuleBase
 getExternalRuleBase = eps_rule_base <$> get_eps
 
-getVisibleOrphanMods :: CoreM ModuleSet
-getVisibleOrphanMods = read cr_visible_orphan_mods
-
 getPrintUnqualified :: CoreM PrintUnqualified
 getPrintUnqualified = read cr_print_unqual
 


=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -22,7 +22,7 @@ import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
 
 import GHC.Core
 import GHC.Core.Opt.CSE  ( cseProgram )
-import GHC.Core.Rules   ( mkRuleBase, ruleCheckProgram, getRules )
+import GHC.Core.Rules   ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )
 import GHC.Core.Ppr     ( pprCoreBindings )
 import GHC.Core.Utils   ( dumpIdInfoOfProgram )
 import GHC.Core.Lint    ( lintAnnots )
@@ -52,9 +52,7 @@ import GHC.Utils.Logger as Logger
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
-import GHC.Unit.Module.Env
 import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.Deps
 
 import GHC.Types.Id.Info
 import GHC.Types.Basic
@@ -77,14 +75,12 @@ import GHC.Unit.Module
 core2core :: HscEnv -> ModGuts -> IO ModGuts
 core2core hsc_env guts@(ModGuts { mg_module  = mod
                                 , mg_loc     = loc
-                                , mg_deps    = deps
                                 , mg_rdr_env = rdr_env })
   = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
-             orph_mods = mkModuleSet (mod : dep_orphs deps)
              uniq_mask = 's'
-       ;
+
        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod
-                                    orph_mods print_unqual loc $
+                                    print_unqual loc $
                            do { hsc_env' <- getHscEnv
                               ; all_passes <- withPlugins (hsc_plugins hsc_env')
                                                 installCoreToDos
@@ -120,7 +116,8 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod
 -}
 
 getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]
-getCoreToDo dflags rule_base extra_vars
+-- This function builds the pipeline of optimisations
+getCoreToDo dflags hpt_rule_base extra_vars
   = flatten_todos core_todo
   where
     phases        = simplPhases        dflags
@@ -158,7 +155,7 @@ getCoreToDo dflags rule_base extra_vars
       = CoreDoPasses
       $   [ maybe_strictness_before phase
           , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter
-                             (initSimplMode dflags phase name) rule_base
+                             (initSimplMode dflags phase name) hpt_rule_base
           , maybe_rule_check phase ]
 
     -- Run GHC's internal simplification phase, after all rules have run.
@@ -169,7 +166,7 @@ getCoreToDo dflags rule_base extra_vars
     -- See Note [Inline in InitialPhase]
     -- See Note [RULEs enabled in InitialPhase]
     simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter
-                                    (initGentleSimplMode dflags) rule_base
+                                    (initGentleSimplMode dflags) hpt_rule_base
 
     dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
                           else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
@@ -547,11 +544,9 @@ ruleCheckPass current_phase pat guts = do
     logger <- getLogger
     withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
                 (const ()) $ do
-        rb <- getRuleBase
-        vis_orphs <- getVisibleOrphanMods
-        let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn
-                          ++ (mg_rules guts)
-        let ropts = initRuleOpts dflags
+        rule_env <- initRuleEnv guts
+        let rule_fn fn = getRules rule_env fn
+            ropts = initRuleOpts dflags
         liftIO $ logDumpMsg logger "Rule check"
                      (ruleCheckProgram ropts current_phase pat
                         rule_fn (mg_binds guts))


=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -10,7 +10,7 @@ import GHC.Prelude
 import GHC.Driver.Flags
 
 import GHC.Core
-import GHC.Core.Rules   ( extendRuleBaseList, extendRuleEnv, addRuleInfo )
+import GHC.Core.Rules
 import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
 import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
 import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
@@ -32,7 +32,6 @@ import GHC.Utils.Trace
 import GHC.Unit.Env ( UnitEnv, ueEPS )
 import GHC.Unit.External
 import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.Deps
 
 import GHC.Types.Id
 import GHC.Types.Id.Info
@@ -82,7 +81,7 @@ simplifyExpr logger euc opts expr
               simpl_env = mkSimplEnv (se_mode opts) fam_envs
               top_env_cfg = se_top_env_cfg opts
               read_eps_rules = eps_rule_base <$> eucEPS euc
-              read_ruleenv = extendRuleEnv emptyRuleEnv <$> read_eps_rules
+              read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules
 
         ; let sz = exprSize expr
 
@@ -133,11 +132,11 @@ simplExprGently env expr = do
 -- The values of this datatype are /only/ driven by the demands of that function.
 data SimplifyOpts = SimplifyOpts
   { so_dump_core_sizes :: !Bool
-  , so_iterations :: !Int
-  , so_mode :: !SimplMode
+  , so_iterations      :: !Int
+  , so_mode            :: !SimplMode
   , so_pass_result_cfg :: !(Maybe LintPassResultConfig)
-  , so_rule_base :: !RuleBase
-  , so_top_env_cfg :: !TopEnvConfig
+  , so_hpt_rules       :: !RuleBase
+  , so_top_env_cfg     :: !TopEnvConfig
   }
 
 simplifyPgm :: Logger
@@ -149,11 +148,10 @@ simplifyPgm :: Logger
 simplifyPgm logger unit_env opts
             guts@(ModGuts { mg_module = this_mod
                           , mg_rdr_env = rdr_env
-                          , mg_deps = deps
-                          , mg_binds = binds, mg_rules = rules
+                          , mg_binds = binds, mg_rules = local_rules
                           , mg_fam_inst_env = fam_inst_env })
   = do { (termination_msg, it_count, counts_out, guts')
-            <- do_iteration 1 [] binds rules
+            <- do_iteration 1 [] binds local_rules
 
         ; when (logHasDumpFlag logger Opt_D_verbose_core2core
                 && logHasDumpFlag logger Opt_D_dump_simpl_stats) $
@@ -170,7 +168,6 @@ simplifyPgm logger unit_env opts
     dump_core_sizes = so_dump_core_sizes opts
     mode            = so_mode opts
     max_iterations  = so_iterations opts
-    hpt_rule_base   = so_rule_base opts
     top_env_cfg     = so_top_env_cfg opts
     print_unqual    = mkPrintUnqualified unit_env rdr_env
     active_rule     = activeRule mode
@@ -179,13 +176,18 @@ simplifyPgm logger unit_env opts
     -- the old bindings are retained until the end of all simplifier iterations
     !guts_no_binds = guts { mg_binds = [], mg_rules = [] }
 
+    hpt_rule_env :: RuleEnv
+    hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts)
+                   -- emptyRuleBase: no EPS rules yet; we will update
+                   -- them on each iteration to pick up the most up to date set
+
     do_iteration :: Int -- Counts iterations
                  -> [SimplCount] -- Counts from earlier iterations, reversed
-                 -> CoreProgram  -- Bindings in
-                 -> [CoreRule]   -- and orphan rules
+                 -> CoreProgram  -- Bindings
+                 -> [CoreRule]   -- Local rules for imported Ids
                  -> IO (String, Int, SimplCount, ModGuts)
 
-    do_iteration iteration_no counts_so_far binds rules
+    do_iteration iteration_no counts_so_far binds local_rules
         -- iteration_no is the number of the iteration we are
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
@@ -201,7 +203,7 @@ simplifyPgm logger unit_env opts
                 -- number of iterations we actually completed
         return ( "Simplifier baled out", iteration_no - 1
                , totalise counts_so_far
-               , guts_no_binds { mg_binds = binds, mg_rules = rules } )
+               , guts_no_binds { mg_binds = binds, mg_rules = local_rules } )
 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
@@ -210,8 +212,8 @@ simplifyPgm logger unit_env opts
       = do {
                 -- Occurrence analysis
            let { tagged_binds = {-# SCC "OccAnal" #-}
-                     occurAnalysePgm this_mod active_unf active_rule rules
-                                     binds
+                     occurAnalysePgm this_mod active_unf active_rule
+                                     local_rules binds
                } ;
            Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
                      FormatCore
@@ -222,24 +224,29 @@ simplifyPgm logger unit_env opts
                 -- poke on IdInfo thunks, which in turn brings in new rules
                 -- behind the scenes.  Otherwise there's a danger we'll simply
                 -- miss the rules for Ids hidden inside imported inlinings
-                -- Hence just before attempting to match rules we read on the EPS
-                -- value and then combine it when the existing rule base.
+                -- Hence just before attempting to match a rule we read the EPS
+                -- value (via read_rule_env) and then combine it with the existing rule base.
                 -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.
-           eps <- ueEPS unit_env ;
-           let  { -- Forcing this value to avoid unnessecary allocations.
+          eps <- ueEPS unit_env ;
+           let  { -- base_rule_env contains
+                  --    (a) home package rules, fixed across all iterations
+                  --    (b) local rules (substituted) from `local_rules` arg to do_iteration
+                  -- Forcing base_rule_env to avoid unnecessary allocations.
                   -- Not doing so results in +25.6% allocations of LargeRecord.
-                ; !rule_base = extendRuleBaseList hpt_rule_base rules
-                ; vis_orphs = this_mod : dep_orphs deps
-                ; base_ruleenv = mkRuleEnv rule_base vis_orphs
+                ; !base_rule_env = updLocalRules hpt_rule_env local_rules
+
+                ; read_eps_rules :: IO PackageRuleBase
                 ; read_eps_rules = eps_rule_base <$> ueEPS unit_env
-                ; read_ruleenv = extendRuleEnv base_ruleenv <$> read_eps_rules
+
+                ; read_rule_env :: IO RuleEnv
+                ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules
 
                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
                 ; simpl_env = mkSimplEnv mode fam_envs } ;
 
                 -- Simplify the program
            ((binds1, rules1), counts1) <-
-             initSmpl logger read_ruleenv top_env_cfg sz $
+             initSmpl logger read_rule_env top_env_cfg sz $
                do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
                                       simplTopBinds simpl_env tagged_binds
 
@@ -247,7 +254,7 @@ simplifyPgm logger unit_env opts
                       -- for imported Ids.  Eg  RULE map my_f = blah
                       -- If we have a substitution my_f :-> other_f, we'd better
                       -- apply it to the rule to, or it'll never match
-                  ; rules1 <- simplImpRules env1 rules
+                  ; rules1 <- simplImpRules env1 local_rules
 
                   ; return (getTopFloatBinds floats, rules1) } ;
 


=====================================
compiler/GHC/Core/Opt/Simplify/Monad.hs
=====================================
@@ -27,8 +27,8 @@ import GHC.Types.Name      ( mkSystemVarName )
 import GHC.Types.Id        ( Id, mkSysLocalOrCoVarM )
 import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo )
 import GHC.Core.Type       ( Type, Mult )
-import GHC.Core            ( RuleEnv(..) )
 import GHC.Core.Opt.Stats
+import GHC.Core.Rules
 import GHC.Core.Utils      ( mkLamTypes )
 import GHC.Types.Unique.Supply
 import GHC.Driver.Flags


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -53,7 +53,7 @@ import GHC.Core.Ppr
 import GHC.Core.TyCo.Ppr ( pprParendType )
 import GHC.Core.FVs
 import GHC.Core.Utils
-import GHC.Core.Rules( getRules )
+import GHC.Core.Rules( RuleEnv, getRules )
 import GHC.Core.Opt.Arity
 import GHC.Core.Unfold
 import GHC.Core.Unfold.Make


=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Tc.Utils.TcType hiding( substTy )
 
 import GHC.Core.Type  hiding( substTy, extendTvSubstList, zapSubst )
 import GHC.Core.Multiplicity
+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
 import GHC.Core.Predicate
 import GHC.Core.Coercion( Coercion )
 import GHC.Core.Opt.Monad
@@ -594,9 +595,10 @@ Hence, the invariant is this:
 -- | Specialise calls to type-class overloaded functions occurring in a program.
 specProgram :: ModGuts -> CoreM ModGuts
 specProgram guts@(ModGuts { mg_module = this_mod
-                          , mg_rules = local_rules
-                          , mg_binds = binds })
+                          , mg_rules  = local_rules
+                          , mg_binds  = binds })
   = do { dflags <- getDynFlags
+       ; rule_env <- initRuleEnv guts
 
               -- We need to start with a Subst that knows all the things
               -- that are in scope, so that the substitution engine doesn't
@@ -606,6 +608,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
        ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSetList $
                                        bindersOfBinds binds
                           , se_module = this_mod
+                          , se_rules  = rule_env
                           , se_dflags = dflags }
 
              go []           = return ([], emptyUDs)
@@ -616,7 +619,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
              -- Specialise the bindings of this module
        ; (binds', uds) <- runSpecM (go binds)
 
-       ; (spec_rules, spec_binds) <- specImports top_env local_rules uds
+       ; (spec_rules, spec_binds) <- specImports top_env uds
 
        ; return (guts { mg_binds = spec_binds ++ binds'
                       , mg_rules = spec_rules ++ local_rules }) }
@@ -681,21 +684,15 @@ specialisation (see canSpecImport):
 -}
 
 specImports :: SpecEnv
-            -> [CoreRule]
             -> UsageDetails
             -> CoreM ([CoreRule], [CoreBind])
-specImports top_env local_rules
-            (MkUD { ud_binds = dict_binds, ud_calls = calls })
+specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
   | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env)
     -- See Note [Disabling cross-module specialisation]
   = return ([], wrapDictBinds dict_binds [])
 
   | otherwise
-  = do { hpt_rules <- getRuleBase
-       ; let rule_base = extendRuleBaseList hpt_rules local_rules
-
-       ; (spec_rules, spec_binds) <- spec_imports top_env [] rule_base
-                                                  dict_binds calls
+  = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls
 
              -- Don't forget to wrap the specialized bindings with
              -- bindings for the needed dictionaries.
@@ -713,89 +710,91 @@ specImports top_env local_rules
 spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope
              -> [Id]             -- Stack of imported functions being specialised
                                  -- See Note [specImport call stack]
-             -> RuleBase         -- Rules from this module and the home package
-                                 -- (but not external packages, which can change)
              -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
                                  -- See Note [Avoiding loops in specImports]
              -> CallDetails      -- Calls for imported things
-             -> CoreM ( [CoreRule]   -- New rules
+             -> CoreM ( SpecEnv      -- Env contains the new rules
+                      , [CoreRule]   -- New rules
                       , [CoreBind] ) -- Specialised bindings
-spec_imports top_env callers rule_base dict_binds calls
+spec_imports env callers dict_binds calls
   = do { let import_calls = dVarEnvElts calls
 --       ; debugTraceMsg (text "specImports {" <+>
 --                         vcat [ text "calls:" <+> ppr import_calls
 --                              , text "dict_binds:" <+> ppr dict_binds ])
-       ; (rules, spec_binds) <- go rule_base import_calls
+       ; (env, rules, spec_binds) <- go env import_calls
 --       ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
 
-       ; return (rules, spec_binds) }
+       ; return (env, rules, spec_binds) }
   where
-    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
-    go _ [] = return ([], [])
-    go rb (cis : other_calls)
+    go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind])
+    go env [] = return (env, [], [])
+    go env (cis : other_calls)
       = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
-           ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis
+           ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis
            ; -- debugTraceMsg (text "specImport }" <+> ppr cis)
 
-           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
-           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
+           ; (env, rules2, spec_binds2) <- go env other_calls
+           ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
 
 spec_import :: SpecEnv               -- Passed in so that all top-level Ids are in scope
             -> [Id]                  -- Stack of imported functions being specialised
                                      -- See Note [specImport call stack]
-            -> RuleBase              -- Rules from this module
             -> FloatedDictBinds      -- Dict bindings, used /only/ for filterCalls
                                      -- See Note [Avoiding loops in specImports]
             -> CallInfoSet           -- Imported function and calls for it
-            -> CoreM ( [CoreRule]    -- New rules
+            -> CoreM ( SpecEnv
+                     , [CoreRule]    -- New rules
                      , [CoreBind] )  -- Specialised bindings
-spec_import top_env callers rb dict_binds cis@(CIS fn _)
+spec_import env callers dict_binds cis@(CIS fn _)
   | isIn "specImport" fn callers
-  = return ([], [])     -- No warning.  This actually happens all the time
-                        -- when specialising a recursive function, because
-                        -- the RHS of the specialised function contains a recursive
-                        -- call to the original function
+  = return (env, [], [])  -- No warning.  This actually happens all the time
+                          -- when specialising a recursive function, because
+                          -- the RHS of the specialised function contains a recursive
+                          -- call to the original function
 
   | null good_calls
-  = return ([], [])
+  = return (env, [], [])
 
   | Just rhs <- canSpecImport dflags fn
   = do {     -- Get rules from the external package state
              -- We keep doing this in case we "page-fault in"
              -- more rules as we go along
-       ; external_rule_base <- getExternalRuleBase
-       ; vis_orphs <- getVisibleOrphanMods
-       ; let rules_for_fn = getRules (RuleEnv [rb, external_rule_base] vis_orphs) fn
+       ; eps_rules <- getExternalRuleBase
+       ; let rule_env = se_rules env `updExternalPackageRules` eps_rules
 
-       ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])
+--       ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls
+--                                                    , ppr (getRules rule_env fn), ppr rhs])
        ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
-            <- runSpecM $ specCalls True top_env dict_binds
-                             rules_for_fn good_calls fn rhs
+            <- runSpecM $ specCalls True env dict_binds
+                                    (getRules rule_env fn) good_calls fn rhs
 
        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
              -- After the rules kick in we may get recursion, but
              -- we rely on a global GlomBinds to sort that out later
              -- See Note [Glom the bindings if imported functions are specialised]
 
+             new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs
+             new_env   = env { se_rules = rule_env `addLocalRules` rules1
+                             , se_subst = new_subst }
+
               -- Now specialise any cascaded calls
-       ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
-       ; (rules2, spec_binds2) <- spec_imports top_env
-                                               (fn:callers)
-                                               (extendRuleBaseList rb rules1)
-                                               (dict_binds `thenFDBs` dict_binds1)
-                                               new_calls
+--       ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
+       ; (env, rules2, spec_binds2)
+            <- spec_imports new_env (fn:callers)
+                                    (dict_binds `thenFDBs` dict_binds1)
+                                    new_calls
 
        ; let final_binds = wrapDictBinds dict_binds1 $
                            spec_binds2 ++ spec_binds1
 
-       ; return (rules2 ++ rules1, final_binds) }
+       ; return (env, rules2 ++ rules1, final_binds) }
 
   | otherwise
   = do { tryWarnMissingSpecs dflags callers fn good_calls
-       ; return ([], [])}
+       ; return (env, [], [])}
 
   where
-    dflags = se_dflags top_env
+    dflags = se_dflags env
     good_calls = filterCalls cis dict_binds
        -- SUPER IMPORTANT!  Drop calls that (directly or indirectly) refer to fn
        -- See Note [Avoiding loops in specImports]
@@ -1086,6 +1085,7 @@ data SpecEnv
              --    the RHS of specialised bindings (no type-let!)
 
        , se_module :: Module
+       , se_rules  :: RuleEnv  -- From the home package and this module
        , se_dflags :: DynFlags
      }
 
@@ -1124,8 +1124,8 @@ specExpr env expr@(App {})
        ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in
        ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args
                 -- Some dicts may have floated out of args_in;
-                -- they should be in scope for rewriteClassOps (#21689)
-             (fun_in', args_out') = rewriteClassOps env_args fun_in args_out
+                -- they should be in scope for fireRewriteRules (#21689)
+             (fun_in', args_out') = fireRewriteRules env_args fun_in args_out
        ; (fun_out', uds_fun) <- specExpr env fun_in'
        ; let uds_call = mkCallUDs env fun_out' args_out'
        ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }
@@ -1160,17 +1160,19 @@ specExpr env (Let bind body)
        ; return (foldr Let body' binds', uds) }
 
 -- See Note [Specialisation modulo dictionary selectors]
--- and Note [ClassOp/DFun selection]
-rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
-rewriteClassOps env (Var f) args
-  | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt`
-  , Just (rule, expr) <- -- pprTrace "rewriteClassOps" (ppr f $$ ppr args $$ ppr (se_subst env)) $
-                         specLookupRule env f args (idCoreRules f)
-  , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]
---  , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True
-  , (fun, args) <- collectArgs expr
-  = rewriteClassOps env fun (args++rest_args)
-rewriteClassOps _ fun args = (fun, args)
+--     Note [ClassOp/DFun selection]
+--     Note [Fire rules in the specialiser]
+fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
+fireRewriteRules env (Var f) args
+  | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f)
+  , let rest_args    = drop (ruleArity rule) args -- See Note [Extra args in the target]
+        zapped_subst = Core.zapSubst (se_subst env)
+        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst expr
+                       -- simplOptExpr needed because lookupRule returns
+                       --   (\x y. rhs) arg1 arg2
+  , (fun, args) <- collectArgs expr'
+  = fireRewriteRules env fun (args++rest_args)
+fireRewriteRules _ fun args = (fun, args)
 
 --------------
 specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
@@ -1276,7 +1278,56 @@ specCase env scrut case_bndr alts
         where
           (env_rhs, args') = substBndrs env_alt args
 
-{-
+{- Note [Fire rules in the specialiser]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#21851)
+
+    module A where
+      f :: Num b => b -> (b, b)
+      f x = (x + 1, snd (f x))
+      {-# SPECIALIZE f :: Int -> (Int, Int) #-}
+
+    module B (g') where
+      import A
+
+      g :: Num a => a -> a
+      g x = fst (f x)
+      {-# NOINLINE[99] g #-}
+
+      h :: Int -> Int
+      h = g
+
+Note that `f` has the CPR property, and so will worker/wrapper.
+
+The call to `g` in `h` will make us specialise `g @Int`. And the specialised
+version of `g` will contain the call `f @Int`; but in the subsequent run of
+the Simplifier, there will be a competition between:
+* The user-supplied SPECIALISE rule for `f`
+* The inlining of the wrapper for `f`
+
+Alas, the latter wins.  And in any case it's very fragile.  So we make the
+Specialiser fire the RULE instead.  It not hard to to (in fireRewriteRules)
+and it's very effective.  Moreover consider
+
+    module A
+      f :: (Ord a, Show b) => a -> b -> blah
+      {-# RULE forall b. f @Int @b = wombat #-}
+
+      wombat :: Show b => Int -> b -> blah
+      wombat = blah
+
+    module B
+      import A
+      g :: forall a. Ord a => blah
+      g @a = ...g...f @a @Char....
+
+      h = ....g @Int....
+
+Now, in module B, GHC will specialise g @Int, which will lead to a
+call f @Int @Char.  If we immediately (in the specialiser) rewrite
+that to womabat @Char, we have a chance to specialise `wombat`.
+
+
 Note [Floating dictionaries out of cases]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1367,13 +1418,12 @@ specBind top_lvl env (NonRec fn rhs) do_body
 
              final_binds :: [DictBind]
              -- See Note [From non-recursive to recursive]
-             final_binds
-               | not (isNilOL dump_dbs)
-               , not (null spec_defns)
-               = [recWithDumpedDicts pairs dump_dbs]
-               | otherwise
-               = [mkDB $ NonRec b r | (b,r) <- pairs]
-                 ++ fromOL dump_dbs
+             final_binds | not (isNilOL dump_dbs)
+                         , not (null spec_defns)
+                         = [recWithDumpedDicts pairs dump_dbs]
+                         | otherwise
+                         = [mkDB $ NonRec b r | (b,r) <- pairs]
+                           ++ fromOL dump_dbs
 
        ; if float_all then
              -- Rather than discard the calls mentioning the bound variables
@@ -1505,8 +1555,10 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
     foldlM spec_call ([], [], emptyUDs) calls_for_me
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
-  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
           "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
+          -- isClassOpId: class-op Ids never inline; we specialise them
+          -- through fireRewriteRules. So don't complain about missed opportunities
           -- Note [Specialisation shape]
     -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
     return ([], [], emptyUDs)
@@ -1533,9 +1585,13 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
 
     already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
     already_covered env new_rules args      -- Note [Specialisations already covered]
-       = isJust (specLookupRule env 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)
+       = isJust (specLookupRule env fn args (beginPhase inl_act)
+                                (new_rules ++ existing_rules))
+         -- Rules: we look both in the new_rules (generated by this invocation
+         --   of specCalls), and in existing_rules (passed in to specCalls)
+         -- 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.
 
     ----------------------------------------------------------
         -- Specialise to one particular call pattern
@@ -1653,13 +1709,16 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
 
 -- Convenience function for invoking lookupRule from Specialise
 -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
-specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-specLookupRule env fn args rules
-  = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules
+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, realIdUnfolding) is_active fn args rules
   where
-    dflags   = se_dflags env
-    in_scope = getSubstInScope (se_subst env)
-    ropts    = initRuleOpts dflags
+    dflags    = se_dflags env
+    in_scope  = getSubstInScope (se_subst env)
+    ropts     = initRuleOpts dflags
+    is_active = isActive phase
 
 {- Note [Specialising DFuns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1846,10 +1905,10 @@ We want to specialise this! How? By doing the method-selection rewrite in
 the Specialiser. Hence
 
 1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the
-   head of the application, repeatedly, via 'rewriteClassOps'.
+   head of the application, repeatedly, via 'fireRewriteRules'.
 2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and
    `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding
-   in 'rewriteClassOps' to do the ClassOp/DFun rewrite.
+   in 'fireRewriteRules' to do the ClassOp/DFun rewrite.
 
 NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able
 to look into the RHS of `$dC` to see the DFun.


=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -12,8 +12,10 @@ module GHC.Core.Rules (
         lookupRule,
 
         -- ** RuleBase, RuleEnv
+        RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,
+        updExternalPackageRules, addLocalRules, updLocalRules,
         emptyRuleBase, mkRuleBase, extendRuleBaseList,
-        pprRuleBase, extendRuleEnv,
+        pprRuleBase,
 
         -- ** Checking rule applications
         ruleCheckProgram,
@@ -22,6 +24,8 @@ module GHC.Core.Rules (
         extendRuleInfo, addRuleInfo,
         addIdSpecialisations,
 
+        -- ** RuleBase and RuleEnv
+
         -- * Misc. CoreRule helpers
         rulesOfBinds, getRules, pprRulesForUser,
 
@@ -34,6 +38,8 @@ import GHC.Prelude
 
 import GHC.Unit.Module   ( Module )
 import GHC.Unit.Module.Env
+import GHC.Unit.Module.ModGuts( ModGuts(..) )
+import GHC.Unit.Module.Deps( Dependencies(..) )
 
 import GHC.Driver.Session( DynFlags )
 import GHC.Driver.Ppr( showSDoc )
@@ -136,7 +142,7 @@ Note [Overall plumbing for rules]
 * At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad.
   The HomePackageTable doesn't have a single RuleBase because technically
   we should only be able to "see" rules "below" this module; so we
-  generate a RuleBase for (c) by combing rules from all the modules
+  generate a RuleBase for (c) by combining rules from all the modules
   "below" us.  That's why we can't just select the home-package RuleBase
   from HscEnv.
 
@@ -340,12 +346,100 @@ addIdSpecialisations id rules
 rulesOfBinds :: [CoreBind] -> [CoreRule]
 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 
+
+{-
+************************************************************************
+*                                                                      *
+                RuleBase
+*                                                                      *
+************************************************************************
+-}
+
+-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
+type RuleBase = NameEnv [CoreRule]
+        -- The rules are unordered;
+        -- we sort out any overlaps on lookup
+
+emptyRuleBase :: RuleBase
+emptyRuleBase = emptyNameEnv
+
+mkRuleBase :: [CoreRule] -> RuleBase
+mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
+
+extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
+extendRuleBaseList rule_base new_guys
+  = foldl' extendRuleBase rule_base new_guys
+
+extendRuleBase :: RuleBase -> CoreRule -> RuleBase
+extendRuleBase rule_base rule
+  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule
+
+pprRuleBase :: RuleBase -> SDoc
+pprRuleBase rules = pprUFM rules $ \rss ->
+  vcat [ pprRules (tidyRules emptyTidyEnv rs)
+       | rs <- rss ]
+
+-- | A full rule environment which we can apply rules from.  Like a 'RuleBase',
+-- but it also includes the set of visible orphans we use to filter out orphan
+-- rules which are not visible (even though we can see them...)
+-- See Note [Orphans] in GHC.Core
+data RuleEnv
+    = RuleEnv { re_local_rules   :: !RuleBase -- Rules from this module
+              , re_home_rules    :: !RuleBase -- Rule from the home package
+                                              --   (excl this module)
+              , re_eps_rules     :: !RuleBase -- Rules from other packages
+                                              --   see Note [External package rules]
+              , re_visible_orphs :: !ModuleSet
+              }
+
+mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv
+mkRuleEnv (ModGuts { mg_module = this_mod
+                   , mg_deps   = deps
+                   , mg_rules  = local_rules })
+          eps_rules hpt_rules
+  = RuleEnv { re_local_rules   = mkRuleBase local_rules
+            , re_home_rules    = hpt_rules
+            , re_eps_rules     = eps_rules
+            , re_visible_orphs = mkModuleSet vis_orphs }
+  where
+    vis_orphs = this_mod : dep_orphs deps
+
+updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv
+-- Completely over-ride the external rules in RuleEnv
+updExternalPackageRules rule_env eps_rules
+  = rule_env { re_eps_rules = eps_rules }
+
+updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv
+-- Completely over-ride the local rules in RuleEnv
+updLocalRules rule_env local_rules
+  = rule_env { re_local_rules = mkRuleBase local_rules }
+
+addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv
+-- Add new local rules
+addLocalRules rule_env rules
+  = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules }
+
+emptyRuleEnv :: RuleEnv
+emptyRuleEnv = RuleEnv { re_local_rules   = emptyNameEnv
+                       , re_home_rules    = emptyNameEnv
+                       , re_eps_rules     = emptyNameEnv
+                       , re_visible_orphs = emptyModuleSet }
+
 getRules :: RuleEnv -> Id -> [CoreRule]
+-- Given a RuleEnv and an Id, find the visible rules for that Id
 -- See Note [Where rules are found]
-getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn
-  = idCoreRules fn ++ concatMap imp_rules rule_base
+getRules (RuleEnv { re_local_rules   = local_rules
+                  , re_home_rules    = home_rules
+                  , re_eps_rules     = eps_rules
+                  , re_visible_orphs = orphs }) fn
+  = idCoreRules fn ++
+    get local_rules ++
+    find_visible home_rules ++
+    find_visible eps_rules
   where
-    imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` [])
+    fn_name = idName fn
+    find_visible rb = filter (ruleIsVisible orphs) (get rb)
+    get rb = lookupNameEnv rb fn_name `orElse` []
 
 ruleIsVisible :: ModuleSet -> CoreRule -> Bool
 ruleIsVisible _ BuiltinRule{} = True
@@ -371,37 +465,28 @@ but that isn't quite right:
        in the module defining the Id (when it's a LocalId), but
        the rules are kept in the global RuleBase
 
+ Note [External package rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Note [Overall plumbing for rules], it is explained that the final
+RuleBase which we must consider is combined from 4 different sources.
 
-************************************************************************
-*                                                                      *
-                RuleBase
-*                                                                      *
-************************************************************************
--}
-
--- RuleBase itself is defined in GHC.Core, along with CoreRule
-
-emptyRuleBase :: RuleBase
-emptyRuleBase = emptyNameEnv
-
-mkRuleBase :: [CoreRule] -> RuleBase
-mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
+During simplifier runs, the fourth source of rules is constantly being updated
+as new interfaces are loaded into the EPS. Therefore just before we check to see
+if any rules match we get the EPS RuleBase and combine it with the existing RuleBase
+and then perform exactly 1 lookup into the new map.
 
-extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
-extendRuleBaseList rule_base new_guys
-  = foldl' extendRuleBase rule_base new_guys
+It is more efficient to avoid combining the environments and store the uncombined
+environments as we can instead perform 1 lookup into each environment and then combine
+the results.
 
-extendRuleBase :: RuleBase -> CoreRule -> RuleBase
-extendRuleBase rule_base rule
-  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule
+Essentially we use the identity:
 
-extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv
-extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs)
+> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)
+>   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2
 
-pprRuleBase :: RuleBase -> SDoc
-pprRuleBase rules = pprUFM rules $ \rss ->
-  vcat [ pprRules (tidyRules emptyTidyEnv rs)
-       | rs <- rss ]
+The latter being more efficient as we don't construct an intermediate
+map.
+-}
 
 {-
 ************************************************************************
@@ -1576,7 +1661,7 @@ ruleCheckFun env fn args
   | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)
   where
     name_match_rules = filter match (rc_rules env fn)
-    match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
+    match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 ruleAppCheck_help env fn args rules


=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -7,7 +7,7 @@ module GHC.Driver.Config.Core.Opt.Simplify
 
 import GHC.Prelude
 
-import GHC.Core ( RuleBase )
+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(..) )
@@ -40,20 +40,19 @@ initSimplifyExprOpts dflags ic = SimplifyExprOpts
   }
 
 initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
-initSimplifyOpts dflags extra_vars iterations mode rule_base = let
+initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let
   -- This is a particularly ugly construction, but we will get rid of it in !8341.
   opts = SimplifyOpts
     { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags
-    , so_iterations = iterations
-    , so_mode = mode
+    , so_iterations      = iterations
+    , so_mode            = mode
     , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags
-      then Just $ initLintPassResultConfig dflags extra_vars (CoreDoSimplify opts)
-      else Nothing
-    , so_rule_base = rule_base
-    , so_top_env_cfg = TopEnvConfig
-        { te_history_size = historySize dflags
-        , te_tick_factor = simplTickFactor dflags
-        }
+                           then Just $ initLintPassResultConfig dflags extra_vars
+                                                            (CoreDoSimplify opts)
+                           else Nothing
+    , so_hpt_rules       = hpt_rule_base
+    , so_top_env_cfg     = TopEnvConfig { te_history_size = historySize dflags
+                                        , te_tick_factor = simplTickFactor dflags }
     }
   in opts
 


=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -21,11 +21,10 @@ import GHC.Prelude
 import GHC.Unit
 import GHC.Unit.Module.ModIface
 
-import GHC.Core         ( RuleBase )
 import GHC.Core.FamInstEnv
 import GHC.Core.InstEnv ( InstEnv, emptyInstEnv )
 import GHC.Core.Opt.ConstantFold
-import GHC.Core.Rules (mkRuleBase)
+import GHC.Core.Rules ( RuleBase, mkRuleBase)
 
 import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv )
 import GHC.Types.CompleteMatch


=====================================
libraries/base/GHC/Real.hs
=====================================
@@ -701,11 +701,14 @@ half of y - 1 can be computed as y `quot` 2, optimising subtraction away.
 
 Note [Inlining (^)
 ~~~~~~~~~~~~~~~~~~
-The INLINABLE pragma allows (^) to be specialised at its call sites.
+The INLINABLE [1] pragma allows (^) to be specialised at its call sites.
 If it is called repeatedly at the same type, that can make a huge
 difference, because of those constants which can be repeatedly
 calculated.
 
+We don't inline until phase 1, to give a chance for the RULES
+"^2/Int" etc to fire first.
+
 Currently the fromInteger calls are not floated because we get
           \d1 d2 x y -> blah
 after the gentle round of simplification.


=====================================
testsuite/tests/simplCore/should_compile/T21851.stderr
=====================================
@@ -15,5 +15,3 @@ g' :: Int -> Int
 g'
   = \ (x :: Int) -> case T21851a.$w$sf x of { (# ww, ww1 #) -> ww }
 
-
-


=====================================
testsuite/tests/simplCore/should_compile/T21851c.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -ddump-simpl -dsuppress-uniques -dno-typeable-binds #-}
+
+module T21851c where
+
+import T21851d
+
+g :: forall a. Num a => a -> (a,String)
+g n | n < 10    = (0, f n True)
+    | otherwise = g (n-2)
+-- The specialised version of g leads to a specialised
+-- call to (f @Int @Bool).  Then we want to fire f's RULE
+-- and specialise 'wombat'
+
+h = g (3::Int)
+


=====================================
testsuite/tests/simplCore/should_compile/T21851d.hs
=====================================
@@ -0,0 +1,11 @@
+module T21851d where
+
+f :: (Num a, Show b) => a -> b -> String
+{-# NOINLINE f #-}
+f x y = "no"
+{-# RULES "wombat"  f = wombat #-}
+
+wombat :: Show b => Int -> b -> String
+{-# INLINEABLE wombat #-}
+wombat 0 y = ""
+wombat n y = show y ++ wombat (n-1) y


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -434,3 +434,6 @@ test('T21286',  normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
 test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
 # One module, T22097.hs, has OPTIONS_GHC -ddump-simpl
 test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
+
+test('T21851', only_ways(['optasm']), multimod_compile, ['T21851', '-v0'])
+test('T21851-2', only_ways(['optasm']), multimod_compile, ['T21851c', '-v0'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91ef98bc9417a0382d4c4f18679eac33cac58b76

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91ef98bc9417a0382d4c4f18679eac33cac58b76
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/20221011/bafdb361/attachment-0001.html>


More information about the ghc-commits mailing list