withDict produces incorrect runtime results with optimization enabled

After attempting to change the reflection library to use withDict instead of unsafeCoerce (see #21568 for the motivation) using GHC 9.4.1-alpha1, reflection's test suite started to error out. Here is a minimized example of the error:

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

#define WITH_DICT 1

module Main (main) where

import Control.Monad (unless)
import qualified Data.Map as M
import Data.Map (Map)

#if WITH_DICT
import GHC.Exts (withDict)
#else
import Unsafe.Coerce (unsafeCoerce)
#endif

main :: IO ()
main = do
  testCase (give Normal (toJSON (Foo Bar)))
           (Object (M.fromList [("Foo",String "Bar")]))
  testCase (give ViaShow (toJSON (Foo Bar)))
           (Object (M.fromList [("Foo",String "SHOWBAR")]))
  putStrLn "All tests passed!"

-----

testCase :: (Eq a, Show a) => a -> a -> IO ()
testCase expected actual =
  unless (expected == actual) $
    error $ unlines
      [ ""
      , "Expected: " ++ show expected
      , "Actual:   " ++ show actual
      ]

class Given a where
  given :: a

give :: forall a r. a -> (Given a => r) -> r
#if WITH_DICT
give = withDict @a @(Given a)
#else
give a k = unsafeCoerce (Gift k :: Gift a r) a

newtype Gift a r = Gift (Given a => r)
#endif

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)

If you compile this with GHC 9.4.1-alpha1 plus optimization, it will unexpectedly fail:

$ ~/Software/ghc-9.4.0.20220501/bin/ghc Bug.hs -O -fforce-recomp
[1 of 2] Compiling Main             ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]

$ ./Bug 
Bug: 
Expected: Object (fromList [("Foo",String "Bar")])
Actual:   Object (fromList [("Foo",String "SHOWBAR")])

CallStack (from HasCallStack):
  error, called at Bug.hs:33:5 in main:Main

On the other hand, if you compile it without optimization, it succeeds:

$ ~/Software/ghc-9.4.0.20220501/bin/ghc Bug.hs -O0 -fforce-recomp
[1 of 2] Compiling Main             ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]

$ ./Bug 
All tests passed!

This behavior appears to be exclusive to withDict. If I define give in terms of unsafeCoerce (which is how reflection currently implements give), then it works regardless of the optimization level:

$ sed -i 's/#define WITH_DICT 1/#define WITH_DICT 0/' Bug.hs

$ ~/Software/ghc-9.4.0.20220501/bin/ghc Bug.hs -O -fforce-recomp
[1 of 2] Compiling Main             ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]

$ ./Bug 
All tests passed!

$ ~/Software/ghc-9.4.0.20220501/bin/ghc Bug.hs -O0 -fforce-recomp
[1 of 2] Compiling Main             ( Bug.hs, Bug.o )
[2 of 2] Linking Bug [Objects changed]

$ ./Bug 
All tests passed!