Make withDict noinline

As pointed out in #21575, it is not sufficient to set withDict to inline
after the typeclass specialiser, because we might inline withDict in one
module and then import it in another, and we run into the same problem.
This means we could still end up with incorrect runtime results because
the typeclass specialiser would assume that distinct typeclass evidence
terms at the same type are equal, when this is not necessarily the case
when using withDict.

Instead, this patch gives withDict a NOINLINE pragma, to circumvent this
issue. This is not entirely satisfactory, as it causes a performance
penalty. Hopefully in the future a better fix can be implemented.

Fixes #21575

(cherry picked from commit 1bbbbab816a5beda01bf97deb50651263db58ca0)

5 files changed, 115 insertions, 14 deletions

diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index f2ffeea8c6..40f947a3c6 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -45,7 +45,6 @@ import GHC.Core.Class
 
 import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) )
 import GHC.Types.Basic
-import GHC.Types.SourceText
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -459,7 +458,9 @@ matchWithDict [cls, mty]
                                mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy
 
        ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type
-       ; let wd_id' = wd_id `setInlinePragma` inlineAfterSpecialiser
+       ; let wd_id' = wd_id `setInlinePragma` neverInlinePragma
+               -- Inlining withDict can cause the specialiser to incorrectly common up
+               -- distinct evidence terms. See (WD6) in Note [withDict].
 
        -- Given co2 : mty ~N# inst_meth_ty, construct the method of
        -- the WithDict dictionary:
@@ -486,12 +487,6 @@ matchWithDict [cls, mty]
 matchWithDict _
   = return NoInstance
 
-inlineAfterSpecialiser :: InlinePragma
--- Do not inline before the specialiser; but do so afterwards
--- See (WD6) in Note [withDict]
-inlineAfterSpecialiser = alwaysInlinePragma `setInlinePragmaActivation`
-                         ActiveAfter NoSourceText 2
-
 {-
 Note [withDict]
 ~~~~~~~~~~~~~~~
@@ -587,12 +582,14 @@ Some further observations about `withDict`:
       See #19915.
 
 (WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to
+
          let wd = \sv k -> k (sv |> co)
-             {-# INLINE [2] #-}
+             {-# NOINLINE wd #-}
          in wd
-      The local `let` and INLINE pragma delays inlining `wd` until after the
-      type-class Specialiser has run.  This is super important. Suppose we
-      have calls
+
+      The local `let` and NOINLINE pragma ensure that the type-class specialiser
+      doesn't wrongly common up distinct evidence terms. This is super important!
+      Suppose we have calls
           withDict A k
           withDict B k
       where k1, k2 :: C T -> blah.  If we inline those withDict calls we'll get
@@ -602,8 +599,14 @@ Some further observations about `withDict`:
       the same, will specialise `k` for that type, and will call the same,
       specialised function from both call sites.  #21575 is a concrete case in point.
 
-      Solution: delay inlining `withDict` until after the specialiser; that is,
-      until Phase 2.  This is not a Final Solution -- seee #21575 "Alas..".
+      Solution: never inline `withDict`. Note that it is not sufficient to delay
+      inlining until after the specialiser (that is, until Phase 2), because if
+      we inline withDict in module A but import it in module B, the specialiser
+      will try to common up the two distinct evidence terms.
+      See test case T21575b.
+
+      This solution is unsatisfactory, as it imposes a performance overhead
+      on uses of withDict.
 
 -}
 
diff --git a/testsuite/tests/simplCore/should_run/T21575b.hs b/testsuite/tests/simplCore/should_run/T21575b.hs
new file mode 100644
index 0000000000..da6362edaa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T21575b.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Main (main) where
+
+import Control.Monad (unless)
+import qualified Data.Map as M
+import Data.Map (Map)
+import T21575b_aux (Given(..), give, unsafeGive)
+
+main :: IO ()
+main = do
+  testCase "Normal"
+    (give Normal (toJSON (Foo Bar)))
+    (unsafeGive Normal (toJSON (Foo Bar)))
+    (Object (M.fromList [("Foo",String "Bar")]))
+  testCase "ViaShow"
+    (give ViaShow (toJSON (Foo Bar)))
+    (unsafeGive ViaShow (toJSON (Foo Bar)))
+    (Object (M.fromList [("Foo",String "SHOWBAR")]))
+
+-----
+
+testCase :: (Eq a, Show a) => String -> a -> a -> a -> IO ()
+testCase str with_give with_unsafeGive expected =
+  putStrLn $ unlines
+      [ str ++ ":"
+      , "    withDict: " ++ show with_give
+      , "unsafeCoerce: " ++ show with_unsafeGive
+      , "    expected: " ++ show expected
+      , ""
+      ]
+
+data Foo = Foo Bar
+
+instance Show Foo where
+  show _ = "SHOWFOO"
+
+data Bar = Bar | BarBar
+
+instance Show Bar where
+  show _ = "SHOWBAR"
+
+----------------------------------------------------------------------------
+-- ToJSON instances
+----------------------------------------------------------------------------
+
+instance Given Style => ToJSON Foo where
+  toJSON (Foo x) = Object $ M.singleton "Foo" (toJSON x)
+
+instance Given Style => ToJSON Bar where
+  toJSON x = case given of
+    Normal -> String $ case x of
+                Bar    -> "Bar"
+                BarBar -> "BarBar"
+    ViaShow -> String $ show x
+
+data Style = Normal | ViaShow
+
+----------------------------------------------------------------------------
+-- Minimized aeson
+----------------------------------------------------------------------------
+
+class ToJSON a where
+  toJSON :: a -> Value
+
+data Value
+  = Object !(Map String Value)
+  | String !String
+  deriving (Eq, Show)
diff --git a/testsuite/tests/simplCore/should_run/T21575b.stdout b/testsuite/tests/simplCore/should_run/T21575b.stdout
new file mode 100644
index 0000000000..2cfdf0dcac
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T21575b.stdout
@@ -0,0 +1,12 @@
+Normal:
+    withDict: Object (fromList [("Foo",String "Bar")])
+unsafeCoerce: Object (fromList [("Foo",String "Bar")])
+    expected: Object (fromList [("Foo",String "Bar")])
+
+
+ViaShow:
+    withDict: Object (fromList [("Foo",String "SHOWBAR")])
+unsafeCoerce: Object (fromList [("Foo",String "SHOWBAR")])
+    expected: Object (fromList [("Foo",String "SHOWBAR")])
+
+
diff --git a/testsuite/tests/simplCore/should_run/T21575b_aux.hs b/testsuite/tests/simplCore/should_run/T21575b_aux.hs
new file mode 100644
index 0000000000..556ef26307
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T21575b_aux.hs
@@ -0,0 +1,16 @@
+module T21575b_aux ( Given(..), give, unsafeGive ) where
+
+import GHC.Exts
+  ( withDict )
+import Unsafe.Coerce
+  ( unsafeCoerce )
+
+class Given a where
+  given :: a
+
+give, unsafeGive :: forall a r. a -> (Given a => r) -> r
+give = withDict @(Given a) @a
+
+unsafeGive a k = unsafeCoerce (Gift k :: Gift a r) a
+
+newtype Gift a r = Gift (Given a => r)
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 5f2aea0a87..81745174aa 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -101,3 +101,4 @@ test('T19569', [only_ways(['optasm']),extra_run_opts('True 1000000')], compile_a
 test('T20203', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])
 test('T19313', expect_broken(19131), compile_and_run, [''])
 test('T21575', normal, compile_and_run, ['-O'])
+test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])