Optimiser: Correctly deal with strings starting with unicode characters in exprConApp_maybe

For example:

"\0" is encoded to "C0 80", then the rule would correct use a decoding
function to work out the first character was "C0 80" but then just used
BS.tail so the rest of the string was "80". This resulted in

"\0" being transformed into '\C0\80' : unpackCStringUTF8# "80"

Which is obviously bogus.

I rewrote the function to call utf8UnconsByteString directly and avoid
the roundtrip through Faststring so now the head/tail is computed by the
same call.

Fixes #19976

(cherry picked from commit 7f6454fb8cd92b2b2ad4e88fa6d81e34d43edb9a)
(cherry picked from commit a02fbadaf59521b5f1af3f05b45933b245093531)

3 files changed, 30 insertions, 21 deletions

diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 5f1ed2ba52..9fca9d0b4b 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -52,13 +52,13 @@ import GHC.Builtin.Types
 import GHC.Builtin.Names
 import GHC.Types.Basic
 import GHC.Unit.Module ( Module )
+import GHC.Utils.Encoding
 import GHC.Utils.Error
 import GHC.Driver.Session
 import GHC.Utils.Outputable
 import GHC.Data.Pair
 import GHC.Utils.Misc
 import GHC.Data.Maybe       ( orElse )
-import GHC.Data.FastString
 import Data.List
 import qualified Data.ByteString as BS
 
@@ -841,9 +841,8 @@ calls to unpackCString# and returns:
 
 Just (':', [Char], ['a', unpackCString# "bc"]).
 
-We need to be careful about UTF8 strings here. ""# contains a ByteString, so
-we must parse it back into a FastString to split off the first character.
-That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
+We need to be careful about UTF8 strings here. ""# contains an encoded ByteString, so
+we call utf8UnconsByteString to correctly deal with the encoding and splitting.
 
 We must also be careful about
    lvl = "foo"#
@@ -852,6 +851,8 @@ to ensure that we see through the let-binding for 'lvl'.  Hence the
 (exprIsLiteral_maybe .. arg) in the guard before the call to
 dealWithStringLiteral.
 
+The tests for this function are in T9400.
+
 Note [Push coercions in exprIsConApp_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In #13025 I found a case where we had
@@ -1204,23 +1205,18 @@ dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
 -- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS
 -- turns those into [] automatically, but just in case something else in GHC
 -- generates a string literal directly.
-dealWithStringLiteral _   str co
-  | BS.null str
-  = pushCoDataCon nilDataCon [Type charTy] co
-
-dealWithStringLiteral fun str co
-  = let strFS = mkFastStringByteString str
-
-        char = mkConApp charDataCon [mkCharLit (headFS strFS)]
-        charTail = BS.tail (bytesFS strFS)
-
-        -- In singleton strings, just add [] instead of unpackCstring# ""#.
-        rest = if BS.null charTail
-                 then mkConApp nilDataCon [Type charTy]
-                 else App (Var fun)
-                          (Lit (LitString charTail))
-
-    in pushCoDataCon consDataCon [Type charTy, char, rest] co
+dealWithStringLiteral fun str co =
+  case utf8UnconsByteString str of
+    Nothing -> pushCoDataCon nilDataCon [Type charTy] co
+    Just (char, charTail) ->
+      let char_expr = mkConApp charDataCon [mkCharLit char]
+          -- In singleton strings, just add [] instead of unpackCstring# ""#.
+          rest = if BS.null charTail
+                   then mkConApp nilDataCon [Type charTy]
+                   else App (Var fun)
+                            (Lit (LitString charTail))
+
+      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co
 
 {-
 Note [Unfolding DFuns]
diff --git a/compiler/GHC/Utils/Encoding.hs b/compiler/GHC/Utils/Encoding.hs
index 24637a3bff..273706befe 100644
--- a/compiler/GHC/Utils/Encoding.hs
+++ b/compiler/GHC/Utils/Encoding.hs
@@ -18,6 +18,7 @@ module GHC.Utils.Encoding (
         utf8CharStart,
         utf8DecodeChar,
         utf8DecodeByteString,
+        utf8UnconsByteString,
         utf8DecodeShortByteString,
         utf8DecodeStringLazy,
         utf8EncodeChar,
@@ -154,6 +155,14 @@ utf8DecodeByteString :: ByteString -> [Char]
 utf8DecodeByteString (BS.PS fptr offset len)
   = utf8DecodeStringLazy fptr offset len
 
+utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)
+utf8UnconsByteString (BS.PS _ _ 0) = Nothing
+utf8UnconsByteString (BS.PS fptr offset len)
+  = unsafeDupablePerformIO $
+      withForeignPtr fptr $ \ptr -> do
+        let (c,n) = utf8DecodeChar (ptr `plusPtr` offset)
+        return $ Just (c, BS.PS fptr (offset + n) (len - n))
+
 utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]
 utf8DecodeStringLazy fp offset (I# len#)
   = unsafeDupablePerformIO $ do
diff --git a/testsuite/tests/simplCore/should_compile/T9400.hs b/testsuite/tests/simplCore/should_compile/T9400.hs
index 4e9cb72cb9..85aad51564 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.hs
+++ b/testsuite/tests/simplCore/should_compile/T9400.hs
@@ -16,3 +16,7 @@ main = do
         (x:xs) -> putStrLn xs
     case "ab" of
         "" -> putStrLn "fail"
+    case "\0abc" of
+        (x:xs) -> putStrLn xs
+    case "zażółćz" of
+        (x:xs) -> putStrLn xs