[Git][ghc/ghc][wip/romes/hardwire-ghc-unit-id] 3 commits: Revert "WIP: Better Hash"
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Mar 16 17:18:42 UTC 2023
Matthew Pickering pushed to branch wip/romes/hardwire-ghc-unit-id at Glasgow Haskell Compiler / GHC
Commits:
c621d509 by Matthew Pickering at 2023-03-16T11:42:38+00:00
Revert "WIP: Better Hash"
This reverts commit 848c2265e8ae73176b8da9065595992a0c60e640.
- - - - -
94dc29de by Matthew Pickering at 2023-03-16T15:09:48+00:00
Revert "Revert "WIP: Better Hash""
This reverts commit c621d509652aed33a6f067e462d2f66ed4d6ac9c.
- - - - -
6cba1aee by Matthew Pickering at 2023-03-16T17:17:59+00:00
wip for rodrigo
- - - - -
6 changed files:
- hadrian/hadrian.cabal
- hadrian/src/Hadrian/Haskell/Cabal.hs
- hadrian/src/Hadrian/Package/Hash.hs → hadrian/src/Hadrian/Haskell/Hash.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Ghc.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
=====================================
hadrian/src/Hadrian/Haskell/Cabal.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hadrian.Haskell.Cabal
@@ -11,7 +13,7 @@
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal (
pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies,
- pkgGenericDescription, cabalArchString, cabalOsString,
+ pkgGenericDescription, cabalArchString, cabalOsString
) where
import Development.Shake
@@ -21,6 +23,25 @@ import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal
import Hadrian.Package
+import Hadrian.Haskell.Cabal.Type
+import Hadrian.Oracles.Cabal
+import Hadrian.Package
+import Development.Shake
+
+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
+
+
-- | Read a Cabal file and return the package version. The Cabal file is tracked.
pkgVersion :: Package -> Action String
pkgVersion = fmap version . readPackageData
@@ -72,3 +93,4 @@ cabalOsString "mingw32" = "windows"
cabalOsString "darwin" = "osx"
cabalOsString "solaris2" = "solaris"
cabalOsString other = other
+
=====================================
hadrian/src/Hadrian/Package/Hash.hs → hadrian/src/Hadrian/Haskell/Hash.hs
=====================================
@@ -1,21 +1,51 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
-module Hadrian.Package.Hash where
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Haskell.Hash (pkgUnitId, pkgHashOracle) where
+
+import Development.Shake
+import Distribution.PackageDescription (GenericPackageDescription)
import Hadrian.Haskell.Cabal.Type
+import Hadrian.Haskell.Cabal
import Hadrian.Oracles.Cabal
import Hadrian.Package
+import Hadrian.Haskell.Cabal.Type
+import Hadrian.Oracles.Cabal
+import Hadrian.Package
+import Development.Shake
+
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
+
-- | Compute the unit-id of a package
-pkgUnitId :: Package -> String
-pkgUnitId pkg = do
- pid <- pkgIdentifier pkg
- phash <- pkgHash pkg
- pure $ pkgId <> "-" <> hash
+-- This needs to be an oracle so it's cached
+pkgUnitId :: Context -> Action String
+pkgUnitId ctx = do
+ pid <- pkgIdentifier (package ctx)
+ phash <- pkgHash ctx
+ liftIO $ print phash
+ pure $ pid -- <> "-" <> phash
data PackageHashInputs = PackageHashInputs {
@@ -23,7 +53,7 @@ data PackageHashInputs = PackageHashInputs {
pkgHashComponent :: PackageType,
pkgHashSourceHash :: BS.ByteString,
-- pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),
- pkgHashDirectDeps :: [PackageName], -- Set InstalledPackageId, -- pkgDependencies are names only, not their installed unit-ids
+ pkgHashDirectDeps :: Set.Set String,
pkgHashOtherConfig :: PackageHashConfigInputs
}
@@ -34,7 +64,7 @@ data PackageHashInputs = PackageHashInputs {
data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashCompilerId :: String,
pkgHashPlatform :: String,
- -- pkgHashFlagAssignment :: FlagAssignment, -- complete not partial
+ pkgHashFlagAssignment :: [String], -- complete not partial
-- pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
pkgHashVanillaLib :: Bool,
pkgHashSharedLib :: Bool,
@@ -43,38 +73,94 @@ data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashGHCiLib :: Bool,
pkgHashProfLib :: Bool,
pkgHashProfExe :: Bool,
- pkgHashProfLibDetail :: ProfDetailLevel,
- pkgHashProfExeDetail :: ProfDetailLevel,
+-- pkgHashProfLibDetail :: ProfDetailLevel,
+-- pkgHashProfExeDetail :: ProfDetailLevel,
pkgHashCoverage :: Bool,
- pkgHashOptimization :: OptimisationLevel,
+ pkgHashOptimization :: Int,
pkgHashSplitObjs :: Bool,
pkgHashSplitSections :: Bool,
pkgHashStripLibs :: Bool,
pkgHashStripExes :: Bool,
- pkgHashDebugInfo :: DebugInfoLevel,
+-- pkgHashDebugInfo :: DebugInfoLevel,
pkgHashProgramArgs :: Map String [String],
pkgHashExtraLibDirs :: [FilePath],
pkgHashExtraLibDirsStatic :: [FilePath],
pkgHashExtraFrameworkDirs :: [FilePath],
- pkgHashExtraIncludeDirs :: [FilePath],
+ pkgHashExtraIncludeDirs :: [FilePath]
-- pkgHashProgPrefix :: Maybe PathTemplate,
-- pkgHashProgSuffix :: Maybe PathTemplate,
- pkgHashPackageDbs :: [Maybe PackageDB]
+ -- pkgHashPackageDbs :: [Maybe PackageDB]
}
deriving Show
-pkgHash :: Package -> Action String
-pkgHash pkg = BS.unpack $ Base16.encode $ SHA256.hash $ do
- pkgIdentifier
- renderPackageHashInputs $ PackageHashInputs
+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
+ ctx_data <- readContextData ctx
+ pkg_data <- readPackageData (package ctx)
+ name <- pkgIdentifier (package ctx)
+ let stag = stage ctx
+ liftIO $ print (package ctx, packageDependencies pkg_data)
+ stagePkgs <- stagePackages stag
+ foos <- mapM (\pkg -> pkgHash (ctx { package = pkg })) [pkg | pkg <- packageDependencies pkg_data, pkg `elem` stagePkgs]
+ liftIO $ print (foos)
+ 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 = Map.singleton "ghc" ghcArgs
+ pkgHashExtraLibDirs = []
+ pkgHashExtraLibDirsStatic = []
+ pkgHashExtraFrameworkDirs = []
+ pkgHashExtraIncludeDirs = []
+
+ let other_config = PackageHashConfigInputs{..}
+
+ return $ BS.unpack $ Base16.encode $ SHA256.hash $
+ renderPackageHashInputs $ PackageHashInputs
{
- pkgHashPkgId = undefined
- , pkgHashComponent = undefined
- , pkgHashSourceHash = undefined
- , pkgHashDirectDeps = undefined
- , pkgHashOtherConfig = undefined
+ pkgHashPkgId = name
+ , pkgHashComponent = (pkgType (package ctx))
+ , pkgHashSourceHash = ""
+ , pkgHashDirectDeps = Set.empty
+ , pkgHashOtherConfig = other_config
}
+prettyShow :: Show a => a -> String
+prettyShow = show
+showHashValue = show
+
renderPackageHashInputs :: PackageHashInputs -> BS.ByteString
renderPackageHashInputs PackageHashInputs{
pkgHashPkgId,
@@ -90,21 +176,23 @@ renderPackageHashInputs PackageHashInputs{
-- unnecessarily when new configuration inputs are added into the hash.
BS.pack $ unlines $ catMaybes $
[ entry "pkgid" prettyShow pkgHashPkgId
- , mentry "component" show pkgHashComponent
+-- , 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 showFlagAssignment pkgHashFlagAssignment
- , opt "configure-script" [] unwords pkgHashConfigureScriptArgs
+ , 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
@@ -112,22 +200,22 @@ renderPackageHashInputs PackageHashInputs{
, 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 "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
+ -- , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
, opt "hpc" False prettyShow pkgHashCoverage
- , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization
+ , 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 "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
+-- , 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
=====================================
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/Generate.hs
=====================================
@@ -14,6 +14,8 @@ import Oracles.Flag
import Oracles.ModuleFiles
import Oracles.Setting
import Hadrian.Haskell.Cabal.Type (PackageData(version))
+import Hadrian.Haskell.Cabal
+import Hadrian.Haskell.Hash
import Hadrian.Oracles.Cabal (readPackageData)
import Packages
import Rules.Libffi
@@ -493,7 +495,7 @@ generateConfigHs = do
-- 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' to create the unit-id in both situations.
- cProjectUnitId <- pkgUnitId <$> getPackage
+ cProjectUnitId <- expr . pkgUnitId =<< getContext
return $ unlines
[ "module GHC.Settings.Config"
, " ( module GHC.Version"
@@ -591,3 +593,4 @@ generatePlatformHostHs = do
, "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
]
+
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -3,6 +3,7 @@
module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where
import Hadrian.Haskell.Cabal
+import Hadrian.Haskell.Hash
import Hadrian.Haskell.Cabal.Type
import Flavour
@@ -14,6 +15,7 @@ import Rules.Libffi (libffiName)
import qualified Data.Set as Set
import System.Directory
import Data.Version.Extra
+import Hadrian.Haskell.Hash
ghcBuilderArgs :: Args
ghcBuilderArgs = mconcat
@@ -248,6 +250,7 @@ wayGhcArgs = do
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
@@ -259,7 +262,7 @@ packageGhcArgs = do
-- 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 package
+ pkgId <- expr $ pkgUnitId ctx
mconcat [ arg "-hide-all-packages"
, arg "-no-user-package-db"
, arg "-package-env -"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/848c2265e8ae73176b8da9065595992a0c60e640...6cba1aeeb424db7dadb997d68a0cc66f853b6642
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/848c2265e8ae73176b8da9065595992a0c60e640...6cba1aeeb424db7dadb997d68a0cc66f853b6642
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/20230316/26c379ad/attachment-0001.html>
More information about the ghc-commits
mailing list