diff --git a/GHC/BaseDir.hs b/GHC/BaseDir.hs new file mode 100644 --- /dev/null +++ b/GHC/BaseDir.hs @@ -0,0 +1,77 @@ +{-# 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 where + +import Prelude -- See Note [Why do we import Prelude here?] + +import Data.List +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) +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 + , null str' || isPathSeparator (head str') + = value ++ expandPathVar var value str' +expandPathVar var value (x:xs) = x : expandPathVar var value xs +expandPathVar _ _ [] = [] + +-- | Calculate the location of the base dir +getBaseDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +getBaseDir = Just . (\p -> p "lib") . rootDir <$> getExecutablePath + 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) +-- 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. +-- +-- getExecutablePath 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 +#endif diff --git a/GHC/PackageDb.hs b/GHC/PackageDb.hs deleted file mode 100644 --- a/GHC/PackageDb.hs +++ /dev/null @@ -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)) diff --git a/GHC/Platform.hs b/GHC/Platform.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform.hs @@ -0,0 +1,362 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/GHC/Platform/Host.hs @@ -0,0 +1,15 @@ +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/Settings/Platform.hs b/GHC/Settings/Platform.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/Platform.hs @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/GHC/Settings/Utils.hs @@ -0,0 +1,15 @@ +module GHC.Settings.Utils where + +import Prelude -- See Note [Why do we import Prelude here?] + +import Data.Char (isSpace) + +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 diff --git a/GHC/UniqueSubdir.hs b/GHC/UniqueSubdir.hs new file mode 100644 --- /dev/null +++ b/GHC/UniqueSubdir.hs @@ -0,0 +1,26 @@ +module GHC.UniqueSubdir + ( uniqueSubdir + ) where + +import Prelude -- See Note [Why do we import Prelude here?] + +import Data.List (intercalate) + +import GHC.Platform +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 + , 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. diff --git a/GHC/Unit/Database.hs b/GHC/Unit/Database.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Database.hs @@ -0,0 +1,703 @@ +{-# 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 #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Control.Exception as Exception +import Control.Monad (when) +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import System.IO +import System.IO.Error +import GHC.IO.Exception (IOErrorType(InappropriateType)) +import 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 + +-- | 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 compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo + { unitId :: uid + -- ^ Unique unit identifier that is used during compilation (e.g. to + -- generate symbols). + + , unitInstanceOf :: compid + -- ^ Identifier of an indefinite unit (i.e. with module holes) that this + -- unit is an instance of. + + , 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 :: String + -- ^ 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)] + -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash + -- we expect the dependency to respect. + + , unitImportDirs :: [FilePath] + -- ^ Directories containing module interfaces + + , unitLibraries :: [String] + -- ^ Names of the Haskell libraries provided by this unit + + , unitExtDepLibsSys :: [String] + -- ^ Names of the external system libraries that this unit depends on. See + -- also `unitExtDepLibsGhc` field. + + , unitExtDepLibsGhc :: [String] + -- ^ 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 :: [FilePath] + -- ^ 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] + -- ^ 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] + -- ^ Names of the external MacOS frameworks that this unit depends on. + + , unitExtDepFrameworkDirs :: [FilePath] + -- ^ Directories containing MacOS frameworks that this unit depends + -- on. + + , unitLinkerOptions :: [String] + -- ^ Linker (e.g. ld) command line options + + , unitCcOptions :: [String] + -- ^ C compiler options that needs to be passed to the C compiler when we + -- compile some C code against this unit. + + , unitIncludes :: [String] + -- ^ C header files that are required by this unit (provided by this unit + -- or external) + + , unitIncludeDirs :: [FilePath] + -- ^ Directories containing C header files that this unit depends + -- on. + + , unitHaddockInterfaces :: [FilePath] + -- ^ Paths to Haddock interface files for this unit + + , unitHaddockHTMLs :: [FilePath] + -- ^ 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) + +-- | 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 {..}) = + g { unitId = fuid unitId + , unitInstanceOf = fcid 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 = + 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 + -- 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 :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath) +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' + | 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 = "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)) + + -- 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 + _ -> 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 :: FilePath -> FilePath -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f +mungeUnitInfoPaths top_dir pkgroot pkg = + -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs + pkg + { 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 diff --git a/GHC/Version.hs b/GHC/Version.hs new file mode 100644 --- /dev/null +++ b/GHC/Version.hs @@ -0,0 +1,21 @@ +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/ghc-boot.cabal b/ghc-boot.cabal --- a/ghc-boot.cabal +++ b/ghc-boot.cabal @@ -1,25 +1,28 @@ -cabal-version: 1.22 -name: ghc-boot -version: 8.8.3 +-- 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 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@. + such a way that while ghc-pkg depends on Cabal, the GHC library + and program do not have to depend on Cabal. +cabal-version: >=1.22 build-type: Simple extra-source-files: changelog.md @@ -34,15 +37,28 @@ default-extensions: NoImplicitPrelude exposed-modules: + GHC.BaseDir GHC.LanguageExtensions - GHC.PackageDb + GHC.Unit.Database GHC.Serialized GHC.ForeignSrcLang GHC.HandleEncoding + GHC.Platform + GHC.Platform.Host + GHC.Settings.Platform + GHC.Settings.Utils + GHC.UniqueSubdir + GHC.Version - build-depends: base >= 4.7 && < 4.14, + -- but done by Hadrian + -- autogen-modules: + -- GHC.Version + -- GHC.Platform.Host + + build-depends: base >= 4.7 && < 4.16, binary == 0.8.*, bytestring == 0.10.*, + containers >= 0.5 && < 0.7, directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5, - ghc-boot-th == 8.8.3 + ghc-boot-th == 9.0.1