summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs4
-rw-r--r--compiler/GHC/Types/Id/Make.hs5
-rw-r--r--testsuite/tests/ghci/scripts/T19667Ghci.hs29
-rw-r--r--testsuite/tests/ghci/scripts/T19667Ghci.script2
-rw-r--r--testsuite/tests/ghci/scripts/T19667Ghci.stdout1
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T2
-rw-r--r--testsuite/tests/typecheck/should_run/T19667.hs29
-rw-r--r--testsuite/tests/typecheck/should_run/T19667.stdout1
-rwxr-xr-xtestsuite/tests/typecheck/should_run/all.T1
9 files changed, 71 insertions, 3 deletions
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index e7f834268d..88439edcc6 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -53,7 +53,7 @@ import GHC.Core.TyCon
, tyConFamilySize )
import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType
- , stripTicksTop, stripTicksTopT, mkTicks )
+ , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )
import GHC.Core.Multiplicity
import GHC.Core.FVs
import GHC.Core.Type
@@ -2243,7 +2243,7 @@ match_inline _ = Nothing
-- See Note [magicDictId magic] in "GHC.Types.Id.Make"
-- for a description of what is going on here.
match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
+match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ]
| Just (_, fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
, Just (_, dictTy, _) <- splitFunTy_maybe fieldTy
, Just dictTc <- tyConAppTyCon_maybe dictTy
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index b2f9dc7adf..1fcdabc977 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1843,6 +1843,11 @@ definition in Core. The rewrite rule works as follows:
The `co` coercion is the newtype-coercion extracted from the type-class.
The type class is obtained by looking at the type of wrap.
+In the constant folding rule it's very import to make sure to strip all ticks
+from the expression as if there's an occurence of
+magicDict we *must* convert it for correctness. See #19667 for where this went
+wrong in GHCi.
+
-------------------------------------------------------------
@realWorld#@ used to be a magic literal, \tr{void#}. If things get
diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.hs b/testsuite/tests/ghci/scripts/T19667Ghci.hs
new file mode 100644
index 0000000000..21e484bee9
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Main (main) where
+
+import Data.Proxy (Proxy(..))
+import GHC.Exts (magicDict)
+import GHC.TypeLits (Symbol)
+import GHC.Exts
+
+newtype SSymbol (s :: Symbol) = SSymbol String
+
+class KnownSymbol (n :: Symbol) where
+ symbolSing :: SSymbol n
+
+symbolVal :: forall n proxy . KnownSymbol n => proxy n -> String
+symbolVal _ = case symbolSing :: SSymbol n of SSymbol x -> x
+
+data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)
+
+-- See Note [NOINLINE someNatVal] in GHC.TypeNats
+{-# NOINLINE reifySymbol #-}
+reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r
+reifySymbol n k = magicDict (WrapS k) (SSymbol n) (Proxy @(Any @Symbol))
+
+main :: IO ()
+main = print $ reifySymbol "Hello World" symbolVal
diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.script b/testsuite/tests/ghci/scripts/T19667Ghci.script
new file mode 100644
index 0000000000..5ecc976eaa
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.script
@@ -0,0 +1,2 @@
+:load T19667Ghci.hs
+:main
diff --git a/testsuite/tests/ghci/scripts/T19667Ghci.stdout b/testsuite/tests/ghci/scripts/T19667Ghci.stdout
new file mode 100644
index 0000000000..06ae699f22
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T19667Ghci.stdout
@@ -0,0 +1 @@
+"Hello World"
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 64f87bc7e2..d6f2dd567e 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -328,4 +328,4 @@ test('T19197', normal, ghci_script, ['T19197.script'])
test('T19158', normal, ghci_script, ['T19158.script'])
test('T19279', normal, ghci_script, ['T19279.script'])
test('T19310', normal, ghci_script, ['T19310.script'])
-
+test('T19667Ghci', extra_files(['T19667Ghci.hs']), ghci_script, ['T19667Ghci.script'])
diff --git a/testsuite/tests/typecheck/should_run/T19667.hs b/testsuite/tests/typecheck/should_run/T19667.hs
new file mode 100644
index 0000000000..21e484bee9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T19667.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Main (main) where
+
+import Data.Proxy (Proxy(..))
+import GHC.Exts (magicDict)
+import GHC.TypeLits (Symbol)
+import GHC.Exts
+
+newtype SSymbol (s :: Symbol) = SSymbol String
+
+class KnownSymbol (n :: Symbol) where
+ symbolSing :: SSymbol n
+
+symbolVal :: forall n proxy . KnownSymbol n => proxy n -> String
+symbolVal _ = case symbolSing :: SSymbol n of SSymbol x -> x
+
+data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)
+
+-- See Note [NOINLINE someNatVal] in GHC.TypeNats
+{-# NOINLINE reifySymbol #-}
+reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => Proxy n -> r) -> r
+reifySymbol n k = magicDict (WrapS k) (SSymbol n) (Proxy @(Any @Symbol))
+
+main :: IO ()
+main = print $ reifySymbol "Hello World" symbolVal
diff --git a/testsuite/tests/typecheck/should_run/T19667.stdout b/testsuite/tests/typecheck/should_run/T19667.stdout
new file mode 100644
index 0000000000..06ae699f22
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T19667.stdout
@@ -0,0 +1 @@
+"Hello World"
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index c4005e402e..efc9fcb374 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -155,3 +155,4 @@ test('T19397M1', extra_files(['T19397S.hs']), compile_and_run, [''])
test('T19397M2', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19397M3', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
+test('T19667', normal, compile_and_run, ['-fhpc'])
View Lorry Controller Status