diff --git a/GHC/BaseDir.hs b/GHC/BaseDir.hs --- a/GHC/BaseDir.hs +++ b/GHC/BaseDir.hs @@ -16,7 +16,7 @@ import Prelude -- See Note [Why do we import Prelude here?] -import Data.List +import Data.List (stripPrefix) import System.FilePath -- Windows diff --git a/GHC/Data/ShortText.hs b/GHC/Data/ShortText.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/ShortText.hs @@ -0,0 +1,128 @@ +{-# 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. +-- 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 +-- up bringing memcmp_ByteArray from bytestring:Data.ByteString.Short.Internal into scope, which results in +-- the memcmp call we choke on. +-- +-- 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. +-- +-- 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 GHC_STAGE < 1 +{-# 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 +-- memory efficient data structure is desirable. + +-- Very similar to FastString, but not hash-consed and with some extra instances and +-- functions for serialisation and I/O. Should be imported qualified. + +module GHC.Data.ShortText ( + -- * ShortText + ShortText(..), + -- ** Conversion to and from String + pack, + unpack, + -- ** Operations + codepointLength, + byteLength, + GHC.Data.ShortText.null, + splitFilePath, + GHC.Data.ShortText.head, + stripPrefix + ) where + +import Prelude + +import Control.Monad (guard) +import Control.DeepSeq as DeepSeq +import Data.Binary +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short.Internal as SBS +import GHC.Exts +import GHC.IO +import GHC.Utils.Encoding +import System.FilePath (isPathSeparator) + +{-| A 'ShortText' is a modified UTF-8 encoded string meant for short strings like +file paths, module descriptions, etc. +-} +newtype ShortText = ShortText { contents :: SBS.ShortByteString + } + deriving stock (Show) + deriving newtype (Eq, Ord, Binary, Semigroup, Monoid, NFData) + +-- We don't want to derive this one from ShortByteString since that one won't handle +-- UTF-8 characters correctly. +instance IsString ShortText where + fromString = pack + +-- | /O(n)/ Returns the length of the 'ShortText' in characters. +codepointLength :: ShortText -> Int +codepointLength st = unsafeDupablePerformIO $ countUTF8Chars (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 + +-- | /O(n)/ Convert a 'ShortText' into a 'String'. +unpack :: ShortText -> String +unpack st = utf8DecodeShortByteString $ contents st + +-- | /O(1)/ Test whether the 'ShortText' is the empty string. +null :: ShortText -> Bool +null st = SBS.null $ contents st + +-- | /O(n)/ Split a 'ShortText' representing a file path into its components by separating +-- on the file separator characters for this platform. +splitFilePath :: ShortText -> [ShortText] +-- This seems dangerous, but since the path separators are in the ASCII set they map down +-- to a single byte when encoded in UTF-8 and so this should work even when casting to ByteString. +-- We DeepSeq.force the resulting list so that we can be sure that no references to the +-- bytestring in `st'` remain in unevaluated thunks, which might prevent `st'` from being +-- collected by the GC. +splitFilePath st = DeepSeq.force $ map (ShortText . SBS.toShort) $ B8.splitWith isPathSeparator st' + where st' = SBS.fromShort $ contents st + +-- | /O(1)/ Returns the first UTF-8 codepoint in the 'ShortText'. Depending on the string in +-- question, this may or may not be the actual first character in the string due to Unicode +-- non-printable characters. +head :: ShortText -> Char +head st + | SBS.null $ contents st = error "head: Empty ShortText" + | otherwise = Prelude.head $ unpack st + +-- | /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. +stripPrefix :: ShortText -> ShortText -> Maybe ShortText +stripPrefix prefix st = do + let !(SBS.SBS prefixBA) = contents prefix + let !(SBS.SBS stBA) = contents st + let prefixLength = sizeofByteArray# prefixBA + let stLength = sizeofByteArray# stBA + -- If the length of 'st' is not >= than the length of 'prefix', it is impossible for 'prefix' + -- to be the prefix of `st`. + guard $ (I# stLength) >= (I# prefixLength) + -- 'prefix' is a prefix of 'st' if the first bytes of 'st' + -- are equal to 'prefix' + guard $ I# (compareByteArrays# prefixBA 0# stBA 0# prefixLength) == 0 + -- Allocate a new ByteArray# and copy the remainder of the 'st' into it + unsafeDupablePerformIO $ do + let newBAsize = (stLength -# prefixLength) + newSBS <- IO $ \s0 -> + let !(# s1, ba #) = newByteArray# newBAsize s0 + s2 = copyByteArray# stBA prefixLength ba 0# newBAsize s1 + !(# s3, fba #) = unsafeFreezeByteArray# ba s2 + in (# s3, SBS.SBS fba #) + return . Just . ShortText $ newSBS diff --git a/GHC/Data/SizedSeq.hs b/GHC/Data/SizedSeq.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/SizedSeq.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} +module GHC.Data.SizedSeq + ( SizedSeq(..) + , emptySS + , addToSS + , addListToSS + , ssElts + , sizeSS + ) where + +import Prelude -- See note [Why do we import Prelude here?] +import Control.DeepSeq +import Data.Binary +import Data.List (genericLength) +import GHC.Generics + +data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] + deriving (Generic, Show) + +instance Functor SizedSeq where + fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l) + +instance Foldable SizedSeq where + foldr f c ss = foldr f c (ssElts ss) + +instance Traversable SizedSeq where + traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l) + +instance Binary a => Binary (SizedSeq a) + +instance NFData a => NFData (SizedSeq a) where + rnf (SizedSeq _ xs) = rnf xs + +emptySS :: SizedSeq a +emptySS = SizedSeq 0 [] + +addToSS :: SizedSeq a -> a -> SizedSeq a +addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) + +addListToSS :: SizedSeq a -> [a] -> SizedSeq a +addListToSS (SizedSeq n r_xs) xs + = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs) + +ssElts :: SizedSeq a -> [a] +ssElts (SizedSeq _ r_xs) = reverse r_xs + +sizeSS :: SizedSeq a -> Word +sizeSS (SizedSeq n _) = n diff --git a/GHC/Platform.hs b/GHC/Platform.hs deleted file mode 100644 --- a/GHC/Platform.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE LambdaCase, ScopedTypeVariables #-} - --- | A description of the platform we're compiling for. --- -module GHC.Platform - ( PlatformMini(..) - , PlatformWordSize(..) - , Platform(..) - , platformArch - , platformOS - , Arch(..) - , OS(..) - , ArmISA(..) - , ArmISAExt(..) - , ArmABI(..) - , PPC_64ABI(..) - , ByteOrder(..) - , target32Bit - , isARM - , osElfTarget - , osMachOTarget - , osSubsectionsViaSymbols - , platformUsesFrameworks - , platformWordSizeInBytes - , platformWordSizeInBits - , platformMinInt - , platformMaxInt - , platformMaxWord - , platformInIntRange - , platformInWordRange - , platformCConvNeedsExtension - , PlatformMisc(..) - , stringEncodeArch - , stringEncodeOS - , SseVersion (..) - , BmiVersion (..) - ) -where - -import Prelude -- See Note [Why do we import Prelude here?] -import GHC.Read -import GHC.ByteOrder (ByteOrder(..)) -import Data.Word -import Data.Int - --- | Contains the bare-bones arch and os information. This isn't enough for --- code gen, but useful for tasks where we can fall back upon the host --- platform, as this is all we know about the host platform. -data PlatformMini - = PlatformMini - { platformMini_arch :: Arch - , platformMini_os :: OS - } - deriving (Read, Show, Eq) - --- | Contains enough information for the native code generator to emit --- code for this platform. -data Platform = Platform - { platformMini :: !PlatformMini - , platformWordSize :: !PlatformWordSize -- ^ Word size - , platformByteOrder :: !ByteOrder -- ^ Byte order (endianness) - , platformUnregisterised :: !Bool - , platformHasGnuNonexecStack :: !Bool - , platformHasIdentDirective :: !Bool - , platformHasSubsectionsViaSymbols :: !Bool - , platformIsCrossCompiling :: !Bool - , platformLeadingUnderscore :: !Bool -- ^ Symbols need underscore prefix - , platformTablesNextToCode :: !Bool - -- ^ Determines whether we will be compiling info tables that reside just - -- before the entry code, or with an indirection to the entry code. See - -- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h. - } - deriving (Read, Show, Eq) - -data PlatformWordSize - = PW4 -- ^ A 32-bit platform - | PW8 -- ^ A 64-bit platform - deriving (Eq) - -instance Show PlatformWordSize where - show PW4 = "4" - show PW8 = "8" - -instance Read PlatformWordSize where - readPrec = do - i :: Int <- readPrec - case i of - 4 -> return PW4 - 8 -> return PW8 - other -> fail ("Invalid PlatformWordSize: " ++ show other) - -platformWordSizeInBytes :: Platform -> Int -platformWordSizeInBytes p = - case platformWordSize p of - PW4 -> 4 - PW8 -> 8 - -platformWordSizeInBits :: Platform -> Int -platformWordSizeInBits p = platformWordSizeInBytes p * 8 - --- | Legacy accessor -platformArch :: Platform -> Arch -platformArch = platformMini_arch . platformMini - --- | Legacy accessor -platformOS :: Platform -> OS -platformOS = platformMini_os . platformMini - --- | Architectures that the native code generator knows about. --- 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 :: PPC_64ABI - } - | ArchS390X - | ArchSPARC - | ArchSPARC64 - | ArchARM - { armISA :: ArmISA - , armISAExt :: [ArmISAExt] - , armABI :: ArmABI - } - | ArchAArch64 - | ArchAlpha - | ArchMipseb - | ArchMipsel - | ArchJavaScript - deriving (Read, Show, Eq) - --- 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 { ppc_64ABI = abi } -> case abi of - ELF_V1 -> "powerpc64" - ELF_V2 -> "powerpc64le" - ArchS390X -> "s390x" - ArchSPARC -> "sparc" - ArchSPARC64 -> "sparc64" - ArchARM { armISA = isa, armISAExt = _, armABI = _ } -> "arm" ++ vsuf - where - vsuf = case isa of - ARMv5 -> "v5" - ARMv6 -> "v6" - ARMv7 -> "v7" - ArchAArch64 -> "aarch64" - ArchAlpha -> "alpha" - ArchMipseb -> "mipseb" - ArchMipsel -> "mipsel" - ArchJavaScript -> "js" - -isARM :: Arch -> Bool -isARM (ArchARM {}) = True -isARM ArchAArch64 = True -isARM _ = False - --- | Operating systems that the native code generator knows about. --- Having OSUnknown should produce a sensible default, but no promises. -data OS - = OSUnknown - | OSLinux - | OSDarwin - | OSSolaris2 - | OSMinGW32 - | OSFreeBSD - | OSDragonFly - | OSOpenBSD - | OSNetBSD - | OSKFreeBSD - | OSHaiku - | OSQNXNTO - | OSAIX - | OSHurd - deriving (Read, Show, Eq) - --- | 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" - --- | ARM Instruction Set Architecture, Extensions and ABI --- -data ArmISA - = ARMv5 - | ARMv6 - | ARMv7 - deriving (Read, Show, Eq) - -data ArmISAExt - = VFPv2 - | VFPv3 - | VFPv3D16 - | NEON - | IWMMX2 - deriving (Read, Show, Eq) - -data ArmABI - = SOFT - | SOFTFP - | HARD - deriving (Read, Show, Eq) - --- | PowerPC 64-bit ABI --- -data PPC_64ABI - = ELF_V1 - | ELF_V2 - deriving (Read, Show, Eq) - --- | This predicate tells us whether the platform is 32-bit. -target32Bit :: Platform -> Bool -target32Bit p = - case platformWordSize p of - PW4 -> True - PW8 -> False - --- | This predicate tells us whether the OS supports ELF-like shared libraries. -osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSDragonFly = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSMinGW32 = False -osElfTarget OSKFreeBSD = True -osElfTarget OSHaiku = True -osElfTarget OSQNXNTO = False -osElfTarget OSAIX = False -osElfTarget OSHurd = True -osElfTarget OSUnknown = False - -- Defaulting to False is safe; it means don't rely on any - -- ELF-specific functionality. It is important to have a default for - -- portability, otherwise we have to answer this question for every - -- new platform we compile on (even unreg). - --- | This predicate tells us whether the OS support Mach-O shared libraries. -osMachOTarget :: OS -> Bool -osMachOTarget OSDarwin = True -osMachOTarget _ = False - -osUsesFrameworks :: OS -> Bool -osUsesFrameworks OSDarwin = True -osUsesFrameworks _ = False - -platformUsesFrameworks :: Platform -> Bool -platformUsesFrameworks = osUsesFrameworks . platformOS - -osSubsectionsViaSymbols :: OS -> Bool -osSubsectionsViaSymbols OSDarwin = True -osSubsectionsViaSymbols _ = False - --- | Platform-specific settings formerly hard-coded in Config.hs. --- --- These should probably be all be triaged whether they can be computed from --- other settings or belong in another another place (like 'Platform' above). -data PlatformMisc = PlatformMisc - { -- TODO Recalculate string from richer info? - platformMisc_targetPlatformString :: String - , platformMisc_ghcWithInterpreter :: Bool - , platformMisc_ghcWithSMP :: Bool - , platformMisc_ghcRTSWays :: String - , platformMisc_libFFI :: Bool - , platformMisc_ghcThreaded :: Bool - , platformMisc_ghcDebugged :: Bool - , platformMisc_ghcRtsWithLibdw :: Bool - , platformMisc_llvmTarget :: String - } - --- | Minimum representable Int value for the given platform -platformMinInt :: Platform -> Integer -platformMinInt p = case platformWordSize p of - PW4 -> toInteger (minBound :: Int32) - PW8 -> toInteger (minBound :: Int64) - --- | Maximum representable Int value for the given platform -platformMaxInt :: Platform -> Integer -platformMaxInt p = case platformWordSize p of - PW4 -> toInteger (maxBound :: Int32) - PW8 -> toInteger (maxBound :: Int64) - --- | Maximum representable Word value for the given platform -platformMaxWord :: Platform -> Integer -platformMaxWord p = case platformWordSize p of - PW4 -> toInteger (maxBound :: Word32) - PW8 -> toInteger (maxBound :: Word64) - --- | Test if the given Integer is representable with a platform Int -platformInIntRange :: Platform -> Integer -> Bool -platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform - --- | Test if the given Integer is representable with a platform Word -platformInWordRange :: Platform -> Integer -> Bool -platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform - --- | For some architectures the C calling convention is that any --- integer shorter than 64 bits is replaced by its 64 bits --- representation using sign or zero extension. -platformCConvNeedsExtension :: Platform -> Bool -platformCConvNeedsExtension platform = case platformArch platform of - ArchPPC_64 _ -> True - ArchS390X -> True - _ -> False - - --------------------------------------------------- --- Instruction sets --------------------------------------------------- - --- | x86 SSE instructions -data SseVersion - = SSE1 - | SSE2 - | SSE3 - | SSE4 - | SSE42 - deriving (Eq, Ord) - --- | x86 BMI (bit manipulation) instructions -data BmiVersion - = BMI1 - | BMI2 - deriving (Eq, Ord) - diff --git a/GHC/Platform/ArchOS.hs b/GHC/Platform/ArchOS.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/ArchOS.hs @@ -0,0 +1,157 @@ +{-# 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) + +-- | 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 + | ArchSPARC + | ArchSPARC64 + | ArchARM ArmISA [ArmISAExt] ArmABI + | ArchAArch64 + | ArchAlpha + | ArchMipseb + | ArchMipsel + | ArchRISCV64 + | ArchJavaScript + deriving (Read, Show, Eq) + +-- | ARM Instruction Set Architecture +data ArmISA + = ARMv5 + | ARMv6 + | ARMv7 + deriving (Read, Show, Eq) + +-- | ARM extensions +data ArmISAExt + = VFPv2 + | VFPv3 + | VFPv3D16 + | NEON + | IWMMX2 + deriving (Read, Show, Eq) + +-- | ARM ABI +data ArmABI + = SOFT + | SOFTFP + | HARD + deriving (Read, Show, Eq) + +-- | PowerPC 64-bit ABI +data PPC_64ABI + = ELF_V1 -- ^ PowerPC64 + | ELF_V2 -- ^ PowerPC64 LE + deriving (Read, Show, Eq) + +-- | 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 + deriving (Read, Show, Eq) + + +-- 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" + ArchSPARC -> "sparc" + ArchSPARC64 -> "sparc64" + ArchARM ARMv5 _ _ -> "armv5" + ArchARM ARMv6 _ _ -> "armv6" + ArchARM ARMv7 _ _ -> "armv7" + ArchAArch64 -> "aarch64" + ArchAlpha -> "alpha" + ArchMipseb -> "mipseb" + ArchMipsel -> "mipsel" + ArchRISCV64 -> "riscv64" + ArchJavaScript -> "js" + +-- | 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" diff --git a/GHC/Platform/Host.hs b/GHC/Platform/Host.hs --- a/GHC/Platform/Host.hs +++ b/GHC/Platform/Host.hs @@ -1,15 +1,12 @@ module GHC.Platform.Host where -import GHC.Platform +import GHC.Platform.ArchOS -cHostPlatformArch :: Arch -cHostPlatformArch = ArchX86_64 +hostPlatformArch :: Arch +hostPlatformArch = ArchX86_64 -cHostPlatformOS :: OS -cHostPlatformOS = OSLinux +hostPlatformOS :: OS +hostPlatformOS = OSLinux -cHostPlatformMini :: PlatformMini -cHostPlatformMini = PlatformMini - { platformMini_arch = cHostPlatformArch - , platformMini_os = cHostPlatformOS - } +hostPlatformArchOS :: ArchOS +hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS diff --git a/GHC/Settings/Platform.hs b/GHC/Settings/Platform.hs deleted file mode 100644 --- a/GHC/Settings/Platform.hs +++ /dev/null @@ -1,99 +0,0 @@ --- Note [Settings file] --- ~~~~~~~~~~~~~~~~~~~~ --- --- GHC has a file, `${top_dir}/settings`, which is the main source of run-time --- configuration. ghc-pkg needs just a little bit of it: the target platform CPU --- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is --- associated with the current version/target. --- --- This module has just enough code to read key value pairs from the settings --- file, and read the target platform from those pairs. --- --- The "0" suffix is because the caller will partially apply it, and that will --- in turn be used a few more times. -module GHC.Settings.Platform where - -import Prelude -- See Note [Why do we import Prelude here?] - -import GHC.BaseDir -import GHC.Platform -import GHC.Settings.Utils - -import Data.Map (Map) -import qualified Data.Map as Map - ------------------------------------------------------------------------------ --- parts of settings file - -getTargetPlatform - :: FilePath -> RawSettings -> Either String Platform -getTargetPlatform settingsFile mySettings = do - let - getBooleanSetting = getBooleanSetting0 settingsFile mySettings - readSetting :: (Show a, Read a) => String -> Either String a - readSetting = readSetting0 settingsFile mySettings - - targetArch <- readSetting "target arch" - targetOS <- readSetting "target os" - targetWordSize <- readSetting "target word size" - targetWordBigEndian <- getBooleanSetting "target word big endian" - targetLeadingUnderscore <- getBooleanSetting "Leading underscore" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" - targetHasIdentDirective <- getBooleanSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" - crossCompiling <- getBooleanSetting "cross compiling" - tablesNextToCode <- getBooleanSetting "Tables next to code" - - pure $ Platform - { platformMini = PlatformMini - { platformMini_arch = targetArch - , platformMini_os = targetOS - } - , platformWordSize = targetWordSize - , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian - , platformUnregisterised = targetUnregisterised - , platformHasGnuNonexecStack = targetHasGnuNonexecStack - , platformHasIdentDirective = targetHasIdentDirective - , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols - , platformIsCrossCompiling = crossCompiling - , platformLeadingUnderscore = targetLeadingUnderscore - , platformTablesNextToCode = tablesNextToCode - } - ------------------------------------------------------------------------------ --- settings file helpers - -type RawSettings = Map String String - --- | See Note [Settings file] for "0" suffix -getSetting0 - :: FilePath -> RawSettings -> String -> Either String String -getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of - Just xs -> Right xs - Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile - --- | See Note [Settings file] for "0" suffix -getFilePathSetting0 - :: FilePath -> FilePath -> RawSettings -> String -> Either String String -getFilePathSetting0 top_dir settingsFile mySettings key = - expandTopDir top_dir <$> getSetting0 settingsFile mySettings key - --- | See Note [Settings file] for "0" suffix -getBooleanSetting0 - :: FilePath -> RawSettings -> String -> Either String Bool -getBooleanSetting0 settingsFile mySettings key = do - rawValue <- getSetting0 settingsFile mySettings key - case rawValue of - "YES" -> Right True - "NO" -> Right False - xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs - --- | See Note [Settings file] for "0" suffix -readSetting0 - :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a -readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of - Just xs -> case maybeRead xs of - Just v -> Right v - Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs - Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile diff --git a/GHC/Settings/Utils.hs b/GHC/Settings/Utils.hs --- a/GHC/Settings/Utils.hs +++ b/GHC/Settings/Utils.hs @@ -3,7 +3,12 @@ import Prelude -- See Note [Why do we import Prelude here?] import Data.Char (isSpace) +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.BaseDir +import GHC.Platform.ArchOS + maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of [(x, "")] -> Just x @@ -13,3 +18,55 @@ maybeReadFuzzy str = case reads str of [(x, s)] | all isSpace s -> Just x _ -> Nothing + + +-- Note [Settings file] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time +-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU +-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is +-- associated with the current version/target platform. +-- +-- This module has just enough code to read key value pairs from the settings +-- file, and read the target platform from those pairs. + +type RawSettings = Map String String + +-- | Read target Arch/OS from the settings +getTargetArchOS + :: FilePath -- ^ Settings filepath (for error messages) + -> RawSettings -- ^ Raw settings file contents + -> Either String ArchOS +getTargetArchOS settingsFile settings = + ArchOS <$> readRawSetting settingsFile settings "target arch" + <*> readRawSetting settingsFile settings "target os" + + +getRawSetting + :: FilePath -> RawSettings -> String -> Either String String +getRawSetting settingsFile settings key = case Map.lookup key settings of + Just xs -> Right xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile + +getRawFilePathSetting + :: FilePath -> FilePath -> RawSettings -> String -> Either String String +getRawFilePathSetting top_dir settingsFile settings key = + expandTopDir top_dir <$> getRawSetting settingsFile settings key + +getRawBooleanSetting + :: FilePath -> RawSettings -> String -> Either String Bool +getRawBooleanSetting settingsFile settings key = do + rawValue <- getRawSetting settingsFile settings key + case rawValue of + "YES" -> Right True + "NO" -> Right False + xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs + +readRawSetting + :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a +readRawSetting settingsFile settings key = case Map.lookup key settings of + Just xs -> case maybeRead xs of + Just v -> Right v + Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs + Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile diff --git a/GHC/UniqueSubdir.hs b/GHC/UniqueSubdir.hs --- a/GHC/UniqueSubdir.hs +++ b/GHC/UniqueSubdir.hs @@ -6,19 +6,15 @@ import Data.List (intercalate) -import GHC.Platform +import GHC.Platform.ArchOS import GHC.Version (cProjectVersion) -- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when -- constructing platform-version-dependent files that need to co-exist. --- --- 'ghc-pkg' falls back on the host platform if the settings file is missing, --- and so needs this since we don't have information about the host platform in --- as much detail as 'Platform', so we use 'PlatformMini' instead. -uniqueSubdir :: PlatformMini -> FilePath -uniqueSubdir archOs = intercalate "-" - [ stringEncodeArch $ platformMini_arch archOs - , stringEncodeOS $ platformMini_os archOs +uniqueSubdir :: ArchOS -> FilePath +uniqueSubdir (ArchOS arch os) = intercalate "-" + [ stringEncodeArch arch + , stringEncodeOS os , cProjectVersion ] -- NB: This functionality is reimplemented in Cabal, so if you diff --git a/GHC/Unit/Database.hs b/GHC/Unit/Database.hs --- a/GHC/Unit/Database.hs +++ b/GHC/Unit/Database.hs @@ -12,6 +12,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -82,16 +83,16 @@ import Data.Binary as Bin import Data.Binary.Put as Bin import Data.Binary.Get as Bin +import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) import System.FilePath as FilePath -import qualified System.FilePath.Posix as FilePath.Posix import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) +import qualified GHC.Data.ShortText as ST import GHC.IO.Handle.Lock import System.Directory -import Data.List (stripPrefix) -- | @ghc-boot@'s UnitInfo, serialized to the database. type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule @@ -142,28 +143,28 @@ -- components that can be registered in a database and used by other -- modules. - , unitAbiHash :: String + , unitAbiHash :: ST.ShortText -- ^ ABI hash used to avoid mixing up units compiled with different -- dependencies, compiler, options, etc. , unitDepends :: [uid] -- ^ Identifiers of the units this one depends on - , unitAbiDepends :: [(uid, String)] + , unitAbiDepends :: [(uid, ST.ShortText)] -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash -- we expect the dependency to respect. - , unitImportDirs :: [FilePath] + , unitImportDirs :: [FilePathST] -- ^ Directories containing module interfaces - , unitLibraries :: [String] + , unitLibraries :: [ST.ShortText] -- ^ Names of the Haskell libraries provided by this unit - , unitExtDepLibsSys :: [String] + , unitExtDepLibsSys :: [ST.ShortText] -- ^ Names of the external system libraries that this unit depends on. See -- also `unitExtDepLibsGhc` field. - , unitExtDepLibsGhc :: [String] + , unitExtDepLibsGhc :: [ST.ShortText] -- ^ Because of slight differences between the GHC dynamic linker (in -- GHC.Runtime.Linker) and the -- native system linker, some packages have to link with a different list @@ -174,46 +175,46 @@ -- If this field is set, then we use that instead of the -- `unitExtDepLibsSys` field. - , unitLibraryDirs :: [FilePath] + , unitLibraryDirs :: [FilePathST] -- ^ Directories containing libraries provided by this unit. See also -- `unitLibraryDynDirs`. -- -- It seems to be used to store paths to external library dependencies -- too. - , unitLibraryDynDirs :: [FilePath] + , unitLibraryDynDirs :: [FilePathST] -- ^ Directories containing the dynamic libraries provided by this unit. -- See also `unitLibraryDirs`. -- -- It seems to be used to store paths to external dynamic library -- dependencies too. - , unitExtDepFrameworks :: [String] + , unitExtDepFrameworks :: [ST.ShortText] -- ^ Names of the external MacOS frameworks that this unit depends on. - , unitExtDepFrameworkDirs :: [FilePath] + , unitExtDepFrameworkDirs :: [FilePathST] -- ^ Directories containing MacOS frameworks that this unit depends -- on. - , unitLinkerOptions :: [String] + , unitLinkerOptions :: [ST.ShortText] -- ^ Linker (e.g. ld) command line options - , unitCcOptions :: [String] + , unitCcOptions :: [ST.ShortText] -- ^ C compiler options that needs to be passed to the C compiler when we -- compile some C code against this unit. - , unitIncludes :: [String] + , unitIncludes :: [ST.ShortText] -- ^ C header files that are required by this unit (provided by this unit -- or external) - , unitIncludeDirs :: [FilePath] + , unitIncludeDirs :: [FilePathST] -- ^ Directories containing C header files that this unit depends -- on. - , unitHaddockInterfaces :: [FilePath] + , unitHaddockInterfaces :: [FilePathST] -- ^ Paths to Haddock interface files for this unit - , unitHaddockHTMLs :: [FilePath] + , unitHaddockHTMLs :: [FilePathST] -- ^ Paths to Haddock directories containing HTML files , unitExposedModules :: [(modulename, Maybe mod)] @@ -242,6 +243,8 @@ } deriving (Eq, Show) +type FilePathST = ST.ShortText + -- | Convert between GenericUnitInfo instances mapGenericUnitInfo :: (uid1 -> uid2) @@ -646,12 +649,12 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option). -mkMungePathUrl :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath) +mkMungePathUrl :: FilePathST -> FilePathST -> (FilePathST -> FilePathST, FilePathST -> FilePathST) mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) where munge_path p - | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' - | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | Just p' <- stripVarPrefix "${pkgroot}" p = mappend pkgroot p' + | Just p' <- stripVarPrefix "$topdir" p = mappend top_dir p' | otherwise = p munge_url p @@ -659,20 +662,19 @@ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath - (r : -- We need to drop a leading "/" or "\\" - -- if there is one: - dropWhile (all isPathSeparator) - (FilePath.splitDirectories p)) + toUrlPath r p = mconcat $ "file:///" : (intersperse "/" (r : (splitDirectories p))) + -- URLs always use posix style '/' separators + -- We need to drop a leading "/" or "\\" if there is one: + splitDirectories :: FilePathST -> [FilePathST] + splitDirectories p = filter (not . ST.null) $ ST.splitFilePath p + -- We could drop the separator here, and then use above. However, -- by leaving it in and using ++ we keep the same path separator -- rather than letting FilePath change it to use \ as the separator - stripVarPrefix var path = case stripPrefix var path of - Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs + stripVarPrefix var path = case ST.stripPrefix var path of + Just "" -> Just "" + Just cs | isPathSeparator (ST.head cs) -> Just cs _ -> Nothing @@ -684,7 +686,7 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option). -mungeUnitInfoPaths :: FilePath -> FilePath -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f +mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f mungeUnitInfoPaths top_dir pkgroot pkg = -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs pkg diff --git a/GHC/Utils/Encoding.hs b/GHC/Utils/Encoding.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Encoding.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# 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. + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module GHC.Utils.Encoding ( + -- * UTF-8 + utf8DecodeCharAddr#, + utf8PrevChar, + utf8CharStart, + utf8DecodeChar, + utf8DecodeByteString, + utf8UnconsByteString, + utf8DecodeShortByteString, + utf8CompareShortByteString, + utf8DecodeStringLazy, + utf8EncodeChar, + utf8EncodeString, + utf8EncodeStringPtr, + utf8EncodeShortByteString, + utf8EncodedLength, + countUTF8Chars, + + -- * Z-encoding + zEncodeString, + zDecodeString, + + -- * Base62-encoding + toBase62, + toBase62Padded + ) where + +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 + +-- ----------------------------------------------------------------------------- +-- Note [Z-Encoding] +-- ~~~~~~~~~~~~~~~~~ + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +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 + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || 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 + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +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 + 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 + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + 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) + + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ + +Note [Base 62 encoding 128-bit integers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of base-62 encoding a single 128-bit integer +(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +(2 * ceil(10.75) characters). Luckily for us, it's the same number of +characters! +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62Padded :: Word64 -> String +toBase62Padded w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = toBase62 w + +toBase62 :: Word64 -> String +toBase62 w = showIntAtBase 62 represent w "" + where + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error "represent (base 62): impossible!" diff --git a/GHC/Version.hs b/GHC/Version.hs --- a/GHC/Version.hs +++ b/GHC/Version.hs @@ -3,13 +3,13 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "b085d34b3dd036ebcb85e5dc1b07d2b5bdbedbb7" +cProjectGitCommitId = "82e6bf12786908ccda643dd1dceb42abcc97290c" cProjectVersion :: String -cProjectVersion = "9.0.1" +cProjectVersion = "9.2.1" cProjectVersionInt :: String -cProjectVersionInt = "900" +cProjectVersionInt = "902" cProjectPatchLevel :: String cProjectPatchLevel = "1" diff --git a/ghc-boot.cabal b/ghc-boot.cabal --- a/ghc-boot.cabal +++ b/ghc-boot.cabal @@ -1,10 +1,12 @@ +cabal-version: 3.0 + -- WARNING: ghc-boot.cabal is automatically generated from ghc-boot.cabal.in by -- ../../configure. Make sure you are editing ghc-boot.cabal.in, not -- ghc-boot.cabal. name: ghc-boot -version: 9.0.1 -license: BSD3 +version: 9.2.1 +license: BSD-3-Clause license-file: LICENSE category: GHC maintainer: ghc-devs@haskell.org @@ -22,7 +24,6 @@ The package database format and this library are constructed in such a way that while ghc-pkg depends on Cabal, the GHC library and program do not have to depend on Cabal. -cabal-version: >=1.22 build-type: Simple extra-source-files: changelog.md @@ -38,27 +39,38 @@ exposed-modules: GHC.BaseDir + GHC.Data.ShortText + GHC.Data.SizedSeq + GHC.Utils.Encoding GHC.LanguageExtensions GHC.Unit.Database GHC.Serialized GHC.ForeignSrcLang GHC.HandleEncoding - GHC.Platform + GHC.Platform.ArchOS GHC.Platform.Host - GHC.Settings.Platform 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. + reexported-modules: + GHC.LanguageExtensions.Type + , GHC.ForeignSrcLang.Type + , GHC.Lexeme + -- but done by Hadrian -- autogen-modules: -- GHC.Version -- GHC.Platform.Host - build-depends: base >= 4.7 && < 4.16, + build-depends: base >= 4.7 && < 4.17, binary == 0.8.*, - bytestring == 0.10.*, + bytestring >= 0.10 && < 0.12, containers >= 0.5 && < 0.7, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5, - ghc-boot-th == 9.0.1 + deepseq >= 1.4 && < 1.5, + ghc-boot-th == 9.2.1