summaryrefslogtreecommitdiff
path: root/hadrian
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2022-08-21 19:34:36 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-09-14 17:17:04 -0400
commitb42cedbefb296437014d0768348b740b960943c0 (patch)
treeeb015b50669c6f4c778ae16a71b28522392e36dd /hadrian
parent98b62871581d09fd7f910f011b8309a342af9886 (diff)
downloadhaskell-b42cedbefb296437014d0768348b740b960943c0.tar.gz
hadrian: Inplace/Final package databases
There are now two different package databases per stage. An inplace package database contains .conf files which point directly into the build directories. The final package database contains .conf files which point into the installed locations. The inplace .conf files are created before any building happens and have fake ABI hash values. The final .conf files are created after a package finished building and contains the proper ABI has. The motivation for this is to make the dependency structure more fine-grained when building modules. Now a module depends just depends directly on M.o from package p rather than the .conf file depend on the .conf file for package p. So when all of a modules direct dependencies have finished building we can start building it rather than waiting for the whole package to finish. The secondary motivation is that the multi-repl doesn't need to build everything before starting the multi-repl session. We can just configure the inplace package-db and use that in order to start the repl.
Diffstat (limited to 'hadrian')
-rw-r--r--hadrian/src/Base.hs22
-rw-r--r--hadrian/src/Builder.hs2
-rw-r--r--hadrian/src/Context.hs21
-rw-r--r--hadrian/src/Context/Type.hs1
-rw-r--r--hadrian/src/Hadrian/Haskell/Cabal/Parse.hs117
-rw-r--r--hadrian/src/Packages.hs1
-rw-r--r--hadrian/src/Rules.hs4
-rw-r--r--hadrian/src/Rules/BinaryDist.hs2
-rw-r--r--hadrian/src/Rules/Compile.hs2
-rw-r--r--hadrian/src/Rules/Dependencies.hs2
-rw-r--r--hadrian/src/Rules/Documentation.hs2
-rw-r--r--hadrian/src/Rules/Generate.hs13
-rw-r--r--hadrian/src/Rules/Libffi.hs6
-rw-r--r--hadrian/src/Rules/Library.hs43
-rw-r--r--hadrian/src/Rules/Program.hs4
-rw-r--r--hadrian/src/Rules/Register.hs79
-rw-r--r--hadrian/src/Rules/Rts.hs2
-rw-r--r--hadrian/src/Rules/SourceDist.hs2
-rw-r--r--hadrian/src/Rules/Test.hs10
-rw-r--r--hadrian/src/Rules/ToolArgs.hs58
-rw-r--r--hadrian/src/Settings/Builders/Cabal.hs4
-rw-r--r--hadrian/src/Settings/Builders/Common.hs8
-rw-r--r--hadrian/src/Settings/Builders/Ghc.hs2
-rw-r--r--hadrian/src/Settings/Builders/GhcPkg.hs22
-rw-r--r--hadrian/src/Settings/Builders/RunTest.hs4
-rw-r--r--hadrian/src/Settings/Program.hs2
-rw-r--r--hadrian/src/Stage.hs34
-rw-r--r--hadrian/src/Utilities.hs2
28 files changed, 318 insertions, 153 deletions
diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs
index b88e2e4df8..3fcc3bb3c6 100644
--- a/hadrian/src/Base.hs
+++ b/hadrian/src/Base.hs
@@ -29,6 +29,8 @@ module Base (
ghcBinDeps, ghcLibDeps, haddockDeps,
relativePackageDbPath, packageDbPath, packageDbStamp, mingwStamp,
systemCxxStdLibConf, systemCxxStdLibConfPath
+ , PackageDbLoc(..), Inplace(..)
+
) where
import Control.Applicative
@@ -82,13 +84,17 @@ shakeFilesDir = "hadrian"
-- | Path to the package database for a given build stage, relative to the build
-- root.
-relativePackageDbPath :: Stage -> FilePath
-relativePackageDbPath stage = stageString stage -/- "lib/package.conf.d"
+relativePackageDbPath :: PackageDbLoc -> FilePath
+relativePackageDbPath (PackageDbLoc stage Final) = stageString stage-/- "lib/package.conf.d"
+relativePackageDbPath (PackageDbLoc stage Inplace) = stageString stage -/- "inplace/package.conf.d"
+
+-- See Note [Inplace vs Final package databases]
+data PackageDbLoc = PackageDbLoc { db_stage :: Stage, db_inplace :: Inplace }
-- | Path to the package database used in a given 'Stage', including
-- the build root.
-packageDbPath :: Stage -> Action FilePath
-packageDbPath stage = buildRoot <&> (-/- relativePackageDbPath stage)
+packageDbPath :: PackageDbLoc -> Action FilePath
+packageDbPath db_loc = buildRoot <&> (-/- relativePackageDbPath db_loc)
-- | We use a stamp file to track the existence of a package database.
packageDbStamp :: FilePath
@@ -99,7 +105,7 @@ systemCxxStdLibConf = "system-cxx-std-lib-1.0.conf"
-- | The name of the generated @system-cxx-std-lib-1.0.conf@ package database
-- entry.
-systemCxxStdLibConfPath :: Stage -> Action FilePath
+systemCxxStdLibConfPath :: PackageDbLoc -> Action FilePath
systemCxxStdLibConfPath stage =
packageDbPath stage <&> (-/- systemCxxStdLibConf)
@@ -112,14 +118,14 @@ stageLibPath :: Stage -> Action FilePath
stageLibPath stage = buildRoot <&> (-/- stageString stage -/- "lib")
-- | Files the GHC library depends on
-ghcLibDeps :: Stage -> Action [FilePath]
-ghcLibDeps stage = do
+ghcLibDeps :: Stage -> Inplace -> Action [FilePath]
+ghcLibDeps stage iplace = do
ps <- mapM (\f -> stageLibPath stage <&> (-/- f))
[ "llvm-targets"
, "llvm-passes"
, "settings"
]
- cxxStdLib <- systemCxxStdLibConfPath stage
+ cxxStdLib <- systemCxxStdLibConfPath (PackageDbLoc stage iplace)
return (cxxStdLib : ps)
-- | Files the GHC binary depends on.
diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index f3c6f80d41..79415ea926 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -102,7 +102,7 @@ instance NFData ConfigurationInfo
-- TODO: Do we really need all these modes? Why do we need 'Dependencies'? We
-- can extract dependencies using the Cabal library.
-- | 'GhcPkg' can initialise a package database and register packages in it.
-data GhcPkgMode = Init -- ^ Initialise an empty package database
+data GhcPkgMode = Recache -- ^ Recache a package database
| Copy -- ^ Copy a package from one database to another.
| Dependencies -- ^ Compute package dependencies.
| Unregister -- ^ Unregister a package.
diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs
index 2b8f1948c3..b3608657ca 100644
--- a/hadrian/src/Context.hs
+++ b/hadrian/src/Context.hs
@@ -3,10 +3,10 @@ module Context (
Context (..), vanillaContext, stageContext,
-- * Expressions
- getStage, getPackage, getWay, getStagedSettingList, getBuildPath,
+ getStage, getPackage, getWay, getStagedSettingList, getBuildPath, getPackageDbLoc,
-- * Paths
- contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
+ contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir,
pkgHaddockFile, pkgRegisteredLibraryFile, pkgRegisteredLibraryFileName,
pkgLibraryFile, pkgGhciLibraryFile,
pkgConfFile, pkgStampFile, objectPath, contextPath, getContextPath, libPath, distDir,
@@ -22,7 +22,7 @@ import Oracles.Setting
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
-vanillaContext s p = Context s p vanilla
+vanillaContext s p = Context s p vanilla Final
-- | Partial context with undefined 'Package' field. Useful for 'Packages'
-- expressions that only read the environment and current 'Stage'.
@@ -33,6 +33,12 @@ stageContext s = vanillaContext s $ error "stageContext: package not set"
getStage :: Expr Context b Stage
getStage = stage <$> getContext
+getInplace :: Expr Context b Inplace
+getInplace = iplace <$> getContext
+
+getPackageDbLoc :: Expr Context b PackageDbLoc
+getPackageDbLoc = PackageDbLoc <$> getStage <*> getInplace
+
-- | Get the 'Package' of the current 'Context'.
getPackage :: Expr Context b Package
getPackage = package <$> getContext
@@ -79,9 +85,12 @@ pkgFile context@Context {..} prefix suffix = do
pkgInplaceConfig :: Context -> Action FilePath
pkgInplaceConfig context = contextPath context <&> (-/- "inplace-pkg-config")
+pkgSetupConfigDir :: Context -> Action FilePath
+pkgSetupConfigDir context = contextPath context
+
-- | Path to the @setup-config@ of a given 'Context'.
pkgSetupConfigFile :: Context -> Action FilePath
-pkgSetupConfigFile context = contextPath context <&> (-/- "setup-config")
+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@.
@@ -129,9 +138,11 @@ pkgGhciLibraryFile context@Context {..} = do
pkgConfFile :: Context -> Action FilePath
pkgConfFile Context {..} = do
pid <- pkgIdentifier package
- dbPath <- packageDbPath stage
+ dbPath <- packageDbPath (PackageDbLoc stage iplace)
return $ dbPath -/- pid <.> "conf"
+-- | Path to the stamp file for a given 'Context'. The stamp file records if
+-- we have built all the objects necessary for a certain way or not.
pkgStampFile :: Context -> Action FilePath
pkgStampFile c@Context{..} = do
let extension = waySuffix way
diff --git a/hadrian/src/Context/Type.hs b/hadrian/src/Context/Type.hs
index 4ce622efed..6bc77faec4 100644
--- a/hadrian/src/Context/Type.hs
+++ b/hadrian/src/Context/Type.hs
@@ -13,6 +13,7 @@ data Context = Context
{ stage :: Stage -- ^ Currently build Stage
, package :: Package -- ^ Currently build Package
, way :: Way -- ^ Currently build Way (usually 'vanilla')
+ , iplace :: Inplace -- ^ Whether to use the inplace or final package database
} deriving (Eq, Generic, Show)
instance Binary Context
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index b14edd035c..048c66c802 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -12,7 +12,7 @@
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal.Parse (
parsePackageData, resolveContextData, parseCabalPkgId, configurePackage,
- buildAutogenFiles, copyPackage, registerPackage
+ buildAutogenFiles, copyPackage, writeInplacePkgConf, registerPackage
) where
import Data.Bifunctor
@@ -62,6 +62,13 @@ import Context
import Flavour
import Packages
import Settings
+import Distribution.Simple.LocalBuildInfo
+import qualified Distribution.Simple.Register as C
+import System.Directory (getCurrentDirectory)
+import qualified Distribution.InstalledPackageInfo as CP
+import Distribution.Simple.Utils (writeUTF8File)
+import Utilities
+
-- | Parse the Cabal file of a given 'Package'. This operation is cached by the
-- "Hadrian.Oracles.TextFile.readPackageData" oracle.
@@ -179,24 +186,15 @@ copyPackage context@Context {..} = do
putProgressInfo $ "| Copy package " ++ quote (pkgName package)
gpd <- pkgGenericDescription package
ctxPath <- Context.contextPath context
- pkgDbPath <- packageDbPath stage
+ pkgDbPath <- packageDbPath (PackageDbLoc stage iplace)
verbosity <- getVerbosity
let v = if verbosity >= Diagnostic then "-v3" else "-v0"
traced "cabal-copy" $
C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
[ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
--- | Register the 'Package' of a given 'Context' into the package database.
-registerPackage :: Context -> Action ()
-registerPackage context@Context {..} = do
- putProgressInfo $ "| Register package " ++ quote (pkgName package)
- ctxPath <- Context.contextPath context
- gpd <- pkgGenericDescription package
- verbosity <- getVerbosity
- let v = if verbosity >= Diagnostic then "-v3" else "-v0"
- traced "cabal-register" $
- C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
- [ "register", "--builddir", ctxPath, v ]
+
+
-- | What type of file is Main
data MainSourceType = HsMain | CppMain | CMain
@@ -299,6 +297,84 @@ resolveContextData context@Context {..} = do
in return cdata
+-- Writes a .conf file which points directly into the build directory of a package
+-- so the artefacts can be used as they are produced.
+write_inplace_conf :: FilePath -> FilePath -> C.PackageDescription -> LocalBuildInfo -> IO ()
+write_inplace_conf pkg_path res_path pd lbi = do
+ withLibLBI pd lbi $ \lib clbi ->
+ do cwd <- getCurrentDirectory
+ let fixupIncludeDir dir | cwd `isPrefixOf` dir = [prefix ++ drop (length cwd) dir]
+ | otherwise = [dir]
+ where
+ prefix = "${pkgroot}/../../../"
+ let installedPkgInfo =
+
+ C.inplaceInstalledPackageInfo (cwd </> pkg_path) build_dir pd (C.mkAbiHash "inplace") lib lbi clbi
+
+ build_dir = "${pkgroot}/../" ++ pkg_path ++ "/build"
+ pkg_name = C.display (C.pkgName (CP.sourcePackageId installedPkgInfo))
+ final_ipi = installedPkgInfo {
+ Installed.includeDirs = concatMap fixupIncludeDir (Installed.includeDirs installedPkgInfo),
+ Installed.libraryDirs = [ build_dir ],
+ Installed.libraryDynDirs = [ build_dir ],
+ Installed.dataDir = "${pkgroot}/../../../../" ++ pkg_path,
+ Installed.haddockHTMLs = [build_dir ++ "/doc/html/" ++ C.display (CP.sourcePackageId installedPkgInfo)],
+ Installed.haddockInterfaces = [build_dir ++ "/doc/html/" ++ pkg_name ++ "/" ++ pkg_name ++ ".haddock"],
+ Installed.importDirs = [build_dir]
+
+ }
+
+ content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
+ C.writeFileAtomic res_path
+ (C.toUTF8LBS content)
+
+-- This uses the API directly because no way to register into a different package db which is
+-- configured. See the use of C.SpecificPackageDB
+registerPackage :: [(Resource, Int)] -> Context -> Action ()
+registerPackage rs context = do
+ cPath <- Context.contextPath context
+ setupConfig <- pkgSetupConfigFile context
+ need [setupConfig] -- This triggers 'configurePackage'
+ pd <- packageDescription <$> readContextData context
+ db_path <- packageDbPath (PackageDbLoc (stage context) (iplace context))
+ dist_dir <- Context.buildPath context
+ pid <- pkgIdentifier (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
+ liftIO $ register db_path pid dist_dir pd lbi
+ -- Then after the register, which just writes the .conf file, do the recache step.
+ buildWithResources rs $
+ target context (GhcPkg Recache (stage context)) [] []
+
+-- 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
+ -> FilePath
+ -> C.PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+register pkg_db conf_file build_dir pd lbi
+ = withLibLBI pd lbi $ \lib clbi -> do
+
+ absPackageDBs <- C.absolutePackageDBPaths packageDbs
+ installedPkgInfo <- C.generateRegistrationInfo
+ C.silent pd lib lbi clbi False reloc build_dir
+ (C.registrationPackageDB absPackageDBs)
+
+ writeRegistrationFile installedPkgInfo
+
+ where
+ regFile = conf_file
+ 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)
+
+
-- | Build autogenerated files @autogen/cabal_macros.h@ and @autogen/Paths_*.hs@.
buildAutogenFiles :: Context -> Action ()
buildAutogenFiles context = do
@@ -312,6 +388,21 @@ buildAutogenFiles context = do
lbi <- C.getPersistBuildConfig cPath
C.initialBuildSteps cPath pd (lbi { C.localPkgDescr = pd }) C.silent
+-- | Write a .conf file for the inplace package database which points into the
+-- build directories rather than the final install locations.
+writeInplacePkgConf :: Context -> Action ()
+writeInplacePkgConf context = do
+ cPath <- Context.contextPath context
+ setupConfig <- pkgSetupConfigFile context
+ need [setupConfig] -- This triggers 'configurePackage'
+ pd <- packageDescription <$> readContextData context
+ conf <- pkgInplaceConfig 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
+ liftIO $ write_inplace_conf (pkgPath (package context)) conf pd (lbi { C.localPkgDescr = pd })
+
+
-- | Look for a @.buildinfo@ in all of the specified directories, stopping on
-- the first one we find.
getHookedBuildInfo :: [FilePath] -> IO C.HookedBuildInfo
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 2cba0d2118..449004ed92 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -249,6 +249,7 @@ libffiBuildPath stage = buildPath $ Context
stage
libffi
(error "libffiBuildPath: way not set.")
+ (error "libffiBuildPath: inplace not set.")
{-
Note [Hadrian's ghci-wrapper package]
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index 9b432b8966..8c65f471a7 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -88,7 +88,7 @@ packageTargets includeGhciLib stage pkg = do
then do -- Collect all targets of a library package.
let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
ways <- interpretInContext context pkgWays
- libs <- mapM (pkgLibraryFile . Context stage pkg) (Set.toList ways)
+ libs <- mapM (\w -> pkgLibraryFile (Context stage pkg w (error "unused"))) (Set.toList ways)
more <- Rules.Library.libraryTargets includeGhciLib context
setupConfig <- pkgSetupConfigFile context
return $ [setupConfig] ++ libs ++ more
@@ -113,7 +113,7 @@ packageRules = do
Rules.Program.buildProgramRules readPackageDb
Rules.Register.configurePackageRules
- forM_ allStages (Rules.Register.registerPackageRules writePackageDb)
+ forM_ [Inplace, Final] $ \iplace -> forM_ allStages $ \stage -> (Rules.Register.registerPackageRules writePackageDb stage iplace)
-- TODO: Can we get rid of this enumeration of contexts? Since we iterate
-- over it to generate all 4 types of rules below, all the time, we
diff --git a/hadrian/src/Rules/BinaryDist.hs b/hadrian/src/Rules/BinaryDist.hs
index 15c0a65d14..ede1a5c420 100644
--- a/hadrian/src/Rules/BinaryDist.hs
+++ b/hadrian/src/Rules/BinaryDist.hs
@@ -447,7 +447,7 @@ iservBins :: Action [(Package, FilePath)]
iservBins = do
rtsways <- interpretInContext (vanillaContext Stage1 ghc) getRtsWays
traverse (fmap (\p -> (iserv, p)) . programPath)
- [ Context Stage1 iserv w
+ [ Context Stage1 iserv w Final
| w <- [vanilla, profiling, dynamic]
, w `elem` rtsways
]
diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs
index afa5abbcca..ff1f9f214b 100644
--- a/hadrian/src/Rules/Compile.hs
+++ b/hadrian/src/Rules/Compile.hs
@@ -191,7 +191,7 @@ parseBuildObject root = parseBuildPath root parseObject
objectContext :: BuildPath Object -> Context
objectContext (BuildPath _ stage pkgPath obj) =
- Context stage (unsafeFindPackageByPath pkgPath) way
+ Context stage (unsafeFindPackageByPath pkgPath) way Inplace
where
way = case obj of
NonHs (NonHsObject _lang _file w) -> w
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
index 9a2a23354f..d49cf68e6e 100644
--- a/hadrian/src/Rules/Dependencies.hs
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -20,7 +20,7 @@ buildPackageDependencies rs = do
root <- buildRootRules
root -/- "**/.dependencies.mk" %> \mk -> do
DepMkFile stage pkgpath <- getDepMkFile root mk
- let context = Context stage (unsafeFindPackageByPath pkgpath) vanilla
+ let context = Context stage (unsafeFindPackageByPath pkgpath) vanilla Inplace
srcs <- hsSources context
gens <- interpretInContext context generatedDependencies
need (srcs ++ gens)
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
index b81690dbb3..df5fdfb94b 100644
--- a/hadrian/src/Rules/Documentation.hs
+++ b/hadrian/src/Rules/Documentation.hs
@@ -266,7 +266,7 @@ data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName
deriving (Eq, Show)
pkgDocContext :: PkgDocTarget -> Context
-pkgDocContext target = Context Stage1 (unsafeFindPackageByName name) vanilla
+pkgDocContext target = Context Stage1 (unsafeFindPackageByName name) vanilla Final
where
name = case target of DotHaddock n -> n
HaddockPrologue n -> n
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index 88fb6d903e..8390aadb77 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -99,7 +99,7 @@ generate file context expr = do
putSuccess $ "| Successfully generated " ++ file ++ "."
generatePackageCode :: Context -> Rules ()
-generatePackageCode context@(Context stage pkg _) = do
+generatePackageCode context@(Context stage pkg _ _) = do
root <- buildRootRules
let dir = buildDir context
generated f = (root -/- dir -/- "**/*.hs") ?== f && not ("//autogen/*" ?== f)
@@ -107,7 +107,9 @@ generatePackageCode context@(Context stage pkg _) = do
generated ?> \file -> do
let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
(src, builder) <- unpack <$> findGenerator context file
- need [src]
+ -- Make sure we have configured the package before running the builder
+ pkg_setup <- pkgSetupConfigFile context
+ need [src, pkg_setup]
build $ target context builder [src] [file]
let boot = src -<.> "hs-boot"
whenM (doesFileExist boot) $ do
@@ -150,7 +152,7 @@ genEventTypes flag file = do
[] []
genPrimopCode :: Context -> FilePath -> Action ()
-genPrimopCode context@(Context stage _pkg _) file = do
+genPrimopCode context@(Context stage _pkg _ _) file = do
root <- buildRoot
need [root -/- primopsTxt stage]
build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
@@ -192,7 +194,8 @@ copyRules = do
prefix -/- "html/**" <~ return "utils/haddock/haddock-api/resources"
prefix -/- "latex/**" <~ return "utils/haddock/haddock-api/resources"
- root -/- relativePackageDbPath stage -/- systemCxxStdLibConf %> \file -> do
+ forM_ [Inplace, Final] $ \iplace ->
+ root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do
copyFile ("mk" -/- "system-cxx-std-lib-1.0.conf") file
generateRules :: Rules ()
@@ -229,7 +232,7 @@ emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
ghcWrapper :: Stage -> Expr String
ghcWrapper (Stage0 {}) = error "Stage0 GHC does not require a wrapper script to run."
ghcWrapper stage = do
- dbPath <- expr $ (</>) <$> topDirectory <*> packageDbPath stage
+ dbPath <- expr $ (</>) <$> topDirectory <*> packageDbPath (PackageDbLoc stage Final)
ghcPath <- expr $ (</>) <$> topDirectory
<*> programPath (vanillaContext (predStage stage) ghc)
return $ unwords $ map show $ [ ghcPath ]
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
index 860d06b116..c0a27128ca 100644
--- a/hadrian/src/Rules/Libffi.hs
+++ b/hadrian/src/Rules/Libffi.hs
@@ -75,11 +75,11 @@ needLibffi stage = do
libffiContext :: Stage -> Action Context
libffiContext stage = do
ways <- interpretInContext
- (Context stage libffi (error "libffiContext: way not set"))
+ (Context stage libffi (error "libffiContext: way not set") (error "libffiContext: iplace not set"))
getLibraryWays
- return . Context stage libffi $ if any (wayUnit Dynamic) ways
+ return $ (\w -> Context stage libffi w Final) (if any (wayUnit Dynamic) ways
then dynamic
- else vanilla
+ else vanilla)
-- | The name of the library
libffiName :: Expr String
diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs
index 46747f9d35..d50f283cfe 100644
--- a/hadrian/src/Rules/Library.hs
+++ b/hadrian/src/Rules/Library.hs
@@ -17,7 +17,6 @@ import Target
import Utilities
import Data.Time.Clock
import Rules.Generate (generatedDependencies)
-import Hadrian.Oracles.Cabal (readPackageData)
import Oracles.Flag
@@ -46,13 +45,12 @@ libraryRules = do
registerStaticLib :: FilePath -> FilePath -> Action ()
registerStaticLib root archivePath = do
-- Simply need the ghc-pkg database .conf file.
- GhcPkgPath _ stage _ (LibA name version _)
+ GhcPkgPath _ stage _ (LibA name _ w)
<- parsePath (parseGhcPkgLibA root)
"<.a library (register) path parser>"
archivePath
- need [ root -/- relativePackageDbPath stage
- -/- (pkgId name version) ++ ".conf"
- ]
+ let ctx = Context stage (unsafeFindPackageByName name) w Final
+ need . (:[]) =<< pkgConfFile ctx
-- | Build a static library ('LibA') under the given build root, whose path is
-- the second argument.
@@ -77,13 +75,12 @@ 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 version _ _))
+ (GhcPkgPath _ stage _ (LibDyn name _ w _))
<- parsePath (parseGhcPkgLibDyn root suffix)
"<dyn register lib parser>"
dynlibpath
- need [ root -/- relativePackageDbPath stage
- -/- pkgId name version ++ ".conf"
- ]
+ let ctx = Context stage (unsafeFindPackageByName name) w Final
+ need . (:[]) =<< pkgConfFile ctx
-- | Build a dynamic library ('LibDyn') under the given build root, with the
-- given suffix (@.so@ or @.dylib@, @.dll@), where the complete path of the
@@ -137,21 +134,17 @@ files etc.
buildPackage :: FilePath -> FilePath -> Action ()
buildPackage root fp = do
- l@(BuildPath _ stage _ (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
- depPkgs <- packageDependencies <$> readPackageData (package ctx)
- -- Stage packages are those we have in this stage.
- stagePkgs <- stagePackages stage
- -- We'll need those packages in our package database.
- deps <- sequence [ pkgConfFile (ctx { package = pkg })
- | pkg <- depPkgs, pkg `elem` stagePkgs ]
- need deps
- need (srcs ++ gens)
+ lib_targets <- libraryTargets True ctx
- need =<< libraryTargets True ctx
+ need (srcs ++ gens ++ lib_targets)
+
+ -- Write the current time into the file so the file always changes if
+ -- we restamp it because a dependency changes.
time <- liftIO $ getCurrentTime
liftIO $ writeFile fp (show time)
ways <- interpretInContext ctx getLibraryWays
@@ -241,28 +234,28 @@ data LibGhci = LibGhci String [Integer] 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)) =
- Context stage pkg 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)) =
- Context stage pkg 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 _)) =
- Context stage pkg 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)) =
- Context stage pkg way
+ Context stage pkg way Final
where
pkg = unsafeFindPackageByName pkgname
@@ -344,7 +337,3 @@ parseStamp = do
(pkgname, pkgver) <- parsePkgId
way <- parseWaySuffix vanilla
return (PkgStamp pkgname pkgver way)
-
--- | Get the package identifier given the package name and version.
-pkgId :: String -> [Integer] -> String
-pkgId name version = name ++ "-" ++ intercalate "." (map show version)
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index 076c22987b..71cccd628f 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -65,8 +65,8 @@ getProgramContexts stage = do
ctx <- programContext stage pkg -- TODO: see todo on programContext.
let allCtxs = if pkg == iserv
then [ vanillaContext stage pkg
- , Context stage pkg profiling
- , Context stage pkg dynamic
+ , Context stage pkg profiling Final
+ , Context stage pkg dynamic Final
]
else [ ctx ]
forM allCtxs $ \ctx -> do
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index dcd05e240c..2574130c9c 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -12,7 +12,6 @@ import Hadrian.Haskell.Cabal
import Oracles.Flag (platformSupportsGhciObjects)
import Packages
import Rules.Rts
-import {-# SOURCE #-} Rules.Library (needLibrary)
import Settings
import Target
import Utilities
@@ -39,19 +38,18 @@ configurePackageRules = do
root -/- "**/setup-config" %> \out -> do
(stage, path) <- parsePath (parseSetupConfig root) "<setup config path parser>" out
let pkg = unsafeFindPackageByPath path
- let ctx = Context stage pkg vanilla
+ let ctx = Context stage pkg vanilla Inplace
buildP <- buildPath ctx
when (pkg == ghcBignum) $ do
isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend
when isGmp $
need [buildP -/- "include/ghc-gmp.h"]
- needLibrary =<< contextDependencies ctx
Cabal.configurePackage ctx
root -/- "**/autogen/cabal_macros.h" %> \out -> do
(stage, path) <- parsePath (parseToBuildSubdirectory root) "<cabal macros path parser>" out
let pkg = unsafeFindPackageByPath path
- Cabal.buildAutogenFiles (Context stage pkg vanilla)
+ Cabal.buildAutogenFiles (Context stage pkg vanilla Inplace)
root -/- "**/autogen/Paths_*.hs" %> \out ->
need [takeDirectory out -/- "cabal_macros.h"]
@@ -87,44 +85,52 @@ registerPackages ctxs = do
-- | Register a package and initialise the corresponding package database if
-- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
-registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
-registerPackageRules rs stage = do
+registerPackageRules :: [(Resource, Int)] -> Stage -> Inplace -> Rules ()
+registerPackageRules rs stage iplace = do
root <- buildRootRules
-- Initialise the package database.
- root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp -> do
+ root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- packageDbStamp %> \stamp -> do
-- This command initialises the package.cache file to avoid a race where
-- a package gets registered but there's not a package.cache file (which
-- leads to errors in GHC).
buildWithResources rs $
- target (Context stage compiler vanilla) (GhcPkg Init stage) [] []
+ target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] []
writeFileLines stamp []
-- Register a package.
- root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
+ root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do
historyDisable
pkgName <- getPackageNameFromConfFile conf
let pkg = unsafeFindPackageByName pkgName
- when (pkg == compiler) $ need =<< ghcLibDeps stage
+ when (pkg == compiler) $ need =<< ghcLibDeps stage iplace
-- Only used in guard when Stage0 {} but can be GlobalLibs or InTreeLibs
isBoot <- (pkg `notElem`) <$> stagePackages stage
- let ctx = Context stage pkg vanilla
+ let ctx = Context stage pkg vanilla iplace
case stage of
Stage0 _ | isBoot -> copyConf rs ctx conf
- _ -> buildConf rs ctx conf
-
-buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
-buildConf _ context@Context {..} _conf = do
+ _ ->
+ -- See Note [Inplace vs Final package databases]
+ case iplace of
+ Inplace -> buildConfInplace rs ctx conf
+ Final -> buildConfFinal rs ctx conf
+
+buildConfFinal :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildConfFinal rs context@Context {..} _conf = do
depPkgIds <- cabalDependencies context
ensureConfigured context
- need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
-
ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
- need =<< mapM pkgStampFile [ context { way = w } | w <- Set.toList ways ]
+ stamps <- mapM pkgStampFile [ context { way = w } | w <- Set.toList ways ]
+ confs <- mapM (\pkgId -> packageDbPath (PackageDbLoc stage Final) <&> (-/- pkgId <.> "conf")) depPkgIds
+ -- Important to need these together to avoid introducing a linearisation. This is not the most critical place
+ -- though because needing the stamp file, will cause all dependent object files to be built anyway (even if other packages)
+ -- so the .conf file being needed will probably not have to build so much (only stuff which is not use transitively). It's
+ -- still better though to need both together to give hadrian the best chance possible to build things in parallel.
+ need (stamps ++ confs)
-- We might need some package-db resource to limit read/write, see packageRules.
path <- buildPath context
@@ -148,7 +154,7 @@ buildConf _ context@Context {..} _conf = do
-- Copy and register the package.
Cabal.copyPackage context
- Cabal.registerPackage context
+ Cabal.registerPackage rs context
-- We declare that this rule also produces files matching:
-- - <root>/stage<N>/lib/<arch>-<os>-ghc-<version>/*libHS<pkgid>*
@@ -165,11 +171,44 @@ buildConf _ context@Context {..} _conf = do
<*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
produces files
+buildConfInplace :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildConfInplace rs context@Context {..} _conf = do
+ depPkgIds <- cabalDependencies context
+ ensureConfigured context
+ need =<< mapM (\pkgId -> packageDbPath (PackageDbLoc stage Inplace) <&> (-/- pkgId <.> "conf")) depPkgIds
+
+ path <- buildPath context
+
+ -- Special package cases (these should ideally be rolled into Cabal).
+ when (package == rts) $
+ -- If Cabal knew about "generated-headers", we could read them from the
+ -- 'configuredCabal' information, and just "need" them here.
+ need [ path -/- "include/DerivedConstants.h"
+ , path -/- "include/ghcautoconf.h"
+ , path -/- "include/ghcplatform.h"
+ , path -/- "include/rts/EventLogConstants.h"
+ , path -/- "include/rts/EventTypes.h"
+ ]
+
+ -- we need to generate this file for GMP
+ when (package == ghcBignum) $ do
+ bignum <- interpretInContext context getBignumBackend
+ when (bignum == "gmp") $
+ need [path -/- "include/ghc-gmp.h"]
+
+ -- Write an "inplace" package conf which points into the build directories
+ -- for finding the build products
+ Cabal.writeInplacePkgConf context
+ conf <- pkgInplaceConfig context
+ buildWithResources rs $
+ target context (GhcPkg Update stage) [conf] []
+
+
copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
copyConf rs context@Context {..} conf = do
depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
target context (GhcPkg Dependencies stage) [pkgName package] []
- need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
+ need =<< mapM (\pkgId -> packageDbPath (PackageDbLoc stage iplace) <&> (-/- pkgId <.> "conf")) depPkgIds
-- We should unregister if the file exists since @ghc-pkg@ will complain
-- about existing package: https://github.com/snowleopard/hadrian/issues/543.
-- Also, we don't always do the unregistration + registration to avoid
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index cb3026cd32..e08c2a856f 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -150,7 +150,7 @@ needRtsLibffiTargets stage = do
needRtsSymLinks :: Stage -> Set.Set Way -> Action ()
needRtsSymLinks stage rtsWays
= forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do
- let ctx = Context stage rts way
+ let ctx = Context stage rts way Final
libPath <- libPath ctx
distDir <- distDir stage
rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs
index b218f66c63..598b6fdcc9 100644
--- a/hadrian/src/Rules/SourceDist.hs
+++ b/hadrian/src/Rules/SourceDist.hs
@@ -160,7 +160,7 @@ prepareTree dest = do
copyAlexHappyFiles =
forM_ alexHappyFiles $ \(stg, pkg, inp, out) -> do
- let ctx = Context stg pkg vanilla
+ let ctx = Context stg pkg vanilla Inplace
srcInputFile = dest -/- pkgPath pkg -/- inp
generatedFile = dest -/- pkgPath pkg -/- out
builder =
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 154496cf1c..abe78b79ab 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -114,7 +114,7 @@ testRules = do
need [stage0prog]
abs_prog_path <- liftIO (IO.canonicalizePath stage0prog)
-- Use the stage1 package database
- pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath Stage1
+ pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath (PackageDbLoc Stage1 Final)
if prog `elem` ["ghc","runghc"] then do
let flags = [ "-no-global-package-db", "-no-user-package-db", "-hide-package", "ghc" , "-package-env","-","-package-db",pkgDb]
writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
@@ -163,7 +163,7 @@ testRules = do
let testGhc = testCompiler args
ghcPath <- getCompilerPath testGhc
whenJust (stageOf testGhc) $ \stg ->
- need . (:[]) =<< programPath (Context stg ghc vanilla)
+ need . (:[]) =<< programPath (Context stg ghc vanilla Final)
ghcConfigProgPath <- programPath =<< programContext stage0InTree ghcConfig
cwd <- liftIO $ IO.getCurrentDirectory
need [makeRelative cwd ghcPath, ghcConfigProgPath]
@@ -322,18 +322,18 @@ needIservBins stg = do
-- not working with the testsuite, see #19624
canBuild (Stage0 {}) _ = pure Nothing
canBuild stg w = do
- contextDeps <- contextDependencies (Context stg iserv w)
+ contextDeps <- contextDependencies (Context stg iserv w Final)
ws <- forM contextDeps $ \c ->
interpretInContext c (getLibraryWays <>
if Context.Type.package c == rts
then getRtsWays
else mempty)
if (all (w `elem`) ws)
- then Just <$> programPath (Context stg iserv w)
+ then Just <$> programPath (Context stg iserv w Final)
else return Nothing
pkgFile :: Stage -> Package -> Action FilePath
pkgFile stage pkg
- | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic)
+ | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic Final)
| otherwise = programPath =<< programContext stage pkg
diff --git a/hadrian/src/Rules/ToolArgs.hs b/hadrian/src/Rules/ToolArgs.hs
index 3eabb3ffb7..e07d5743c4 100644
--- a/hadrian/src/Rules/ToolArgs.hs
+++ b/hadrian/src/Rules/ToolArgs.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE ViewPatterns #-}
module Rules.ToolArgs(toolArgsTarget) where
-import qualified Rules.Generate
+import Rules.Generate
import Development.Shake
import Target
import Context
@@ -15,6 +15,8 @@ import Hadrian.Haskell.Cabal.Type
import System.Directory (canonicalizePath)
import System.Environment (lookupEnv)
import qualified Data.Set as Set
+import Oracles.ModuleFiles
+import Utilities
-- | @tool:@ is used by tooling in order to get the arguments necessary
-- to set up a GHC API session which can compile modules from GHC. When
@@ -59,7 +61,6 @@ multiSetup pkg_s = do
-- Get the arguments for all the targets
pargs <- mapM one_args tool_targets
-- Build any other dependencies (such as generated files)
- allDeps
liftIO $ writeOutput (concatMap (\x -> ["-unit", x]) (map ( "@" <>) pargs))
where
@@ -74,13 +75,16 @@ multiSetup pkg_s = do
one_args p = do
putProgressInfo ("Computing arguments for " ++ pkgName p)
root <- buildRoot
- let fake_target = target (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+ let fake_target = target (Context stage0InTree p (if windowsHost then vanilla else dynamic) Inplace)
(Ghc ToolArgs stage0InTree) [] ["ignored"]
arg_list <- interpret fake_target getArgs
- let c = (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+ let c = Context stage0InTree p (if windowsHost then vanilla else dynamic) Inplace -- Critical use of Inplace, one of the main motivations!
-- readContextData has the effect of configuring the package so all
-- dependent packages will also be built.
cd <- readContextData c
+ srcs <- hsSources c
+ gens <- interpretInContext c generatedDependencies
+ need (srcs ++ gens)
let rexp m = ["-reexported-module", m]
writeFile' (resp_file root p) (intercalate "\n" (th_hack arg_list
++ modules cd
@@ -119,36 +123,24 @@ mkToolTarget es p = do
-- This builds automatically generated dependencies. Not sure how to do
-- this generically yet.
putProgressInfo ("Computing arguments for " ++ pkgName p)
- allDeps
- let fake_target = target (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+
+ let context = Context stage0InTree p (if windowsHost then vanilla else dynamic) Final
+ let fake_target = target context
(Ghc ToolArgs stage0InTree) [] ["ignored"]
+ -- Generate any source files for this target
+ cd <- readContextData context
+ srcs <- hsSources context
+ gens <- interpretInContext context generatedDependencies
+
+ -- Build any necessary dependencies
+ depPkgIds <- cabalDependencies context
+ dep_confs <- mapM (\pkgId -> packageDbPath (PackageDbLoc stage0InTree Final) <&> (-/- pkgId <.> "conf")) depPkgIds
+
+ need (gens ++ srcs ++ dep_confs)
+
arg_list <- interpret fake_target getArgs
liftIO $ writeOutput (arg_list ++ es)
-allDeps :: Action ()
-allDeps = do
- do
- -- We can't build DLLs on Windows (yet). Actually we should only
- -- include the dynamic way when we have a dynamic host GHC, but just
- -- checking for Windows seems simpler for now.
- let fake_target = target (Context stage0InTree compiler (if windowsHost then vanilla else dynamic))
- (Ghc ToolArgs stage0InTree) [] ["ignored"]
-
- -- need the autogenerated files so that they are precompiled
- interpret fake_target Rules.Generate.compilerDependencies >>= need
-
- root <- buildRoot
- let ghc_prim = buildDir (vanillaContext stage0InTree ghcPrim)
- let dir = buildDir (vanillaContext stage0InTree compiler)
- need [ root -/- dir -/- "GHC" -/- "Settings" -/- "Config.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Parser.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Parser" -/- "Lexer.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Parser" -/- "HaddockLex.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs" ]
-
- need [ root -/- ghc_prim -/- "GHC" -/- "PrimopWrappers.hs" ]
-
-- This list is quite a lot like stage0packages but doesn't include
-- critically the `exe:ghc` component as that depends on the GHC library
-- which takes a while to compile.
@@ -158,6 +150,7 @@ toolTargets = [ binary
, cabalSyntax
, cabal
, compiler
+ , containers
, directory
, process
, exceptions
@@ -177,6 +170,7 @@ toolTargets = [ binary
, time
, templateHaskell
, text
+ , terminfo
, transformers
-- , unlit # executable
] ++ if windowsHost then [ win32 ] else [ unix ]
@@ -195,12 +189,12 @@ dirMap = do
-- configuring would build the whole GHC library which we probably
-- don't want to do.
mkGhc = do
- let c = (Context stage0InTree compiler (if windowsHost then vanilla else dynamic))
+ let c = (Context stage0InTree compiler (if windowsHost then vanilla else dynamic) Final)
cd <- readContextData c
fp <- liftIO $ canonicalizePath "ghc/"
return (fp, (compiler, "-ighc" : modules cd ++ otherModules cd ++ ["ghc/Main.hs"]))
go p = do
- let c = (Context stage0InTree p (if windowsHost then vanilla else dynamic))
+ let c = (Context stage0InTree p (if windowsHost then vanilla else dynamic) Final)
-- readContextData has the effect of configuring the package so all
-- dependent packages will also be built.
cd <- readContextData c
diff --git a/hadrian/src/Settings/Builders/Cabal.hs b/hadrian/src/Settings/Builders/Cabal.hs
index c85104eeae..f13418a333 100644
--- a/hadrian/src/Settings/Builders/Cabal.hs
+++ b/hadrian/src/Settings/Builders/Cabal.hs
@@ -230,7 +230,7 @@ withBuilderArgs :: Builder -> Args
withBuilderArgs b = case b of
Ghc _ stage -> do
top <- expr topDirectory
- pkgDb <- expr $ packageDbPath stage
+ pkgDb <- expr $ packageDbPath (PackageDbLoc stage Inplace)
-- GHC starts with a nonempty package DB stack, so we need to tell it
-- to empty the stack first for it to truly consider only the package
-- DB we explicitly provide. See #17468.
@@ -238,7 +238,7 @@ withBuilderArgs b = case b of
arg ("--ghc-option=-package-db=" ++ top -/- pkgDb)
GhcPkg _ stage -> do
top <- expr topDirectory
- pkgDb <- expr $ packageDbPath stage
+ pkgDb <- expr $ packageDbPath (PackageDbLoc stage Inplace)
notStage0 ? arg ("--ghc-pkg-option=--global-package-db=" ++ top -/- pkgDb)
_ -> return [] -- no arguments
diff --git a/hadrian/src/Settings/Builders/Common.hs b/hadrian/src/Settings/Builders/Common.hs
index a011cb0dae..e89152be9e 100644
--- a/hadrian/src/Settings/Builders/Common.hs
+++ b/hadrian/src/Settings/Builders/Common.hs
@@ -53,15 +53,15 @@ cWarnings = mconcat
packageDatabaseArgs :: Args
packageDatabaseArgs = do
- stage <- getStage
- dbPath <- expr (packageDbPath stage)
+ loc <- getPackageDbLoc
+ dbPath <- expr (packageDbPath loc)
expr (need [dbPath -/- packageDbStamp])
prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=")
arg $ prefix ++ dbPath
bootPackageDatabaseArgs :: Args
bootPackageDatabaseArgs = do
- stage <- getStage
- dbPath <- expr $ packageDbPath stage
+ loc <- getPackageDbLoc
+ dbPath <- expr $ packageDbPath loc
expr $ need [dbPath -/- packageDbStamp]
stage0 ? packageDatabaseArgs
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index 7deb22f179..04e6d160d7 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -28,7 +28,7 @@ ghcBuilderArgs = mconcat
let nextStageRtsBuildIncludeDir = nextStageRtsBuildDir </> "include"
builder Ghc ? arg ("-I" ++ nextStageRtsBuildIncludeDir)
, compileAndLinkHs, compileC, compileCxx, findHsDependencies
- , toolArgs]
+ , toolArgs ]
toolArgs :: Args
toolArgs = do
diff --git a/hadrian/src/Settings/Builders/GhcPkg.hs b/hadrian/src/Settings/Builders/GhcPkg.hs
index 5de76cc753..6508cd0401 100644
--- a/hadrian/src/Settings/Builders/GhcPkg.hs
+++ b/hadrian/src/Settings/Builders/GhcPkg.hs
@@ -4,9 +4,9 @@ import Settings.Builders.Common
ghcPkgBuilderArgs :: Args
ghcPkgBuilderArgs = mconcat
- [ builder (GhcPkg Init) ? do
- stage <- getStage
- pkgDb <- expr $ packageDbPath stage
+ [ builder (GhcPkg Recache) ? do
+ loc <- getPackageDbLoc
+ pkgDb <- expr $ packageDbPath loc
-- Confusingly calls recache rather than init because shake "creates"
-- the package db by virtue of creating the path to it, so we just recache
-- to create the package.cache file.
@@ -14,16 +14,16 @@ ghcPkgBuilderArgs = mconcat
, builder (GhcPkg Copy) ? do
verbosity <- expr getVerbosity
- stage <- getStage
- pkgDb <- expr $ packageDbPath stage
+ loc <- getPackageDbLoc
+ pkgDb <- expr $ packageDbPath loc
mconcat [ use_db pkgDb
, arg "register"
, verbosity < Verbose ? arg "-v0"
]
, builder (GhcPkg Unregister) ? do
verbosity <- expr getVerbosity
- stage <- getStage
- pkgDb <- expr $ packageDbPath stage
+ loc <- getPackageDbLoc
+ pkgDb <- expr $ packageDbPath loc
mconcat [ use_db pkgDb
, arg "unregister"
, arg "--force"
@@ -31,16 +31,14 @@ ghcPkgBuilderArgs = mconcat
]
, builder (GhcPkg Update) ? do
verbosity <- expr getVerbosity
- context <- getContext
- config <- expr $ pkgInplaceConfig context
- stage <- getStage
- pkgDb <- expr $ packageDbPath stage
+ loc <- getPackageDbLoc
+ pkgDb <- expr $ packageDbPath loc
mconcat [ notM stage0 ? use_db pkgDb
, arg "update"
, arg "--force"
, verbosity < Verbose ? arg "-v0"
, bootPackageDatabaseArgs
- , arg config ] ]
+ , arg =<< getInput ] ]
where
use_db db = mconcat
-- We use ghc-pkg's --global-package-db to manipulate our databases.
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 13eb146134..40bc5f2ac6 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -89,7 +89,7 @@ inTreeCompilerArgs stg = do
(hasDynamicRts, hasThreadedRts) <- do
- ways <- interpretInContext (Context stg rts vanilla) getRtsWays
+ ways <- interpretInContext (vanillaContext stg rts) getRtsWays
return (dynamic `elem` ways, threaded `elem` ways)
-- MP: We should be able to vary if stage1/stage2 is dynamic, ie a dynamic stage1
-- should be able to built a static stage2?
@@ -119,7 +119,7 @@ inTreeCompilerArgs stg = do
top <- topDirectory
pkgConfCacheFile <- System.FilePath.normalise . (top -/-)
- <$> (packageDbPath stg <&> (-/- "package.cache"))
+ <$> (packageDbPath (PackageDbLoc stg Final) <&> (-/- "package.cache"))
libdir <- System.FilePath.normalise . (top -/-)
<$> stageLibPath stg
diff --git a/hadrian/src/Settings/Program.hs b/hadrian/src/Settings/Program.hs
index 62d41909d3..9886b7a0e0 100644
--- a/hadrian/src/Settings/Program.hs
+++ b/hadrian/src/Settings/Program.hs
@@ -14,7 +14,7 @@ programContext :: Stage -> Package -> Action Context
programContext stage pkg = do
profiled <- askGhcProfiled stage
dynGhcProgs <- askDynGhcPrograms --dynamicGhcPrograms =<< flavour
- return $ Context stage pkg (wayFor profiled dynGhcProgs)
+ return $ Context stage pkg (wayFor profiled dynGhcProgs) Final
where wayFor prof dyn
| prof && dyn =
diff --git a/hadrian/src/Stage.hs b/hadrian/src/Stage.hs
index be2d123e06..fa83889579 100644
--- a/hadrian/src/Stage.hs
+++ b/hadrian/src/Stage.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE LambdaCase #-}
-module Stage (Stage (..), WhichLibs(..), isStage0, stage0InTree, stage0Boot, allStages,predStage, succStage, stageString) where
+module Stage (Stage (..), WhichLibs(..), Inplace(..), isStage0, stage0InTree, stage0Boot, allStages,predStage, succStage, stageString) where
import Development.Shake.Classes
import GHC.Generics
@@ -28,6 +28,38 @@ import GHC.Generics
data Stage = Stage0 WhichLibs | Stage1 | Stage2 | Stage3
deriving (Show, Eq, Ord, Generic)
+{-
+Note [Inplace vs Final package databases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are two package databases we maintain an "inplace" one and a "final" one.
+The inplace one is created by pre-configuring all the packages before doing any
+building. All GHC invocations to build .hs files will use an inplace package database
+for two reasons.
+
+1. To increase parallelism
+2. ./hadrian/ghci-multi can use the inplace package db to avoid having to build everything
+ before starting.
+
+The "inplace" database has .conf files which point directly to the build folders.
+The "final" database has a .conf file which points like normall to the install folder.
+
+Therefore when we are building modules, we can start compiling a module as soon as
+all it's dependencies are available in the build folder, rather than waiting for the
+whole package to finish, be copied and installed like before.
+
+Once we need to do a final link then we need to wait for the "final" versions to
+be enabled because then we want to make sure to create objects with the right rpaths and
+so on. The "final" .conf has dependencies on all the objects in the package (unlike the "inplace" .conf
+which has no such dependencies).
+
+-}
+data Inplace = Inplace | Final deriving (Show, Eq, Generic)
+
+instance Binary Inplace
+instance Hashable Inplace
+instance NFData Inplace
+
-- | See Note [Stage 0 build plans]
data WhichLibs = GlobalLibs -- ^ Build build tools against the globally installed libraries
diff --git a/hadrian/src/Utilities.hs b/hadrian/src/Utilities.hs
index 419d505bd8..2599e740f4 100644
--- a/hadrian/src/Utilities.hs
+++ b/hadrian/src/Utilities.hs
@@ -36,7 +36,7 @@ askWithResources rs target = H.askWithResources rs target getArgs
contextDependencies :: Context -> Action [Context]
contextDependencies Context {..} = do
depPkgs <- go [package]
- return [ Context stage pkg way | pkg <- depPkgs, pkg /= package ]
+ return [ Context stage pkg way iplace | pkg <- depPkgs, pkg /= package ]
where
go pkgs = do
deps <- concatMapM step pkgs