diff options
Diffstat (limited to 'hadrian/src/Hadrian')
| -rw-r--r-- | hadrian/src/Hadrian/BuildPath.hs | 21 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Builder/Git.hs | 3 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Haskell/Cabal.hs | 15 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Haskell/Cabal/Parse.hs | 11 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Haskell/Hash.hs | 257 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Haskell/Hash.hs-boot | 8 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Package.hs | 2 |
7 files changed, 299 insertions, 18 deletions
diff --git a/hadrian/src/Hadrian/BuildPath.hs b/hadrian/src/Hadrian/BuildPath.hs index 8d2806b587..342a2ca7eb 100644 --- a/hadrian/src/Hadrian/BuildPath.hs +++ b/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] diff --git a/hadrian/src/Hadrian/Builder/Git.hs b/hadrian/src/Hadrian/Builder/Git.hs index 6875a48fbd..0f073ac463 100644 --- a/hadrian/src/Hadrian/Builder/Git.hs +++ b/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 ] ] diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs index f5864b6297..1220e6bbe4 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal.hs +++ b/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 + diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs index 74ae8fb16a..760f4295c9 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs +++ b/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 @@ -344,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 @@ -356,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 @@ -372,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@. diff --git a/hadrian/src/Hadrian/Haskell/Hash.hs b/hadrian/src/Hadrian/Haskell/Hash.hs new file mode 100644 index 0000000000..ee644168e2 --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Hash.hs @@ -0,0 +1,257 @@ +{-# 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 diff --git a/hadrian/src/Hadrian/Haskell/Hash.hs-boot b/hadrian/src/Hadrian/Haskell/Hash.hs-boot new file mode 100644 index 0000000000..b6fc67e36f --- /dev/null +++ b/hadrian/src/Hadrian/Haskell/Hash.hs-boot @@ -0,0 +1,8 @@ +module Hadrian.Haskell.Hash where + +import Hadrian.Package +import Stage +import Development.Shake + +pkgUnitId :: Stage -> Package -> Action String + diff --git a/hadrian/src/Hadrian/Package.hs b/hadrian/src/Hadrian/Package.hs index 6bc31d7c58..6291edee74 100644 --- a/hadrian/src/Hadrian/Package.hs +++ b/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 |