ghc-boot 9.0.1 → 9.14.1
raw patch · 16 files changed
Files
- GHC/BaseDir.hs +27/−15
- GHC/Data/ShortText.hs +134/−0
- GHC/Data/SizedSeq.hs +51/−0
- GHC/HandleEncoding.hs +2/−2
- GHC/Platform.hs +0/−362
- GHC/Platform/Host.hs +0/−15
- GHC/Serialized.hs +4/−0
- GHC/Settings/Platform.hs +0/−99
- GHC/Settings/Utils.hs +64/−0
- GHC/UniqueSubdir.hs +5/−9
- GHC/Unit/Database.hs +62/−41
- GHC/Utils/Encoding.hs +287/−0
- GHC/Utils/Encoding/UTF8.hs +100/−0
- GHC/Version.hs +0/−21
- Setup.hs +120/−0
- ghc-boot.cabal +54/−14
GHC/BaseDir.hs view
@@ -2,7 +2,6 @@ -- | Note [Base Dir] -- ~~~~~~~~~~~~~~~~~--- -- GHC's base directory or top directory containers miscellaneous settings and -- the package database. The main compiler of course needs this directory to -- read those settings and read and write packages. ghc-pkg uses it to find the@@ -12,18 +11,22 @@ -- will expand `${top_dir}` inside strings so GHC doesn't need to know it's on -- 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?] -import Data.List+import Data.List (stripPrefix)+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)+#if !defined(openbsd_HOST_OS)+import System.Environment (executablePath)+#else import System.Environment (getExecutablePath) #endif @@ -37,22 +40,30 @@ expandPathVar :: String -> FilePath -> String -> String expandPathVar var value str | Just str' <- stripPrefix ('$':var) str- , null str' || isPathSeparator (head str')+ , maybe True isPathSeparator (listToMaybe str') = value ++ expandPathVar var value str' expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] +#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)+#else -- on unix, this is a bit more confusing. -- The layout right now is something like --@@ -64,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
@@ -0,0 +1,134 @@+{-# 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+-- 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 solution.+-- |+-- 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.+--+-- /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+ ShortText(..),+ -- ** Conversion to and from String+ singleton,+ 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 = utf8CountCharsShortByteString (contents st)++-- | /O(1)/ Returns the length of the 'ShortText' in bytes.+byteLength :: ShortText -> Int+byteLength st = SBS.length $ contents st++-- | /O(n)/ Convert a 'String' into a 'ShortText'.+pack :: String -> ShortText+pack s = ShortText $ utf8EncodeShortByteString s++-- | Create a singleton+singleton :: Char -> ShortText+singleton s = pack [s]++-- | /O(n)/ Convert a 'ShortText' into a 'String'.+unpack :: ShortText -> String+unpack st = utf8DecodeShortByteString $ contents st++-- | /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+ | hd:_ <- unpack st+ = hd+ | otherwise+ = error "head: Empty ShortText"++-- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of+-- the second iff the first is its prefix, and otherwise Nothing.+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 <length of prefix> 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
+ GHC/Data/SizedSeq.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-}+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 GHC.Generics++#if ! MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif++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)++-- NB, important this is eta-expand so that foldl' is inlined.+addListToSS :: SizedSeq a -> [a] -> SizedSeq a+addListToSS s xs = foldl' addToSS s xs++ssElts :: SizedSeq a -> [a]+ssElts (SizedSeq _ r_xs) = reverse r_xs++sizeSS :: SizedSeq a -> Word+sizeSS (SizedSeq n _) = n
GHC/HandleEncoding.hs view
@@ -10,8 +10,8 @@ -- GHC produces output regardless of OS. configureHandleEncoding :: IO () configureHandleEncoding = do- env <- getEnvironment- case lookup "GHC_CHARENC" env of+ mb_val <- lookupEnv "GHC_CHARENC"+ case mb_val of Just "UTF-8" -> do hSetEncoding stdout utf8 hSetEncoding stderr utf8
− GHC/Platform.hs
@@ -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)-
− GHC/Platform/Host.hs
@@ -1,15 +0,0 @@-module GHC.Platform.Host where--import GHC.Platform--cHostPlatformArch :: Arch-cHostPlatformArch = ArchX86_64--cHostPlatformOS :: OS-cHostPlatformOS = OSLinux--cHostPlatformMini :: PlatformMini-cHostPlatformMini = PlatformMini- { platformMini_arch = cHostPlatformArch- , platformMini_os = cHostPlatformOS- }
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/Platform.hs
@@ -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
GHC/Settings/Utils.hs view
@@ -3,7 +3,13 @@ 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+import System.FilePath+ maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of [(x, "")] -> Just x@@ -13,3 +19,61 @@ 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"++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+ :: 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
GHC/UniqueSubdir.hs view
@@ -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
GHC/Unit/Database.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -82,19 +83,24 @@ 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+#if !defined(mingw32_HOST_OS)+import Data.Bits ((.|.))+import System.Posix.Files+import System.Posix.Types (FileMode)+#endif 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+type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule -- | Information about an unit (a unit is an installed module library). --@@ -104,14 +110,16 @@ -- Some types are left as parameters to be instantiated differently in ghc-pkg -- and in ghc itself. ---data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo+data GenericUnitInfo srcpkgid srcpkgname uid modulename mod = GenericUnitInfo { unitId :: uid -- ^ Unique unit identifier that is used during compilation (e.g. to -- generate symbols). - , unitInstanceOf :: compid+ , unitInstanceOf :: uid -- ^ Identifier of an indefinite unit (i.e. with module holes) that this -- unit is an instance of.+ --+ -- For non instantiated units, unitInstanceOf=unitId , unitInstantiations :: [(modulename, mod)] -- ^ How this unit instantiates some of its module holes. Map hole module@@ -142,28 +150,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 +182,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,19 +250,20 @@ } deriving (Eq, Show) +type FilePathST = ST.ShortText+ -- | Convert between GenericUnitInfo instances mapGenericUnitInfo :: (uid1 -> uid2)- -> (cid1 -> cid2) -> (srcpkg1 -> srcpkg2) -> (srcpkgname1 -> srcpkgname2) -> (modname1 -> modname2) -> (mod1 -> mod2)- -> (GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1- -> GenericUnitInfo cid2 srcpkg2 srcpkgname2 uid2 modname2 mod2)-mapGenericUnitInfo fuid fcid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) =+ -> (GenericUnitInfo srcpkg1 srcpkgname1 uid1 modname1 mod1+ -> GenericUnitInfo srcpkg2 srcpkgname2 uid2 modname2 mod2)+mapGenericUnitInfo fuid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) = g { unitId = fuid unitId- , unitInstanceOf = fcid unitInstanceOf+ , unitInstanceOf = fuid unitInstanceOf , unitInstantiations = fmap (bimap fmodname fmod) unitInstantiations , unitPackageId = fsrcpkg unitPackageId , unitPackageName = fsrcpkgname unitPackageName@@ -405,8 +414,14 @@ -- | Write the whole of the package DB, both parts. -- writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()-writePackageDb file ghcPkgs ghcPkgPart =+writePackageDb file ghcPkgs ghcPkgPart = do writeFileAtomic file (runPut putDbForGhcPkg)+#if !defined(mingw32_HOST_OS)+ addFileMode file 0o444+ -- ^ In case the current umask is too restrictive force all read bits to+ -- allow access.+#endif+ return () where putDbForGhcPkg = do putHeader@@ -418,6 +433,13 @@ ghcPartLen = fromIntegral (BS.Lazy.length ghcPart) ghcPart = encode ghcPkgs +#if !defined(mingw32_HOST_OS)+addFileMode :: FilePath -> FileMode -> IO ()+addFileMode file m = do+ o <- fileMode <$> getFileStatus file+ setFileMode file (m .|. o)+#endif+ getHeader :: Get (Word32, Word32) getHeader = do magic <- getByteString (BS.length headerMagic)@@ -646,12 +668,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 +681,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 +705,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 -> GenericUnitInfo a b c d e mungeUnitInfoPaths top_dir pkgroot pkg = -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs pkg
+ GHC/Utils/Encoding.hs view
@@ -0,0 +1,287 @@+{-# 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+-- 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+ module GHC.Utils.Encoding.UTF8,++ -- * Z-encoding+ UserString,+ EncodedString,+ zEncodeString,+ zDecodeString,++ -- * Base62-encoding+ toBase62,+ toBase62Padded+ ) where++import Prelude++import Foreign+import Data.Char+import qualified Data.Char as Char+import Numeric++import GHC.Utils.Encoding.UTF8++-- -----------------------------------------------------------------------------+-- 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+ (##) Z0H unboxed 0-tuple+ (#,,,,#) Z5H unboxed 5-tuple+-}++type UserString = String -- As the user typed it+type EncodedString = String -- Encoded form+++zEncodeString :: UserString -> EncodedString+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+unencodedChar c = c >= 'a' && c <= 'z'+ || c >= 'A' && c <= 'Z'+ || c >= '0' && c <= '9'++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' : case hex_str of+ hd : _+ | isDigit hd -> hex_str+ _ -> '0' : hex_str+ where hex_str = showHex (ord c) "U"+ -- ToDo: we could improve the encoding here in various ways.+ -- eg. strings of unicode characters come out as 'z1234Uz5678U', we+ -- 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 n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest+ go n other = error ("decode_tuple: " ++ show n ++ ' ':other)++{-+************************************************************************+* *+ 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!"
+ GHC/Utils/Encoding/UTF8.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-}+{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected. This module used to live in the `ghc`+-- package but has been moved to `ghc-boot` because the definition+-- of the package database (needed in both ghc and in ghc-pkg) lives in+-- `ghc-boot` and uses ShortText, which in turn depends on this module.++-- | Simple, non-streaming 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+-- overview.+--+module GHC.Utils.Encoding.UTF8+ ( -- * Decoding single characters+ utf8DecodeCharAddr#+ , utf8DecodeCharPtr+ , utf8DecodeCharByteArray#+ , utf8PrevChar+ , utf8CharStart+ , utf8UnconsByteString+ -- * Decoding strings+ , utf8DecodeByteString+ , utf8DecodeShortByteString+ , utf8DecodeForeignPtr+ , utf8DecodeByteArray#+ -- * Counting characters+ , utf8CountCharsShortByteString+ , utf8CountCharsByteArray#+ -- * Comparison+ , utf8CompareByteArray#+ , utf8CompareShortByteString+ -- * Encoding strings+ , utf8EncodeByteArray#+ , utf8EncodePtr+ , utf8EncodeByteString+ , utf8EncodeShortByteString+ , utf8EncodedLength+ ) where+++import Prelude++import Foreign+import GHC.IO+import GHC.Encoding.UTF8++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import Data.ByteString.Short.Internal (ShortByteString(..))++-- | Find the start of the codepoint preceding the codepoint at the given+-- 'Ptr'. This is undefined if there is no previous valid codepoint.+utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)+utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))++-- | Find the start of the codepoint at the given 'Ptr'. This is undefined if+-- there is no previous valid codepoint.+utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)+utf8CharStart p = go p+ where go p = do w <- peek p+ if w >= 0x80 && w < 0xC0+ then go (p `plusPtr` (-1))+ else return p++utf8CountCharsShortByteString :: ShortByteString -> Int+utf8CountCharsShortByteString (SBS ba) = utf8CountCharsByteArray# ba++utf8DecodeShortByteString :: ShortByteString -> [Char]+utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba#++-- | Decode a 'ByteString' containing a UTF-8 string.+utf8DecodeByteString :: ByteString -> [Char]+utf8DecodeByteString (BS.PS fptr offset len)+ = utf8DecodeForeignPtr fptr offset len++utf8EncodeShortByteString :: String -> ShortByteString+utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str)++-- | Encode a 'String' into a 'ByteString'.+utf8EncodeByteString :: String -> ByteString+utf8EncodeByteString s =+ unsafePerformIO $ do+ let len = utf8EncodedLength s+ buf <- mallocForeignPtrBytes len+ withForeignPtr buf $ \ptr -> do+ utf8EncodePtr ptr s+ pure (BS.fromForeignPtr buf 0 len)++utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)+utf8UnconsByteString (BS.PS _ _ 0) = Nothing+utf8UnconsByteString (BS.PS fptr offset len)+ = unsafeDupablePerformIO $+ withForeignPtr fptr $ \ptr -> do+ let (c,n) = utf8DecodeCharPtr (ptr `plusPtr` offset)+ return $ Just (c, BS.PS fptr (offset + n) (len - n))++utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering+utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2
− GHC/Version.hs
@@ -1,21 +0,0 @@-module GHC.Version where--import Prelude -- See Note [Why do we import Prelude here?]--cProjectGitCommitId :: String-cProjectGitCommitId = "b085d34b3dd036ebcb85e5dc1b07d2b5bdbedbb7"--cProjectVersion :: String-cProjectVersion = "9.0.1"--cProjectVersionInt :: String-cProjectVersionInt = "900"--cProjectPatchLevel :: String-cProjectPatchLevel = "1"--cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "1"--cProjectPatchLevel2 :: String-cProjectPatchLevel2 = ""
+ Setup.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+module Main where++import Distribution.Simple+import Distribution.Simple.BuildPaths+import Distribution.Types.LocalBuildInfo+import Distribution.Verbosity+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Simple.Setup++import System.IO+import System.Directory+import System.FilePath+import System.Environment+import Control.Monad+import Data.Char+import GHC.ResponseFile++main :: IO ()+main = defaultMainWithHooks ghcHooks+ where+ ghcHooks = simpleUserHooks+ { postConf = \args cfg pd lbi -> do+ let verbosity = fromFlagOrDefault minBound (configVerbosity cfg)+ ghcAutogen verbosity lbi+ postConf simpleUserHooks args cfg pd lbi+ }++ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()+ghcAutogen verbosity lbi@LocalBuildInfo{..} = do+ -- Get compiler/ root directory from the cabal file+ let Just compilerRoot = takeDirectory <$> pkgDescrFile++ let platformHostFile = "GHC/Platform/Host.hs"+ platformHostPath = autogenPackageModulesDir lbi </> platformHostFile+ ghcVersionFile = "GHC/Version.hs"+ ghcVersionPath = autogenPackageModulesDir lbi </> ghcVersionFile++ -- Get compiler settings+ settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case+ Just settings -> pure $ Left $ read settings+ Nothing -> do+ (ghc,withPrograms) <- requireProgram normal ghcProgram withPrograms+ Right . read <$> getProgramOutput normal ghc ["--info"]++ -- Write GHC.Platform.Host+ createDirectoryIfMissingVerbose verbosity True (takeDirectory platformHostPath)+ rewriteFileEx verbosity platformHostPath (generatePlatformHostHs settings)++ -- Write GHC.Version+ createDirectoryIfMissingVerbose verbosity True (takeDirectory ghcVersionPath)+ rewriteFileEx verbosity ghcVersionPath (generateVersionHs settings)++-- | Takes either a list of hadrian generated settings, or a list of settings from ghc --info,+-- and keys in both lists, and looks up the value in the appropriate list+getSetting :: Either [(String,String)] [(String,String)] -> String -> String -> Either String String+getSetting settings kh kr = case settings of+ Left settings -> go settings kh+ Right settings -> go settings kr+ where+ go settings k = case lookup k settings of+ Nothing -> Left (show k ++ " not found in settings: " ++ show settings)+ Just v -> Right v++generatePlatformHostHs :: Either [(String,String)] [(String,String)] -> String+generatePlatformHostHs settings = either error id $ do+ let getSetting' = getSetting settings+ cHostPlatformArch <- getSetting' "hostPlatformArch" "target arch"+ cHostPlatformOS <- getSetting' "hostPlatformOS" "target os"+ return $ unlines+ [ "module GHC.Platform.Host where"+ , ""+ , "import GHC.Platform.ArchOS"+ , ""+ , "hostPlatformArch :: Arch"+ , "hostPlatformArch = " ++ cHostPlatformArch+ , ""+ , "hostPlatformOS :: OS"+ , "hostPlatformOS = " ++ cHostPlatformOS+ , ""+ , "hostPlatformArchOS :: ArchOS"+ , "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"+ ]++generateVersionHs :: Either [(String,String)] [(String,String)] -> String+generateVersionHs settings = either error id $ do+ let getSetting' = getSetting settings+ cProjectGitCommitId <- getSetting' "cProjectGitCommitId" "Project Git commit id"+ cProjectVersion <- getSetting' "cProjectVersion" "Project version"+ cProjectVersionInt <- getSetting' "cProjectVersionInt" "Project Version Int"++ cProjectPatchLevel <- getSetting' "cProjectPatchLevel" "Project Patch Level"+ cProjectPatchLevel1 <- getSetting' "cProjectPatchLevel1" "Project Patch Level1"+ cProjectPatchLevel2 <- getSetting' "cProjectPatchLevel2" "Project Patch Level2"+ return $ unlines+ [ "module GHC.Version where"+ , ""+ , "import Prelude -- See Note [Why do we import Prelude here?]"+ , ""+ , "cProjectGitCommitId :: String"+ , "cProjectGitCommitId = " ++ show cProjectGitCommitId+ , ""+ , "cProjectVersion :: String"+ , "cProjectVersion = " ++ show cProjectVersion+ , ""+ , "cProjectVersionInt :: String"+ , "cProjectVersionInt = " ++ show cProjectVersionInt+ , ""+ , "cProjectPatchLevel :: String"+ , "cProjectPatchLevel = " ++ show cProjectPatchLevel+ , ""+ , "cProjectPatchLevel1 :: String"+ , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1+ , ""+ , "cProjectPatchLevel2 :: String"+ , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2+ ]
ghc-boot.cabal view
@@ -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.14.1+license: BSD-3-Clause license-file: LICENSE category: GHC maintainer: ghc-devs@haskell.org@@ -22,15 +24,26 @@ 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+build-type: Custom extra-source-files: changelog.md +custom-setup+ 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@@ -38,27 +51,54 @@ exposed-modules: GHC.BaseDir+ GHC.Data.ShortText+ GHC.Data.SizedSeq+ GHC.Utils.Encoding+ GHC.Utils.Encoding.UTF8 GHC.LanguageExtensions GHC.Unit.Database GHC.Serialized GHC.ForeignSrcLang GHC.HandleEncoding- GHC.Platform GHC.Platform.Host- GHC.Settings.Platform GHC.Settings.Utils GHC.UniqueSubdir GHC.Version ++ -- reexport platform modules from ghc-platform+ reexported-modules:+ GHC.Platform.ArchOS+ -- but done by Hadrian- -- autogen-modules:- -- GHC.Version- -- GHC.Platform.Host+ autogen-modules:+ GHC.Version+ GHC.Platform.Host - build-depends: base >= 4.7 && < 4.16,+ build-depends: base >= 4.7 && < 4.23, binary == 0.8.*,- bytestring == 0.10.*,- 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,- ghc-boot-th == 9.0.1+ 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