compiler/GHC/Core.hs

@@ -85,9 +85,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,
@@ -105,7 +104,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
@@ -1062,6 +1060,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
@@ -1076,12 +1080,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)
 -}
 
 {-
@@ -1096,49 +1108,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

@@ -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.
 

compiler/GHC/Core/Opt/DmdAnal.hs

@@ -1520,6 +1520,9 @@ $wtheresCrud = \ ww ww1 ->
       ...
 ```
 This is currently a bug that we willingly accept and it's documented in #21128.
+
+See also Note [indexError] in base:GHC.Ix, which describes how we use
+SPECIALISE to mitigate this problem for indexError.
 -}
 
 {- *********************************************************************

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
 

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))

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) } ;
 

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

@@ -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)
+--     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.

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

compiler/GHC/Driver/Config/Core/Opt/Simplify.hs

@@ -6,7 +6,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/HsToCore/Errors/Ppr.hs

@@ -86,7 +86,7 @@ instance Diagnostic DsMessage where
               hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)
     DsUselessSpecialiseForClassMethodSelector poly_id
       -> mkSimpleDecorated $
-           text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
+           text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id)
     DsUselessSpecialiseForNoInlineFunction poly_id
       -> mkSimpleDecorated $
           text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)

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/Ix.hs

@@ -140,12 +140,30 @@ Note [Out-of-bounds error messages]
 The default method for 'index' generates hoplelessIndexError, because
 Ix doesn't have Show as a superclass.  For particular base types we
 can do better, so we override the default method for index.
--}
 
--- Abstract these errors from the relevant index functions so that
--- the guts of the function will be small enough to inline.
+Note [indexError]
+~~~~~~~~~~~~~~~~~
+We abstract the guts of constructing an out-of-bounds error into `indexError`.
+We give it a NOINLINE pragma, because we don't want to duplicate this
+cold-path code.
+
+We give it a SPECIALISE pragma because we really want it to take
+its arguments unboxed, to avoid reboxing code in the caller, and
+perhaps even some reboxing code in the hot path of a caller.
+See Note [Boxity for bottoming functions] in GHC.Core.Opt.DmdAnal.
+
+The SPECIALISE pragma means that at least the Int-indexed case
+of indexError /will/ unbox its arguments.
 
+The [2] phase is because if we don't give an activation we'll get
+the one from the inline pragama (i.e. never) which is a bit silly.
+See Note [Activation pragmas for SPECIALISE] in GHC.HsToCore.Binds.
+-}
+
+-- indexError: see Note [indexError]
 {-# NOINLINE indexError #-}
+{-# SPECIALISE [2] indexError :: (Int,Int) -> Int -> String -> b #-}
+
 indexError :: Show a => (a,a) -> a -> String -> b
 indexError rng i tp
   = errorWithoutStackTrace (showString "Ix{" . showString tp . showString "}.index: Index " .

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/T21851_2.hs

+{-# OPTIONS_GHC -ddump-simpl -dsuppress-uniques -dno-typeable-binds #-}
+
+module T21851_2 where
+
+import T21851_2a
+
+g :: forall a. (Ord 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/T21851_2.stderr

+[1 of 2] Compiling T21851_2a        ( T21851_2a.hs, T21851_2a.o )
+[2 of 2] Compiling T21851_2         ( T21851_2.hs, T21851_2.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 107, types: 96, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Integer
+[GblId, Unf=OtherCon []]
+lvl = GHC.Num.Integer.IS 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl1 :: Integer
+[GblId, Unf=OtherCon []]
+lvl1 = GHC.Num.Integer.IS 0#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl2 :: Integer
+[GblId, Unf=OtherCon []]
+lvl2 = GHC.Num.Integer.IS 10#
+
+Rec {
+-- RHS size: {terms: 25, types: 5, coercions: 0, joins: 0/0}
+T21851_2.$s$wwombat [InlPrag=[~], Occ=LoopBreaker]
+  :: GHC.Prim.Int# -> Bool -> [Char]
+[GblId, Arity=2, Str=<1L><ML>, Unf=OtherCon []]
+T21851_2.$s$wwombat
+  = \ (ww :: GHC.Prim.Int#) (y :: Bool) ->
+      case ww of ds {
+        __DEFAULT ->
+          case y of {
+            False ->
+              GHC.CString.unpackAppendCString#
+                GHC.Show.$fShowBool3
+                (T21851_2.$s$wwombat (GHC.Prim.-# ds 1#) GHC.Types.False);
+            True ->
+              GHC.CString.unpackAppendCString#
+                GHC.Show.$fShowBool2
+                (T21851_2.$s$wwombat (GHC.Prim.-# ds 1#) GHC.Types.True)
+          };
+        0# -> GHC.Types.[] @Char
+      }
+end Rec }
+
+Rec {
+-- RHS size: {terms: 16, types: 6, coercions: 0, joins: 0/0}
+T21851_2.$w$sg [InlPrag=[2], Occ=LoopBreaker]
+  :: GHC.Prim.Int# -> (# GHC.Prim.Int#, String #)
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []]
+T21851_2.$w$sg
+  = \ (ww :: GHC.Prim.Int#) ->
+      case GHC.Prim.<# ww 10# of {
+        __DEFAULT -> T21851_2.$w$sg (GHC.Prim.-# ww 2#);
+        1# -> (# 0#, T21851_2.$s$wwombat ww GHC.Types.True #)
+      }
+end Rec }
+
+-- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0}
+lvl3 :: forall {a}. [Char]
+[GblId]
+lvl3 = \ (@a) -> T21851_2a.$wf GHC.Prim.(##) @a @Bool
+
+Rec {
+-- RHS size: {terms: 27, types: 18, coercions: 0, joins: 0/0}
+T21851_2.$wg [InlPrag=[2], Occ=LoopBreaker]
+  :: forall {a}. (Ord a, Num a) => a -> (# a, String #)
+[GblId[StrictWorker([!])],
+ Arity=3,
+ Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><L>,
+ Unf=OtherCon []]
+T21851_2.$wg
+  = \ (@a) ($dOrd :: Ord a) ($dNum :: Num a) (n :: a) ->
+      case < @a $dOrd n (fromInteger @a $dNum lvl2) of {
+        False ->
+          T21851_2.$wg
+            @a $dOrd $dNum (- @a $dNum n (fromInteger @a $dNum lvl));
+        True -> (# fromInteger @a $dNum lvl1, lvl3 @a #)
+      }
+end Rec }
+
+-- RHS size: {terms: 13, types: 16, coercions: 0, joins: 0/0}
+g [InlPrag=[2]] :: forall a. (Ord a, Num a) => a -> (a, String)
+[GblId,
+ Arity=3,
+ Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 ($dOrd [Occ=Once1] :: Ord a)
+                 ($dNum [Occ=Once1] :: Num a)
+                 (n [Occ=Once1] :: a) ->
+                 case T21851_2.$wg @a $dOrd $dNum n of
+                 { (# ww [Occ=Once1], ww1 [Occ=Once1] #) ->
+                 (ww, ww1)
+                 }}]
+g = \ (@a) ($dOrd :: Ord a) ($dNum :: Num a) (n :: a) ->
+      case T21851_2.$wg @a $dOrd $dNum n of { (# ww, ww1 #) ->
+      (ww, ww1)
+      }
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+h :: (Int, String)
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 10}]
+h = case T21851_2.$w$sg 3# of { (# ww, ww1 #) ->
+    (GHC.Types.I# ww, ww1)
+    }
+
+
+------ Local rules for imported ids --------
+"SPEC/T21851_2 $wwombat @Bool" [2]
+    forall ($dShow :: Show Bool).
+      T21851_2a.$wwombat @Bool $dShow
+      = T21851_2.$s$wwombat
+
+

testsuite/tests/simplCore/should_compile/T21851_2a.hs

+module T21851_2a 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

@@ -442,3 +442,7 @@ test('T22357',  normal, compile, ['-O'])
 #    Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
 test('T17366',  normal, multimod_compile, ['T17366', '-O -v0 -ddump-rule-firings'])
 test('T17366_AR',  [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -v0 -ddump-rule-firings'])
+
+# One module, T21851_2.hs, has OPTIONS_GHC -ddump-simpl
+# Expecting to see $s$wwombat
+test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O -dno-typeable-binds -dsuppress-uniques'])