Lookup string literals in top-level thunks (fix #16373)

4 files changed, 35 insertions, 6 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 421de78568..f2c9e95253 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -2452,18 +2452,20 @@ stripStrTopTicksT e = stripTicksTopT tickishFloatable e
 -- Also  matches unpackCStringUtf8#
 
 match_eq_string :: RuleFun
-match_eq_string _ id_unf _
-        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]
-  | unpk_key1 <- getUnique unpk1
+match_eq_string _ env _ [e1, e2]
+  | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1
+  , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2
+  , unpk_key1 <- getUnique unpk1
   , unpk_key2 <- getUnique unpk2
   , unpk_key1 == unpk_key2
   -- For now we insist the literals have to agree in their encoding
   -- to keep the rule simple. But we could check if the decoded strings
   -- compare equal in here as well.
   , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]
-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1
-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2
-  = Just (if s1 == s2 then trueValBool else falseValBool)
+  , Just (LitString s1) <- exprIsLiteral_maybe env lit1
+  , Just (LitString s2) <- exprIsLiteral_maybe env lit2
+  = Just $ mkTicks (ticks1 ++ ticks2)
+         $ (if s1 == s2 then trueValBool else falseValBool)
 
 match_eq_string _ _ _ _ = Nothing
 
diff --git a/testsuite/tests/simplCore/should_compile/T16373.hs b/testsuite/tests/simplCore/should_compile/T16373.hs
new file mode 100644
index 0000000000..e8346ca30a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T16373.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-typeable-binds -O2 #-}
+
+module Test2 where
+
+import GHC.TypeLits
+import Data.Proxy
+
+testAA :: Bool
+testAA = symbolVal (Proxy :: Proxy "A") == symbolVal (Proxy :: Proxy "A")
+
+testAB :: Bool
+testAB = symbolVal (Proxy :: Proxy "A") == symbolVal (Proxy :: Proxy "B")
diff --git a/testsuite/tests/simplCore/should_compile/T16373.stderr b/testsuite/tests/simplCore/should_compile/T16373.stderr
new file mode 100644
index 0000000000..0fe8484609
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T16373.stderr
@@ -0,0 +1,13 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 4, types: 2, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+testAB = False
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+testAA = True
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index dbec3b3066..25296eda0f 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -370,3 +370,4 @@ test('T19890',  [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl'])
 test('T20125',  [ grep_errmsg(r'= T20125.MkT') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T20143',  [ grep_errmsg(r'unsafeEqualityProof') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T20174', normal, compile, [''])
+test('T16373', normal, compile, [''])