Teach SpecConstr about typeDeterminesValue

This patch addresses #21831, point 2.  See
Note [generaliseDictPats] in SpecConstr

I took the opportunity to refactor the construction of specialisation
rules a bit, so that the rule name says what type we are specialising
at.

Surprisingly, there's a 20% decrease in compile time for test
perf/compiler/T18223. I took a look at it, and the code size seems the
same throughout. I did a quick ticky profile which seemed to show a
bit less substitution going on.  Hmm.  Maybe it's the "don't do
eta-expansion in stable unfoldings" patch, which is part of the
same MR as this patch.

Anyway, since it's a move in the right direction, I didn't think it
was worth looking into further.

Metric Decrease:
    T18223

13 files changed, 214 insertions, 158 deletions

diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 173d546b73..d3cf764be0 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -28,13 +28,14 @@ import GHC.Core
 import GHC.Core.Subst
 import GHC.Core.Utils
 import GHC.Core.Unfold
-import GHC.Core.FVs     ( exprsFreeVarsList )
+import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )
 import GHC.Core.Opt.Monad
 import GHC.Core.Opt.WorkWrap.Utils
 import GHC.Core.DataCon
 import GHC.Core.Class( classTyVars )
 import GHC.Core.Coercion hiding( substCo )
 import GHC.Core.Rules
+import GHC.Core.Predicate ( typeDeterminesValue )
 import GHC.Core.Type     hiding ( substTy )
 import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName )
 import GHC.Core.Multiplicity
@@ -1811,6 +1812,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
 --        return ()
 
                 -- And build the results
+        ; (qvars', pats') <- generaliseDictPats qvars pats
         ; let spec_body_ty   = exprType spec_body
               (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)
                   = calcSpecInfo fn call_pat extra_bndrs
@@ -1848,7 +1850,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
               inline_act = idInlineActivation fn
               this_mod   = sc_module $ sc_opts env
               rule       = mkRule this_mod True {- Auto -} True {- Local -}
-                                  rule_name inline_act fn_name qvars pats rule_rhs
+                                  rule_name inline_act
+                                  fn_name qvars' pats' rule_rhs
                            -- See Note [Transfer activation]
 
         -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))
@@ -1870,6 +1873,27 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                                , os_id = spec_id
                                , os_rhs = spec_rhs }) }
 
+generaliseDictPats :: [Var] -> [CoreExpr]  -- Quantified vars and pats
+                   -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats
+-- See Note [generaliseDictPats]
+generaliseDictPats qvars pats
+  = do { (extra_qvars, pats') <- mapAccumLM go [] pats
+       ; case extra_qvars of
+             [] -> return (qvars,                pats)
+             _  -> return (qvars ++ extra_qvars, pats') }
+  where
+    qvar_set = mkVarSet qvars
+    go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr)
+    go extra_qvs pat
+       | not (isTyCoArg pat)
+       , let pat_ty = exprType pat
+       , typeDeterminesValue pat_ty
+       , exprFreeVars pat `disjointVarSet` qvar_set
+       = do { id <- mkSysLocalOrCoVarM (fsLit "dict") Many pat_ty
+            ; return (id:extra_qvs, Var id) }
+       | otherwise
+       = return (extra_qvs, pat)
+
 -- See Note [SpecConstr and strict fields]
 mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
 mkSeqs seqees res_ty rhs =
@@ -1910,6 +1934,33 @@ Now we get:
     $sf void @t = $se
     RULE: f True = $sf void#
 And now we can substitute `f True` with `$sf void#` with everything working out nicely!
+
+Note [generaliseDictPats]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these two rules (#21831, item 2):
+  RULE "SPEC:foo"  forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1
+  RULE "SC:foo"    forall a. foo @Int @a $fNumInteger = $sfoo2 @a
+The former comes from the type class specialiser, the latter from SpecConstr.
+Note that $fNumInteger is a top-level binding for Num Integer.
+
+The trouble is that neither is more general than the other.  In a call
+   (foo @Int @Integer $fNumInteger d)
+it isn't clear which rule to fire.
+
+The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger,
+but actually /could/ fire regardless.  That is, it could be
+  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a
+
+Now, it is clear that SPEC:foo is more specific.  But GHC can't tell
+that, because SpecConstr doesn't know that dictionary arguments are
+singleton types!  So generaliseDictPats teaches it this fact.  It
+spots such patterns (using typeDeterminesValue), and quantifies over
+the dictionary.  Now we get
+
+  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a
+
+And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new
+"SC:foo" to match the (prefix of) "SPEC:foo".
 -}
 
 calcSpecInfo :: Id                     -- The original function
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 74a903fbc8..9d948765aa 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -13,7 +13,6 @@ module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Ppr
 import GHC.Driver.Config
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Config.Core.Rules ( initRuleOpts )
@@ -34,15 +33,13 @@ import GHC.Core.Utils     ( exprIsTrivial
                           , stripTicksTop )
 import GHC.Core.FVs
 import GHC.Core.TyCo.Rep (TyCoBinder (..))
-import GHC.Core.Opt.Arity     ( collectBindersPushingCo
-                              , etaExpandToJoinPointRule )
+import GHC.Core.Opt.Arity( collectBindersPushingCo )
 
 import GHC.Builtin.Types  ( unboxedUnitTy )
 
-import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust )
+import GHC.Data.Maybe     ( maybeToList, isJust )
 import GHC.Data.Bag
 import GHC.Data.OrdList
-import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
 import GHC.Types.Basic
@@ -1577,7 +1574,7 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
                  (spec_bndrs, spec_rhs, spec_fn_ty)
                    | add_void_arg = ( voidPrimId : spec_bndrs1
-                                    , Lam        voidArgId  spec_rhs1
+                                    , Lam voidArgId spec_rhs1
                                     , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)
                    | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
 
@@ -1598,28 +1595,9 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
                        | otherwise = -- Specialising local fn
                                      text "SPEC"
 
-                rule_name = mkFastString $ showSDoc dflags $
-                            herald <+> ftext (occNameFS (getOccName fn))
-                                   <+> hsep (mapMaybe ppr_call_key_ty call_args)
-                            -- This name ends up in interface files, so use occNameString.
-                            -- Otherwise uniques end up there, making builds
-                            -- less deterministic (See #4012 comment:61 ff)
-
-                rule_wout_eta = mkRule
-                                  this_mod
-                                  True {- Auto generated -}
-                                  is_local
-                                  rule_name
-                                  inl_act       -- Note [Auto-specialisation and RULES]
-                                  (idName fn)
-                                  rule_bndrs
-                                  rule_lhs_args
-                                  (mkVarApps (Var spec_fn) spec_bndrs)
-
-                spec_rule
-                  = case isJoinId_maybe fn of
-                      Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta
-                      Nothing -> rule_wout_eta
+                spec_rule = mkSpecRule dflags this_mod True inl_act
+                                    herald fn rule_bndrs rule_lhs_args
+                                    (mkVarApps (Var spec_fn) spec_bndrs)
 
                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                 -- See Note [Specialising Calls]
@@ -1675,7 +1653,6 @@ specLookupRule env fn args rules
     in_scope = Core.substInScope (se_subst env)
     ropts    = initRuleOpts dflags
 
-
 {- Note [Specialising DFuns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 DFuns have a special sort of unfolding (DFunUnfolding), and these are
@@ -2630,12 +2607,6 @@ pprCallInfo :: Id -> CallInfo -> SDoc
 pprCallInfo fn (CI { ci_key = key })
   = ppr fn <+> ppr key
 
-ppr_call_key_ty :: SpecArg -> Maybe SDoc
-ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty
-ppr_call_key_ty UnspecType    = Just $ char '_'
-ppr_call_key_ty (SpecDict _)  = Nothing
-ppr_call_key_ty UnspecArg     = Nothing
-
 instance Outputable CallInfo where
   ppr (CI { ci_key = key, ci_fvs = _fvs })
     = text "CI" <> braces (sep (map ppr key))
@@ -2767,20 +2738,8 @@ wantCallsFor _env _f = True
  -- all in one place.  So we simply collect usage info for imported
  -- overloaded functions.
 
-{- Note [Type determines value]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Only specialise on non-impicit-parameter predicates, because these
-are the ones whose *type* determines their *value*.  In particular,
-with implicit params, the type args *don't* say what the value of the
-implicit param is!  See #7101.
-
-So we treat implicit params just like ordinary arguments for the
-purposes of specialisation.  Note that we still want to specialise
-functions with implicit params if they have *other* dicts which are
-class params; see #17930.
-
-Note [Interesting dictionary arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this
          \a.\d:Eq a.  let f = ... in ...(f d)...
 There really is not much point in specialising f wrt the dictionary d,
@@ -2845,10 +2804,6 @@ in the NonRec case of specBind.  (This is too exotic to trouble with
 the Rec case.)
 -}
 
-typeDeterminesValue :: Type -> Bool
--- See Note [Type determines value]
-typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
-
 interestingDict :: CoreExpr -> Type -> Bool
 -- A dictionary argument is interesting if it has *some* structure,
 -- see Note [Interesting dictionary arguments]
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index 9dd1a7b815..b3fde40055 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -19,7 +19,7 @@ module GHC.Core.Predicate (
   mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
 
   -- Class predicates
-  mkClassPred, isDictTy,
+  mkClassPred, isDictTy, typeDeterminesValue,
   isClassPred, isEqPredClass, isCTupleClass,
   getClassPredTys, getClassPredTys_maybe,
   classMethodTy, classMethodInstTy,
@@ -102,6 +102,10 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys
 isDictTy :: Type -> Bool
 isDictTy = isClassPred
 
+typeDeterminesValue :: Type -> Bool
+-- See Note [Type determines value]
+typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
+
 getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
 getClassPredTys ty = case getClassPredTys_maybe ty of
         Just (clas, tys) -> (clas, tys)
@@ -132,6 +136,19 @@ classMethodInstTy sel_id arg_tys
   = funResultTy $
     piResultTys (varType sel_id) arg_tys
 
+{- Note [Type determines value]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only specialise on non-impicit-parameter predicates, because these
+are the ones whose *type* determines their *value*.  In particular,
+with implicit params, the type args *don't* say what the value of the
+implicit param is!  See #7101.
+
+So we treat implicit params just like ordinary arguments for the
+purposes of specialisation.  Note that we still want to specialise
+functions with implicit params if they have *other* dicts which are
+class params; see #17930.
+-}
+
 -- --------------------- Equality predicates ---------------------------------
 
 -- | A choice of equality relation. This is separate from the type 'Role'
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index eba63f590a..e2d6487267 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -8,7 +8,10 @@
 -- | Functions for collecting together and applying rewrite rules to a module.
 -- The 'CoreRule' datatype itself is declared elsewhere.
 module GHC.Core.Rules (
-        -- ** Constructing
+        -- ** Looking up rules
+        lookupRule,
+
+        -- ** RuleBase, RuleEnv
         emptyRuleBase, mkRuleBase, extendRuleBaseList,
         pprRuleBase, extendRuleEnv,
 
@@ -22,7 +25,9 @@ module GHC.Core.Rules (
         -- * Misc. CoreRule helpers
         rulesOfBinds, getRules, pprRulesForUser,
 
-        lookupRule, mkRule, roughTopNames
+        -- * Making rules
+        mkRule, mkSpecRule, roughTopNames
+
     ) where
 
 import GHC.Prelude
@@ -30,6 +35,9 @@ import GHC.Prelude
 import GHC.Unit.Module   ( Module )
 import GHC.Unit.Module.Env
 
+import GHC.Driver.Session( DynFlags )
+import GHC.Driver.Ppr( showSDoc )
+
 import GHC.Core         -- All of it
 import GHC.Core.Subst
 import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
@@ -43,9 +51,11 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX )
 import GHC.Core.Type as Type
    ( Type, TCvSubst, extendTvSubst, extendCvSubst
    , mkEmptyTCvSubst, substTy, getTyVar_maybe )
+import GHC.Core.TyCo.Ppr( pprParendType )
 import GHC.Core.Coercion as Coercion
 import GHC.Core.Tidy     ( tidyRules )
 import GHC.Core.Map.Expr ( eqCoreExpr )
+import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )
 
 import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe )
 import GHC.Builtin.Types    ( anyTypeOfKind )
@@ -58,6 +68,7 @@ import GHC.Types.Var.Set
 import GHC.Types.Name    ( Name, NamedThing(..), nameIsLocalOrFrom )
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
+import GHC.Types.Name.Occurrence( occNameFS )
 import GHC.Types.Unique.FM
 import GHC.Types.Tickish
 import GHC.Types.Basic
@@ -152,33 +163,18 @@ Note [Overall plumbing for rules]
 *                                                                      *
 ************************************************************************
 
-A @CoreRule@ holds details of one rule for an @Id@, which
+A CoreRule holds details of one rule for an Id, which
 includes its specialisations.
 
-For example, if a rule for @f@ contains the mapping:
-\begin{verbatim}
-        forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
-\end{verbatim}
+For example, if a rule for f is
+   RULE "f" forall @a @b d. f @(List a) @b d = f' a b
+
 then when we find an application of f to matching types, we simply replace
 it by the matching RHS:
-\begin{verbatim}
         f (List Int) Bool dict ===>  f' Int Bool
-\end{verbatim}
 All the stuff about how many dictionaries to discard, and what types
 to apply the specialised function to, are handled by the fact that the
 Rule contains a template for the result of the specialisation.
-
-There is one more exciting case, which is dealt with in exactly the same
-way.  If the specialised value is unboxed then it is lifted at its
-definition site and unlifted at its uses.  For example:
-
-        pi :: forall a. Num a => a
-
-might have a specialisation
-
-        [Int#] ===>  (case pi' of Lift pi# -> pi#)
-
-where pi' :: Lift Int# is the specialised version of pi.
 -}
 
 mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
@@ -207,6 +203,40 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs
     orph = chooseOrphanAnchor local_lhs_names
 
 --------------
+mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc
+           -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
+-- Make a specialisation rule, for Specialise or SpecConstr
+mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs
+  = case isJoinId_maybe fn of
+      Just join_arity -> etaExpandToJoinPointRule join_arity rule
+      Nothing         -> rule
+  where
+    rule = mkRule this_mod is_auto is_local
+                  rule_name
+                  inl_act       -- Note [Auto-specialisation and RULES]
+                  (idName fn)
+                  bndrs args rhs
+
+    is_local = isLocalId fn
+    rule_name = mkSpecRuleName dflags herald fn args
+
+mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString
+mkSpecRuleName dflags herald fn args
+  = mkFastString $ showSDoc dflags $
+    herald <+> ftext (occNameFS (getOccName fn))
+                     -- This name ends up in interface files, so use occNameFS.
+                     -- Otherwise uniques end up there, making builds
+                     -- less deterministic (See #4012 comment:61 ff)
+           <+> hsep (mapMaybe ppr_call_key_ty args)
+  where
+    ppr_call_key_ty :: CoreExpr -> Maybe SDoc
+    ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of
+                                  Just {} -> Just (text "@_")
+                                  Nothing -> Just $ char '@' <> pprParendType ty
+    ppr_call_key_ty _ = Nothing
+
+
+--------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
 -- ^ Find the \"top\" free names of several expressions.
 -- Such names are either:
@@ -446,16 +476,9 @@ findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)
     (fn,args) = target
 
 isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
--- This tests if one rule is more specific than another
--- We take the view that a BuiltinRule is less specific than
--- anything else, because we want user-define rules to "win"
--- In particular, class ops have a built-in rule, but we
--- any user-specific rules to win
---   eg (#4397)
---      truncate :: (RealFrac a, Integral b) => a -> b
---      {-# RULES "truncate/Double->Int" truncate = double2Int #-}
---      double2Int :: Double -> Int
---   We want the specific RULE to beat the built-in class-op rule
+-- The call (rule1 `isMoreSpecific` rule2)
+-- sees if rule2 can be instantiated to look like rule1
+-- See Note [isMoreSpecific]
 isMoreSpecific _        (BuiltinRule {}) _                = False
 isMoreSpecific _        (Rule {})        (BuiltinRule {}) = True
 isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
@@ -470,7 +493,24 @@ isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
 noBlackList :: Activation -> Bool
 noBlackList _ = False           -- Nothing is black listed
 
-{- Note [Extra args in the target]
+{- Note [isMoreSpecific]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The call (rule1 `isMoreSpecific` rule2)
+sees if rule2 can be instantiated to look like rule1.
+
+Wrinkle:
+
+* We take the view that a BuiltinRule is less specific than
+  anything else, because we want user-defined rules to "win"
+  In particular, class ops have a built-in rule, but we
+  prefer any user-specific rules to win:
+    eg (#4397)
+       truncate :: (RealFrac a, Integral b) => a -> b
+       {-# RULES "truncate/Double->Int" truncate = double2Int #-}
+       double2Int :: Double -> Int
+  We want the specific RULE to beat the built-in class-op rule
+
+Note [Extra args in the target]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we find a matching rule, we return (Just (rule, rhs)),
 /but/ the rule firing has only consumed as many of the input args
@@ -610,6 +650,27 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs
               , text "LHS args:" <+> ppr tmpl_es
               , text "Actual args:" <+> ppr target_es ]
 
+----------------------
+match_exprs :: RuleMatchEnv -> RuleSubst
+            -> [CoreExpr]       -- Templates
+            -> [CoreExpr]       -- Targets
+            -> Maybe RuleSubst
+-- If the targets are longer than templates, succeed, simply ignoring
+-- the leftover targets. This matters in the call in matchN.
+--
+-- Precondition: corresponding elements of es1 and es2 have the same
+--               type, assuming earlier elements match.
+-- Example:  f :: forall v. v -> blah
+--   match_exprs [Type a, y::a] [Type Int, 3]
+-- Then, after matching Type a against Type Int,
+-- the type of (y::a) matches that of (3::Int)
+match_exprs _ subst [] _
+  = Just subst
+match_exprs renv subst (e1:es1) (e2:es2)
+  = do { subst' <- match renv subst e1 e2 MRefl
+       ; match_exprs renv subst' es1 es2 }
+match_exprs _ _ _ _ = Nothing
+
 
 {- Note [Unbound RULE binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -743,27 +804,6 @@ emptyRuleSubst :: RuleSubst
 emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
                     , rs_binds = \e -> e, rs_bndrs = [] }
 
-----------------------
-match_exprs :: RuleMatchEnv -> RuleSubst
-            -> [CoreExpr]       -- Templates
-            -> [CoreExpr]       -- Targets
-            -> Maybe RuleSubst
--- If the targets are longer than templates, succeed, simply ignoring
--- the leftover targets. This matters in the call in matchN.
---
--- Precondition: corresponding elements of es1 and es2 have the same
---               type, assumuing earlier elements match
--- Example:  f :: forall v. v -> blah
---   match_exprs [Type a, y::a] [Type Int, 3]
--- Then, after matching Type a against Type Int,
--- the type of (y::a) matches that of (3::Int)
-match_exprs _ subst [] _
-  = Just subst
-match_exprs renv subst (e1:es1) (e2:es2)
-  = do { subst' <- match renv subst e1 e2 MRefl
-       ; match_exprs renv subst' es1 es2 }
-match_exprs _ _ _ _ = Nothing
-
 
 {- Note [Casts in the target]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index f816157e10..1095402c73 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -475,26 +475,27 @@ dsRule (L loc (HsRule { rd_name = name
               simpl_opts = initSimpleOpts dflags
               final_rhs = simpleOptExpr simpl_opts rhs''    -- De-crap it
               rule_name = unLoc name
-              final_bndrs_set = mkVarSet final_bndrs
-              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
-                        exprsSomeFreeVarsList isId args
-
-        ; rule <- dsMkUserRule this_mod is_local
-                         rule_name rule_act fn_name final_bndrs args
-                         final_rhs
-        ; warnRuleShadowing rule_name rule_act fn_id arg_ids
+              rule = mkRule this_mod False is_local rule_name rule_act
+                            fn_name final_bndrs args final_rhs
+        ; dsWarnOrphanRule rule
+        ; dsWarnRuleShadowing fn_id rule
 
         ; return (Just rule)
         } } }
 
-warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
+dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
 -- See Note [Rules and inlining/other rules]
-warnRuleShadowing rule_name rule_act fn_id arg_ids
+dsWarnRuleShadowing fn_id
+    (Rule { ru_name = rule_name, ru_act = rule_act, ru_bndrs = bndrs, ru_args = args})
   = do { check False fn_id    -- We often have multiple rules for the same Id in a
                               -- module. Maybe we should check that they don't overlap
                               -- but currently we don't
        ; mapM_ (check True) arg_ids }
   where
+    bndrs_set = mkVarSet bndrs
+    arg_ids = filterOut (`elemVarSet` bndrs_set) $
+              exprsSomeFreeVarsList isId args
+
     check check_rules_too lhs_id
       | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
                        -- If imported with no unfolding, no worries
@@ -510,6 +511,8 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
       = [ rule | rule <- idCoreRules lhs_id
                , ruleActivation rule `competesWith` rule_act ]
 
+dsWarnRuleShadowing _ _ = return () -- Not expecting built-in rules here
+
 -- See Note [Desugaring coerce as cast]
 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
 unfold_coerce bndrs lhs rhs = do
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index ea3191f5d6..930a9ca220 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -18,14 +18,14 @@ lower levels it is preserved with @let@/@letrec@s).
 
 module GHC.HsToCore.Binds
    ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
-   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
+   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
+   , dsWarnOrphanRule
    )
 where
 
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Ppr
 import GHC.Driver.Config
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Unit.Module
@@ -73,7 +73,6 @@ import GHC.Data.Maybe
 import GHC.Data.OrdList
 import GHC.Data.Graph.Directed
 import GHC.Data.Bag
-import GHC.Data.FastString
 
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Misc
@@ -720,18 +719,12 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
                             `setInlinePragma` inl_prag
                             `setIdUnfolding`  spec_unf
 
-       ; rule <- dsMkUserRule this_mod is_local_id
-                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
-                        rule_act poly_name
-                        rule_bndrs rule_lhs_args
-                        (mkVarApps (Var spec_id) spec_bndrs)
+             rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
+                               poly_id rule_bndrs rule_lhs_args
+                               (mkVarApps (Var spec_id) spec_bndrs)
+             spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
 
-       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
-
--- Commented out: see Note [SPECIALISE on INLINE functions]
---       ; when (isInlinePragma id_inl)
---              (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
---                        <+> quotes (ppr poly_name))
+       ; dsWarnOrphanRule rule
 
        ; return (Just (unitOL (spec_id, spec_rhs), rule))
             -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
@@ -774,13 +767,10 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              | otherwise   = spec_prag_act                   -- Specified by user
 
 
-dsMkUserRule :: Module -> Bool -> RuleName -> Activation
-       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
-dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
-    let rule = mkRule this_mod False is_local name act fn bndrs args rhs
-    when (isOrphan (ru_orphan rule)) $
-        diagnosticDs (DsOrphanRule rule)
-    return rule
+dsWarnOrphanRule :: CoreRule -> DsM ()
+dsWarnOrphanRule rule
+  = when (isOrphan (ru_orphan rule)) $
+    diagnosticDs (DsOrphanRule rule)
 
 {- Note [SPECIALISE on INLINE functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/perf/compiler/T4007.stdout b/testsuite/tests/perf/compiler/T4007.stdout
index fc69f2c1c3..1d64fc106d 100644
--- a/testsuite/tests/perf/compiler/T4007.stdout
+++ b/testsuite/tests/perf/compiler/T4007.stdout
@@ -3,7 +3,7 @@ Rule fired: Class op return (BUILTIN)
 Rule fired: unpack (GHC.Base)
 Rule fired: fold/build (GHC.Base)
 Rule fired: Class op >> (BUILTIN)
-Rule fired: SPEC/T4007 sequence__c @IO _ _ (T4007)
+Rule fired: SPEC/T4007 sequence__c @IO @_ @_ (T4007)
 Rule fired: <# (BUILTIN)
 Rule fired: tagToEnum# (BUILTIN)
 Rule fired: unpack-list (GHC.Base)
diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr
index b67e385a98..d66a294f5d 100644
--- a/testsuite/tests/simplCore/should_compile/T15445.stderr
+++ b/testsuite/tests/simplCore/should_compile/T15445.stderr
@@ -1,11 +1,11 @@
 Rule fired: Class op + (BUILTIN)
 Rule fired: Class op fromInteger (BUILTIN)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
-Rule fired: SPEC plusTwoRec (T15445a)
-Rule fired: SPEC $fShowList (GHC.Show)
+Rule fired: USPEC plusTwoRec @Int (T15445a)
+Rule fired: USPEC $fShowList @Int (GHC.Show)
 Rule fired: Class op >> (BUILTIN)
 Rule fired: Class op show (BUILTIN)
-Rule fired: SPEC plusTwoRec (T15445a)
+Rule fired: USPEC plusTwoRec @Int (T15445a)
 Rule fired: Class op enumFromTo (BUILTIN)
 Rule fired: Class op show (BUILTIN)
 Rule fired: Class op enumFromTo (BUILTIN)
diff --git a/testsuite/tests/simplCore/should_compile/T19246.stderr b/testsuite/tests/simplCore/should_compile/T19246.stderr
index acfe1500b8..9e649711fa 100644
--- a/testsuite/tests/simplCore/should_compile/T19246.stderr
+++ b/testsuite/tests/simplCore/should_compile/T19246.stderr
@@ -4,8 +4,8 @@
 
 
 ==================== Tidy Core rules ====================
-"SPEC f" [2] forall ($dOrd :: Ord Int). f @Int $dOrd = $sf
 "SPEC/T19246 $wf @Int" [2]
     forall ($dOrd :: Ord Int). $wf @Int $dOrd = $s$wf
+"USPEC f @Int" [2] forall ($dOrd :: Ord Int). f @Int $dOrd = $sf
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr
index 0fbd7a577c..41bc7de5f4 100644
--- a/testsuite/tests/simplCore/should_compile/T8331.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8331.stderr
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core rules ====================
-"SPEC useAbstractMonad"
+"USPEC useAbstractMonad @(ReaderT Int (ST s))"
     forall (@s)
            ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).
       useAbstractMonad @(ReaderT Int (ST s)) $dMonadAbstractIOST
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stdout b/testsuite/tests/simplCore/should_compile/T8848.stdout
index c4a33adb65..5cfdc6d3ff 100644
--- a/testsuite/tests/simplCore/should_compile/T8848.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8848.stdout
@@ -1,2 +1,2 @@
-Rule fired: SPEC map2 (T8848)
-Rule fired: SPEC map2 (T8848)
+Rule fired: USPEC map2 @('S ('S 'Z)) @_ @_ @_ (T8848)
+Rule fired: USPEC map2 @('S ('S 'Z)) @_ @_ @_ (T8848)
diff --git a/testsuite/tests/simplCore/should_compile/T8848a.stderr b/testsuite/tests/simplCore/should_compile/T8848a.stderr
index 82d9815221..e5b069b1f9 100644
--- a/testsuite/tests/simplCore/should_compile/T8848a.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8848a.stderr
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core rules ====================
-"SPEC f"
+"USPEC f @[Int] @_"
     forall (@b) ($dOrd :: Ord [Int]). f @[Int] @b $dOrd = f_$sf @b
 
 
diff --git a/testsuite/tests/simplCore/should_compile/spec004.stderr b/testsuite/tests/simplCore/should_compile/spec004.stderr
index 825319bcb6..c1265b3d54 100644
--- a/testsuite/tests/simplCore/should_compile/spec004.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec004.stderr
@@ -1,9 +1,9 @@
 
 ==================== Specialise ====================
 Result size of Specialise
-  = {terms: 53, types: 46, coercions: 0, joins: 0/0}
+  = {terms: 52, types: 41, coercions: 0, joins: 0/0}
 
--- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 13, types: 10, coercions: 0, joins: 0/0}
 $sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char]
 [LclId, Arity=1]
 $sfoo
@@ -16,9 +16,9 @@ $sfoo
              @b
              c
              (GHC.CString.unpackFoldrCString# @b "!"# c n)
-             (show @Int GHC.Show.$fShowInt y))
+             (GHC.Show.$fShowInt_$cshow y))
 
--- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 17, types: 15, coercions: 0, joins: 0/0}
 foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
 [LclIdX,
  Arity=3,
@@ -49,7 +49,7 @@ $trModule = "main"#
 $trModule :: GHC.Types.TrName
 [LclId,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
 $trModule = GHC.Types.TrNameS $trModule
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
@@ -63,15 +63,15 @@ $trModule = "ShouldCompile"#
 $trModule :: GHC.Types.TrName
 [LclId,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
 $trModule = GHC.Types.TrNameS $trModule
 
 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-ShouldCompile.$trModule :: GHC.Unit.Module
+ShouldCompile.$trModule :: GHC.Types.Module
 [LclIdX,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-ShouldCompile.$trModule = GHC.Unit.Module $trModule $trModule
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule
 
 -- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0}
 bar :: String