diff --git a/GHC/BaseDir.hs b/GHC/BaseDir.hs --- a/GHC/BaseDir.hs +++ b/GHC/BaseDir.hs @@ -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 diff --git a/GHC/Data/ShortText.hs b/GHC/Data/ShortText.hs --- a/GHC/Data/ShortText.hs +++ b/GHC/Data/ShortText.hs @@ -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 diff --git a/GHC/Data/SizedSeq.hs b/GHC/Data/SizedSeq.hs --- a/GHC/Data/SizedSeq.hs +++ b/GHC/Data/SizedSeq.hs @@ -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 diff --git a/GHC/Platform/ArchOS.hs b/GHC/Platform/ArchOS.hs deleted file mode 100644 --- a/GHC/Platform/ArchOS.hs +++ /dev/null @@ -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" diff --git a/GHC/Serialized.hs b/GHC/Serialized.hs --- a/GHC/Serialized.hs +++ b/GHC/Serialized.hs @@ -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 diff --git a/GHC/Settings/Utils.hs b/GHC/Settings/Utils.hs --- a/GHC/Settings/Utils.hs +++ b/GHC/Settings/Utils.hs @@ -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 diff --git a/GHC/Utils/Encoding.hs b/GHC/Utils/Encoding.hs --- a/GHC/Utils/Encoding.hs +++ b/GHC/Utils/Encoding.hs @@ -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 - -* "(# #)" 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) - {- ************************************************************************ diff --git a/GHC/Utils/Encoding/UTF8.hs b/GHC/Utils/Encoding/UTF8.hs --- a/GHC/Utils/Encoding/UTF8.hs +++ b/GHC/Utils/Encoding/UTF8.hs @@ -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) */ diff --git a/ghc-boot.cabal b/ghc-boot.cabal --- a/ghc-boot.cabal +++ b/ghc-boot.cabal @@ -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