diff options
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 |