ghc-boot 9.4.1 → 9.6.0.20230302

raw patch · 6 files changed

+398/−315 lines, 6 filesdep ~basedep ~ghc-boot-thdep ~unixPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc-boot-th, unix

API changes (from Hackage documentation)

Files

• GHC/BaseDir.hs +2/−1
• GHC/Data/ShortText.hs +14/−6
• GHC/Platform/ArchOS.hs +7/−1
• GHC/Utils/Encoding.hs +8/−302
• GHC/Utils/Encoding/UTF8.hs +361/−0
• ghc-boot.cabal +6/−5

@@ -17,6 +17,7 @@ import Prelude -- See Note [Why do we import Prelude here?]  import Data.List (stripPrefix)+import Data.Maybe (listToMaybe) import System.FilePath  -- Windows@@ -37,7 +38,7 @@ expandPathVar :: String -> FilePath -> String -> String expandPathVar var value str   | Just str' <- stripPrefix ('$':var) str-  , null str' || isPathSeparator (head str')+  , maybe True isPathSeparator (listToMaybe str')   = value ++ expandPathVar var value str' expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = []

@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies, CPP #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}--- gross hack: we manuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore.+-- gross hack: we maneuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore. -- LLVM based GHC's fail to compile memcmp ffi calls.  These end up as memcmp$def in the llvm ir, however we -- don't have any prototypes and subsequently the llvm toolchain chokes on them.  Since 7fdcce6d, we use -- ShortText for the package database.  This however introduces this very module; which through inlining ends@@ -10,7 +10,7 @@ -- The solution thusly is to force late binding via the linker instead of inlining when comping with the -- bootstrap compiler.  This will produce a slower (slightly less optimised) stage1 compiler only. ----- See issue 18857. hsyl20 deserves credit for coming up with the idea for the soltuion.+-- See issue 18857. hsyl20 deserves credit for coming up with the idea for the solution. -- -- This can be removed when we exit the boot compiler window. Thus once we drop GHC-9.2 as boot compiler, -- we can drop this code as well.@@ -29,6 +29,7 @@         -- * ShortText         ShortText(..),         -- ** Conversion to and from String+        singleton,         pack,         unpack,         -- ** Operations@@ -67,15 +68,20 @@  -- | /O(n)/ Returns the length of the 'ShortText' in characters. codepointLength :: ShortText -> Int-codepointLength st = unsafeDupablePerformIO $ countUTF8Chars (contents st)+codepointLength st = utf8CountCharsShortByteString (contents st)+ -- | /O(1)/ Returns the length of the 'ShortText' in bytes. byteLength :: ShortText -> Int byteLength st = SBS.length $ contents st  -- | /O(n)/ Convert a 'String' into a 'ShortText'. pack :: String -> ShortText-pack s = unsafeDupablePerformIO $ ShortText <$> utf8EncodeShortByteString s+pack s = ShortText $ utf8EncodeShortByteString s +-- | Create a singleton+singleton :: Char -> ShortText+singleton s = pack [s]+ -- | /O(n)/ Convert a 'ShortText' into a 'String'. unpack :: ShortText -> String unpack st = utf8DecodeShortByteString $ contents st@@ -100,8 +106,10 @@ -- non-printable characters. head :: ShortText -> Char head st-  | SBS.null $ contents st = error "head: Empty ShortText"-  | otherwise              = Prelude.head $ unpack st+  | hd:_ <- unpack st+  = hd+  | otherwise+  = error "head: Empty ShortText"  -- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of -- the second iff the first is its prefix, and otherwise Nothing.

@@ -44,7 +44,9 @@    | ArchMipseb    | ArchMipsel    | ArchRISCV64+   | ArchLoongArch64    | ArchJavaScript+   | ArchWasm32    deriving (Read, Show, Eq, Ord)  -- | ARM Instruction Set Architecture@@ -95,6 +97,7 @@    | OSQNXNTO    | OSAIX    | OSHurd+   | OSWasi    deriving (Read, Show, Eq, Ord)  @@ -132,7 +135,9 @@   ArchMipseb        -> "mipseb"   ArchMipsel        -> "mipsel"   ArchRISCV64       -> "riscv64"-  ArchJavaScript    -> "js"+  ArchLoongArch64   -> "loongarch64"+  ArchJavaScript    -> "javascript"+  ArchWasm32        -> "wasm32"  -- | See Note [Platform Syntax]. stringEncodeOS :: OS -> String@@ -151,3 +156,4 @@   OSQNXNTO    -> "nto-qnx"   OSAIX       -> "aix"   OSHurd      -> "hurd"+  OSWasi      -> "wasi"

@@ -17,23 +17,11 @@  module GHC.Utils.Encoding (         -- * UTF-8-        utf8DecodeCharAddr#,-        utf8PrevChar,-        utf8CharStart,-        utf8DecodeChar,-        utf8DecodeByteString,-        utf8UnconsByteString,-        utf8DecodeShortByteString,-        utf8CompareShortByteString,-        utf8DecodeStringLazy,-        utf8EncodeChar,-        utf8EncodeString,-        utf8EncodeStringPtr,-        utf8EncodeShortByteString,-        utf8EncodedLength,-        countUTF8Chars,+        module GHC.Utils.Encoding.UTF8,          -- * Z-encoding+        UserString,+        EncodedString,         zEncodeString,         zDecodeString, @@ -45,295 +33,11 @@ import Prelude  import Foreign-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Data.Char import qualified Data.Char as Char import Numeric-import GHC.IO-import GHC.ST -import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import Data.ByteString.Short.Internal (ShortByteString(..))--import GHC.Exts---- -------------------------------------------------------------------------------- UTF-8---- We can't write the decoder as efficiently as we'd like without--- resorting to unboxed extensions, unfortunately.  I tried to write--- an IO version of this function, but GHC can't eliminate boxed--- results from an IO-returning function.------ We assume we can ignore overflow when parsing a multibyte character here.--- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences--- before decoding them (see "GHC.Data.StringBuffer").--{-# INLINE utf8DecodeChar# #-}-utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)-utf8DecodeChar# indexWord8# =-  let !ch0 = word2Int# (indexWord8# 0#) in-  case () of-    _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)--      | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#-                  (ch1 -# 0x80#)),-           2# #)--      | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch2 -# 0x80#)),-           3# #)--     | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        let !ch3 = word2Int# (indexWord8# 3#) in-        if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else-        (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#-                 ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch3 -# 0x80#)),-           4# #)--      | otherwise -> fail 1#-  where-        -- all invalid sequences end up here:-        fail :: Int# -> (# Char#, Int# #)-        fail nBytes# = (# '\0'#, nBytes# #)-        -- '\xFFFD' would be the usual replacement character, but-        -- that's a valid symbol in Haskell, so will result in a-        -- confusing parse error later on.  Instead we use '\0' which-        -- will signal a lexer error immediately.--utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)-utf8DecodeCharAddr# a# off# =-#if !MIN_VERSION_base(4,16,0)-    utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))-#else-    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#)))-#endif--utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)-utf8DecodeCharByteArray# ba# off# =-#if !MIN_VERSION_base(4,16,0)-    utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))-#else-    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#)))-#endif---utf8DecodeChar :: Ptr Word8 -> (Char, Int)-utf8DecodeChar !(Ptr a#) =-  case utf8DecodeCharAddr# a# 0# of-    (# c#, nBytes# #) -> ( C# c#, I# nBytes# )---- UTF-8 is cleverly designed so that we can always figure out where--- the start of the current character is, given any position in a--- stream.  This function finds the start of the previous character,--- assuming there *is* a previous character.-utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)-utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))--utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)-utf8CharStart p = go p- where go p = do w <- peek p-                 if w >= 0x80 && w < 0xC0-                        then go (p `plusPtr` (-1))-                        else return p--{-# INLINE utf8DecodeLazy# #-}-utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]-utf8DecodeLazy# retain decodeChar# len#-  = unpack 0#-  where-    unpack i#-        | isTrue# (i# >=# len#) = retain >> return []-        | otherwise =-            case decodeChar# i# of-              (# c#, nBytes# #) -> do-                rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)-                return (C# c# : rest)--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-      let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset-      utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#--- Note that since utf8DecodeLazy# returns a thunk the lifetime of the--- ForeignPtr actually needs to be longer than the lexical lifetime--- withForeignPtr would provide here. That's why we use touchForeignPtr to--- keep the fp alive until the last character has actually been decoded.--utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering-utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0#-   -- UTF-8 has the property that sorting by bytes values also sorts by-   -- code-points.-   -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property-   -- doesn't hold and we must explicitly check this case here.-   -- Note that decoding every code point would also work but it would be much-   -- more costly.-   where-       !sz1 = sizeofByteArray# a1-       !sz2 = sizeofByteArray# a2-       go off1 off2-         | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ-         | isTrue# (off1 >=# sz1)                          = LT-         | isTrue# (off2 >=# sz2)                          = GT-         | otherwise =-#if !MIN_VERSION_base(4,16,0)-               let !b1_1 = indexWord8Array# a1 off1-                   !b2_1 = indexWord8Array# a2 off2-#else-               let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)-                   !b2_1 = word8ToWord# (indexWord8Array# a2 off2)-#endif-               in case b1_1 of-                  0xC0## -> case b2_1 of-                     0xC0## -> go (off1 +# 1#) (off2 +# 1#)-#if !MIN_VERSION_base(4,16,0)-                     _      -> case indexWord8Array# a1 (off1 +# 1#) of-#else-                     _      -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of-#endif-                        0x80## -> LT-                        _      -> go (off1 +# 1#) (off2 +# 1#)-                  _      -> case b2_1 of-#if !MIN_VERSION_base(4,16,0)-                     0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of-#else-                     0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of-#endif-                        0x80## -> GT-                        _      -> go (off1 +# 1#) (off2 +# 1#)-                     _   | isTrue# (b1_1 `gtWord#` b2_1) -> GT-                         | isTrue# (b1_1 `ltWord#` b2_1) -> LT-                         | otherwise                     -> go (off1 +# 1#) (off2 +# 1#)--utf8DecodeShortByteString :: ShortByteString -> [Char]-utf8DecodeShortByteString (SBS ba#)-  = unsafeDupablePerformIO $-      let len# = sizeofByteArray# ba# in-      utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len#--countUTF8Chars :: ShortByteString -> IO Int-countUTF8Chars (SBS ba) = go 0# 0#-  where-    len# = sizeofByteArray# ba-    go i# n#-      | isTrue# (i# >=# len#) =-          return (I# n#)-      | otherwise = do-          case utf8DecodeCharByteArray# ba i# of-            (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)--{-# INLINE utf8EncodeChar #-}-utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)-               -> Char -> ST s Int-utf8EncodeChar write# c =-  let x = fromIntegral (ord c) in-  case () of-    _ | x > 0 && x <= 0x007f -> do-          write 0 x-          return 1-        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we-        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).-      | x <= 0x07ff -> do-          write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))-          write 1 (0x80 .|. (x .&. 0x3F))-          return 2-      | x <= 0xffff -> do-          write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)-          write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)-          write 2 (0x80 .|. (x .&. 0x3F))-          return 3-      | otherwise -> do-          write 0 (0xF0 .|. (x `shiftR` 18))-          write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))-          write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))-          write 3 (0x80 .|. (x .&. 0x3F))-          return 4-  where-    {-# INLINE write #-}-    write (I# off#) (W# c#) = ST $ \s ->-#if !MIN_VERSION_base(4,16,0)-      case write# off# (narrowWord8# c#) s of-#else-      case write# off# (wordToWord8# c#) s of-#endif-        s -> (# s, () #)--utf8EncodeString :: String -> ByteString-utf8EncodeString s =-  unsafePerformIO $ do-    let len = utf8EncodedLength s-    buf <- mallocForeignPtrBytes len-    withForeignPtr buf $ \ptr -> do-      utf8EncodeStringPtr ptr s-      pure (BS.fromForeignPtr buf 0 len)--utf8EncodeStringPtr :: Ptr Word8 -> String -> IO ()-utf8EncodeStringPtr (Ptr a#) str = go a# str-  where go !_   []   = return ()-        go a# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)-          -- writeWord8OffAddr# was taking a Word#-          I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c-#else-          I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c-#endif-          go (a# `plusAddr#` off#) cs--utf8EncodeShortByteString :: String -> IO ShortByteString-utf8EncodeShortByteString str = IO $ \s ->-  case utf8EncodedLength str         of { I# len# ->-  case newByteArray# len# s          of { (# s, mba# #) ->-  case go mba# 0# str                of { ST f_go ->-  case f_go s                        of { (# s, () #) ->-  case unsafeFreezeByteArray# mba# s of { (# s, ba# #) ->-  (# s, SBS ba# #) }}}}}-  where-    go _ _ [] = return ()-    go mba# i# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)-      -- writeWord8Array# was taking a Word#-      I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c-#else-      I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c-#endif-      go mba# (i# +# off#) cs--utf8EncodedLength :: String -> Int-utf8EncodedLength str = go 0 str-  where go !n [] = n-        go n (c:cs)-          | ord c > 0 && ord c <= 0x007f = go (n+1) cs-          | ord c <= 0x07ff = go (n+2) cs-          | ord c <= 0xffff = go (n+3) cs-          | otherwise       = go (n+4) cs+import GHC.Utils.Encoding.UTF8  -- ----------------------------------------------------------------------------- -- Note [Z-Encoding]@@ -441,8 +145,10 @@ encode_ch c    = encode_as_unicode_char c  encode_as_unicode_char :: Char -> EncodedString-encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str-                                                           else '0':hex_str+encode_as_unicode_char c = 'z' : case hex_str of+  hd : _+    | isDigit hd -> hex_str+  _ -> '0' : hex_str   where hex_str = showHex (ord c) "U"   -- ToDo: we could improve the encoding here in various ways.   -- eg. strings of unicode characters come out as 'z1234Uz5678U', we

@@ -0,0 +1,361 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-}+{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected. This module used to live in the `ghc`+-- package but has been moved to `ghc-boot` because the definition+-- of the package database (needed in both ghc and in ghc-pkg) lives in+-- `ghc-boot` and uses ShortText, which in turn depends on this module.++-- | Simple, non-streaming UTF-8 codecs.+--+-- This is one of several UTF-8 implementations provided by GHC; see Note+-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an+-- overview.+--+module GHC.Utils.Encoding.UTF8+    ( -- * Decoding single characters+      utf8DecodeCharAddr#+    , utf8DecodeCharPtr+    , utf8DecodeCharByteArray#+    , utf8PrevChar+    , utf8CharStart+    , utf8UnconsByteString+      -- * Decoding strings+    , utf8DecodeByteString+    , utf8DecodeShortByteString+    , utf8DecodeForeignPtr+    , utf8DecodeByteArray#+      -- * Counting characters+    , utf8CountCharsShortByteString+    , utf8CountCharsByteArray#+      -- * Comparison+    , utf8CompareByteArray#+    , utf8CompareShortByteString+      -- * Encoding strings+    , utf8EncodeByteArray#+    , utf8EncodePtr+    , utf8EncodeByteString+    , utf8EncodeShortByteString+    , utf8EncodedLength+    ) where+++import Prelude++import Foreign+import GHC.IO+#if MIN_VERSION_base(4,18,0)+import GHC.Encoding.UTF8+#else+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Data.Char+import GHC.Exts+import GHC.ST+#endif++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import Data.ByteString.Short.Internal (ShortByteString(..))++-- | Find the start of the codepoint preceding the codepoint at the given+-- 'Ptr'. This is undefined if there is no previous valid codepoint.+utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)+utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))++-- | Find the start of the codepoint at the given 'Ptr'. This is undefined if+-- there is no previous valid codepoint.+utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)+utf8CharStart p = go p+ where go p = do w <- peek p+                 if w >= 0x80 && w < 0xC0+                        then go (p `plusPtr` (-1))+                        else return p++utf8CountCharsShortByteString :: ShortByteString -> Int+utf8CountCharsShortByteString (SBS ba) = utf8CountCharsByteArray# ba++utf8DecodeShortByteString :: ShortByteString -> [Char]+utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba#++-- | Decode a 'ByteString' containing a UTF-8 string.+utf8DecodeByteString :: ByteString -> [Char]+utf8DecodeByteString (BS.PS fptr offset len)+  = utf8DecodeForeignPtr fptr offset len++utf8EncodeShortByteString :: String -> ShortByteString+utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str)++-- | Encode a 'String' into a 'ByteString'.+utf8EncodeByteString :: String -> ByteString+utf8EncodeByteString s =+  unsafePerformIO $ do+    let len = utf8EncodedLength s+    buf <- mallocForeignPtrBytes len+    withForeignPtr buf $ \ptr -> do+      utf8EncodePtr ptr s+      pure (BS.fromForeignPtr buf 0 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) = utf8DecodeCharPtr (ptr `plusPtr` offset)+        return $ Just (c, BS.PS fptr (offset + n) (len - n))++utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering+utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2++---------------------------------------------------------+-- Everything below was moved into base in GHC 9.6+--+-- These can be dropped in GHC 9.6 + 2 major releases.+---------------------------------------------------------++#if !MIN_VERSION_base(4,18,0)++-- We can't write the decoder as efficiently as we'd like without+-- resorting to unboxed extensions, unfortunately.  I tried to write+-- an IO version of this function, but GHC can't eliminate boxed+-- results from an IO-returning function.+--+-- We assume we can ignore overflow when parsing a multibyte character here.+-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences+-- before decoding them (see "GHC.Data.StringBuffer").++{-# INLINE utf8DecodeChar# #-}+-- | Decode a single codepoint from a byte buffer indexed by the given indexing+-- function.+utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)+utf8DecodeChar# indexWord8# =+  let !ch0 = word2Int# (indexWord8# 0#) in+  case () of+    _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)++      | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->+        let !ch1 = word2Int# (indexWord8# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#+                  (ch1 -# 0x80#)),+           2# #)++      | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->+        let !ch1 = word2Int# (indexWord8# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        let !ch2 = word2Int# (indexWord8# 2#) in+        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+        (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#)  +#+                  (ch2 -# 0x80#)),+           3# #)++     | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->+        let !ch1 = word2Int# (indexWord8# 1#) in+        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+        let !ch2 = word2Int# (indexWord8# 2#) in+        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+        let !ch3 = word2Int# (indexWord8# 3#) in+        if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else+        (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#+                 ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#)  +#+                  (ch3 -# 0x80#)),+           4# #)++      | otherwise -> fail 1#+  where+        -- all invalid sequences end up here:+        fail :: Int# -> (# Char#, Int# #)+        fail nBytes# = (# '\0'#, nBytes# #)+        -- '\xFFFD' would be the usual replacement character, but+        -- that's a valid symbol in Haskell, so will result in a+        -- confusing parse error later on.  Instead we use '\0' which+        -- will signal a lexer error immediately.++-- | Decode a single character at the given 'Addr#'.+utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)+utf8DecodeCharAddr# a# off# =+#if !MIN_VERSION_base(4,16,0)+    utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))+#else+    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#)))+#endif++-- | Decode a single codepoint starting at the given 'Ptr'.+utf8DecodeCharPtr :: Ptr Word8 -> (Char, Int)+utf8DecodeCharPtr !(Ptr a#) =+  case utf8DecodeCharAddr# a# 0# of+    (# c#, nBytes# #) -> ( C# c#, I# nBytes# )++-- | Decode a single codepoint starting at the given byte offset into a+-- 'ByteArray#'.+utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)+utf8DecodeCharByteArray# ba# off# =+#if !MIN_VERSION_base(4,16,0)+    utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))+#else+    utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#)))+#endif++{-# INLINE utf8Decode# #-}+utf8Decode# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]+utf8Decode# retain decodeChar# len#+  = unpack 0#+  where+    unpack i#+        | isTrue# (i# >=# len#) = retain >> return []+        | otherwise =+            case decodeChar# i# of+              (# c#, nBytes# #) -> do+                rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)+                return (C# c# : rest)++utf8DecodeForeignPtr :: ForeignPtr Word8 -> Int -> Int -> [Char]+utf8DecodeForeignPtr fp offset (I# len#)+  = unsafeDupablePerformIO $ do+      let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset+      utf8Decode# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#+-- Note that since utf8Decode# returns a thunk the lifetime of the+-- ForeignPtr actually needs to be longer than the lexical lifetime+-- withForeignPtr would provide here. That's why we use touchForeignPtr to+-- keep the fp alive until the last character has actually been decoded.++utf8DecodeByteArray# :: ByteArray# -> [Char]+utf8DecodeByteArray# ba#+  = unsafeDupablePerformIO $+      let len# = sizeofByteArray# ba# in+      utf8Decode# (return ()) (utf8DecodeCharByteArray# ba#) len#++utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering+utf8CompareByteArray# a1 a2 = go 0# 0#+   -- UTF-8 has the property that sorting by bytes values also sorts by+   -- code-points.+   -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property+   -- doesn't hold and we must explicitly check this case here.+   -- Note that decoding every code point would also work but it would be much+   -- more costly.+   where+       !sz1 = sizeofByteArray# a1+       !sz2 = sizeofByteArray# a2+       go off1 off2+         | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ+         | isTrue# (off1 >=# sz1)                          = LT+         | isTrue# (off2 >=# sz2)                          = GT+         | otherwise =+#if !MIN_VERSION_base(4,16,0)+               let !b1_1 = indexWord8Array# a1 off1+                   !b2_1 = indexWord8Array# a2 off2+#else+               let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)+                   !b2_1 = word8ToWord# (indexWord8Array# a2 off2)+#endif+               in case b1_1 of+                  0xC0## -> case b2_1 of+                     0xC0## -> go (off1 +# 1#) (off2 +# 1#)+#if !MIN_VERSION_base(4,16,0)+                     _      -> case indexWord8Array# a1 (off1 +# 1#) of+#else+                     _      -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of+#endif+                        0x80## -> LT+                        _      -> go (off1 +# 1#) (off2 +# 1#)+                  _      -> case b2_1 of+#if !MIN_VERSION_base(4,16,0)+                     0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of+#else+                     0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of+#endif+                        0x80## -> GT+                        _      -> go (off1 +# 1#) (off2 +# 1#)+                     _   | isTrue# (b1_1 `gtWord#` b2_1) -> GT+                         | isTrue# (b1_1 `ltWord#` b2_1) -> LT+                         | otherwise                     -> go (off1 +# 1#) (off2 +# 1#)++utf8CountCharsByteArray# :: ByteArray# -> Int+utf8CountCharsByteArray# ba = go 0# 0#+  where+    len# = sizeofByteArray# ba+    go i# n#+      | isTrue# (i# >=# len#) = I# n#+      | otherwise =+          case utf8DecodeCharByteArray# ba i# of+            (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)++{-# INLINE utf8EncodeChar #-}+utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)+               -> Char -> ST s Int+utf8EncodeChar write# c =+  let x = fromIntegral (ord c) in+  case () of+    _ | x > 0 && x <= 0x007f -> do+          write 0 x+          return 1+        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we+        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).+      | x <= 0x07ff -> do+          write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))+          write 1 (0x80 .|. (x .&. 0x3F))+          return 2+      | x <= 0xffff -> do+          write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)+          write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)+          write 2 (0x80 .|. (x .&. 0x3F))+          return 3+      | otherwise -> do+          write 0 (0xF0 .|. (x `shiftR` 18))+          write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))+          write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))+          write 3 (0x80 .|. (x .&. 0x3F))+          return 4+  where+    {-# INLINE write #-}+    write (I# off#) (W# c#) = ST $ \s ->+#if !MIN_VERSION_base(4,16,0)+      case write# off# (narrowWord8# c#) s of+#else+      case write# off# (wordToWord8# c#) s of+#endif+        s -> (# s, () #)++utf8EncodePtr :: Ptr Word8 -> String -> IO ()+utf8EncodePtr (Ptr a#) str = go a# str+  where go !_   []   = return ()+        go a# (c:cs) = do+#if !MIN_VERSION_base(4,16,0)+          -- writeWord8OffAddr# was taking a Word#+          I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c+#else+          I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c+#endif+          go (a# `plusAddr#` off#) cs++utf8EncodeByteArray# :: String -> ByteArray#+utf8EncodeByteArray# str = runRW# $ \s ->+  case utf8EncodedLength str         of { I# len# ->+  case newByteArray# len# s          of { (# s, mba# #) ->+  case go mba# 0# str                of { ST f_go ->+  case f_go s                        of { (# s, () #) ->+  case unsafeFreezeByteArray# mba# s of { (# _, ba# #) ->+  ba# }}}}}+  where+    go _ _ [] = return ()+    go mba# i# (c:cs) = do+#if !MIN_VERSION_base(4,16,0)+      -- writeWord8Array# was taking a Word#+      I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c+#else+      I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c+#endif+      go mba# (i# +# off#) cs++utf8EncodedLength :: String -> Int+utf8EncodedLength str = go 0 str+  where go !n [] = n+        go n (c:cs)+          | ord c > 0 && ord c <= 0x007f = go (n+1) cs+          | ord c <= 0x07ff = go (n+2) cs+          | ord c <= 0xffff = go (n+3) cs+          | otherwise       = go (n+4) cs++#endif /* MIN_VERSION_base(4,18,0) */

@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.4.1+version:        9.6.0.20230302 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -28,7 +28,7 @@ extra-source-files: changelog.md  custom-setup-    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.9, directory, filepath+    setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, filepath  source-repository head     type:     git@@ -45,6 +45,7 @@             GHC.Data.ShortText             GHC.Data.SizedSeq             GHC.Utils.Encoding+            GHC.Utils.Encoding.UTF8             GHC.LanguageExtensions             GHC.Unit.Database             GHC.Serialized@@ -69,14 +70,14 @@             GHC.Version             GHC.Platform.Host -    build-depends: base       >= 4.7 && < 4.18,+    build-depends: base       >= 4.7 && < 4.19,                    binary     == 0.8.*,                    bytestring >= 0.10 && < 0.12,                    containers >= 0.5 && < 0.7,                    directory  >= 1.2 && < 1.4,                    filepath   >= 1.3 && < 1.5,                    deepseq    >= 1.4 && < 1.5,-                   ghc-boot-th == 9.4.1+                   ghc-boot-th == 9.6.0.20230302     if !os(windows)         build-depends:-                   unix       >= 2.7 && < 2.8+                   unix       >= 2.7 && < 2.9