diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2022-05-16 13:33:12 +0100 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2022-06-15 17:06:44 +0100 |
commit | 1eba76f5f5511b63fb7585fde001506f9aaf24f6 (patch) | |
tree | f4b327019ac370bffb95ae317edd0cc03c2a26a3 /testsuite/tests | |
parent | 486f43202c8be8eaea8b54c6bac7e9238aaf9b39 (diff) | |
download | haskell-1eba76f5f5511b63fb7585fde001506f9aaf24f6.tar.gz |
Fix bad interaction between withDict and the Specialiser
This MR fixes a bad bug, where the withDict was inlined too
vigorously, which in turn made the type-class Specialiser generate
a bogus specialisation, because it saw the same overloaded function
applied to two /different/ dictionaries.
Solution: inline `withDict` later. See (WD8) of Note [withDict]
in GHC.HsToCore.Expr
See #21575, which is fixed by this change.
(cherry picked from commit d2284c4c9dd484a4b459366956c4aedc72336b04)
Diffstat (limited to 'testsuite/tests')
-rw-r--r-- | testsuite/tests/simplCore/should_run/T21575.hs | 107 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T21575.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 2 |
3 files changed, 109 insertions, 1 deletions
diff --git a/testsuite/tests/simplCore/should_run/T21575.hs b/testsuite/tests/simplCore/should_run/T21575.hs new file mode 100644 index 0000000000..976483f963 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T21575.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- 0 => use unsafeCoerce +-- 1 => use withDict +#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!" + +{- +toJSONBar :: Given Style => Bar -> Value + + give Normal (\gd -> toJSONBar gd e) + --> withDict @Style @(Given Style) Normal (toJSON e) + --> toJSONBar ((Normal |> co) :: Given Style) e + + give Normal (\gd -> toJSONBar gd e') + --> toJSONBar ((ViaShow |> co) :: Given Style) e' + +--------- With new cast ------------ + + give Normal (\gd -> toJSONBar gd e) + --> withDict @Style @(Given Style) Normal (\gd -> toJSONBar gd e) + --> ((\gd -> toJSONBar gd e) |> co) Normal + --> (\gd' -> toJSonBar (gd' |> sym (co[1])) e) Normal + --> toJSONBar (Normal |> co') e -- Boo! + +-} + +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) diff --git a/testsuite/tests/simplCore/should_run/T21575.stdout b/testsuite/tests/simplCore/should_run/T21575.stdout new file mode 100644 index 0000000000..14332104f6 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T21575.stdout @@ -0,0 +1 @@ +All tests passed! diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 94e5156bac..5f2aea0a87 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -100,4 +100,4 @@ test('T19413', normal, compile_and_run, ['']) test('T19569', [only_ways(['optasm']),extra_run_opts('True 1000000')], compile_and_run, ['-O2']) 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']) |