Fire RULES in the Specialiser

The Specialiser has, for some time, fires class-op RULES in the
specialiser itself: see
   Note [Specialisation modulo dictionary selectors]

This MR beefs it up a bit, so that it fires /all/ RULES in the
specialiser, not just class-op rules.  See
   Note [Fire rules in the specialiser]
The result is a bit more specialisation; see test
   simplCore/should_compile/T21851_2

This pushed me into a bit of refactoring.  I made a new data types
GHC.Core.Rules.RuleEnv, which combines
  - the several source of rules (local, home-package, external)
  - the orphan-module dependencies

in a single record for `getRules` to consult.  That drove a bunch of
follow-on refactoring, including allowing me to remove
cr_visible_orphan_mods from the CoreReader data type.

I moved some of the RuleBase/RuleEnv stuff into GHC.Core.Rule.

The reorganisation in the Simplifier improve compile times a bit
(geom mean -0.1%), but T9961 is an outlier

Metric Decrease:
    T9961

8 files changed, 335 insertions, 169 deletions

diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index af2045caac..9b9fd995a2 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -323,7 +323,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.
 
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index e06d4ed06d..0f87a8aeb6 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/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
@@ -114,12 +114,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
 }
 
@@ -181,19 +180,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
@@ -245,15 +242,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
 
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 214e7620c2..c7834a0b31 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/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 )
@@ -53,9 +53,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
@@ -78,14 +76,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
@@ -121,7 +117,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
@@ -176,7 +173,7 @@ getCoreToDo dflags rule_base extra_vars
 
     ----------------------------
     run_simplifier mode iter
-      = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode rule_base
+      = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode hpt_rule_base
 
     simpl_phase phase name iter = CoreDoPasses $
                                   [ maybe_strictness_before phase
@@ -573,11 +570,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))
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index e473cd24af..0c8ec92f6c 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/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 )
@@ -31,7 +31,6 @@ import GHC.Utils.Constants (debugIsOn)
 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
@@ -81,7 +80,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
 
@@ -132,11 +131,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
@@ -148,11 +147,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) $
@@ -169,7 +167,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
@@ -178,13 +175,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
@@ -200,7 +202,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.
@@ -209,8 +211,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
@@ -221,24 +223,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
 
@@ -246,7 +253,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) } ;
 
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index b20bf0a8ad..d67593d1bf 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 88e6b409d5..31a0130969 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 22c3e50f73..99230b3a3b 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -17,6 +17,7 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts )
 
 import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, 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
@@ -636,9 +637,11 @@ 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 })
-  = do { dflags <- getDynFlags
+                          , mg_rules  = local_rules
+                          , mg_binds  = binds })
+  = do { dflags   <- getDynFlags
+       ; rule_env <- initRuleEnv guts
+                     -- See Note [Fire rules in the specialiser]
 
               -- We need to start with a Subst that knows all the things
               -- that are in scope, so that the substitution engine doesn't
@@ -650,6 +653,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
                                       --    mkInScopeSetList $
                                       --  bindersOfBinds binds
                           , se_module = this_mod
+                          , se_rules  = rule_env
                           , se_dflags = dflags }
 
              go []           = return ([], emptyUDs)
@@ -660,7 +664,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 }) }
@@ -725,21 +729,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.
@@ -757,89 +755,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]
@@ -1134,6 +1134,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
      }
 
@@ -1172,8 +1173,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) }
@@ -1208,17 +1209,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)
@@ -1324,7 +1327,67 @@ 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`
+In fact, the latter wins -- see Note [Rewrite rules and inlining] in
+GHC.Core.Opt.Simplify.Iteration.  However, it a bit fragile.
+
+Moreover consider (test T21851_2):
+
+    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`.
+
+Conclusion: it's treat if the Specialiser fires RULEs itself.
+It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is
+making sure that we have a reasonably up to date EPS rule base. Currently
+we load it up just once, in `initRuleEnv`, called at the beginning of
+`specProgram`.
+
+NB: you might wonder if running rules in the specialiser (this Note)
+renders Note [Rewrite rules and inlining] in the Simplifier redundant.
+That is, if we run rules in the specialiser, does it matter if we make
+rules "win" over inlining in the Simplifier?  Yes, it does!  See the
+discussion in #21851.
+
 Note [Floating dictionaries out of cases]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1415,13 +1478,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
@@ -1553,8 +1615,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 for" (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)
@@ -1581,9 +1645,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
@@ -1708,13 +1776,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1913,10 +1984,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.
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 428baa348e..d9bd0a912c 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/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 )
@@ -135,7 +141,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.
 
@@ -339,12 +345,106 @@ 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
+
+  | Just {} <- isDataConId_maybe fn   -- Short cut for data constructor workers
+  = []                                -- and wrappers, which never have any rules
+
+  | otherwise
+  = 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
@@ -370,37 +470,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.
+-}
 
 {-
 ************************************************************************
@@ -1575,7 +1666,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