summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-04-09 15:12:49 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-10 05:33:38 -0400
commit6974c9e478120f6c4eeb53ebfa935c30cafcdf8e (patch)
tree60ad5e80d4221e004c1ca0c6ea1eab462cefc6f0
parentd39a2b243b53b5c10895f8b56f1d7e2749c99a4b (diff)
downloadhaskell-6974c9e478120f6c4eeb53ebfa935c30cafcdf8e.tar.gz
Fix magicDict in ghci (and in the presence of other ticks)
The problem was that ghci inserts some ticks around the crucial bit of the expression. Just like in some of the other rules we now strip the ticks so that the rule fires more reliably. It was possible to defeat magicDict by using -fhpc as well, so not just an issue in ghci. Fixes #19667 and related to #19673
-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'])