ghc-boot 8.8.3 → 9.14.1
raw patch · 13 files changed
Files
- GHC/BaseDir.hs +89/−0
- GHC/Data/ShortText.hs +134/−0
- GHC/Data/SizedSeq.hs +51/−0
- GHC/HandleEncoding.hs +2/−2
- GHC/PackageDb.hs +0/−577
- GHC/Serialized.hs +4/−0
- GHC/Settings/Utils.hs +79/−0
- GHC/UniqueSubdir.hs +22/−0
- GHC/Unit/Database.hs +724/−0
- GHC/Utils/Encoding.hs +287/−0
- GHC/Utils/Encoding/UTF8.hs +100/−0
- Setup.hs +120/−0
- ghc-boot.cabal +72/−16
+ GHC/BaseDir.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}++-- | 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+-- global package database too.+--+-- In the interest of making GHC builds more relocatable, many settings also+-- 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+ ( expandTopDir+ , expandPathVar+ , getBaseDir+ ) where++import Prelude -- See Note [Why do we import Prelude here?]++import Data.List (stripPrefix)+import Data.Maybe (listToMaybe)+import System.FilePath++#if !defined(openbsd_HOST_OS)+import System.Environment (executablePath)+#else+import System.Environment (getExecutablePath)+#endif++-- | Expand occurrences of the @$topdir@ interpolation in a string.+expandTopDir :: FilePath -> String -> String+expandTopDir = expandPathVar "topdir"++-- | @expandPathVar var value str@+--+-- replaces occurrences of variable @$var@ with @value@ in str.+expandPathVar :: String -> FilePath -> String -> String+expandPathVar var value str+ | Just str' <- stripPrefix ('$':var) 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 = 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+#else+-- on unix, this is a bit more confusing.+-- The layout right now is something like+--+-- /bin/ghc-X.Y.Z <- wrapper script (1)+-- /bin/ghc <- symlink to wrapper script (2)+-- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3)+-- /lib/ghc-X.Y.Z <- $topdir (4)+--+-- As such, we first need to find the absolute location to the+-- binary.+--+-- 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 = 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/PackageDb.hs
@@ -1,577 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--------------------------------------------------------------------------------- |--- Module : GHC.PackageDb--- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014------ Maintainer : ghc-devs@haskell.org--- Portability : portable------ This module provides the view of GHC's database of registered packages that--- is shared between GHC the compiler\/library, and the ghc-pkg program. It--- defines the database format that is shared between GHC and ghc-pkg.------ The database format, and this library are constructed so that GHC does not--- have to depend on the Cabal library. The ghc-pkg program acts as the--- gateway between the external package format (which is defined by Cabal) and--- the internal package format which is specialised just for GHC.------ GHC the compiler only needs some of the information which is kept about--- registerd packages, such as module names, various paths etc. On the other--- hand ghc-pkg has to keep all the information from Cabal packages and be able--- to regurgitate it for users and other tools.------ The first trick is that we duplicate some of the information in the package--- database. We essentially keep two versions of the datbase in one file, one--- version used only by ghc-pkg which keeps the full information (using the--- serialised form of the 'InstalledPackageInfo' type defined by the Cabal--- library); and a second version written by ghc-pkg and read by GHC which has--- just the subset of information that GHC needs.------ The second trick is that this module only defines in detail the format of--- the second version -- the bit GHC uses -- and the part managed by ghc-pkg--- is kept in the file but here we treat it as an opaque blob of data. That way--- this library avoids depending on Cabal.----module GHC.PackageDb (- InstalledPackageInfo(..),- DbModule(..),- DbUnitId(..),- BinaryStringRep(..),- DbUnitIdModuleRep(..),- emptyInstalledPackageInfo,- PackageDbLock,- lockPackageDb,- unlockPackageDb,- DbMode(..),- DbOpenMode(..),- isDbOpenReadMode,- readPackageDbForGhc,- readPackageDbForGhcPkg,- writePackageDb- ) where--import Prelude -- See note [Why do we import Prelude here?]-import Data.Version (Version(..))-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS.Char8-import qualified Data.ByteString.Lazy as BS.Lazy-import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)-import qualified Data.Foldable as F-import qualified Data.Traversable as F-import Data.Binary as Bin-import Data.Binary.Put as Bin-import Data.Binary.Get as Bin-import Control.Exception as Exception-import Control.Monad (when)-import System.FilePath-import System.IO-import System.IO.Error-import GHC.IO.Exception (IOErrorType(InappropriateType))-import GHC.IO.Handle.Lock-import System.Directory----- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits--- that GHC is interested in. See Cabal's documentation for a more detailed--- description of all of the fields.----data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod- = InstalledPackageInfo {- unitId :: instunitid,- componentId :: compid,- instantiatedWith :: [(modulename, mod)],- sourcePackageId :: srcpkgid,- packageName :: srcpkgname,- packageVersion :: Version,- sourceLibName :: Maybe srcpkgname,- abiHash :: String,- depends :: [instunitid],- -- | Like 'depends', but each dependency is annotated with the- -- ABI hash we expect the dependency to respect.- abiDepends :: [(instunitid, String)],- importDirs :: [FilePath],- hsLibraries :: [String],- extraLibraries :: [String],- extraGHCiLibraries :: [String],- libraryDirs :: [FilePath],- libraryDynDirs :: [FilePath],- frameworks :: [String],- frameworkDirs :: [FilePath],- ldOptions :: [String],- ccOptions :: [String],- includes :: [String],- includeDirs :: [FilePath],- haddockInterfaces :: [FilePath],- haddockHTMLs :: [FilePath],- exposedModules :: [(modulename, Maybe mod)],- hiddenModules :: [modulename],- indefinite :: Bool,- exposed :: Bool,- trusted :: Bool- }- deriving (Eq, Show)---- | A convenience constraint synonym for common constraints over parameters--- to 'InstalledPackageInfo'.-type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod =- (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,- BinaryStringRep modulename, BinaryStringRep compid,- BinaryStringRep instunitid,- DbUnitIdModuleRep instunitid compid unitid modulename mod)---- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.--- There is only one type class because these types are mutually recursive.--- NB: The functional dependency helps out type inference in cases--- where types would be ambiguous.-class DbUnitIdModuleRep instunitid compid unitid modulename mod- | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid- where- fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod- toDbModule :: mod -> DbModule instunitid compid unitid modulename mod- fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid- toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod---- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.--- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.--- It has phantom type parameters as this is the most convenient way--- to avoid undecidable instances.-data DbModule instunitid compid unitid modulename mod- = DbModule {- dbModuleUnitId :: unitid,- dbModuleName :: modulename- }- | DbModuleVar {- dbModuleVarName :: modulename- }- deriving (Eq, Show)---- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database.--- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.--- It has phantom type parameters as this is the most convenient way--- to avoid undecidable instances.-data DbUnitId instunitid compid unitid modulename mod- = DbUnitId compid [(modulename, mod)]- | DbInstalledUnitId instunitid- deriving (Eq, Show)--class BinaryStringRep a where- fromStringRep :: BS.ByteString -> a- toStringRep :: a -> BS.ByteString--emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g- => InstalledPackageInfo a b c d e f g-emptyInstalledPackageInfo =- InstalledPackageInfo {- unitId = fromStringRep BS.empty,- componentId = fromStringRep BS.empty,- instantiatedWith = [],- sourcePackageId = fromStringRep BS.empty,- packageName = fromStringRep BS.empty,- packageVersion = Version [] [],- sourceLibName = Nothing,- abiHash = "",- depends = [],- abiDepends = [],- importDirs = [],- hsLibraries = [],- extraLibraries = [],- extraGHCiLibraries = [],- libraryDirs = [],- libraryDynDirs = [],- frameworks = [],- frameworkDirs = [],- ldOptions = [],- ccOptions = [],- includes = [],- includeDirs = [],- haddockInterfaces = [],- haddockHTMLs = [],- exposedModules = [],- hiddenModules = [],- indefinite = False,- exposed = False,- trusted = False- }---- | Represents a lock of a package db.-newtype PackageDbLock = PackageDbLock Handle---- | Acquire an exclusive lock related to package DB under given location.-lockPackageDb :: FilePath -> IO PackageDbLock---- | Release the lock related to package DB.-unlockPackageDb :: PackageDbLock -> IO ()---- | Acquire a lock of given type related to package DB under given location.-lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock-lockPackageDbWith mode file = do- -- We are trying to open the lock file and then lock it. Thus the lock file- -- needs to either exist or we need to be able to create it. Ideally we- -- would not assume that the lock file always exists in advance. When we are- -- dealing with a package DB where we have write access then if the lock- -- file does not exist then we can create it by opening the file in- -- read/write mode. On the other hand if we are dealing with a package DB- -- where we do not have write access (e.g. a global DB) then we can only- -- open in read mode, and the lock file had better exist already or we're in- -- trouble. So for global read-only DBs on platforms where we must lock the- -- DB for reading then we will require that the installer/packaging has- -- included the lock file.- --- -- Thus the logic here is to first try opening in read-write mode- -- and if that fails we try read-only (to handle global read-only DBs).- -- If either succeed then lock the file. IO exceptions (other than the first- -- open attempt failing due to the file not existing) simply propagate.- --- -- Note that there is a complexity here which was discovered in #13945: some- -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was- -- opened for write access. We would previously try opening the lockfile for- -- read-only access first, however this failed when run on such filesystems.- -- Consequently, we now try read-write access first, falling back to read-only- -- if we are denied permission (e.g. in the case of a global database).- catchJust- (\e -> if isPermissionError e then Just () else Nothing)- (lockFileOpenIn ReadWriteMode)- (const $ lockFileOpenIn ReadMode)- where- lock = file <.> "lock"-- lockFileOpenIn io_mode = bracketOnError- (openBinaryFile lock io_mode)- hClose- -- If file locking support is not available, ignore the error and proceed- -- normally. Without it the only thing we lose on non-Windows platforms is- -- the ability to safely issue concurrent updates to the same package db.- $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return ()- return $ PackageDbLock hnd--lockPackageDb = lockPackageDbWith ExclusiveLock-unlockPackageDb (PackageDbLock hnd) = do- hUnlock hnd- hClose hnd---- | Mode to open a package db in.-data DbMode = DbReadOnly | DbReadWrite---- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So--- it is like 'Maybe' but with a type argument for the mode to enforce that the--- mode is used consistently.-data DbOpenMode (mode :: DbMode) t where- DbOpenReadOnly :: DbOpenMode 'DbReadOnly t- DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t--deriving instance Functor (DbOpenMode mode)-deriving instance F.Foldable (DbOpenMode mode)-deriving instance F.Traversable (DbOpenMode mode)--isDbOpenReadMode :: DbOpenMode mode t -> Bool-isDbOpenReadMode = \case- DbOpenReadOnly -> True- DbOpenReadWrite{} -> False---- | Read the part of the package DB that GHC is interested in.----readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>- FilePath -> IO [InstalledPackageInfo a b c d e f g]-readPackageDbForGhc file =- decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case- (pkgs, DbOpenReadOnly) -> return pkgs- where- getDbForGhc = do- _version <- getHeader- _ghcPartLen <- get :: Get Word32- ghcPart <- get- -- the next part is for ghc-pkg, but we stop here.- return ghcPart---- | Read the part of the package DB that ghc-pkg is interested in------ Note that the Binary instance for ghc-pkg's representation of packages--- is not defined in this package. This is because ghc-pkg uses Cabal types--- (and Binary instances for these) which this package does not depend on.------ If we open the package db in read only mode, we get its contents. Otherwise--- we additionally receive a PackageDbLock that represents a lock on the--- database, so that we can safely update it later.----readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->- IO (pkgs, DbOpenMode mode PackageDbLock)-readPackageDbForGhcPkg file mode =- decodeFromFile file mode getDbForGhcPkg- where- getDbForGhcPkg = do- _version <- getHeader- -- skip over the ghc part- ghcPartLen <- get :: Get Word32- _ghcPart <- skip (fromIntegral ghcPartLen)- -- the next part is for ghc-pkg- ghcPkgPart <- get- return ghcPkgPart---- | Write the whole of the package DB, both parts.----writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>- FilePath -> [InstalledPackageInfo a b c d e f g] ->- pkgs -> IO ()-writePackageDb file ghcPkgs ghcPkgPart =- writeFileAtomic file (runPut putDbForGhcPkg)- where- putDbForGhcPkg = do- putHeader- put ghcPartLen- putLazyByteString ghcPart- put ghcPkgPart- where- ghcPartLen :: Word32- ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)- ghcPart = encode ghcPkgs--getHeader :: Get (Word32, Word32)-getHeader = do- magic <- getByteString (BS.length headerMagic)- when (magic /= headerMagic) $- fail "not a ghc-pkg db file, wrong file magic number"-- majorVersion <- get :: Get Word32- -- The major version is for incompatible changes-- minorVersion <- get :: Get Word32- -- The minor version is for compatible extensions-- when (majorVersion /= 1) $- fail "unsupported ghc-pkg db format version"- -- If we ever support multiple major versions then we'll have to change- -- this code-- -- The header can be extended without incrementing the major version,- -- we ignore fields we don't know about (currently all).- headerExtraLen <- get :: Get Word32- skip (fromIntegral headerExtraLen)-- return (majorVersion, minorVersion)--putHeader :: Put-putHeader = do- putByteString headerMagic- put majorVersion- put minorVersion- put headerExtraLen- where- majorVersion = 1 :: Word32- minorVersion = 0 :: Word32- headerExtraLen = 0 :: Word32--headerMagic :: BS.ByteString-headerMagic = BS.Char8.pack "\0ghcpkg\0"----- TODO: we may be able to replace the following with utils from the binary--- package in future.---- | Feed a 'Get' decoder with data chunks from a file.----decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->- IO (pkgs, DbOpenMode mode PackageDbLock)-decodeFromFile file mode decoder = case mode of- DbOpenReadOnly -> do- -- When we open the package db in read only mode, there is no need to acquire- -- shared lock on non-Windows platform because we update the database with an- -- atomic rename, so readers will always see the database in a consistent- -- state.-#if defined(mingw32_HOST_OS)- bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do-#endif- (, DbOpenReadOnly) <$> decodeFileContents- DbOpenReadWrite{} -> do- -- When we open the package db in read/write mode, acquire an exclusive lock- -- on the database and return it so we can keep it for the duration of the- -- update.- bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do- (, DbOpenReadWrite lock) <$> decodeFileContents- where- decodeFileContents = withBinaryFile file ReadMode $ \hnd ->- feed hnd (runGetIncremental decoder)-- feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize- if BS.null chunk- then feed hnd (k Nothing)- else feed hnd (k (Just chunk))- feed _ (Done _ _ res) = return res- feed _ (Fail _ _ msg) = ioError err- where- err = mkIOError InappropriateType loc Nothing (Just file)- `ioeSetErrorString` msg- loc = "GHC.PackageDb.readPackageDb"---- Copied from Cabal's Distribution.Simple.Utils.-writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()-writeFileAtomic targetPath content = do- let (targetDir, targetFile) = splitFileName targetPath- Exception.bracketOnError- (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")- (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)- (\(tmpPath, handle) -> do- BS.Lazy.hPut handle content- hClose handle- renameFile tmpPath targetPath)--instance (RepInstalledPackageInfo a b c d e f g) =>- Binary (InstalledPackageInfo a b c d e f g) where- put (InstalledPackageInfo- unitId componentId instantiatedWith sourcePackageId- packageName packageVersion- sourceLibName- abiHash depends abiDepends importDirs- hsLibraries extraLibraries extraGHCiLibraries- libraryDirs libraryDynDirs- frameworks frameworkDirs- ldOptions ccOptions- includes includeDirs- haddockInterfaces haddockHTMLs- exposedModules hiddenModules- indefinite exposed trusted) = do- put (toStringRep sourcePackageId)- put (toStringRep packageName)- put packageVersion- put (fmap toStringRep sourceLibName)- put (toStringRep unitId)- put (toStringRep componentId)- put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))- instantiatedWith)- put abiHash- put (map toStringRep depends)- put (map (\(k,v) -> (toStringRep k, v)) abiDepends)- put importDirs- put hsLibraries- put extraLibraries- put extraGHCiLibraries- put libraryDirs- put libraryDynDirs- put frameworks- put frameworkDirs- put ldOptions- put ccOptions- put includes- put includeDirs- put haddockInterfaces- put haddockHTMLs- put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))- exposedModules)- put (map toStringRep hiddenModules)- put indefinite- put exposed- put trusted-- get = do- sourcePackageId <- get- packageName <- get- packageVersion <- get- sourceLibName <- get- unitId <- get- componentId <- get- instantiatedWith <- get- abiHash <- get- depends <- get- abiDepends <- get- importDirs <- get- hsLibraries <- get- extraLibraries <- get- extraGHCiLibraries <- get- libraryDirs <- get- libraryDynDirs <- get- frameworks <- get- frameworkDirs <- get- ldOptions <- get- ccOptions <- get- includes <- get- includeDirs <- get- haddockInterfaces <- get- haddockHTMLs <- get- exposedModules <- get- hiddenModules <- get- indefinite <- get- exposed <- get- trusted <- get- return (InstalledPackageInfo- (fromStringRep unitId)- (fromStringRep componentId)- (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))- instantiatedWith)- (fromStringRep sourcePackageId)- (fromStringRep packageName) packageVersion- (fmap fromStringRep sourceLibName)- abiHash- (map fromStringRep depends)- (map (\(k,v) -> (fromStringRep k, v)) abiDepends)- importDirs- hsLibraries extraLibraries extraGHCiLibraries- libraryDirs libraryDynDirs- frameworks frameworkDirs- ldOptions ccOptions- includes includeDirs- haddockInterfaces haddockHTMLs- (map (\(mod_name, mb_mod) ->- (fromStringRep mod_name, fmap fromDbModule mb_mod))- exposedModules)- (map fromStringRep hiddenModules)- indefinite exposed trusted)--instance (BinaryStringRep modulename, BinaryStringRep compid,- BinaryStringRep instunitid,- DbUnitIdModuleRep instunitid compid unitid modulename mod) =>- Binary (DbModule instunitid compid unitid modulename mod) where- put (DbModule dbModuleUnitId dbModuleName) = do- putWord8 0- put (toDbUnitId dbModuleUnitId)- put (toStringRep dbModuleName)- put (DbModuleVar dbModuleVarName) = do- putWord8 1- put (toStringRep dbModuleVarName)- get = do- b <- getWord8- case b of- 0 -> do dbModuleUnitId <- get- dbModuleName <- get- return (DbModule (fromDbUnitId dbModuleUnitId)- (fromStringRep dbModuleName))- _ -> do dbModuleVarName <- get- return (DbModuleVar (fromStringRep dbModuleVarName))--instance (BinaryStringRep modulename, BinaryStringRep compid,- BinaryStringRep instunitid,- DbUnitIdModuleRep instunitid compid unitid modulename mod) =>- Binary (DbUnitId instunitid compid unitid modulename mod) where- put (DbInstalledUnitId instunitid) = do- putWord8 0- put (toStringRep instunitid)- put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do- putWord8 1- put (toStringRep dbUnitIdComponentId)- put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)- get = do- b <- getWord8- case b of- 0 -> do- instunitid <- get- return (DbInstalledUnitId (fromStringRep instunitid))- _ -> do- dbUnitIdComponentId <- get- dbUnitIdInsts <- get- return (DbUnitId- (fromStringRep dbUnitIdComponentId)- (map (\(mod_name, mod) -> ( fromStringRep mod_name- , fromDbModule mod))- dbUnitIdInsts))
GHC/Serialized.hs view
@@ -22,10 +22,14 @@ import Data.Bits import Data.Word ( Word8 ) import Data.Data+import Control.DeepSeq -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8]++instance NFData Serialized where+ rnf (Serialized tr ws) = rnf tr `seq` rnf ws -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
+ GHC/Settings/Utils.hs view
@@ -0,0 +1,79 @@+module GHC.Settings.Utils where++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+ _ -> Nothing++maybeReadFuzzy :: Read a => String -> Maybe a+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
@@ -0,0 +1,22 @@+module GHC.UniqueSubdir+ ( uniqueSubdir+ ) where++import Prelude -- See Note [Why do we import Prelude here?]++import Data.List (intercalate)++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.+uniqueSubdir :: ArchOS -> FilePath+uniqueSubdir (ArchOS arch os) = intercalate "-"+ [ stringEncodeArch arch+ , stringEncodeOS os+ , cProjectVersion+ ]+ -- NB: This functionality is reimplemented in Cabal, so if you+ -- change it, be sure to update Cabal.+ -- TODO make Cabal use this now that it is in ghc-boot.
+ GHC/Unit/Database.hs view
@@ -0,0 +1,724 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : GHC.Unit.Database+-- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014+--+-- Maintainer : ghc-devs@haskell.org+-- Portability : portable+--+-- This module provides the view of GHC's database of registered packages that+-- is shared between GHC the compiler\/library, and the ghc-pkg program. It+-- defines the database format that is shared between GHC and ghc-pkg.+--+-- The database format, and this library are constructed so that GHC does not+-- have to depend on the Cabal library. The ghc-pkg program acts as the+-- gateway between the external package format (which is defined by Cabal) and+-- the internal package format which is specialised just for GHC.+--+-- GHC the compiler only needs some of the information which is kept about+-- registered packages, such as module names, various paths etc. On the other+-- hand ghc-pkg has to keep all the information from Cabal packages and be able+-- to regurgitate it for users and other tools.+--+-- The first trick is that we duplicate some of the information in the package+-- database. We essentially keep two versions of the database in one file, one+-- version used only by ghc-pkg which keeps the full information (using the+-- serialised form of the 'InstalledPackageInfo' type defined by the Cabal+-- library); and a second version written by ghc-pkg and read by GHC which has+-- just the subset of information that GHC needs.+--+-- The second trick is that this module only defines in detail the format of+-- the second version -- the bit GHC uses -- and the part managed by ghc-pkg+-- is kept in the file but here we treat it as an opaque blob of data. That way+-- this library avoids depending on Cabal.+--+module GHC.Unit.Database+ ( GenericUnitInfo(..)+ , type DbUnitInfo+ , DbModule (..)+ , DbInstUnitId (..)+ , mapGenericUnitInfo+ -- * Read and write+ , DbMode(..)+ , DbOpenMode(..)+ , isDbOpenReadMode+ , readPackageDbForGhc+ , readPackageDbForGhcPkg+ , writePackageDb+ -- * Locking+ , PackageDbLock+ , lockPackageDb+ , unlockPackageDb+ -- * Misc+ , mkMungePathUrl+ , mungeUnitInfoPaths+ )+where++import Prelude -- See note [Why do we import Prelude here?]+import Data.Version (Version(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Lazy as BS.Lazy+import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)+import qualified Data.Foldable as F+import qualified Data.Traversable as F+import Data.Bifunctor+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+#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++-- | @ghc-boot@'s UnitInfo, serialized to the database.+type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule++-- | Information about an unit (a unit is an installed module library).+--+-- This is a subset of Cabal's 'InstalledPackageInfo', with just the bits+-- that GHC is interested in.+--+-- Some types are left as parameters to be instantiated differently in ghc-pkg+-- and in ghc itself.+--+data GenericUnitInfo srcpkgid srcpkgname uid modulename mod = GenericUnitInfo+ { unitId :: uid+ -- ^ Unique unit identifier that is used during compilation (e.g. to+ -- generate symbols).++ , 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+ -- names to actual module++ , unitPackageId :: srcpkgid+ -- ^ Source package identifier.+ --+ -- Cabal instantiates this with Distribution.Types.PackageId.PackageId+ -- type which only contains the source package name and version. Notice+ -- that it doesn't contain the Hackage revision, nor any kind of hash.++ , unitPackageName :: srcpkgname+ -- ^ Source package name++ , unitPackageVersion :: Version+ -- ^ Source package version++ , unitComponentName :: Maybe srcpkgname+ -- ^ Name of the component.+ --+ -- Cabal supports more than one components (libraries, executables,+ -- testsuites) in the same package. Each component has a name except the+ -- default one (that can only be a library component) for which we use+ -- "Nothing".+ --+ -- GHC only deals with "library" components as they are the only kind of+ -- components that can be registered in a database and used by other+ -- modules.++ , 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, ST.ShortText)]+ -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash+ -- we expect the dependency to respect.++ , unitImportDirs :: [FilePathST]+ -- ^ Directories containing module interfaces++ , unitLibraries :: [ST.ShortText]+ -- ^ Names of the Haskell libraries provided by this unit++ , unitExtDepLibsSys :: [ST.ShortText]+ -- ^ Names of the external system libraries that this unit depends on. See+ -- also `unitExtDepLibsGhc` field.++ , 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+ -- of libraries when using GHC's. Examples include: libs that are actually+ -- gnu ld scripts, and the possibility that the .a libs do not exactly+ -- match the .so/.dll equivalents.+ --+ -- If this field is set, then we use that instead of the+ -- `unitExtDepLibsSys` field.++ , 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 :: [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 :: [ST.ShortText]+ -- ^ Names of the external MacOS frameworks that this unit depends on.++ , unitExtDepFrameworkDirs :: [FilePathST]+ -- ^ Directories containing MacOS frameworks that this unit depends+ -- on.++ , unitLinkerOptions :: [ST.ShortText]+ -- ^ Linker (e.g. ld) command line options++ , 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 :: [ST.ShortText]+ -- ^ C header files that are required by this unit (provided by this unit+ -- or external)++ , unitIncludeDirs :: [FilePathST]+ -- ^ Directories containing C header files that this unit depends+ -- on.++ , unitHaddockInterfaces :: [FilePathST]+ -- ^ Paths to Haddock interface files for this unit++ , unitHaddockHTMLs :: [FilePathST]+ -- ^ Paths to Haddock directories containing HTML files++ , unitExposedModules :: [(modulename, Maybe mod)]+ -- ^ Modules exposed by the unit.+ --+ -- A module can be re-exported from another package. In this case, we+ -- indicate the module origin in the second parameter.++ , unitHiddenModules :: [modulename]+ -- ^ Hidden modules.+ --+ -- These are useful for error reporting (e.g. if a hidden module is+ -- imported)++ , unitIsIndefinite :: Bool+ -- ^ True if this unit has some module holes that need to be instantiated+ -- with real modules to make the unit usable (a.k.a. Backpack).++ , unitIsExposed :: Bool+ -- ^ True if the unit is exposed. A unit could be installed in a database+ -- by "disabled" by not being exposed.++ , unitIsTrusted :: Bool+ -- ^ True if the unit is trusted (cf Safe Haskell)++ }+ deriving (Eq, Show)++type FilePathST = ST.ShortText++-- | Convert between GenericUnitInfo instances+mapGenericUnitInfo+ :: (uid1 -> uid2)+ -> (srcpkg1 -> srcpkg2)+ -> (srcpkgname1 -> srcpkgname2)+ -> (modname1 -> modname2)+ -> (mod1 -> mod2)+ -> (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 = fuid unitInstanceOf+ , unitInstantiations = fmap (bimap fmodname fmod) unitInstantiations+ , unitPackageId = fsrcpkg unitPackageId+ , unitPackageName = fsrcpkgname unitPackageName+ , unitComponentName = fmap fsrcpkgname unitComponentName+ , unitDepends = fmap fuid unitDepends+ , unitAbiDepends = fmap (first fuid) unitAbiDepends+ , unitExposedModules = fmap (bimap fmodname (fmap fmod)) unitExposedModules+ , unitHiddenModules = fmap fmodname unitHiddenModules+ }++-- | @ghc-boot@'s 'Module', serialized to the database.+data DbModule+ = DbModule+ { dbModuleUnitId :: DbInstUnitId+ , dbModuleName :: BS.ByteString+ }+ | DbModuleVar+ { dbModuleVarName :: BS.ByteString+ }+ deriving (Eq, Show)++-- | @ghc-boot@'s instantiated unit id, serialized to the database.+data DbInstUnitId++ -- | Instantiated unit+ = DbInstUnitId+ BS.ByteString -- component id+ [(BS.ByteString, DbModule)] -- instantiations: [(modulename,module)]++ -- | Uninstantiated unit+ | DbUnitId+ BS.ByteString -- unit id+ deriving (Eq, Show)++-- | Represents a lock of a package db.+newtype PackageDbLock = PackageDbLock Handle++-- | Acquire an exclusive lock related to package DB under given location.+lockPackageDb :: FilePath -> IO PackageDbLock++-- | Release the lock related to package DB.+unlockPackageDb :: PackageDbLock -> IO ()++-- | Acquire a lock of given type related to package DB under given location.+lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock+lockPackageDbWith mode file = do+ -- We are trying to open the lock file and then lock it. Thus the lock file+ -- needs to either exist or we need to be able to create it. Ideally we+ -- would not assume that the lock file always exists in advance. When we are+ -- dealing with a package DB where we have write access then if the lock+ -- file does not exist then we can create it by opening the file in+ -- read/write mode. On the other hand if we are dealing with a package DB+ -- where we do not have write access (e.g. a global DB) then we can only+ -- open in read mode, and the lock file had better exist already or we're in+ -- trouble. So for global read-only DBs on platforms where we must lock the+ -- DB for reading then we will require that the installer/packaging has+ -- included the lock file.+ --+ -- Thus the logic here is to first try opening in read-write mode+ -- and if that fails we try read-only (to handle global read-only DBs).+ -- If either succeed then lock the file. IO exceptions (other than the first+ -- open attempt failing due to the file not existing) simply propagate.+ --+ -- Note that there is a complexity here which was discovered in #13945: some+ -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was+ -- opened for write access. We would previously try opening the lockfile for+ -- read-only access first, however this failed when run on such filesystems.+ -- Consequently, we now try read-write access first, falling back to read-only+ -- if we are denied permission (e.g. in the case of a global database).+ catchJust+ (\e -> if isPermissionError e then Just () else Nothing)+ (lockFileOpenIn ReadWriteMode)+ (const $ lockFileOpenIn ReadMode)+ where+ lock = file <.> "lock"++ lockFileOpenIn io_mode = bracketOnError+ (openBinaryFile lock io_mode)+ hClose+ -- If file locking support is not available, ignore the error and proceed+ -- normally. Without it the only thing we lose on non-Windows platforms is+ -- the ability to safely issue concurrent updates to the same package db.+ $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return ()+ return $ PackageDbLock hnd++lockPackageDb = lockPackageDbWith ExclusiveLock+unlockPackageDb (PackageDbLock hnd) = do+ hUnlock hnd+ hClose hnd++-- | Mode to open a package db in.+data DbMode = DbReadOnly | DbReadWrite++-- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So+-- it is like 'Maybe' but with a type argument for the mode to enforce that the+-- mode is used consistently.+data DbOpenMode (mode :: DbMode) t where+ DbOpenReadOnly :: DbOpenMode 'DbReadOnly t+ DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t++deriving instance Functor (DbOpenMode mode)+deriving instance F.Foldable (DbOpenMode mode)+deriving instance F.Traversable (DbOpenMode mode)++isDbOpenReadMode :: DbOpenMode mode t -> Bool+isDbOpenReadMode = \case+ DbOpenReadOnly -> True+ DbOpenReadWrite{} -> False++-- | Read the part of the package DB that GHC is interested in.+--+readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]+readPackageDbForGhc file =+ decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case+ (pkgs, DbOpenReadOnly) -> return pkgs+ where+ getDbForGhc = do+ _version <- getHeader+ _ghcPartLen <- get :: Get Word32+ ghcPart <- get+ -- the next part is for ghc-pkg, but we stop here.+ return ghcPart++-- | Read the part of the package DB that ghc-pkg is interested in+--+-- Note that the Binary instance for ghc-pkg's representation of packages+-- is not defined in this package. This is because ghc-pkg uses Cabal types+-- (and Binary instances for these) which this package does not depend on.+--+-- If we open the package db in read only mode, we get its contents. Otherwise+-- we additionally receive a PackageDbLock that represents a lock on the+-- database, so that we can safely update it later.+--+readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->+ IO (pkgs, DbOpenMode mode PackageDbLock)+readPackageDbForGhcPkg file mode =+ decodeFromFile file mode getDbForGhcPkg+ where+ getDbForGhcPkg = do+ _version <- getHeader+ -- skip over the ghc part+ ghcPartLen <- get :: Get Word32+ _ghcPart <- skip (fromIntegral ghcPartLen)+ -- the next part is for ghc-pkg+ ghcPkgPart <- get+ return ghcPkgPart++-- | Write the whole of the package DB, both parts.+--+writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()+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+ put ghcPartLen+ putLazyByteString ghcPart+ put ghcPkgPart+ where+ ghcPartLen :: Word32+ 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)+ when (magic /= headerMagic) $+ fail "not a ghc-pkg db file, wrong file magic number"++ majorVersion <- get :: Get Word32+ -- The major version is for incompatible changes++ minorVersion <- get :: Get Word32+ -- The minor version is for compatible extensions++ when (majorVersion /= 1) $+ fail "unsupported ghc-pkg db format version"+ -- If we ever support multiple major versions then we'll have to change+ -- this code++ -- The header can be extended without incrementing the major version,+ -- we ignore fields we don't know about (currently all).+ headerExtraLen <- get :: Get Word32+ skip (fromIntegral headerExtraLen)++ return (majorVersion, minorVersion)++putHeader :: Put+putHeader = do+ putByteString headerMagic+ put majorVersion+ put minorVersion+ put headerExtraLen+ where+ majorVersion = 1 :: Word32+ minorVersion = 0 :: Word32+ headerExtraLen = 0 :: Word32++headerMagic :: BS.ByteString+headerMagic = BS.Char8.pack "\0ghcpkg\0"+++-- TODO: we may be able to replace the following with utils from the binary+-- package in future.++-- | Feed a 'Get' decoder with data chunks from a file.+--+decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->+ IO (pkgs, DbOpenMode mode PackageDbLock)+decodeFromFile file mode decoder = case mode of+ DbOpenReadOnly -> do+ -- Note [Locking package database on Windows]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- When we open the package db in read only mode, there is no need to acquire+ -- shared lock on non-Windows platform because we update the database with an+ -- atomic rename, so readers will always see the database in a consistent+ -- state.+#if defined(mingw32_HOST_OS)+ bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do+#endif+ (, DbOpenReadOnly) <$> decodeFileContents+ DbOpenReadWrite{} -> do+ -- When we open the package db in read/write mode, acquire an exclusive lock+ -- on the database and return it so we can keep it for the duration of the+ -- update.+ bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do+ (, DbOpenReadWrite lock) <$> decodeFileContents+ where+ decodeFileContents = withBinaryFile file ReadMode $ \hnd ->+ feed hnd (runGetIncremental decoder)++ feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize+ if BS.null chunk+ then feed hnd (k Nothing)+ else feed hnd (k (Just chunk))+ feed _ (Done _ _ res) = return res+ feed _ (Fail _ _ msg) = ioError err+ where+ err = mkIOError InappropriateType loc Nothing (Just file)+ `ioeSetErrorString` msg+ loc = "GHC.Unit.Database.readPackageDb"++-- Copied from Cabal's Distribution.Simple.Utils.+writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()+writeFileAtomic targetPath content = do+ let (targetDir, targetFile) = splitFileName targetPath+ Exception.bracketOnError+ (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")+ (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)+ (\(tmpPath, handle) -> do+ BS.Lazy.hPut handle content+ hClose handle+ renameFile tmpPath targetPath)++instance Binary DbUnitInfo where+ put (GenericUnitInfo+ unitId unitInstanceOf unitInstantiations+ unitPackageId+ unitPackageName unitPackageVersion+ unitComponentName+ unitAbiHash unitDepends unitAbiDepends unitImportDirs+ unitLibraries unitExtDepLibsSys unitExtDepLibsGhc+ unitLibraryDirs unitLibraryDynDirs+ unitExtDepFrameworks unitExtDepFrameworkDirs+ unitLinkerOptions unitCcOptions+ unitIncludes unitIncludeDirs+ unitHaddockInterfaces unitHaddockHTMLs+ unitExposedModules unitHiddenModules+ unitIsIndefinite unitIsExposed unitIsTrusted) = do+ put unitPackageId+ put unitPackageName+ put unitPackageVersion+ put unitComponentName+ put unitId+ put unitInstanceOf+ put unitInstantiations+ put unitAbiHash+ put unitDepends+ put unitAbiDepends+ put unitImportDirs+ put unitLibraries+ put unitExtDepLibsSys+ put unitExtDepLibsGhc+ put unitLibraryDirs+ put unitLibraryDynDirs+ put unitExtDepFrameworks+ put unitExtDepFrameworkDirs+ put unitLinkerOptions+ put unitCcOptions+ put unitIncludes+ put unitIncludeDirs+ put unitHaddockInterfaces+ put unitHaddockHTMLs+ put unitExposedModules+ put unitHiddenModules+ put unitIsIndefinite+ put unitIsExposed+ put unitIsTrusted++ get = do+ unitPackageId <- get+ unitPackageName <- get+ unitPackageVersion <- get+ unitComponentName <- get+ unitId <- get+ unitInstanceOf <- get+ unitInstantiations <- get+ unitAbiHash <- get+ unitDepends <- get+ unitAbiDepends <- get+ unitImportDirs <- get+ unitLibraries <- get+ unitExtDepLibsSys <- get+ unitExtDepLibsGhc <- get+ libraryDirs <- get+ libraryDynDirs <- get+ frameworks <- get+ frameworkDirs <- get+ unitLinkerOptions <- get+ unitCcOptions <- get+ unitIncludes <- get+ unitIncludeDirs <- get+ unitHaddockInterfaces <- get+ unitHaddockHTMLs <- get+ unitExposedModules <- get+ unitHiddenModules <- get+ unitIsIndefinite <- get+ unitIsExposed <- get+ unitIsTrusted <- get+ return (GenericUnitInfo+ unitId+ unitInstanceOf+ unitInstantiations+ unitPackageId+ unitPackageName+ unitPackageVersion+ unitComponentName+ unitAbiHash+ unitDepends+ unitAbiDepends+ unitImportDirs+ unitLibraries unitExtDepLibsSys unitExtDepLibsGhc+ libraryDirs libraryDynDirs+ frameworks frameworkDirs+ unitLinkerOptions unitCcOptions+ unitIncludes unitIncludeDirs+ unitHaddockInterfaces unitHaddockHTMLs+ unitExposedModules+ unitHiddenModules+ unitIsIndefinite unitIsExposed unitIsTrusted)++instance Binary DbModule where+ put (DbModule dbModuleUnitId dbModuleName) = do+ putWord8 0+ put dbModuleUnitId+ put dbModuleName+ put (DbModuleVar dbModuleVarName) = do+ putWord8 1+ put dbModuleVarName+ get = do+ b <- getWord8+ case b of+ 0 -> DbModule <$> get <*> get+ _ -> DbModuleVar <$> get++instance Binary DbInstUnitId where+ put (DbUnitId uid) = do+ putWord8 0+ put uid+ put (DbInstUnitId dbUnitIdComponentId dbUnitIdInsts) = do+ putWord8 1+ put dbUnitIdComponentId+ put dbUnitIdInsts++ get = do+ b <- getWord8+ case b of+ 0 -> DbUnitId <$> get+ _ -> DbInstUnitId <$> get <*> get+++-- | Return functions to perform path/URL variable substitution as per the Cabal+-- ${pkgroot} spec+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)+--+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.+-- The "pkgroot" is the directory containing the package database.+--+-- 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 :: FilePathST -> FilePathST -> (FilePathST -> FilePathST, FilePathST -> FilePathST)+mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)+ where+ munge_path p+ | Just p' <- stripVarPrefix "${pkgroot}" p = mappend pkgroot p'+ | Just p' <- stripVarPrefix "$topdir" p = mappend top_dir p'+ | otherwise = p++ munge_url p+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'+ | otherwise = 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 ST.stripPrefix var path of+ Just "" -> Just ""+ Just cs | isPathSeparator (ST.head cs) -> Just cs+ _ -> Nothing+++-- | Perform path/URL variable substitution as per the Cabal ${pkgroot} spec+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.+-- The "pkgroot" is the directory containing the package database.+--+-- 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 :: 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+ { unitImportDirs = munge_paths (unitImportDirs pkg)+ , unitIncludeDirs = munge_paths (unitIncludeDirs pkg)+ , unitLibraryDirs = munge_paths (unitLibraryDirs pkg)+ , unitLibraryDynDirs = munge_paths (unitLibraryDynDirs pkg)+ , unitExtDepFrameworkDirs = munge_paths (unitExtDepFrameworkDirs pkg)+ , unitHaddockInterfaces = munge_paths (unitHaddockInterfaces pkg)+ -- haddock-html is allowed to be either a URL or a file+ , unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg))+ }+ where+ munge_paths = map munge_path+ munge_urls = map munge_url+ (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
+ 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
+ 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,48 +1,104 @@-cabal-version: 1.22-name: ghc-boot-version: 8.8.3+cabal-version: 3.0 -license: BSD3+-- 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.14.1+license: BSD-3-Clause license-file: LICENSE category: GHC maintainer: ghc-devs@haskell.org-bug-reports: https://gitlab.haskell.org/ghc/ghc/issues+bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new synopsis: Shared functionality between GHC and its boot libraries-description: This library is shared between GHC, @ghc-pkg@, and other boot+description: This library is shared between GHC, ghc-pkg, and other boot libraries. .- A note about "GHC.PackageDb": it only deals with the subset of+ A note about "GHC.Unit.Database": it only deals with the subset of the package database that the compiler cares about: modules paths etc and not package metadata like description, authors- etc. It is thus not a library interface to @ghc-pkg@ and is __not__+ etc. It is thus not a library interface to ghc-pkg and is *not* suitable for modifying GHC package databases. . 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@.-build-type: Simple+ such a way that while ghc-pkg depends on Cabal, the GHC library+ and program do not have to depend on Cabal.+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 default-extensions: NoImplicitPrelude exposed-modules:+ GHC.BaseDir+ GHC.Data.ShortText+ GHC.Data.SizedSeq+ GHC.Utils.Encoding+ GHC.Utils.Encoding.UTF8 GHC.LanguageExtensions- GHC.PackageDb+ GHC.Unit.Database GHC.Serialized GHC.ForeignSrcLang GHC.HandleEncoding+ GHC.Platform.Host+ GHC.Settings.Utils+ GHC.UniqueSubdir+ GHC.Version - build-depends: base >= 4.7 && < 4.14,++ -- reexport platform modules from ghc-platform+ reexported-modules:+ GHC.Platform.ArchOS++ -- but done by Hadrian+ autogen-modules:+ GHC.Version+ GHC.Platform.Host++ build-depends: base >= 4.7 && < 4.23, binary == 0.8.*,- bytestring == 0.10.*,+ bytestring >= 0.10 && < 0.13,+ containers >= 0.5 && < 0.9, directory >= 1.2 && < 1.4,- filepath >= 1.3 && < 1.5,- ghc-boot-th == 8.8.3+ 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