From 099183437c9a181c93502026216ab8eea81db520 Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Wed, 24 Mar 2021 18:53:17 +0100
Subject: Don't warn about ClassOp bindings not specialising.

Fixes #19586
---
 compiler/GHC/Core/Opt/Specialise.hs                | 34 ++++++++++++++++++++++
 compiler/GHC/Types/Id.hs                           |  6 ++++
 testsuite/tests/simplCore/should_compile/T19586.hs | 14 +++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  3 ++
 4 files changed, 57 insertions(+)
 create mode 100644 testsuite/tests/simplCore/should_compile/T19586.hs

diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index fc62f5fa8a..cab95b8b67 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -809,6 +809,7 @@ canSpecImport dflags fn
 tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
 -- See Note [Warning about missed specialisations]
 tryWarnMissingSpecs dflags callers fn calls_for_fn
+  | isClassOpId fn = return () -- See Note [Missed specialization for ClassOps]
   | wopt Opt_WarnMissedSpecs dflags
     && not (null callers)
     && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs
@@ -824,7 +825,40 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
           , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
           , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
 
+{- Note [Missed specialisation for ClassOps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #19592 I saw a number of missed specialisation warnings
+which were the result of things like:
+
+    case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ...
+
+where isJumpishInstr is part of the Instruction class and defined like
+this:
+
+    class Instruction instr where
+        ...
+        isJumpishInstr :: instr -> Bool
+        ...
 
+isJumpishInstr is a ClassOp which will select the right method
+from within the dictionary via our built in rules. See also
+Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance.
+
+We don't give these unfoldings, and as a result the specialiser
+complains. But usually this doesn't matter. The simplifier will
+apply the rule and we end up with
+
+    case isJumpishInstrImplX86 eta3_a78C of { ...
+
+Since isJumpishInstrImplX86 is defined for a concrete instance (given
+by the dictionary) it is usually already well specialised!
+Theoretically the implementation of a method could still be overloaded
+over a different type class than what it's a method of. But I wasn't able
+to make this go wrong, and SPJ thinks this should be fine as well.
+
+So I decided to remove the warnings for failed specialisations on ClassOps
+alltogether as they do more harm than good.
+-}
 
 {- Note [Do not specialise imported DFuns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index dbc2bed651..48ec97f6f8 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -66,6 +66,7 @@ module GHC.Types.Id (
         isRecordSelector, isNaughtyRecordSelector,
         isPatSynRecordSelector,
         isDataConRecordSelector,
+        isClassOpId,
         isClassOpId_maybe, isDFunId,
         isPrimOpId, isPrimOpId_maybe,
         isFCallId, isFCallId_maybe,
@@ -458,6 +459,7 @@ isFCallId               :: Id -> Bool
 isDataConWorkId         :: Id -> Bool
 isDataConWrapId         :: Id -> Bool
 isDFunId                :: Id -> Bool
+isClassOpId             :: Id -> Bool
 
 isClassOpId_maybe       :: Id -> Maybe Class
 isPrimOpId_maybe        :: Id -> Maybe PrimOp
@@ -481,6 +483,10 @@ isNaughtyRecordSelector id = case Var.idDetails id of
                         RecSelId { sel_naughty = n } -> n
                         _                               -> False
 
+isClassOpId id = case Var.idDetails id of
+                        ClassOpId _   -> True
+                        _other        -> False
+
 isClassOpId_maybe id = case Var.idDetails id of
                         ClassOpId cls -> Just cls
                         _other        -> Nothing
diff --git a/testsuite/tests/simplCore/should_compile/T19586.hs b/testsuite/tests/simplCore/should_compile/T19586.hs
new file mode 100644
index 0000000000..7cce9f368d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19586.hs
@@ -0,0 +1,14 @@
+-- Don't warn about specialization failures for class ops.
+
+{-# OPTIONS_GHC -O -Wall-missed-specialisations #-}
+module T19586 where
+
+type MyConstraint a b = (Show a, Enum b, Show b)
+
+foo :: MyConstraint a b => Int -> a -> b -> (String, String)
+foo 0 x y = (show x, show . succ $ y)
+foo n x y = foo (n-1) x y
+
+
+bar :: Int -> Char -> (String, String)
+bar x y = foo x x y
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index dba67fa80b..935c10d6fc 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -352,6 +352,9 @@ test('T19360', only_ways(['optasm']), compile, [''])
 # If the test goes wrong we'll get more case expressions in the output
 test('T19581', [ grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 
+# T19586 should not generate missed specialisation warnings
+test('T19586', normal, compile, [''])
+
 test('T19599', normal, compile, ['-O -ddump-rules'])
 test('T19599a', normal, compile, ['-O -ddump-rules'])
 test('T13873',  [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
-- 
cgit v1.2.1