[Git][ghc/ghc][wip/romes/hardwire-ghc-unit-id] WIP: Better Hash
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Tue Mar 21 14:49:39 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/hardwire-ghc-unit-id at Glasgow Haskell Compiler / GHC
Commits:
85d2e6b4 by romes at 2023-03-21T14:49:21+00:00
WIP: Better Hash
Co-author: @mpickering
TODO: Fix identifier of rts which is depended on.
What about the simple identifiers in haddocks?
Perhaps we only need the full unitid for the pacckage databases.
If filepaths have hashes then cabal can't parse them
The wrong way to handle this. Reverting...
Revert "If filepaths have hashes then cabal can't parse them"
This reverts commit 91d45aee4e3509fd258c498f5f19b0efedd58fbc.
Revert "Revert "If filepaths have hashes then cabal can't parse them""
This reverts commit 4aab197ed680cc5d192c4845c009c4bd1871535e.
IWP
- - - - -
18 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
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
=====================================
@@ -112,16 +112,24 @@ parseWayUnit = Parsec.choice
-- | Parse a @"pkgname-pkgversion"@ 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>)"
+parsePkgId :: Parsec.Parsec String () (String, [Integer], String)
+parsePkgId = parseRTS <|> (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
+ Parsec.choice [ (,,) newName <$> parsePkgVersion <*> (Parsec.char '-' *> parsePkgHash)
, parsePkgId' newName ]
+ parseRTS = do
+ _ <- Parsec.string "rts" <* Parsec.char '-'
+ v <- parsePkgVersion
+ pure ("rts", v, "")
+
+parsePkgHash :: Parsec.Parsec String () String
+parsePkgHash = Parsec.many1 Parsec.alphaNum
+
-- | Parse "."-separated integers that describe a package's version.
parsePkgVersion :: Parsec.Parsec String () [Integer]
parsePkgVersion = fmap reverse (parsePkgVersion' [])
=====================================
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,
+ pkgDependencies, pkgGenericDescription, cabalArchString, cabalOsString
) where
import Development.Shake
@@ -20,20 +20,13 @@ 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 .
--- The Cabal file is tracked.
-pkgIdentifier :: Package -> Action String
-pkgIdentifier package = do
- cabal <- readPackageData package
- return $ if null (version cabal)
- then name cabal
- else name cabal ++ "-" ++ version cabal
-
-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
pkgSynopsis :: Package -> Action String
pkgSynopsis = fmap synopsis . readPackageData
@@ -72,3 +65,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,245 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Haskell.Hash (pkgUnitId, pkgHashOracle) where
+
+import Development.Shake
+
+import Hadrian.Haskell.Cabal.Type as C
+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... rTS BReaks. At some
+ -- point it's not even clear which way we're building
+ 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
+ -- liftIO $ print $ pid <> "-" <> truncateHash 4 phash
+ pure $ pid <> "-" <> truncateHash 4 phash
+
+ where
+ truncateHash :: Int -> String -> String
+ truncateHash = take
+
+-- | 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.
+--
+-- 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 C.name cabal
+ else C.name cabal ++ "-" ++ version cabal
+
+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
+
+-- TODO: Needs to be oracle to be cached? Called lots of times
+pkgHashOracle :: Rules ()
+pkgHashOracle = void $ addOracleCache $ \(PkgHashKey ctx) -> do
+ -- RECURSIVE ORACLE: ctx_data <- readContextData ctx
+ pkg_data <- readPackageData (package ctx)
+ name <- pkgSimpleIdentifier (package ctx)
+ let stag = stage ctx
+ liftIO $ print ("Package and Package Dependencies", package ctx, packageDependencies pkg_data)
+ stagePkgs <- stagePackages stag
+ depsHashes <- mapM (\pkg -> pkgHash (ctx { package = pkg })) [pkg | pkg <- packageDependencies pkg_data, pkg `elem` stagePkgs]
+ liftIO $ print ("Pkg Deps Hashes", depsHashes)
+ 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
+ -- TODO: fullyStatic flavour transformer
+ pkgHashFullyStaticExe = False
+ 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 -- Map.singleton "ghc" ghcArgs
+ 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.empty
+ , 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,14 @@ 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' to create the unit-id in both situations.
+ cProjectUnitId <- expr . (`pkgUnitId` ghc) =<< getContext
return $ unlines
[ "module GHC.Settings.Config"
, " ( module GHC.Version"
@@ -593,3 +592,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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85d2e6b40e60eb511fecafa3c3a0f7cd3fcd5cb7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85d2e6b40e60eb511fecafa3c3a0f7cd3fcd5cb7
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/20230321/9e9e6b5c/attachment-0001.html>
More information about the ghc-commits
mailing list