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 (stage context) package
     return $ prefix ++ pid ++ suffix
 
 pkgFile :: Context -> String -> String -> Action FilePath
 pkgFile context@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@.
 pkgHaddockFile :: Context -> Action FilePath
-pkgHaddockFile Context {..} = do
+pkgHaddockFile context@Context {..} = do
     root <- buildRoot
-    version <- pkgIdentifier package
+    version <- pkgUnitId stage 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@Context {..} = do
     libDir    <- libPath context
-    pkgId     <- pkgIdentifier package
+    pkgId     <- pkgUnitId stage package
     fileName  <- pkgRegisteredLibraryFileName context
     distDir   <- distDir stage
     return $ if Dynamic `wayUnit` way
@@ -115,9 +115,9 @@ pkgRegisteredLibraryFile context@Context {..} = do
 
 -- | Just the final filename portion of pkgRegisteredLibraryFile
 pkgRegisteredLibraryFileName :: Context -> Action FilePath
-pkgRegisteredLibraryFileName Context{..} = do
+pkgRegisteredLibraryFileName context@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@Context {..} = do
 
 -- | Path to the configuration file of a given 'Context'.
 pkgConfFile :: Context -> Action FilePath
-pkgConfFile Context {..} = do
-    pid  <- pkgIdentifier package
+pkgConfFile context@Context {..} = do
+    pid  <- pkgUnitId stage package
     dbPath <- packageDbPath (PackageDbLoc stage iplace)
     return $ dbPath -/- pid <.> "conf"
 

hadrian/src/Flavour.hs

@@ -112,7 +112,7 @@ parseFlavour baseFlavours transformers str =
 
 -- | Add arguments to the 'args' of a 'Flavour'.
 addArgs :: Args -> Flavour -> Flavour
-addArgs args' fl = fl { args = args fl <> args' }
+addArgs args' fl = fl { extraArgs = extraArgs fl <> args' }
 
 -- | Turn on -Werror for packages built with the stage1 compiler.
 -- It mimics the CI settings so is useful to turn on when developing.
@@ -468,7 +468,7 @@ applySetting (KeyVal ks op v) = case runSettingsM ks builderPredicate of
   Left err -> throwError $
       "error while setting `" ++ intercalate "`." ks ++ ": " ++ err
   Right pred -> Right $ \flav -> flav
-    { args = update (args flav) pred }
+    { extraArgs = update (extraArgs flav) pred }
 
   where override arguments predicate = do
           holds <- predicate

hadrian/src/Flavour/Type.hs

@@ -14,8 +14,9 @@ import Data.Set (Set)
 data Flavour = Flavour {
     -- | Flavour name, to select this flavour from command line.
     name :: String,
-    -- | Use these command line arguments.
-    args :: Args,
+    -- | Use these extra command line arguments.
+    -- This can't depend on the result of configuring a package (ie, using readContextData)
+    extraArgs :: Args,
     -- | Build these packages.
     packages :: Stage -> Action [Package],
     -- | Bignum backend: 'native', 'gmp', 'ffi', etc.

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/Builder/Git.hs

@@ -2,12 +2,13 @@ module Hadrian.Builder.Git (gitArgs) where
 
 import Expression
 
--- | Default command line arguments for invoking the archiving utility @tar@.
+-- | Default command line arguments for invoking the archiving utility @git@.
 gitArgs :: Args
 gitArgs = mconcat
   [ builder (Git ListFiles) ? mconcat
       [ arg "ls-files"
       , arg "--recurse-submodules"
       , arg "-z"
+      , getInputs
       ]
   ]

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@.
+-- | Read a Cabal file and return the package identifier without a hash, e.g. @base-4.10.0.0@.
 -- 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

@@ -63,7 +63,6 @@ import Hadrian.Target
 import Base
 import Builder
 import Context
-import Flavour
 import Settings
 import Distribution.Simple.LocalBuildInfo
 import qualified Distribution.Simple.Register as C
@@ -158,9 +157,8 @@ configurePackage context@Context {..} = do
             pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
 
     -- Compute the list of flags, and the Cabal configuration arguments
-    flavourArgs <- args <$> flavour
-    flagList    <- interpret (target context (Cabal Flags stage) [] []) flavourArgs
-    argList     <- interpret (target context (Cabal Setup stage) [] []) flavourArgs
+    flagList    <- interpret (target context (Cabal Flags stage) [] []) getArgs
+    argList     <- interpret (target context (Cabal Setup stage) [] []) getArgs
     trackArgsHash (target context (Cabal Flags stage) [] [])
     trackArgsHash (target context (Cabal Setup stage) [] [])
     verbosity   <- getVerbosity
@@ -345,7 +343,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 (stage context) (package context)
     -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
     -- from the local build info @lbi@.
     lbi <- liftIO $ C.getPersistBuildConfig cPath
@@ -357,12 +355,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 +371,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@.

hadrian/src/Hadrian/Haskell/Hash.hs

+{-# 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.ByteString as BS (readFile)
+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
+import Packages
+import Development.Shake.Classes
+import Control.Monad
+import Utilities
+import Base
+import Context
+import System.Directory.Extra (listFilesRecursive)
+import CommandLine
+import Control.Arrow (first)
+
+
+-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0-abcd@.
+-- This needs to be an oracle so it's cached
+pkgUnitId :: Stage -> Package -> Action String
+pkgUnitId stg pkg = do
+  pid   <- pkgSimpleIdentifier pkg
+  use_hash <- cmdUnitIdHash
+  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
+        hash <- if use_hash
+                  then do
+                    phash <- pkgHash stg pkg
+                    return $ truncateHash 4 phash
+                  else
+                    return "inplace"
+        pure $ pid <> "-" <> hash
+
+  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
+       pkgHashVanillaLib          :: Bool,
+       pkgHashSharedLib           :: Bool,
+       pkgHashDynExe              :: Bool,
+       pkgHashGHCiLib             :: Bool,
+       pkgHashProfLib             :: Bool,
+       pkgHashProfExe             :: Bool,
+       pkgHashSplitObjs           :: Bool,
+       pkgHashSplitSections       :: Bool,
+       pkgHashStripLibs           :: Bool,
+       pkgHashStripExes           :: Bool,
+       pkgHashProgramArgs         :: Map String [String]
+       -- pkgHashProgPrefix          :: Maybe PathTemplate,
+       -- pkgHashProgSuffix          :: Maybe PathTemplate,
+       -- pkgHashPackageDbs          :: [Maybe PackageDB]
+       -- Captured by extraArgs
+--       pkgHashDebugInfo           :: DebugInfoLevel,
+--       pkgHashCoverage            :: Bool,
+--       pkgHashFullyStaticExe      :: Bool,
+--       pkgHashProfLibDetail       :: ProfDetailLevel,
+--       pkgHashOptimization        :: Int,
+--       pkgHashProfExeDetail       :: ProfDetailLevel,
+--       pkgHashExtraLibDirs        :: [FilePath],
+--       pkgHashExtraLibDirsStatic  :: [FilePath],
+--       pkgHashExtraFrameworkDirs  :: [FilePath],
+--       pkgHashExtraIncludeDirs    :: [FilePath]
+     }
+  deriving Show
+
+newtype PkgHashKey = PkgHashKey (Stage, Package)
+  deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult PkgHashKey = String
+
+pkgHash :: Stage -> Package -> Action String
+pkgHash stg p = askOracle . PkgHashKey $ (stg, p)
+
+-- Needs to be an oracle to be cached. Called lots of times.
+pkgHashOracle :: Rules ()
+pkgHashOracle = void $ addOracleCache $ \(PkgHashKey (stag, pkg)) -> do
+  let vanilla_ctx = vanillaContext stag pkg
+  pkg_data <- readPackageData pkg
+  name <- pkgSimpleIdentifier pkg
+  stagePkgs <- stagePackages stag
+
+  depsHashes <- sequence [pkgHash stag pkg' | pkg' <- packageDependencies pkg_data, pkg' `elem` stagePkgs]
+
+  flav <- flavour
+  let flavourArgs = extraArgs flav
+
+  targetOs       <- setting TargetOs
+  projectVersion <- setting ProjectVersion
+  let pkgHashCompilerId = "ghc-" ++ projectVersion
+      pkgHashPlatform = targetOs
+
+  libWays <- interpretInContext vanilla_ctx (libraryWays flav)
+  dyn_ghc <- dynamicGhcPrograms flav
+  flags <-  interpret (target vanilla_ctx (Cabal Flags stag) [] []) getArgs
+  let pkgHashFlagAssignment = flags
+      pkgHashVanillaLib = vanilla `Set.member` libWays
+      pkgHashSharedLib = dynamic `Set.member` libWays
+      pkgHashDynExe = dyn_ghc
+      pkgHashGHCiLib = False
+      pkgHashProfLib = profiling `Set.member` libWays
+      pkgHashProfExe = pkg == ghc && ghcProfiled flav stag
+      pkgHashSplitObjs = False -- Deprecated
+      pkgHashSplitSections = ghcSplitSections flav
+      pkgHashStripExes = False
+      pkgHashStripLibs = False
+
+  pkgHashProgramArgs <- Map.unions <$> (forM (Set.toList libWays) $ \lib_way -> do
+    let ctx = vanilla_ctx { way = lib_way }
+    ghcArgs <- interpret (target ctx (Ghc CompileHs stag) [] []) flavourArgs
+    ghcCArgs <- interpret (target ctx (Ghc CompileCWithGhc stag) [] []) flavourArgs
+    linkArgs <- interpret (target ctx (Ghc LinkHs stag) [] []) flavourArgs
+    ccArgs  <- interpret (target ctx (Cc CompileC stag) [] []) flavourArgs
+    hsc2hsArgs <- interpret (target ctx (Hsc2Hs stag) [] []) flavourArgs
+    -- TODO: Other arguments for other things (a user could pass extra options to any
+    -- builder we know about and we need to enumerate them here)
+    return $ Map.fromList (map (first (++ waySuffix lib_way))
+                           [("ghc", ghcArgs)
+                           ,("ghc-c", ghcCArgs)
+                           ,("ghc-link", linkArgs)
+                           ,("hsc2hs", hsc2hsArgs)
+                           ,("cc", ccArgs) ]))
+
+  let other_config = PackageHashConfigInputs{..}
+
+  files <- allFilesInDirectory (pkgPath pkg)
+  need files
+  files_hash <- liftIO (SHA256.finalize <$> hashFiles (SHA256.init) files)
+
+  return $ BS.unpack $ Base16.encode $ SHA256.hash $
+    renderPackageHashInputs $ PackageHashInputs
+    {
+       pkgHashPkgId       = name
+    ,  pkgHashComponent   = pkgType pkg
+    ,  pkgHashSourceHash  = files_hash
+    ,  pkgHashDirectDeps  = Set.fromList depsHashes
+    ,  pkgHashOtherConfig = other_config
+    }
+
+allFilesInDirectory :: FilePath -> Action [FilePath]
+allFilesInDirectory dir = liftIO $ listFilesRecursive dir
+
+-- Either use git ls-tree if we are in a git repo, otherwise just get all the
+-- files in the given directory.
+{- Deb9 toolchain is too old to support git ls-tree properly
+  git_tree <- isInGitTree
+  if git_tree
+    then do
+      let gitFiles = filter fileFilter . split (=='\NUL')
+          fileFilter file = not (null file) && ((dir ++ "/*") ?== file)
+      gitFiles <$> askWithResources [] (target (vanillaContext stage0Boot compiler)  -- This value doesn't matter.
+                                               (Git ListFiles) [dir] [])
+    else
+      liftIO $ listFilesRecursive dir
+
+
+isInGitTree :: Action Bool
+isInGitTree = do
+  git_commit <- setting ProjectGitCommitId
+  -- git_commit is not set if we are in a source dist
+  return $ not ("" == git_commit)
+-}
+
+
+
+hashFiles :: SHA256.Ctx -> [FilePath] -> IO SHA256.Ctx
+hashFiles = foldM hashFile
+
+hashFile :: SHA256.Ctx -> FilePath -> IO SHA256.Ctx
+hashFile !ctx fp = do
+  contents <- BS.readFile fp
+  return $! SHA256.update ctx contents
+
+
+renderPackageHashInputs :: PackageHashInputs -> BS.ByteString
+renderPackageHashInputs PackageHashInputs{
+                          pkgHashPkgId,
+                          pkgHashComponent,
+                          pkgHashSourceHash,
+                          pkgHashDirectDeps,
+                          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"       show pkgHashPkgId
+      , entry "component"  show pkgHashComponent
+      , entry "src"         show pkgHashSourceHash
+      , entry "deps"        (intercalate ", " . map show
+                                              . Set.toList) pkgHashDirectDeps
+        -- and then all the config
+      , entry "compilerid"  show pkgHashCompilerId
+      , entry "platform" show pkgHashPlatform
+      , opt   "flags" mempty show pkgHashFlagAssignment
+      , opt   "vanilla-lib" True  show pkgHashVanillaLib
+      , opt   "shared-lib"  False show pkgHashSharedLib
+      , opt   "dynamic-exe" False show pkgHashDynExe
+      , opt   "ghci-lib"    False show pkgHashGHCiLib
+      , opt   "prof-lib"    False show pkgHashProfLib
+      , opt   "prof-exe"    False show pkgHashProfExe
+      , opt   "split-objs"   False show pkgHashSplitObjs
+      , opt   "split-sections" False show pkgHashSplitSections
+      , opt   "stripped-lib" False show pkgHashStripLibs
+      , opt   "stripped-exe" True  show pkgHashStripExes
+      ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs
+  where
+    entry key     format value = Just (key ++ ": " ++ format value)
+    opt   key def format value
+         | value == def = Nothing
+         | otherwise    = entry key format value

hadrian/src/Hadrian/Haskell/Hash.hs-boot

+module Hadrian.Haskell.Hash where
+
+import Hadrian.Package
+import Stage
+import Development.Shake
+
+pkgUnitId :: Stage -> Package -> Action String
+

hadrian/src/Hadrian/Package.hs

@@ -81,4 +81,4 @@ instance NFData   PackageType
 
 instance Binary   Package
 instance Hashable Package
-instance NFData   Package
+instance NFData   Package
\ No newline at end of file

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 Stage1 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 Stage1 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
@@ -483,6 +484,15 @@ generateConfigHs = do
     trackGenerateHs
     cProjectName        <- getSetting ProjectName
     cBooterVersion      <- getSetting GhcVersion
+    -- 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 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) =<< getStage
     return $ unlines
         [ "module GHC.Settings.Config"
         , "  ( module GHC.Version"
@@ -491,6 +501,7 @@ generateConfigHs = do
         , "  , cProjectName"
         , "  , cBooterVersion"
         , "  , cStage"
+        , "  , cProjectUnitId"
         , "  ) where"
         , ""
         , "import GHC.Prelude.Basic"
@@ -511,6 +522,9 @@ generateConfigHs = do
         , ""
         , "cStage                :: String"
         , "cStage                = show (" ++ stageString stage ++ " :: Int)"
+        , ""
+        , "cProjectUnitId :: String"
+        , "cProjectUnitId = " ++ show cProjectUnitId
         ]
   where
     stageString (Stage0 InTreeLibs) = "1"
@@ -530,6 +544,7 @@ generateVersionHs = do
     cProjectPatchLevel  <- getSetting ProjectPatchLevel
     cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
     cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
+
     return $ unlines
         [ "module GHC.Version where"
         , ""
@@ -574,3 +589,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

+{-# LANGUAGE TypeApplications #-}
 module Rules.Register (
     configurePackageRules, registerPackageRules, registerPackages,
     libraryTargets
@@ -20,11 +21,16 @@ 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.Compat.Parsing 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 +189,7 @@ buildConfFinal rs context@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 stage package
     files <- liftIO $
       (++) <$> getDirectoryFilesIO "." [dir -/- "*libHS"++pkgid++"*"]
            <*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
@@ -251,11 +257,33 @@ 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 parser "<parseCabalName>" $ Cabal.fieldLineStreamFromString s)
   where
-    f :: Cabal.PackageId -> (String, Version)
-    f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)
+    parser = Cabal.try nameWithHashParser <|> (extractVersion <$> Cabal.parsec)
+
+    extractVersion :: Cabal.PackageId -> (String, Version)
+    extractVersion 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.hs

 {-# LANGUAGE TupleSections #-}
 
 module Settings (
-    getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
+    getExtraArgs, getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
     findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath,
     isLibrary, stagePackages, getBignumBackend, getBignumCheck, completeSetting
     ) where
@@ -25,8 +25,11 @@ import Settings.Flavours.Validate
 import Settings.Flavours.Release
 
 
+getExtraArgs :: Args
+getExtraArgs = expr flavour >>= extraArgs
+
 getArgs :: Args
-getArgs = expr flavour >>= args
+getArgs = mconcat [ defaultBuilderArgs, getExtraArgs, defaultPackageArgs ]
 
 getLibraryWays :: Ways
 getLibraryWays = expr flavour >>= libraryWays

hadrian/src/Settings/Builders/Cabal.hs

@@ -85,7 +85,7 @@ commonCabalArgs :: Stage -> Args
 commonCabalArgs stage = do
   verbosity <- expr getVerbosity
   pkg       <- getPackage
-  package_id <- expr $ pkgIdentifier pkg
+  package_id <- expr $ pkgUnitId stage 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 +101,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

@@ -39,6 +39,7 @@ toolArgs = do
               , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
               , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
               , map ("-optP" ++) <$> getContextData cppOpts
+              , getContextData hcOpts
               ]
 
 compileAndLinkHs :: Args
@@ -228,6 +229,8 @@ commonGhcArgs = do
               -- input hash to avoid superfluous recompilation, avoiding
               -- #18672.
               arg "-fdiagnostics-color=always"
+            -- Important this is last.. as these options can override the default options
+            , getContextData hcOpts
             ]
 
 -- TODO: Do '-ticky' in all debug ways?
@@ -243,11 +246,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
+    stage <- getStage
     ghc_ver <- readVersion <$> (expr . ghcVersionStage =<< getStage)
-    pkgId   <- expr $ pkgIdentifier package
+    -- 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 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 $ pkgUnitId stage package
     mconcat [ arg "-hide-all-packages"
             , arg "-no-user-package-db"
             , arg "-package-env -"