Make withDict opaque to the specialiser

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 introduces a new magicId, 'nospec', which is only
inlined in CorePrep. We make use of it in the definition of withDict
to ensure that the typeclass specialiser does not common up distinct
typeclass evidence terms.

Fixes #21575

4 files changed, 98 insertions, 0 deletions

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 bebd839724..a887d5cedb 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -105,4 +105,5 @@ test('T19313', normal, compile_and_run, [''])
 test('UnliftedArgRule', normal, compile_and_run, [''])
 test('T21229', normal, compile_and_run, ['-O'])
 test('T21575', normal, compile_and_run, ['-O'])
+test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
 test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836