diff --git a/GHC/BaseDir.hs b/GHC/BaseDir.hs new file mode 100644 --- /dev/null +++ b/GHC/BaseDir.hs @@ -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 diff --git a/GHC/Data/ShortText.hs b/GHC/Data/ShortText.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/ShortText.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies #-} +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- gross hack: we maneuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore. +-- LLVM based GHC's fail to compile memcmp ffi calls. These end up as memcmp$def in the llvm ir, however we +-- don't have any prototypes and subsequently the llvm toolchain chokes on them. Since 7fdcce6d, we use +-- ShortText for the package database. This however introduces this very module; which through inlining ends +-- up bringing memcmp_ByteArray from bytestring:Data.ByteString.Short.Internal into scope, which results in +-- the memcmp call we choke on. +-- +-- The solution thusly is to force late binding via the linker instead of inlining when comping with the +-- bootstrap compiler. This will produce a slower (slightly less optimised) stage1 compiler only. +-- +-- See issue 18857. hsyl20 deserves credit for coming up with the idea for the solution. +-- | +-- An Unicode string for internal GHC use. Meant to replace String +-- in places where being a lazy linked is not very useful and a more +-- memory efficient data structure is desirable. + +-- Very similar to FastString, but not hash-consed and with some extra instances and +-- functions for serialisation and I/O. Should be imported qualified. +-- +-- /Note:/ This string is stored in Modified UTF8 format, +-- thus it's not byte-compatible with @ShortText@ type in @text-short@ +-- package. + +module GHC.Data.ShortText ( + -- * ShortText + ShortText(..), + -- ** Conversion to and from String + singleton, + pack, + unpack, + -- ** Operations + codepointLength, + byteLength, + GHC.Data.ShortText.null, + splitFilePath, + GHC.Data.ShortText.head, + stripPrefix + ) where + +import Prelude + +import Control.Monad (guard) +import Control.DeepSeq as DeepSeq +import Data.Binary +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short.Internal as SBS +import GHC.Exts +import GHC.IO +import GHC.Utils.Encoding +import System.FilePath (isPathSeparator) + +{-| A 'ShortText' is a modified UTF-8 encoded string meant for short strings like +file paths, module descriptions, etc. +-} +newtype ShortText = ShortText { contents :: SBS.ShortByteString + } + deriving stock (Show) + deriving newtype (Eq, Ord, Binary, Semigroup, Monoid, NFData) + +-- We don't want to derive this one from ShortByteString since that one won't handle +-- UTF-8 characters correctly. +instance IsString ShortText where + fromString = pack + +-- | /O(n)/ Returns the length of the 'ShortText' in characters. +codepointLength :: ShortText -> Int +codepointLength st = utf8CountCharsShortByteString (contents st) + +-- | /O(1)/ Returns the length of the 'ShortText' in bytes. +byteLength :: ShortText -> Int +byteLength st = SBS.length $ contents st + +-- | /O(n)/ Convert a 'String' into a 'ShortText'. +pack :: String -> ShortText +pack s = ShortText $ utf8EncodeShortByteString s + +-- | Create a singleton +singleton :: Char -> ShortText +singleton s = pack [s] + +-- | /O(n)/ Convert a 'ShortText' into a 'String'. +unpack :: ShortText -> String +unpack st = utf8DecodeShortByteString $ contents st + +-- | /O(1)/ Test whether the 'ShortText' is the empty string. +null :: ShortText -> Bool +null st = SBS.null $ contents st + +-- | /O(n)/ Split a 'ShortText' representing a file path into its components by separating +-- on the file separator characters for this platform. +splitFilePath :: ShortText -> [ShortText] +-- This seems dangerous, but since the path separators are in the ASCII set they map down +-- to a single byte when encoded in UTF-8 and so this should work even when casting to ByteString. +-- We DeepSeq.force the resulting list so that we can be sure that no references to the +-- bytestring in `st'` remain in unevaluated thunks, which might prevent `st'` from being +-- collected by the GC. +splitFilePath st = DeepSeq.force $ map (ShortText . SBS.toShort) $ B8.splitWith isPathSeparator st' + where st' = SBS.fromShort $ contents st + +-- | /O(1)/ Returns the first UTF-8 codepoint in the 'ShortText'. Depending on the string in +-- question, this may or may not be the actual first character in the string due to Unicode +-- non-printable characters. +head :: ShortText -> Char +head st + | hd:_ <- unpack st + = hd + | otherwise + = error "head: Empty ShortText" + +-- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of +-- the second iff the first is its prefix, and otherwise Nothing. +stripPrefix :: ShortText -> ShortText -> Maybe ShortText +stripPrefix prefix st = do + let !(SBS.SBS prefixBA) = contents prefix + let !(SBS.SBS stBA) = contents st + let prefixLength = sizeofByteArray# prefixBA + let stLength = sizeofByteArray# stBA + -- If the length of 'st' is not >= than the length of 'prefix', it is impossible for 'prefix' + -- to be the prefix of `st`. + guard $ (I# stLength) >= (I# prefixLength) + -- 'prefix' is a prefix of 'st' if the first bytes of 'st' + -- are equal to 'prefix' + guard $ I# (compareByteArrays# prefixBA 0# stBA 0# prefixLength) == 0 + -- Allocate a new ByteArray# and copy the remainder of the 'st' into it + unsafeDupablePerformIO $ do + let newBAsize = (stLength -# prefixLength) + newSBS <- IO $ \s0 -> + let !(# s1, ba #) = newByteArray# newBAsize s0 + s2 = copyByteArray# stBA prefixLength ba 0# newBAsize s1 + !(# s3, fba #) = unsafeFreezeByteArray# ba s2 + in (# s3, SBS.SBS fba #) + return . Just . ShortText $ newSBS diff --git a/GHC/Data/SizedSeq.hs b/GHC/Data/SizedSeq.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/SizedSeq.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-} +module GHC.Data.SizedSeq + ( SizedSeq(..) + , emptySS + , addToSS + , addListToSS + , ssElts + , sizeSS + ) where + +import Prelude -- See note [Why do we import Prelude here?] +import Control.DeepSeq +import Data.Binary +import GHC.Generics + +#if ! MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif + +data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] + deriving (Generic, Show) + +instance Functor SizedSeq where + fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l) + +instance Foldable SizedSeq where + foldr f c ss = foldr f c (ssElts ss) + +instance Traversable SizedSeq where + traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l) + +instance Binary a => Binary (SizedSeq a) + +instance NFData a => NFData (SizedSeq a) where + rnf (SizedSeq _ xs) = rnf xs + +emptySS :: SizedSeq a +emptySS = SizedSeq 0 [] + +addToSS :: SizedSeq a -> a -> SizedSeq a +addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) + +-- NB, important this is eta-expand so that foldl' is inlined. +addListToSS :: SizedSeq a -> [a] -> SizedSeq a +addListToSS s xs = foldl' addToSS s xs + +ssElts :: SizedSeq a -> [a] +ssElts (SizedSeq _ r_xs) = reverse r_xs + +sizeSS :: SizedSeq a -> Word +sizeSS (SizedSeq n _) = n diff --git a/GHC/HandleEncoding.hs b/GHC/HandleEncoding.hs --- a/GHC/HandleEncoding.hs +++ b/GHC/HandleEncoding.hs @@ -10,8 +10,8 @@ -- GHC produces output regardless of OS. configureHandleEncoding :: IO () configureHandleEncoding = do - env <- getEnvironment - case lookup "GHC_CHARENC" env of + mb_val <- lookupEnv "GHC_CHARENC" + case mb_val of Just "UTF-8" -> do hSetEncoding stdout utf8 hSetEncoding stderr utf8 diff --git a/GHC/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/Serialized.hs b/GHC/Serialized.hs --- a/GHC/Serialized.hs +++ b/GHC/Serialized.hs @@ -22,10 +22,14 @@ import Data.Bits import Data.Word ( Word8 ) import Data.Data +import Control.DeepSeq -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8] + +instance NFData Serialized where + rnf (Serialized tr ws) = rnf tr `seq` rnf ws -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized diff --git a/GHC/Settings/Utils.hs b/GHC/Settings/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Settings/Utils.hs @@ -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 diff --git a/GHC/UniqueSubdir.hs b/GHC/UniqueSubdir.hs new file mode 100644 --- /dev/null +++ b/GHC/UniqueSubdir.hs @@ -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. 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,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 diff --git a/GHC/Utils/Encoding.hs b/GHC/Utils/Encoding.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Encoding.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} +{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected. This module used to live in the `ghc` +-- package but has been moved to `ghc-boot` because the definition +-- of the package database (needed in both ghc and in ghc-pkg) lives in +-- `ghc-boot` and uses ShortText, which in turn depends on this module. + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module GHC.Utils.Encoding ( + -- * UTF-8 + module GHC.Utils.Encoding.UTF8, + + -- * Z-encoding + UserString, + EncodedString, + zEncodeString, + zDecodeString, + + -- * Base62-encoding + toBase62, + toBase62Padded + ) where + +import Prelude + +import Foreign +import Data.Char +import qualified Data.Char as Char +import Numeric + +import GHC.Utils.Encoding.UTF8 + +-- ----------------------------------------------------------------------------- +-- Note [Z-Encoding] +-- ~~~~~~~~~~~~~~~~~ + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (##) Z0H unboxed 0-tuple + (#,,,,#) Z5H unboxed 5-tuple +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString = \case + [] -> [] + (c:cs) + -- If a digit is at the start of a symbol then we need to encode it. + -- Otherwise package names like 9pH-0.1 give linker errors. + | c >= '0' && c <= '9' -> encode_as_unicode_char c ++ go cs + | otherwise -> go (c:cs) + where + go = \case + [] -> [] + -- encode boxed/unboxed tuples respectively as ZnT/ZnH (e.g. Z3T/Z3H for + -- 3-tuples). Note that the arity corresponds to the number of + -- commas+1. No comma means 0-arity, i.e. Z0T/Z0H. + -- + -- The 1-arity unboxed tuple "(# #)" (notice the space between the '#'s) + -- isn't special-cased, i.e. it is encoded as "ZLzhz20UzhZR". There is no + -- 1-arity boxed tuple (we use Solo/MkSolo instead). + -- + -- arity boxed z-name unboxed z-name + -- 0 () Z0T (##) Z0H + -- 1 N/A N/A (# #) ZLzhz20UzhZR + -- 2 (,) Z2T (#,#) Z2H + -- 3 (,,) Z3T (#,,#) Z3H + -- ... + -- + '(':'#':'#':')':cs -> "Z0H" ++ go cs + '(':')':cs -> "Z0T" ++ go cs + '(':'#':cs + | (n, '#':')':cs') <- count_commas cs + -> 'Z' : shows (n+1) ('H': go cs') + '(':cs + | (n, ')':cs') <- count_commas cs + -> 'Z' : shows (n+1) ('T': go cs') + c:cs -> encode_ch c ++ go cs + +count_commas :: String -> (Int, String) +count_commas = go 0 + where + go !n = \case + ',':cs -> go (n+1) cs + cs -> (n,cs) + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c = 'z' : case hex_str of + hd : _ + | isDigit hd -> hex_str + _ -> '0' : hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ + +Note [Base 62 encoding 128-bit integers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of base-62 encoding a single 128-bit integer +(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +(2 * ceil(10.75) characters). Luckily for us, it's the same number of +characters! +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62Padded :: Word64 -> String +toBase62Padded w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = toBase62 w + +toBase62 :: Word64 -> String +toBase62 w = showIntAtBase 62 represent w "" + where + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error "represent (base 62): impossible!" diff --git a/GHC/Utils/Encoding/UTF8.hs b/GHC/Utils/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Encoding/UTF8.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} +{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected. This module used to live in the `ghc` +-- package but has been moved to `ghc-boot` because the definition +-- of the package database (needed in both ghc and in ghc-pkg) lives in +-- `ghc-boot` and uses ShortText, which in turn depends on this module. + +-- | Simple, non-streaming Modified UTF-8 codecs. +-- +-- This is one of several UTF-8 implementations provided by GHC; see Note +-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an +-- overview. +-- +module GHC.Utils.Encoding.UTF8 + ( -- * Decoding single characters + utf8DecodeCharAddr# + , utf8DecodeCharPtr + , utf8DecodeCharByteArray# + , utf8PrevChar + , utf8CharStart + , utf8UnconsByteString + -- * Decoding strings + , utf8DecodeByteString + , utf8DecodeShortByteString + , utf8DecodeForeignPtr + , utf8DecodeByteArray# + -- * Counting characters + , utf8CountCharsShortByteString + , utf8CountCharsByteArray# + -- * Comparison + , utf8CompareByteArray# + , utf8CompareShortByteString + -- * Encoding strings + , utf8EncodeByteArray# + , utf8EncodePtr + , utf8EncodeByteString + , utf8EncodeShortByteString + , utf8EncodedLength + ) where + + +import Prelude + +import Foreign +import GHC.IO +import GHC.Encoding.UTF8 + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import Data.ByteString.Short.Internal (ShortByteString(..)) + +-- | Find the start of the codepoint preceding the codepoint at the given +-- 'Ptr'. This is undefined if there is no previous valid codepoint. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +-- | Find the start of the codepoint at the given 'Ptr'. This is undefined if +-- there is no previous valid codepoint. +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +utf8CountCharsShortByteString :: ShortByteString -> Int +utf8CountCharsShortByteString (SBS ba) = utf8CountCharsByteArray# ba + +utf8DecodeShortByteString :: ShortByteString -> [Char] +utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba# + +-- | Decode a 'ByteString' containing a UTF-8 string. +utf8DecodeByteString :: ByteString -> [Char] +utf8DecodeByteString (BS.PS fptr offset len) + = utf8DecodeForeignPtr fptr offset len + +utf8EncodeShortByteString :: String -> ShortByteString +utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str) + +-- | Encode a 'String' into a 'ByteString'. +utf8EncodeByteString :: String -> ByteString +utf8EncodeByteString s = + unsafePerformIO $ do + let len = utf8EncodedLength s + buf <- mallocForeignPtrBytes len + withForeignPtr buf $ \ptr -> do + utf8EncodePtr ptr s + pure (BS.fromForeignPtr buf 0 len) + +utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString) +utf8UnconsByteString (BS.PS _ _ 0) = Nothing +utf8UnconsByteString (BS.PS fptr offset len) + = unsafeDupablePerformIO $ + withForeignPtr fptr $ \ptr -> do + let (c,n) = utf8DecodeCharPtr (ptr `plusPtr` offset) + return $ Just (c, BS.PS fptr (offset + n) (len - n)) + +utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering +utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +module Main where + +import Distribution.Simple +import Distribution.Simple.BuildPaths +import Distribution.Types.LocalBuildInfo +import Distribution.Verbosity +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Simple.Setup + +import System.IO +import System.Directory +import System.FilePath +import System.Environment +import Control.Monad +import Data.Char +import GHC.ResponseFile + +main :: IO () +main = defaultMainWithHooks ghcHooks + where + ghcHooks = simpleUserHooks + { postConf = \args cfg pd lbi -> do + let verbosity = fromFlagOrDefault minBound (configVerbosity cfg) + ghcAutogen verbosity lbi + postConf simpleUserHooks args cfg pd lbi + } + +ghcAutogen :: Verbosity -> LocalBuildInfo -> IO () +ghcAutogen verbosity lbi@LocalBuildInfo{..} = do + -- Get compiler/ root directory from the cabal file + let Just compilerRoot = takeDirectory <$> pkgDescrFile + + let platformHostFile = "GHC/Platform/Host.hs" + platformHostPath = autogenPackageModulesDir lbi platformHostFile + ghcVersionFile = "GHC/Version.hs" + ghcVersionPath = autogenPackageModulesDir lbi ghcVersionFile + + -- Get compiler settings + settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case + Just settings -> pure $ Left $ read settings + Nothing -> do + (ghc,withPrograms) <- requireProgram normal ghcProgram withPrograms + Right . read <$> getProgramOutput normal ghc ["--info"] + + -- Write GHC.Platform.Host + createDirectoryIfMissingVerbose verbosity True (takeDirectory platformHostPath) + rewriteFileEx verbosity platformHostPath (generatePlatformHostHs settings) + + -- Write GHC.Version + createDirectoryIfMissingVerbose verbosity True (takeDirectory ghcVersionPath) + rewriteFileEx verbosity ghcVersionPath (generateVersionHs settings) + +-- | Takes either a list of hadrian generated settings, or a list of settings from ghc --info, +-- and keys in both lists, and looks up the value in the appropriate list +getSetting :: Either [(String,String)] [(String,String)] -> String -> String -> Either String String +getSetting settings kh kr = case settings of + Left settings -> go settings kh + Right settings -> go settings kr + where + go settings k = case lookup k settings of + Nothing -> Left (show k ++ " not found in settings: " ++ show settings) + Just v -> Right v + +generatePlatformHostHs :: Either [(String,String)] [(String,String)] -> String +generatePlatformHostHs settings = either error id $ do + let getSetting' = getSetting settings + cHostPlatformArch <- getSetting' "hostPlatformArch" "target arch" + cHostPlatformOS <- getSetting' "hostPlatformOS" "target os" + return $ unlines + [ "module GHC.Platform.Host where" + , "" + , "import GHC.Platform.ArchOS" + , "" + , "hostPlatformArch :: Arch" + , "hostPlatformArch = " ++ cHostPlatformArch + , "" + , "hostPlatformOS :: OS" + , "hostPlatformOS = " ++ cHostPlatformOS + , "" + , "hostPlatformArchOS :: ArchOS" + , "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS" + ] + +generateVersionHs :: Either [(String,String)] [(String,String)] -> String +generateVersionHs settings = either error id $ do + let getSetting' = getSetting settings + cProjectGitCommitId <- getSetting' "cProjectGitCommitId" "Project Git commit id" + cProjectVersion <- getSetting' "cProjectVersion" "Project version" + cProjectVersionInt <- getSetting' "cProjectVersionInt" "Project Version Int" + + cProjectPatchLevel <- getSetting' "cProjectPatchLevel" "Project Patch Level" + cProjectPatchLevel1 <- getSetting' "cProjectPatchLevel1" "Project Patch Level1" + cProjectPatchLevel2 <- getSetting' "cProjectPatchLevel2" "Project Patch Level2" + return $ unlines + [ "module GHC.Version where" + , "" + , "import Prelude -- See Note [Why do we import Prelude here?]" + , "" + , "cProjectGitCommitId :: String" + , "cProjectGitCommitId = " ++ show cProjectGitCommitId + , "" + , "cProjectVersion :: String" + , "cProjectVersion = " ++ show cProjectVersion + , "" + , "cProjectVersionInt :: String" + , "cProjectVersionInt = " ++ show cProjectVersionInt + , "" + , "cProjectPatchLevel :: String" + , "cProjectPatchLevel = " ++ show cProjectPatchLevel + , "" + , "cProjectPatchLevel1 :: String" + , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1 + , "" + , "cProjectPatchLevel2 :: String" + , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2 + ] diff --git a/ghc-boot.cabal b/ghc-boot.cabal --- a/ghc-boot.cabal +++ b/ghc-boot.cabal @@ -1,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