[Git][ghc/ghc][wip/romes/hardwire-ghc-unit-id] Add hashes to unit-ids created by hadrian
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Mar 27 15:00:43 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/hardwire-ghc-unit-id at Glasgow Haskell Compiler / GHC
Commits:
6cdf5a0e by romes at 2023-03-27T16:00:19+01:00
Add hashes to unit-ids created by hadrian
Co-author: @mpickering
- - - - -
26 changed files:
- hadrian/hadrian.cabal
- hadrian/src/Context.hs
- hadrian/src/Hadrian/BuildPath.hs
- hadrian/src/Hadrian/Haskell/Cabal.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- + hadrian/src/Hadrian/Haskell/Hash.hs
- + hadrian/src/Hadrian/Haskell/Hash.hs-boot
- hadrian/src/Hadrian/Package.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/CabalReinstall.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Builders/Haddock.hs
- testsuite/driver/testlib.py
- testsuite/tests/backpack/cabal/bkpcabal02/all.T
- testsuite/tests/cabal/t18567/all.T
- testsuite/tests/driver/T16318/Makefile
- testsuite/tests/driver/T18125/Makefile
- testsuite/tests/ghci/scripts/Makefile
- testsuite/tests/package/T4806a.stderr
- utils/ghc-pkg/Main.hs
Changes:
=====================================
hadrian/hadrian.cabal
=====================================
@@ -55,6 +55,7 @@ executable hadrian
, Hadrian.BuildPath
, Hadrian.Expression
, Hadrian.Haskell.Cabal
+ , Hadrian.Haskell.Hash
, Hadrian.Haskell.Cabal.Type
, Hadrian.Haskell.Cabal.Parse
, Hadrian.Oracles.ArgsHash
@@ -163,6 +164,8 @@ executable hadrian
, transformers >= 0.4 && < 0.7
, unordered-containers >= 0.2.1 && < 0.3
, text >= 1.2 && < 3
+ , cryptohash-sha256 >= 0.11 && < 0.12
+ , base16-bytestring >= 0.1.1 && < 1.1.0.0
ghc-options: -Wall
-Wincomplete-record-updates
-Wredundant-constraints
=====================================
hadrian/src/Context.hs
=====================================
@@ -70,15 +70,15 @@ distDir st = do
hostArch <- cabalArchString <$> setting arch
return $ hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
-pkgFileName :: Package -> String -> String -> Action FilePath
-pkgFileName package prefix suffix = do
- pid <- pkgIdentifier package
+pkgFileName :: Context -> Package -> String -> String -> Action FilePath
+pkgFileName context package prefix suffix = do
+ pid <- pkgUnitId context package
return $ prefix ++ pid ++ suffix
pkgFile :: Context -> String -> String -> Action FilePath
pkgFile context at Context {..} prefix suffix = do
path <- buildPath context
- fileName <- pkgFileName package prefix suffix
+ fileName <- pkgFileName context package prefix suffix
return $ path -/- fileName
-- | Path to inplace package configuration file of a given 'Context'.
@@ -95,9 +95,9 @@ pkgSetupConfigFile context = pkgSetupConfigDir context <&> (-/- "setup-config")
-- | Path to the haddock file of a given 'Context', e.g.:
-- @_build/stage1/libraries/array/doc/html/array/array.haddock at .
pkgHaddockFile :: Context -> Action FilePath
-pkgHaddockFile Context {..} = do
+pkgHaddockFile context at Context {..} = do
root <- buildRoot
- version <- pkgIdentifier package
+ version <- pkgUnitId context package
return $ root -/- "doc/html/libraries" -/- version -/- pkgName package <.> "haddock"
-- | Path to the registered ghc-pkg library file of a given 'Context', e.g.:
@@ -106,7 +106,7 @@ pkgHaddockFile Context {..} = do
pkgRegisteredLibraryFile :: Context -> Action FilePath
pkgRegisteredLibraryFile context at Context {..} = do
libDir <- libPath context
- pkgId <- pkgIdentifier package
+ pkgId <- pkgUnitId context package
fileName <- pkgRegisteredLibraryFileName context
distDir <- distDir stage
return $ if Dynamic `wayUnit` way
@@ -115,9 +115,9 @@ pkgRegisteredLibraryFile context at Context {..} = do
-- | Just the final filename portion of pkgRegisteredLibraryFile
pkgRegisteredLibraryFileName :: Context -> Action FilePath
-pkgRegisteredLibraryFileName Context{..} = do
+pkgRegisteredLibraryFileName context at Context{..} = do
extension <- libsuf stage way
- pkgFileName package "libHS" extension
+ pkgFileName context package "libHS" extension
-- | Path to the library file of a given 'Context', e.g.:
@@ -136,8 +136,8 @@ pkgGhciLibraryFile context at Context {..} = do
-- | Path to the configuration file of a given 'Context'.
pkgConfFile :: Context -> Action FilePath
-pkgConfFile Context {..} = do
- pid <- pkgIdentifier package
+pkgConfFile context at Context {..} = do
+ pid <- pkgUnitId context package
dbPath <- packageDbPath (PackageDbLoc stage iplace)
return $ dbPath -/- pid <.> "conf"
=====================================
hadrian/src/Hadrian/BuildPath.hs
=====================================
@@ -110,17 +110,28 @@ parseWayUnit = Parsec.choice
, Parsec.char 'l' *> pure Logging
] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
--- | Parse a @"pkgname-pkgversion"@ string into the package name and the
+-- | Parse a @"pkgname-pkgversion-pkghash"@ string into the package name and the
-- integers that make up the package version.
-parsePkgId :: Parsec.Parsec String () (String, [Integer])
-parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
+--
+-- If no hash was assigned, an empty string is returned in its place.
+parsePkgId :: Parsec.Parsec String () (String, [Integer], String)
+parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>(-<hash>?))"
where
parsePkgId' currName = do
s <- Parsec.many1 Parsec.alphaNum
_ <- Parsec.char '-'
let newName = if null currName then s else currName ++ "-" ++ s
- Parsec.choice [ (newName,) <$> parsePkgVersion
- , parsePkgId' newName ]
+ Parsec.choice
+ [ (,,) newName <$> parsePkgVersion
+ <*> Parsec.option "" (Parsec.try $ do
+ _ <- Parsec.char '-'
+ -- Ensure we're not parsing a libDynName as a hash
+ _ <- Parsec.notFollowedBy (Parsec.string "ghc" *> parsePkgVersion)
+ parsePkgHash)
+ , parsePkgId' newName ]
+
+parsePkgHash :: Parsec.Parsec String () String
+parsePkgHash = Parsec.many1 Parsec.alphaNum
-- | Parse "."-separated integers that describe a package's version.
parsePkgVersion :: Parsec.Parsec String () [Integer]
=====================================
hadrian/src/Hadrian/Haskell/Cabal.hs
=====================================
@@ -10,8 +10,8 @@
-- Cabal files.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal (
- pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies,
- pkgGenericDescription, cabalArchString, cabalOsString,
+ pkgVersion, pkgUnitId, pkgSynopsis, pkgDescription, pkgSimpleIdentifier,
+ pkgDependencies, pkgGenericDescription, cabalArchString, cabalOsString
) where
import Development.Shake
@@ -20,15 +20,19 @@ import Distribution.PackageDescription (GenericPackageDescription)
import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal
import Hadrian.Package
+import {-# SOURCE #-} Hadrian.Haskell.Hash (pkgUnitId)
+
-- | Read a Cabal file and return the package version. The Cabal file is tracked.
pkgVersion :: Package -> Action String
pkgVersion = fmap version . readPackageData
--- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0 at .
+-- | Read a Cabal file and return the package identifier without a hash, e.g. @base-4.10.0.0 at .
-- The Cabal file is tracked.
-pkgIdentifier :: Package -> Action String
-pkgIdentifier package = do
+--
+-- For an identifier complete with the hash use 'pkgUnitId'
+pkgSimpleIdentifier :: Package -> Action String
+pkgSimpleIdentifier package = do
cabal <- readPackageData package
return $ if null (version cabal)
then name cabal
@@ -72,3 +76,4 @@ cabalOsString "mingw32" = "windows"
cabalOsString "darwin" = "osx"
cabalOsString "solaris2" = "solaris"
cabalOsString other = other
+
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -345,7 +345,7 @@ registerPackage rs context = do
pd <- packageDescription <$> readContextData context
db_path <- packageDbPath (PackageDbLoc (stage context) (iplace context))
dist_dir <- Context.buildPath context
- pid <- pkgIdentifier (package context)
+ pid <- pkgUnitId context (package context)
-- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
-- from the local build info @lbi at .
lbi <- liftIO $ C.getPersistBuildConfig cPath
@@ -357,12 +357,12 @@ registerPackage rs context = do
-- This is copied and simplified from Cabal, because we want to install the package
-- into a different package database to the one it was configured against.
register :: FilePath
- -> FilePath
+ -> String -- ^ Package Identifier
-> FilePath
-> C.PackageDescription
-> LocalBuildInfo
-> IO ()
-register pkg_db conf_file build_dir pd lbi
+register pkg_db pid build_dir pd lbi
= withLibLBI pd lbi $ \lib clbi -> do
absPackageDBs <- C.absolutePackageDBPaths packageDbs
@@ -373,13 +373,13 @@ register pkg_db conf_file build_dir pd lbi
writeRegistrationFile installedPkgInfo
where
- regFile = conf_file
+ regFile = pkg_db </> pid <.> "conf"
reloc = relocatable lbi
-- Using a specific package db here is why we have to copy the function from Cabal.
packageDbs = [C.SpecificPackageDB pkg_db]
writeRegistrationFile installedPkgInfo = do
- writeUTF8File (pkg_db </> regFile <.> "conf") (CP.showInstalledPackageInfo installedPkgInfo)
+ writeUTF8File regFile (CP.showInstalledPackageInfo installedPkgInfo)
-- | Build autogenerated files @autogen/cabal_macros.h@ and @autogen/Paths_*.hs at .
=====================================
hadrian/src/Hadrian/Haskell/Hash.hs
=====================================
@@ -0,0 +1,230 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Haskell.Hash (pkgUnitId, pkgHashOracle) where
+
+import Development.Shake
+
+import Hadrian.Haskell.Cabal.Type
+import Hadrian.Haskell.Cabal
+import Hadrian.Oracles.Cabal
+import Hadrian.Package
+
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe
+import Data.List
+import Context.Type
+import Oracles.Setting
+import Hadrian.Target
+import Hadrian.Expression
+import Builder
+import Flavour.Type
+import Settings
+import Way.Type
+import Way
+import Packages
+import Development.Shake.Classes
+import Control.Monad
+
+
+-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0-abcd at .
+-- This needs to be an oracle so it's cached
+pkgUnitId :: Context -> Package -> Action String
+pkgUnitId ctx' pkg = do
+ let ctx = ctx'{package = pkg}
+ pid <- pkgSimpleIdentifier (package ctx)
+ phash <- pkgHash ctx
+ if pkgName pkg == "rts"
+ -- The unit-id will change depending on the way, we need to treat the rts separately
+ then pure pid
+ else do
+ -- Other boot packages still hardcode their unit-id to just <name>, but we
+ -- can have hadrian generate a different unit-id for them just as cabal does
+ -- because the boot packages unit-ids are overriden by setting -this-unit-id
+ -- in the cabal file
+ pure $ pid <> "-" <> truncateHash 4 phash
+
+ where
+ truncateHash :: Int -> String -> String
+ truncateHash = take
+
+data PackageHashInputs = PackageHashInputs {
+ pkgHashPkgId :: String, -- ^ name-version
+ pkgHashComponent :: PackageType,
+ pkgHashSourceHash :: BS.ByteString,
+ -- pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),
+ pkgHashDirectDeps :: Set.Set String,
+ pkgHashOtherConfig :: PackageHashConfigInputs
+ }
+
+-- | Those parts of the package configuration that contribute to the
+-- package hash computed by hadrian (which is simpler than cabal's).
+--
+-- setting in Oracle.setting, which come from system.config
+data PackageHashConfigInputs = PackageHashConfigInputs {
+ pkgHashCompilerId :: String,
+ pkgHashPlatform :: String,
+ pkgHashFlagAssignment :: [String], -- complete not partial
+ -- pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
+ pkgHashVanillaLib :: Bool,
+ pkgHashSharedLib :: Bool,
+ pkgHashDynExe :: Bool,
+ pkgHashFullyStaticExe :: Bool,
+ pkgHashGHCiLib :: Bool,
+ pkgHashProfLib :: Bool,
+ pkgHashProfExe :: Bool,
+-- pkgHashProfLibDetail :: ProfDetailLevel,
+-- pkgHashProfExeDetail :: ProfDetailLevel,
+ pkgHashCoverage :: Bool,
+ pkgHashOptimization :: Int,
+ pkgHashSplitObjs :: Bool,
+ pkgHashSplitSections :: Bool,
+ pkgHashStripLibs :: Bool,
+ pkgHashStripExes :: Bool,
+-- pkgHashDebugInfo :: DebugInfoLevel,
+ pkgHashProgramArgs :: Map String [String],
+ pkgHashExtraLibDirs :: [FilePath],
+ pkgHashExtraLibDirsStatic :: [FilePath],
+ pkgHashExtraFrameworkDirs :: [FilePath],
+ pkgHashExtraIncludeDirs :: [FilePath]
+ -- pkgHashProgPrefix :: Maybe PathTemplate,
+ -- pkgHashProgSuffix :: Maybe PathTemplate,
+ -- pkgHashPackageDbs :: [Maybe PackageDB]
+ }
+ deriving Show
+
+newtype PkgHashKey = PkgHashKey Context
+ deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult PkgHashKey = String
+
+pkgHash :: Context -> Action String
+pkgHash = askOracle . PkgHashKey
+
+-- Needs to be an oracle to be cached. Called lots of times.
+pkgHashOracle :: Rules ()
+pkgHashOracle = void $ addOracleCache $ \(PkgHashKey ctx) -> do
+ pkg_data <- readPackageData (package ctx)
+ name <- pkgSimpleIdentifier (package ctx)
+ let stag = stage ctx
+ stagePkgs <- stagePackages stag
+ depsHashes <- mapM (\pkg -> pkgHash (ctx { package = pkg })) [pkg | pkg <- packageDependencies pkg_data, pkg `elem` stagePkgs]
+ flav <- flavour
+ let flavourArgs = args flav
+
+ targetOs <- setting TargetOs
+ let pkgHashCompilerId = ""
+ pkgHashPlatform = targetOs
+ libWays <- interpretInContext ctx (libraryWays flav)
+ dyn_ghc <- dynamicGhcPrograms flav
+ flags <- interpret (target ctx (Cabal Flags stag) [] []) flavourArgs
+ let pkgHashFlagAssignment = flags
+ pkgHashConfigureScriptArgs = ""
+ pkgHashVanillaLib = vanilla `Set.member` libWays
+ pkgHashSharedLib = dynamic `Set.member` libWays
+ pkgHashDynExe = dyn_ghc
+ pkgHashFullyStaticExe = False -- TODO: fullyStatic flavour transformer
+ pkgHashGHCiLib = False
+ pkgHashProfLib = profiling `Set.member` libWays
+ pkgHashProfExe = package ctx == ghc && ghcProfiled flav stag
+ pkgHashCoverage = False -- Can't configure this
+ pkgHashOptimization = 0 -- TODO: A bit tricky to configure
+ pkgHashSplitObjs = False -- Deprecated
+ pkgHashSplitSections = ghcSplitSections flav
+ pkgHashStripExes = False
+ pkgHashStripLibs = False
+ pkgHashDebugInfo = undefined
+
+ -- ghcArgs <- interpret (target ctx (Cabal Setup stag) [] []) flavourArgs
+ let pkgHashProgramArgs = mempty -- TODO: Map.singleton "ghc" ghcArgs,
+ -- but the above call to 'interpret' causes a
+ -- build-time loop
+ pkgHashExtraLibDirs = []
+ pkgHashExtraLibDirsStatic = []
+ pkgHashExtraFrameworkDirs = []
+ pkgHashExtraIncludeDirs = []
+
+ let other_config = PackageHashConfigInputs{..}
+
+ return $ BS.unpack $ Base16.encode $ SHA256.hash $
+ renderPackageHashInputs $ PackageHashInputs
+ {
+ pkgHashPkgId = name
+ , pkgHashComponent = pkgType (package ctx)
+ , pkgHashSourceHash = ""
+ , pkgHashDirectDeps = Set.fromList depsHashes
+ , pkgHashOtherConfig = other_config
+ }
+
+prettyShow, showHashValue :: Show a => a -> String
+prettyShow = show
+showHashValue = show
+
+renderPackageHashInputs :: PackageHashInputs -> BS.ByteString
+renderPackageHashInputs PackageHashInputs{
+ pkgHashPkgId,
+ pkgHashComponent,
+ pkgHashSourceHash,
+ pkgHashDirectDeps,
+ -- pkgHashPkgConfigDeps,
+ pkgHashOtherConfig =
+ PackageHashConfigInputs{..}
+ } =
+ -- The purpose of this somewhat laboured rendering (e.g. why not just
+ -- use show?) is so that existing package hashes do not change
+ -- unnecessarily when new configuration inputs are added into the hash.
+ BS.pack $ unlines $ catMaybes $
+ [ entry "pkgid" prettyShow pkgHashPkgId
+-- , mentry "component" show pkgHashComponent
+ , entry "src" showHashValue pkgHashSourceHash
+ {-
+ , entry "pkg-config-deps"
+ (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++
+ case mb_v of
+ Nothing -> ""
+ Just v -> " " ++ prettyShow v)
+ . Set.toList) pkgHashPkgConfigDeps
+ -}
+ , entry "deps" (intercalate ", " . map prettyShow
+ . Set.toList) pkgHashDirectDeps
+ -- and then all the config
+ , entry "compilerid" prettyShow pkgHashCompilerId
+ , entry "platform" prettyShow pkgHashPlatform
+ , opt "flags" mempty show pkgHashFlagAssignment
+-- , opt "configure-script" [] unwords pkgHashConfigureScriptArgs
+ , opt "vanilla-lib" True prettyShow pkgHashVanillaLib
+ , opt "shared-lib" False prettyShow pkgHashSharedLib
+ , opt "dynamic-exe" False prettyShow pkgHashDynExe
+ , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe
+ , opt "ghci-lib" False prettyShow pkgHashGHCiLib
+ , opt "prof-lib" False prettyShow pkgHashProfLib
+ , opt "prof-exe" False prettyShow pkgHashProfExe
+ -- , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
+ -- , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
+ , opt "hpc" False prettyShow pkgHashCoverage
+ , opt "optimisation" 0 (show) pkgHashOptimization
+ , opt "split-objs" False prettyShow pkgHashSplitObjs
+ , opt "split-sections" False prettyShow pkgHashSplitSections
+ , opt "stripped-lib" False prettyShow pkgHashStripLibs
+ , opt "stripped-exe" True prettyShow pkgHashStripExes
+-- , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo
+ , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs
+ , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic
+ , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs
+ , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
+-- , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
+-- , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix
+-- , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs
+
+ ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs
+ where
+ entry key format value = Just (key ++ ": " ++ format value)
+ mentry key format value = fmap (\v -> key ++ ": " ++ format v) value
+ opt key def format value
+ | value == def = Nothing
+ | otherwise = entry key format value
=====================================
hadrian/src/Hadrian/Haskell/Hash.hs-boot
=====================================
@@ -0,0 +1,8 @@
+module Hadrian.Haskell.Hash where
+
+import Context.Type
+import Hadrian.Package
+import Development.Shake
+
+pkgUnitId :: Context -> Package -> Action String
+
=====================================
hadrian/src/Hadrian/Package.hs
=====================================
@@ -81,4 +81,4 @@ instance NFData PackageType
instance Binary Package
instance Hashable Package
-instance NFData Package
\ No newline at end of file
+instance NFData Package
=====================================
hadrian/src/Rules.hs
=====================================
@@ -8,6 +8,7 @@ import qualified Hadrian.Oracles.Cabal.Rules
import qualified Hadrian.Oracles.DirectoryContents
import qualified Hadrian.Oracles.Path
import qualified Hadrian.Oracles.TextFile
+import qualified Hadrian.Haskell.Hash
import Expression
import qualified Oracles.Flavour
@@ -142,6 +143,7 @@ oracleRules :: Rules ()
oracleRules = do
Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
Hadrian.Oracles.Cabal.Rules.cabalOracle
+ Hadrian.Haskell.Hash.pkgHashOracle
Hadrian.Oracles.DirectoryContents.directoryContentsOracle
Hadrian.Oracles.Path.pathOracle
Hadrian.Oracles.TextFile.textFileOracle
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -132,7 +132,8 @@ bindistRules = do
version <- setting ProjectVersion
targetPlatform <- setting TargetPlatformFull
distDir <- Context.distDir Stage1
- rtsDir <- pkgIdentifier rts
+ rtsDir <- pkgUnitId (vanillaContext Stage1 rts) rts
+ -- let rtsDir = "rts"
let ghcBuildDir = root -/- stageString Stage1
bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty
=====================================
hadrian/src/Rules/CabalReinstall.hs
=====================================
@@ -10,7 +10,7 @@ import Utilities
import qualified System.Directory.Extra as IO
import Data.Either
import Rules.BinaryDist
-import Hadrian.Haskell.Cabal (pkgIdentifier)
+import Hadrian.Haskell.Cabal (pkgUnitId)
import Oracles.Setting
{-
@@ -54,7 +54,8 @@ cabalBuildRules = do
need (lib_targets ++ (map (\(_, p) -> p) (bin_targets ++ iserv_targets)))
distDir <- Context.distDir Stage1
- rtsDir <- pkgIdentifier rts
+ rtsDir <- pkgUnitId (vanillaContext Stage1 rts) rts
+ -- let rtsDir = "rts"
let ghcBuildDir = root -/- stageString Stage1
rtsIncludeDir = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -293,7 +293,7 @@ parsePkgDocTarget root = do
_ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
_ <- Parsec.string (htmlRoot ++ "/")
_ <- Parsec.string "libraries/"
- (pkgname, _) <- parsePkgId <* Parsec.char '/'
+ (pkgname, _, _) <- parsePkgId <* Parsec.char '/'
Parsec.choice
[ Parsec.try (Parsec.string "haddock-prologue.txt")
*> pure (HaddockPrologue pkgname)
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -14,6 +14,7 @@ import Oracles.Flag
import Oracles.ModuleFiles
import Oracles.Setting
import Hadrian.Haskell.Cabal.Type (PackageData(version))
+import Hadrian.Haskell.Cabal
import Hadrian.Oracles.Cabal (readPackageData)
import Packages
import Rules.Libffi
@@ -487,16 +488,15 @@ generateConfigHs = do
trackGenerateHs
cProjectName <- getSetting ProjectName
cBooterVersion <- getSetting GhcVersion
- cProjectVersionMunged <- getSetting ProjectVersionMunged
- -- ROMES:TODO:HASH First we attempt a fixed unit-id with version but without hash.
- --
- -- We now use a more informative unit-id for ghc. See Note [GHC's Unit Id]
- -- in GHC.Unit.Types
+ -- We now give a unit-id with a version and a hash to ghc.
+ -- See Note [GHC's Unit Id] in GHC.Unit.Types
--
-- It's crucial that the unit-id matches the unit-key -- ghc is no longer
-- part of the WiringMap, so we don't to go back and forth between the
- -- unit-id and the unit-key -- we take care here that they are the same.
- let cProjectUnitId = "ghc-" ++ cProjectVersionMunged -- ROMES:TODO:HASH
+ -- unit-id and the unit-key -- we take care that they are the same by using
+ -- 'pkgUnitId' on 'compiler' (the ghc-library package) to create the
+ -- unit-id in both situations.
+ cProjectUnitId <- expr . (`pkgUnitId` compiler) =<< getContext
return $ unlines
[ "module GHC.Settings.Config"
, " ( module GHC.Version"
@@ -593,3 +593,5 @@ generatePlatformHostHs = do
, "hostPlatformArchOS :: ArchOS"
, "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
]
+
+
=====================================
hadrian/src/Rules/Library.hs
=====================================
@@ -45,7 +45,7 @@ libraryRules = do
registerStaticLib :: FilePath -> FilePath -> Action ()
registerStaticLib root archivePath = do
-- Simply need the ghc-pkg database .conf file.
- GhcPkgPath _ stage _ (LibA name _ w)
+ GhcPkgPath _ stage _ (LibA name _ _ w)
<- parsePath (parseGhcPkgLibA root)
"<.a library (register) path parser>"
archivePath
@@ -56,7 +56,7 @@ registerStaticLib root archivePath = do
-- the second argument.
buildStaticLib :: FilePath -> FilePath -> Action ()
buildStaticLib root archivePath = do
- l@(BuildPath _ stage _ (LibA pkgname _ way))
+ l@(BuildPath _ stage _ (LibA pkgname _ _ way))
<- parsePath (parseBuildLibA root)
"<.a library (build) path parser>"
archivePath
@@ -75,7 +75,7 @@ buildStaticLib root archivePath = do
registerDynamicLib :: FilePath -> String -> FilePath -> Action ()
registerDynamicLib root suffix dynlibpath = do
-- Simply need the ghc-pkg database .conf file.
- (GhcPkgPath _ stage _ (LibDyn name _ w _))
+ (GhcPkgPath _ stage _ (LibDyn name _ _ w _))
<- parsePath (parseGhcPkgLibDyn root suffix)
"<dyn register lib parser>"
dynlibpath
@@ -99,7 +99,7 @@ buildDynamicLib root suffix dynlibpath = do
-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
buildGhciLibO :: FilePath -> FilePath -> Action ()
buildGhciLibO root ghcilibPath = do
- l@(BuildPath _ stage _ (LibGhci _ _ _))
+ l@(BuildPath _ stage _ (LibGhci _ _ _ _))
<- parsePath (parseBuildLibGhci root)
"<.o ghci lib (build) path parser>"
ghcilibPath
@@ -134,7 +134,7 @@ files etc.
buildPackage :: FilePath -> FilePath -> Action ()
buildPackage root fp = do
- l@(BuildPath _ _ _ (PkgStamp _ _ way)) <- parsePath (parseStampPath root) "<.stamp parser>" fp
+ l@(BuildPath _ _ _ (PkgStamp _ _ _ way)) <- parsePath (parseStampPath root) "<.stamp parser>" fp
let ctx = stampContext l
srcs <- hsSources ctx
gens <- interpretInContext ctx generatedDependencies
@@ -226,47 +226,47 @@ needLibrary cs = need =<< concatMapM (libraryTargets True) cs
-- * Library paths types and parsers
--- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
-data LibA = LibA String [Integer] Way deriving (Eq, Show)
+-- | > libHS<pkg name>-<pkg version>-<pkg hash>[_<way suffix>].a
+data LibA = LibA String [Integer] String Way deriving (Eq, Show)
-- | > <so or dylib>
data DynLibExt = So | Dylib deriving (Eq, Show)
--- | > libHS<pkg name>-<pkg version>[_<way suffix>]-ghc<ghc version>.<so|dylib>
-data LibDyn = LibDyn String [Integer] Way DynLibExt deriving (Eq, Show)
+-- | > libHS<pkg name>-<pkg version>-<pkg hash>[_<way suffix>]-ghc<ghc version>.<so|dylib>
+data LibDyn = LibDyn String [Integer] String Way DynLibExt deriving (Eq, Show)
--- | > HS<pkg name>-<pkg version>[_<way suffix>].o
-data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show)
+-- | > HS<pkg name>-<pkg version>-<pkg hash>[_<way suffix>].o
+data LibGhci = LibGhci String [Integer] String Way deriving (Eq, Show)
-- | Get the 'Context' corresponding to the build path for a given static library.
libAContext :: BuildPath LibA -> Context
-libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) =
+libAContext (BuildPath _ stage pkgpath (LibA pkgname _ _ way)) =
Context stage pkg way Final
where
pkg = library pkgname pkgpath
-- | Get the 'Context' corresponding to the build path for a given GHCi library.
libGhciContext :: BuildPath LibGhci -> Context
-libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way)) =
+libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ _ way)) =
Context stage pkg way Final
where
pkg = library pkgname pkgpath
-- | Get the 'Context' corresponding to the build path for a given dynamic library.
libDynContext :: BuildPath LibDyn -> Context
-libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) =
+libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ _ way _)) =
Context stage pkg way Final
where
pkg = library pkgname pkgpath
-- | Get the 'Context' corresponding to the build path for a given static library.
stampContext :: BuildPath PkgStamp -> Context
-stampContext (BuildPath _ stage _ (PkgStamp pkgname _ way)) =
+stampContext (BuildPath _ stage _ (PkgStamp pkgname _ _ way)) =
Context stage pkg way Final
where
pkg = unsafeFindPackageByName pkgname
-data PkgStamp = PkgStamp String [Integer] Way deriving (Eq, Show)
+data PkgStamp = PkgStamp String [Integer] String Way deriving (Eq, Show)
-- | Parse a path to a ghci library to be built, making sure the path starts
@@ -313,34 +313,34 @@ parseGhcPkgLibDyn root ext = parseGhcPkgPath root (parseLibDynFilename ext)
parseLibAFilename :: Parsec.Parsec String () LibA
parseLibAFilename = do
_ <- Parsec.string "libHS"
- (pkgname, pkgver) <- parsePkgId
+ (pkgname, pkgver, pkghash) <- parsePkgId
way <- parseWaySuffix vanilla
_ <- Parsec.string ".a"
- return (LibA pkgname pkgver way)
+ return (LibA pkgname pkgver pkghash way)
-- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
parseLibGhciFilename :: Parsec.Parsec String () LibGhci
parseLibGhciFilename = do
_ <- Parsec.string "HS"
- (pkgname, pkgver) <- parsePkgId
+ (pkgname, pkgver, pkghash) <- parsePkgId
_ <- Parsec.string "."
way <- parseWayPrefix vanilla
_ <- Parsec.string "o"
- return (LibGhci pkgname pkgver way)
+ return (LibGhci pkgname pkgver pkghash way)
-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
parseLibDynFilename ext = do
_ <- Parsec.string "libHS"
- (pkgname, pkgver) <- parsePkgId
+ (pkgname, pkgver, pkghash) <- parsePkgId
way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
_ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
_ <- Parsec.string ("." ++ ext)
- return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
+ return (LibDyn pkgname pkgver pkghash way $ if ext == "so" then So else Dylib)
parseStamp :: Parsec.Parsec String () PkgStamp
parseStamp = do
_ <- Parsec.string "stamp-"
- (pkgname, pkgver) <- parsePkgId
+ (pkgname, pkgver, pkghash) <- parsePkgId
way <- parseWaySuffix vanilla
- return (PkgStamp pkgname pkgver way)
+ return (PkgStamp pkgname pkgver pkghash way)
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
module Rules.Register (
configurePackageRules, registerPackageRules, registerPackages,
libraryTargets
@@ -20,11 +21,15 @@ import Utilities
import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec as Parsec
import qualified Data.Set as Set
+import qualified Data.Char as Char
+import Data.Bifunctor (bimap)
import Distribution.Version (Version)
-import qualified Distribution.Parsec as Cabal
-import qualified Distribution.Types.PackageName as Cabal
import qualified Distribution.Types.PackageId as Cabal
+import qualified Distribution.Types.PackageName as Cabal
+import qualified Distribution.Parsec as Cabal
+import qualified Distribution.Parsec.FieldLineStream as Cabal
+import qualified Distribution.Compat.CharParsing as CabalCharParsing
import qualified Hadrian.Haskell.Cabal.Parse as Cabal
import qualified System.Directory as IO
@@ -183,7 +188,7 @@ buildConfFinal rs context at Context {..} _conf = do
-- so that if any change ends up modifying a library (but not its .conf
-- file), we still rebuild things that depend on it.
dir <- (-/-) <$> libPath context <*> distDir stage
- pkgid <- pkgIdentifier package
+ pkgid <- pkgUnitId context package
files <- liftIO $
(++) <$> getDirectoryFilesIO "." [dir -/- "*libHS"++pkgid++"*"]
<*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
@@ -251,11 +256,32 @@ getPackageNameFromConfFile conf
takeBaseName conf ++ ": " ++ err
Right (name, _) -> return name
+-- | Parse a cabal-like name
parseCabalName :: String -> Either String (String, Version)
-parseCabalName = fmap f . Cabal.eitherParsec
+-- Try to parse a name with a hash, but otherwise parse a name without one.
+parseCabalName s = bimap show id (Cabal.runParsecParser nameWithHashParser "<parseCabalName>" $ Cabal.fieldLineStreamFromString s)
+ <|> fmap f (Cabal.eitherParsec s)
where
f :: Cabal.PackageId -> (String, Version)
f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)
+ -- Definition similar to 'Parsec PackageIdentifier' from Cabal but extended
+ -- with logic for parsing the hash (despite not returning it)
+ nameWithHashParser :: Cabal.ParsecParser (String, Version)
+ nameWithHashParser = Cabal.PP $ \_ -> do
+ xs' <- Parsec.sepBy component (Parsec.char '-')
+ case reverse xs' of
+ _hash:version_str:xs ->
+ case Cabal.simpleParsec @Version version_str of
+ Nothing -> fail ("failed to parse a version from " <> version_str)
+ Just v ->
+ if not (null xs) && all (\c -> all (/= '.') c && not (all Char.isDigit c)) xs
+ then return $ (intercalate "-" (reverse xs), v)
+ else fail "all digits or a dot in a portion of package name"
+ _ -> fail "couldn't parse a hash, a version and a name"
+ where
+ component = CabalCharParsing.munch1 (\c -> Char.isAlphaNum c || c == '.')
+
+
-- | Return extra library targets.
extraTargets :: Context -> Action [FilePath]
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -84,8 +84,9 @@ cabalSetupArgs = builder (Cabal Setup) ? do
commonCabalArgs :: Stage -> Args
commonCabalArgs stage = do
verbosity <- expr getVerbosity
+ ctx <- getContext
pkg <- getPackage
- package_id <- expr $ pkgIdentifier pkg
+ package_id <- expr $ pkgUnitId ctx pkg
let prefix = "${pkgroot}" ++ (if windowsHost then "" else "/..")
mconcat [ -- Don't strip libraries when cross compiling.
-- TODO: We need to set @--with-strip=(stripCmdPath :: Action FilePath)@,
@@ -101,7 +102,7 @@ commonCabalArgs stage = do
, arg "--cabal-file"
, arg $ pkgCabalFile pkg
, arg "--ipid"
- , arg "$pkg-$version"
+ , arg package_id
, arg "--prefix"
, arg prefix
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -243,21 +243,24 @@ wayGhcArgs = do
, (way == debug || way == debugDynamic) ?
pure ["-ticky", "-DTICKY_TICKY"] ]
+-- | Args related to correct handling of packages, such as setting
+-- -this-unit-id and passing -package-id for dependencies
packageGhcArgs :: Args
packageGhcArgs = do
package <- getPackage
+ ctx <- getContext
ghc_ver <- readVersion <$> (expr . ghcVersionStage =<< getStage)
-- ROMES: Until the boot compiler no longer needs ghc's
-- unit-id to be "ghc", the stage0 compiler must be built
-- with `-this-unit-id ghc`, while the wired-in unit-id of
-- ghc is correctly set to the unit-id we'll generate for
- -- stage1 (set in generateVersionHs in Rules.Generate).
+ -- stage1 (set in generateConfigHs in Rules.Generate).
--
-- However, we don't need to set the unit-id of "ghc" to "ghc" when
-- building stage0 because we have a flag in compiler/ghc.cabal.in that is
-- sets `-this-unit-id ghc` when hadrian is building stage0, which will
-- overwrite this one.
- pkgId <- expr $ pkgIdentifier package
+ pkgId <- expr $ pkgUnitId ctx package
mconcat [ arg "-hide-all-packages"
, arg "-no-user-package-db"
, arg "-package-env -"
=====================================
hadrian/src/Settings/Builders/Haddock.hs
=====================================
@@ -42,7 +42,7 @@ haddockBuilderArgs = mconcat
version <- expr $ pkgVersion pkg
synopsis <- expr $ pkgSynopsis pkg
haddocks <- expr $ haddockDependencies context
- haddocks_with_versions <- expr $ sequence $ [(,h) <$> pkgIdentifier p | (p, h) <- haddocks]
+ haddocks_with_versions <- expr $ sequence $ [(,h) <$> pkgUnitId context p | (p, h) <- haddocks]
hVersion <- expr $ pkgVersion haddock
statsDir <- expr $ haddockStatsFilesDir
baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
=====================================
testsuite/driver/testlib.py
=====================================
@@ -930,8 +930,9 @@ def normalise_win32_io_errors(name, opts):
def normalise_version_( *pkgs ):
def normalise_version__( str ):
- return re.sub('(' + '|'.join(map(re.escape,pkgs)) + ')-[0-9.]+(-[0-9a-f]+)?',
- '\\1-<VERSION>', str)
+ # (name)(-version)(-hash)(-components)
+ return re.sub('(' + '|'.join(map(re.escape,pkgs)) + ')-[0-9.]+(-[0-9a-zA-Z]+)?(-[0-9a-zA-Z]+)?',
+ '\\1-<VERSION>-<HASH>', str)
return normalise_version__
def normalise_version( *pkgs ):
=====================================
testsuite/tests/backpack/cabal/bkpcabal02/all.T
=====================================
@@ -5,6 +5,6 @@ else:
test('bkpcabal02',
[extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']),
- js_broken(22351)],
+ js_broken(22351), normalise_version('bkpcabal01')],
run_command,
['$MAKE -s --no-print-directory bkpcabal02 ' + cleanup])
=====================================
testsuite/tests/cabal/t18567/all.T
=====================================
@@ -6,6 +6,7 @@ else:
test('T18567',
[ extra_files(['Setup.hs', 'sublib/', 'sublib-unused', 'src/', 'internal-lib.cabal'])
, js_broken(22356)
+ , normalise_version('internal-lib')
],
run_command,
['$MAKE -s --no-print-directory T18567 ' + cleanup])
=====================================
testsuite/tests/driver/T16318/Makefile
=====================================
@@ -5,7 +5,7 @@ include $(TOP)/mk/test.mk
test_pe = test-package-environment
T16318:
- "$(GHC_PKG)" latest base > $(test_pe)
+ "$(GHC_PKG)" field base id --simple-output > $(test_pe)
"$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1
C=`cat out | grep "Loaded package environment" -c` ; \
if [ $$C != "1" ]; then false; fi
=====================================
testsuite/tests/driver/T18125/Makefile
=====================================
@@ -6,8 +6,8 @@ test_pe = test-package-environment
test_lib = containers
T18125:
- "$(GHC_PKG)" latest base > $(test_pe)
- "$(GHC_PKG)" latest $(test_lib) >> $(test_pe)
+ "$(GHC_PKG)" field base id --simple-output > $(test_pe)
+ "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe)
"$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1
C=`cat out | grep "$(test_lib)" -c` ; \
if [ $$C != "1" ]; then false; fi
=====================================
testsuite/tests/ghci/scripts/Makefile
=====================================
@@ -69,4 +69,4 @@ T12023:
.PHONY: T19650_setup
T19650_setup:
- '$(GHC_PKG)' latest base > my_package_env
+ '$(GHC_PKG)' field base id --simple-output > my_package_env
=====================================
testsuite/tests/package/T4806a.stderr
=====================================
@@ -1,7 +1,7 @@
T4806a.hs:1:1: error:
Could not load module ‘Data.Map’
- It is a member of the package ‘containers-0.6.6’
+ It is a member of the package ‘containers-0.6.7-4362’
which is unusable because the -ignore-package flag was used to ignore at least one of its dependencies:
- deepseq-1.4.8.0 template-haskell-2.20.0.0
+ deepseq-1.4.8.1-c027 template-haskell-2.20.0.0-4d68
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -23,6 +23,7 @@
module Main (main) where
+import Debug.Trace
import qualified GHC.Unit.Database as GhcPkg
import GHC.Unit.Database hiding (mkMungePathUrl)
import GHC.HandleEncoding
@@ -1600,7 +1601,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
simplePackageList my_flags pkgs = do
let showPkg :: InstalledPackageInfo -> String
- showPkg | FlagShowUnitIds `elem` my_flags = display . installedUnitId
+ showPkg | FlagShowUnitIds `elem` my_flags = traceId . display . installedUnitId
| FlagNamesOnly `elem` my_flags = display . mungedName . mungedId
| otherwise = display . mungedId
strs = map showPkg pkgs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cdf5a0eefbe40a9b9c88cb7a8fac85a4508eb1c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cdf5a0eefbe40a9b9c88cb7a8fac85a4508eb1c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230327/e1f9b1f8/attachment-0001.html>
More information about the ghc-commits
mailing list