diff --git a/GHC/BaseDir.hs b/GHC/BaseDir.hs --- a/GHC/BaseDir.hs +++ b/GHC/BaseDir.hs @@ -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 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,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 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,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 diff --git a/GHC/HandleEncoding.hs b/GHC/HandleEncoding.hs --- a/GHC/HandleEncoding.hs +++ b/GHC/HandleEncoding.hs @@ -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 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/Host.hs b/GHC/Platform/Host.hs deleted file mode 100644 --- a/GHC/Platform/Host.hs +++ /dev/null @@ -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 - } diff --git a/GHC/Serialized.hs b/GHC/Serialized.hs --- a/GHC/Serialized.hs +++ b/GHC/Serialized.hs @@ -22,10 +22,14 @@ import Data.Bits import Data.Word ( Word8 ) import Data.Data +import Control.DeepSeq -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8] + +instance NFData Serialized where + rnf (Serialized tr ws) = rnf tr `seq` rnf ws -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized diff --git a/GHC/Settings/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,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 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,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 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,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!" diff --git a/GHC/Utils/Encoding/UTF8.hs b/GHC/Utils/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Encoding/UTF8.hs @@ -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 diff --git a/GHC/Version.hs b/GHC/Version.hs deleted file mode 100644 --- a/GHC/Version.hs +++ /dev/null @@ -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 = "" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 + ] 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.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