summaryrefslogtreecommitdiff
path: root/hadrian
diff options
context:
space:
mode:
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