ghc-boot 9.6.6 → 9.14.1
raw patch · 9 files changed
Files
- GHC/BaseDir.hs +23/−12
- GHC/Data/ShortText.hs +5/−7
- GHC/Data/SizedSeq.hs +7/−4
- GHC/Platform/ArchOS.hs +0/−161
- GHC/Serialized.hs +4/−0
- GHC/Settings/Utils.hs +7/−0
- GHC/Utils/Encoding.hs +43/−47
- GHC/Utils/Encoding/UTF8.hs +1/−262
- ghc-boot.cabal +36/−15
GHC/BaseDir.hs view
@@ -12,7 +12,11 @@ -- installation location at build time. ghc-pkg also can expand those variables -- and so needs the top dir location to do that too. -module GHC.BaseDir where+module GHC.BaseDir+ ( expandTopDir+ , expandPathVar+ , getBaseDir+ ) where import Prelude -- See Note [Why do we import Prelude here?] @@ -20,11 +24,9 @@ import Data.Maybe (listToMaybe) import System.FilePath --- Windows-#if defined(mingw32_HOST_OS)-import System.Environment (getExecutablePath)--- POSIX-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)+#if !defined(openbsd_HOST_OS)+import System.Environment (executablePath)+#else import System.Environment (getExecutablePath) #endif @@ -43,17 +45,25 @@ expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] +#if defined(openbsd_HOST_OS)+-- Polyfill for base-4.17 executablePath and OpenBSD which doesn't+-- have executablePath. The best it can do is use argv[0] which is+-- good enough for most uses of getBaseDir.+executablePath :: Maybe (IO (Maybe FilePath))+executablePath = Just (Just <$> getExecutablePath)+#endif+ -- | Calculate the location of the base dir getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS)-getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath where -- locate the "base dir" when given the path -- to the real ghc executable (as opposed to symlink) -- that is running this function. rootDir :: FilePath -> FilePath rootDir = takeDirectory . takeDirectory . normalise-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)+#else -- on unix, this is a bit more confusing. -- The layout right now is something like --@@ -65,14 +75,15 @@ -- As such, we first need to find the absolute location to the -- binary. ----- getExecutablePath will return (3). One takeDirectory will+-- executablePath will return (3). One takeDirectory will -- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). -- -- This of course only works due to the current layout. If -- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} -- this would need to be changed accordingly. ---getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath-#else-getBaseDir = return Nothing+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath+ where+ rootDir :: FilePath -> FilePath+ rootDir = takeDirectory . takeDirectory #endif
GHC/Data/ShortText.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies, CPP #-}+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- 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@@ -11,12 +11,6 @@ -- 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 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.-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-{-# OPTIONS_GHC -fignore-interface-pragmas #-}-#endif -- | -- An Unicode string for internal GHC use. Meant to replace String -- in places where being a lazy linked is not very useful and a more@@ -24,6 +18,10 @@ -- Very similar to FastString, but not hash-consed and with some extra instances and -- functions for serialisation and I/O. Should be imported qualified.+--+-- /Note:/ This string is stored in Modified UTF8 format,+-- thus it's not byte-compatible with @ShortText@ type in @text-short@+-- package. module GHC.Data.ShortText ( -- * ShortText
GHC/Data/SizedSeq.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-} module GHC.Data.SizedSeq ( SizedSeq(..) , emptySS@@ -11,9 +11,12 @@ import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary-import Data.List (genericLength) import GHC.Generics +#if ! MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+ data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] deriving (Generic, Show) @@ -37,9 +40,9 @@ addToSS :: SizedSeq a -> a -> SizedSeq a addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) +-- NB, important this is eta-expand so that foldl' is inlined. addListToSS :: SizedSeq a -> [a] -> SizedSeq a-addListToSS (SizedSeq n r_xs) xs- = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)+addListToSS s xs = foldl' addToSS s xs ssElts :: SizedSeq a -> [a] ssElts (SizedSeq _ r_xs) = reverse r_xs
− GHC/Platform/ArchOS.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}---- | Platform architecture and OS------ We need it in ghc-boot because ghc-pkg needs it.-module GHC.Platform.ArchOS- ( ArchOS(..)- , Arch(..)- , OS(..)- , ArmISA(..)- , ArmISAExt(..)- , ArmABI(..)- , PPC_64ABI(..)- , stringEncodeArch- , stringEncodeOS- )-where--import Prelude -- See Note [Why do we import Prelude here?]---- | Platform architecture and OS.-data ArchOS- = ArchOS- { archOS_arch :: Arch- , archOS_OS :: OS- }- deriving (Read, Show, Eq, Ord)---- | Architectures------ TODO: It might be nice to extend these constructors with information about--- what instruction set extensions an architecture might support.----data Arch- = ArchUnknown- | ArchX86- | ArchX86_64- | ArchPPC- | ArchPPC_64 PPC_64ABI- | ArchS390X- | ArchARM ArmISA [ArmISAExt] ArmABI- | ArchAArch64- | ArchAlpha- | ArchMipseb- | ArchMipsel- | ArchRISCV64- | ArchLoongArch64- | ArchJavaScript- | ArchWasm32- deriving (Read, Show, Eq, Ord)---- | ARM Instruction Set Architecture-data ArmISA- = ARMv5- | ARMv6- | ARMv7- deriving (Read, Show, Eq, Ord)---- | ARM extensions-data ArmISAExt- = VFPv2- | VFPv3- | VFPv3D16- | NEON- | IWMMX2- deriving (Read, Show, Eq, Ord)---- | ARM ABI-data ArmABI- = SOFT- | SOFTFP- | HARD- deriving (Read, Show, Eq, Ord)---- | PowerPC 64-bit ABI-data PPC_64ABI- = ELF_V1 -- ^ PowerPC64- | ELF_V2 -- ^ PowerPC64 LE- deriving (Read, Show, Eq, Ord)---- | Operating systems.------ Using OSUnknown to generate code should produce a sensible default, but no--- promises.-data OS- = OSUnknown- | OSLinux- | OSDarwin- | OSSolaris2- | OSMinGW32- | OSFreeBSD- | OSDragonFly- | OSOpenBSD- | OSNetBSD- | OSKFreeBSD- | OSHaiku- | OSQNXNTO- | OSAIX- | OSHurd- | OSWasi- | OSGhcjs- deriving (Read, Show, Eq, Ord)----- Note [Platform Syntax]--- ~~~~~~~~~~~~~~~~~~~~~~------ There is a very loose encoding of platforms shared by many tools we are--- encoding to here. GNU Config (http://git.savannah.gnu.org/cgit/config.git),--- and LLVM's http://llvm.org/doxygen/classllvm_1_1Triple.html are perhaps the--- most definitional parsers. The basic syntax is a list of '-'-separated--- components. The Unix 'uname' command syntax is related but briefer.------ Those two parsers are quite forgiving, and even the 'config.sub'--- normalization is forgiving too. The "best" way to encode a platform is--- therefore somewhat a matter of taste.------ The 'stringEncode*' functions here convert each part of GHC's structured--- notion of a platform into one dash-separated component.---- | See Note [Platform Syntax].-stringEncodeArch :: Arch -> String-stringEncodeArch = \case- ArchUnknown -> "unknown"- ArchX86 -> "i386"- ArchX86_64 -> "x86_64"- ArchPPC -> "powerpc"- ArchPPC_64 ELF_V1 -> "powerpc64"- ArchPPC_64 ELF_V2 -> "powerpc64le"- ArchS390X -> "s390x"- ArchARM ARMv5 _ _ -> "armv5"- ArchARM ARMv6 _ _ -> "armv6"- ArchARM ARMv7 _ _ -> "armv7"- ArchAArch64 -> "aarch64"- ArchAlpha -> "alpha"- ArchMipseb -> "mipseb"- ArchMipsel -> "mipsel"- ArchRISCV64 -> "riscv64"- ArchLoongArch64 -> "loongarch64"- ArchJavaScript -> "javascript"- ArchWasm32 -> "wasm32"---- | See Note [Platform Syntax].-stringEncodeOS :: OS -> String-stringEncodeOS = \case- OSUnknown -> "unknown"- OSLinux -> "linux"- OSDarwin -> "darwin"- OSSolaris2 -> "solaris2"- OSMinGW32 -> "mingw32"- OSFreeBSD -> "freebsd"- OSDragonFly -> "dragonfly"- OSOpenBSD -> "openbsd"- OSNetBSD -> "netbsd"- OSKFreeBSD -> "kfreebsdgnu"- OSHaiku -> "haiku"- OSQNXNTO -> "nto-qnx"- OSAIX -> "aix"- OSHurd -> "hurd"- OSWasi -> "wasi"- OSGhcjs -> "ghcjs"
GHC/Serialized.hs view
@@ -22,10 +22,14 @@ import Data.Bits import Data.Word ( Word8 ) import Data.Data+import Control.DeepSeq -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8]++instance NFData Serialized where+ rnf (Serialized tr ws) = rnf tr `seq` rnf ws -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
GHC/Settings/Utils.hs view
@@ -8,6 +8,7 @@ import GHC.BaseDir import GHC.Platform.ArchOS+import System.FilePath maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of@@ -41,6 +42,12 @@ getTargetArchOS settingsFile settings = ArchOS <$> readRawSetting settingsFile settings "target arch" <*> readRawSetting settingsFile settings "target os"++getGlobalPackageDb :: FilePath -> RawSettings -> Either String FilePath+getGlobalPackageDb settingsFile settings = do+ rel_db <- getRawSetting settingsFile settings "Relative Global Package DB"+ return (dropFileName settingsFile </> rel_db)+ getRawSetting
GHC/Utils/Encoding.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised@@ -79,9 +80,8 @@ :+ ZCzp () Z0T 0-tuple (,,,,) Z5T 5-tuple- (# #) Z1H unboxed 1-tuple (note the space)+ (##) Z0H unboxed 0-tuple (#,,,,#) Z5H unboxed 5-tuple- (NB: There is no Z1T nor Z0H.) -} type UserString = String -- As the user typed it@@ -89,15 +89,48 @@ zEncodeString :: UserString -> EncodedString-zEncodeString cs = case maybe_tuple cs of- Just n -> n -- Tuples go to Z2T etc- Nothing -> go cs- where- go [] = []- go (c:cs) = encode_digit_ch c ++ go' cs- go' [] = []- go' (c:cs) = encode_ch c ++ go' cs+zEncodeString = \case+ [] -> []+ (c:cs)+ -- If a digit is at the start of a symbol then we need to encode it.+ -- Otherwise package names like 9pH-0.1 give linker errors.+ | c >= '0' && c <= '9' -> encode_as_unicode_char c ++ go cs+ | otherwise -> go (c:cs)+ where+ go = \case+ [] -> []+ -- encode boxed/unboxed tuples respectively as ZnT/ZnH (e.g. Z3T/Z3H for+ -- 3-tuples). Note that the arity corresponds to the number of+ -- commas+1. No comma means 0-arity, i.e. Z0T/Z0H.+ --+ -- The 1-arity unboxed tuple "(# #)" (notice the space between the '#'s)+ -- isn't special-cased, i.e. it is encoded as "ZLzhz20UzhZR". There is no+ -- 1-arity boxed tuple (we use Solo/MkSolo instead).+ --+ -- arity boxed z-name unboxed z-name+ -- 0 () Z0T (##) Z0H+ -- 1 N/A N/A (# #) ZLzhz20UzhZR+ -- 2 (,) Z2T (#,#) Z2H+ -- 3 (,,) Z3T (#,,#) Z3H+ -- ...+ --+ '(':'#':'#':')':cs -> "Z0H" ++ go cs+ '(':')':cs -> "Z0T" ++ go cs+ '(':'#':cs+ | (n, '#':')':cs') <- count_commas cs+ -> 'Z' : shows (n+1) ('H': go cs')+ '(':cs+ | (n, ')':cs') <- count_commas cs+ -> 'Z' : shows (n+1) ('T': go cs')+ c:cs -> encode_ch c ++ go cs +count_commas :: String -> (Int, String)+count_commas = go 0+ where+ go !n = \case+ ',':cs -> go (n+1) cs+ cs -> (n,cs)+ unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False unencodedChar 'z' = False@@ -105,12 +138,6 @@ || c >= 'A' && c <= 'Z' || c >= '0' && c <= '9' --- If a digit is at the start of a symbol then we need to encode it.--- Otherwise package names like 9pH-0.1 give linker errors.-encode_digit_ch :: Char -> EncodedString-encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c-encode_digit_ch c | otherwise = encode_ch c- encode_ch :: Char -> EncodedString encode_ch c | unencodedChar c = [c] -- Common case first @@ -213,39 +240,8 @@ go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest go 0 ('T':rest) = "()" ++ zDecodeString rest go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest- go 1 ('H':rest) = "(# #)" ++ zDecodeString rest go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest go n other = error ("decode_tuple: " ++ show n ++ ' ':other)--{--Tuples are encoded as- Z3T or Z3H-for 3-tuples or unboxed 3-tuples respectively. No other encoding starts- Z<digit>--* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)- There are no unboxed 0-tuples.--* "()" is the tycon for a boxed 0-tuple.- There are no boxed 1-tuples.--}--maybe_tuple :: UserString -> Maybe EncodedString--maybe_tuple "(# #)" = Just("Z1H")-maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of- (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")- _ -> Nothing-maybe_tuple "()" = Just("Z0T")-maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of- (n, ')' : _) -> Just ('Z' : shows (n+1) "T")- _ -> Nothing-maybe_tuple _ = Nothing--count_commas :: Int -> String -> (Int, String)-count_commas n (',' : cs) = count_commas (n+1) cs-count_commas n cs = (n,cs)- {- ************************************************************************
GHC/Utils/Encoding/UTF8.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised@@ -7,7 +6,7 @@ -- 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.+-- | Simple, non-streaming Modified 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@@ -45,14 +44,7 @@ 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@@ -106,256 +98,3 @@ 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) */
ghc-boot.cabal view
@@ -5,7 +5,7 @@ -- ghc-boot.cabal. name: ghc-boot-version: 9.6.6+version: 9.14.1 license: BSD-3-Clause license-file: LICENSE category: GHC@@ -28,13 +28,22 @@ extra-source-files: changelog.md custom-setup- setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, filepath+ setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, filepath source-repository head type: git location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/ghc-boot +Flag bootstrap+ Description:+ Enabled when building the stage1 compiler in order to vendor the in-tree+ `template-haskell` library (including its dependency `ghc-boot-th`), while+ allowing dependencies to depend on the boot `template-haskell` library.+ See Note [Bootstrapping Template Haskell]+ Default: False+ Manual: True+ Library default-language: Haskell2010 other-extensions: DeriveGeneric, RankNTypes, ScopedTypeVariables@@ -51,33 +60,45 @@ GHC.Serialized GHC.ForeignSrcLang GHC.HandleEncoding- GHC.Platform.ArchOS GHC.Platform.Host GHC.Settings.Utils GHC.UniqueSubdir GHC.Version - -- reexport modules from ghc-boot-th so that packages don't have to import- -- both ghc-boot and ghc-boot-th. It makes the dependency graph easier to- -- understand and to refactor.++ -- reexport platform modules from ghc-platform reexported-modules:- GHC.LanguageExtensions.Type- , GHC.ForeignSrcLang.Type- , GHC.Lexeme+ GHC.Platform.ArchOS -- but done by Hadrian autogen-modules: GHC.Version GHC.Platform.Host - build-depends: base >= 4.7 && < 4.19,+ build-depends: base >= 4.7 && < 4.23, binary == 0.8.*,- bytestring >= 0.10 && < 0.12,- containers >= 0.5 && < 0.7,+ bytestring >= 0.10 && < 0.13,+ containers >= 0.5 && < 0.9, directory >= 1.2 && < 1.4,- filepath >= 1.3 && < 1.5,- deepseq >= 1.4 && < 1.5,- ghc-boot-th == 9.6.6+ filepath >= 1.3 && < 1.6,+ deepseq >= 1.4 && < 1.6,+ ghc-platform >= 0.1,++ -- reexport modules from ghc-boot-th so that packages+ -- don't have to import all of ghc-boot and ghc-boot-th.+ -- It makes the dependency graph easier to understand.+ reexported-modules:+ GHC.LanguageExtensions.Type+ , GHC.ForeignSrcLang.Type+ , GHC.Lexeme++ if flag(bootstrap)+ build-depends:+ ghc-boot-th-next == 9.14.1+ else+ build-depends:+ ghc-boot-th == 9.14.1+ if !os(windows) build-depends: unix >= 2.7 && < 2.9