[Git][ghc/ghc][wip/romes/hardwire-ghc-unit-id] WIP: Better Hash

Rodrigo Mesquita (@alt-romes) gitlab at gitlab.haskell.org
Tue Mar 21 16:18:17 UTC 2023



Rodrigo Mesquita pushed to branch wip/romes/hardwire-ghc-unit-id at Glasgow Haskell Compiler / GHC


Commits:
19f95b6e by romes at 2023-03-21T16:18:02+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,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)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19f95b6e29cd3f24363bc886806cb0aa21805a33

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19f95b6e29cd3f24363bc886806cb0aa21805a33
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/47f291f6/attachment-0001.html>


More information about the ghc-commits mailing list