Commit 43e5c8f1 authored by Duncan Coutts's avatar Duncan Coutts Committed by Duncan Coutts

Parallelise the install command This is based on Mikhail Glushenkov's patches.

It adds a '-j N' (= 'number of jobs') option for the 'install' command, which
can be used to specify the number of concurrent workers. If possible, at most
N packages will be built concurrently.

This version of the patch is less featureful than Mikhail's version but also
rather simpler. The key difference compared to Mikhail's version is that this
version is lacking the output serialisation and the ability to tag each output
message with the task it came from. All output is interleaved. The next step
will be to make parallel builds log to files rather than the console and only
to display a summary on the console.

In addition to not having to change the output functions, the code is a bit
simpler by keep the structure of the code the same as before, rather than
splitting it into a number of concurrent tasks with channels. Instead each
task simply executes the same pattern of install actions and concurrency
limits are enforced using semaphores.
parent b0999460
......@@ -104,7 +104,8 @@ configure verbosity packageDBs repos comp conf
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags),
useLoggingHandle = Nothing,
useWorkingDir = Nothing
useWorkingDir = Nothing,
forceExternalSetupMethod = False
}
where
-- Hack: we typically want to allow the UserPackageDB for finding the
......
......@@ -78,6 +78,7 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.Client.World as World
import qualified Distribution.InstalledPackageInfo as Installed
import Paths_cabal_install (getBinDir)
import Distribution.Client.JobControl
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId), compilerFlavor
......@@ -99,7 +100,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion
( PackageIdentifier, PackageId, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion, InstalledPackageId )
import qualified Distribution.PackageDescription as PackageDescription
......@@ -409,16 +410,20 @@ checkPrintPlan verbosity installed installPlan installFlags pkgSpecifiers = do
linearizeInstallPlan :: PackageIndex
-> InstallPlan
-> [(ConfiguredPackage, PackageStatus)]
linearizeInstallPlan installedPkgIndex plan = unfoldr next plan
linearizeInstallPlan installedPkgIndex plan =
unfoldr next plan
where
next plan' = case InstallPlan.ready plan' of
[] -> Nothing
(pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan')
where pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
result = BuildOk DocsNotTried TestsNotTried
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
(pkg:_) -> Just ((pkg, status), plan'')
where
pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
plan'' = InstallPlan.completed pkgid
(BuildOk DocsNotTried TestsNotTried)
(InstallPlan.processing [pkg] plan')
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
data PackageStatus = NewPackage
| NewVersion [Version]
......@@ -737,12 +742,18 @@ performInstallations verbosity
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
executeInstallPlan installPlan $ \cpkg ->
jobControl <- if parallelBuild then newParallelJobControl
else newSerialJobControl
buildLimit <- newJobLimit numJobs
fetchLimit <- newJobLimit (min numJobs numFetchJobs)
installLimit <- newJobLimit 1 --serialise installation
executeInstallPlan verbosity jobControl installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
fetchSourcePackage verbosity src $ \src' ->
installLocalPackage verbosity (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity buildLimit installLimit
(setupScriptOptions installedPkgIndex)
miscOptions configFlags' installFlags haddockFlags
compid pkg mpath useLogFile
......@@ -751,6 +762,10 @@ performInstallations verbosity
platform = InstallPlan.planPlatform installPlan
compid = InstallPlan.planCompiler installPlan
numJobs = fromFlag (installNumJobs installFlags)
numFetchJobs = 2
parallelBuild = numJobs >= 2
setupScriptOptions index = SetupScriptOptions {
useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),
useCompiler = Just comp,
......@@ -771,7 +786,8 @@ performInstallations verbosity
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags),
useLoggingHandle = Nothing,
useWorkingDir = Nothing
useWorkingDir = Nothing,
forceExternalSetupMethod = parallelBuild
}
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
......@@ -784,6 +800,8 @@ performInstallations verbosity
= Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"
| otherwise
= flagToMaybe (installLogFile installFlags)
substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath
substLogFileName template pkg = fromPathTemplate
. substPathTemplate env
$ template
......@@ -796,16 +814,39 @@ performInstallations verbosity
}
executeInstallPlan :: Monad m
=> InstallPlan
-> (ConfiguredPackage -> m BuildResult)
-> m InstallPlan
executeInstallPlan plan installPkg = case InstallPlan.ready plan of
[] -> return plan
(pkg: _) -> do buildResult <- installPkg pkg
let plan' = updatePlan (packageId pkg) buildResult plan
executeInstallPlan plan' installPkg
executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> InstallPlan
-> (ConfiguredPackage -> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl plan0 installPkg =
tryNewTasks 0 plan0
where
tryNewTasks taskCount plan = do
case InstallPlan.ready plan of
[] | taskCount == 0 -> return plan
| otherwise -> waitForTasks taskCount plan
pkgs -> do
sequence_
[ do notice verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg
return (packageId pkg, buildResult)
| pkg <- pkgs
, let pkgid = packageId pkg]
let taskCount' = taskCount + length pkgs
plan' = InstallPlan.processing pkgs plan
waitForTasks taskCount' plan'
waitForTasks taskCount plan = do
notice verbosity $ "Waiting for install task to finish..."
(pkgid, buildResult) <- collectJob jobCtl
notice verbosity $ "Collecting build result for " ++ display pkgid
let taskCount' = taskCount-1
plan' = updatePlan pkgid buildResult plan
tryNewTasks taskCount' plan'
updatePlan pkgid (Right buildSuccess) =
InstallPlan.completed pkgid buildSuccess
......@@ -847,74 +888,91 @@ installConfiguredPackage platform comp configFlags
fetchSourcePackage
:: Verbosity
-> JobLimit
-> PackageLocation (Maybe FilePath)
-> (PackageLocation FilePath -> IO BuildResult)
-> IO BuildResult
fetchSourcePackage verbosity src installPkg = do
fetchSourcePackage verbosity fetchLimit src installPkg = do
fetched <- checkFetched src
case fetched of
Just src' -> installPkg src'
Nothing -> onFailure DownloadFailed $
fetchPackage verbosity src >>= installPkg
Nothing -> onFailure DownloadFailed $ do
loc <- withJobLimit fetchLimit $
fetchPackage verbosity src
installPkg loc
installLocalPackage
:: Verbosity -> PackageIdentifier -> PackageLocation FilePath
:: Verbosity
-> JobLimit
-> PackageIdentifier -> PackageLocation FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
installLocalPackage verbosity pkgid location installPkg = case location of
installLocalPackage verbosity jobLimit pkgid location installPkg =
case location of
LocalUnpackedPackage dir ->
installPkg (Just dir)
LocalTarballPackage tarballPath ->
installLocalTarballPackage verbosity pkgid tarballPath installPkg
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
RemoteTarballPackage _ tarballPath ->
installLocalTarballPackage verbosity pkgid tarballPath installPkg
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
RepoTarballPackage _ _ tarballPath ->
installLocalTarballPackage verbosity pkgid tarballPath installPkg
installLocalTarballPackage verbosity jobLimit
pkgid tarballPath installPkg
installLocalTarballPackage
:: Verbosity -> PackageIdentifier -> FilePath
:: Verbosity
-> JobLimit
-> PackageIdentifier -> FilePath
-> (Maybe FilePath -> IO BuildResult)
-> IO BuildResult
installLocalTarballPackage verbosity pkgid tarballPath installPkg = do
installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do
tmp <- getTemporaryDirectory
withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
onFailure UnpackFailed $ do
info verbosity $ "Extracting " ++ tarballPath
++ " to " ++ tmpDirPath ++ "..."
let relUnpackedPath = display pkgid
absUnpackedPath = tmpDirPath </> relUnpackedPath
descFilePath = absUnpackedPath
</> display (packageName pkgid) <.> "cabal"
extractTarGzFile tmpDirPath relUnpackedPath tarballPath
exists <- doesFileExist descFilePath
when (not exists) $
die $ "Package .cabal file not found: " ++ show descFilePath
withJobLimit jobLimit $ do
info verbosity $ "Extracting " ++ tarballPath
++ " to " ++ tmpDirPath ++ "..."
extractTarGzFile tmpDirPath relUnpackedPath tarballPath
exists <- doesFileExist descFilePath
when (not exists) $
die $ "Package .cabal file not found: " ++ show descFilePath
installPkg (Just absUnpackedPath)
installUnpackedPackage :: Verbosity
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity scriptOptions miscOptions
installUnpackedPackage
:: Verbosity
-> JobLimit
-> JobLimit
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity buildLimit installLimit
scriptOptions miscOptions
configFlags installConfigFlags haddockFlags
compid pkg workingDir useLogFile =
-- Configure phase
onFailure ConfigureFailed $ do
onFailure ConfigureFailed $ withJobLimit buildLimit $ do
setup configureCommand configureFlags
-- Build phase
......@@ -938,7 +996,7 @@ installUnpackedPackage verbosity scriptOptions miscOptions
| otherwise = TestsNotTried
-- Install phase
onFailure InstallFailed $
onFailure InstallFailed $ withJobLimit installLimit $
withWin32SelfUpgrade verbosity configFlags compid pkg $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
......
......@@ -790,11 +790,11 @@ installOptions showOrParseArgs =
(yesNoOpt showOrParseArgs)
, option "j" ["jobs"]
"Run N jobs simultaneously."
"Run NUM jobs simultaneously."
installNumJobs (\v flags -> flags { installNumJobs = v })
(reqArg "NUM" (readP_to_E (const $ "Argument should be an integer")
(toFlag `fmap` parse))
(flagToList . fmap display))
(reqArg "NUM" (readP_to_E (\_ -> "jobs should be a number")
(fmap toFlag (Parse.readS_to_P reads)))
(map show . flagToList))
] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids
ParseArgs ->
option [] ["only"]
......
......@@ -38,8 +38,7 @@ import Distribution.PackageDescription.Parse
import Distribution.Simple.Configure
( configCompiler )
import Distribution.Simple.Compiler
( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack
, compilerVersion )
( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program
( ProgramConfiguration, emptyProgramConfiguration
, rawSystemProgramConf, ghcProgram )
......@@ -76,26 +75,28 @@ import Data.Maybe ( fromMaybe, isJust )
import Data.Char ( isSpace )
data SetupScriptOptions = SetupScriptOptions {
useCabalVersion :: VersionRange,
useCompiler :: Maybe Compiler,
usePackageDB :: PackageDBStack,
usePackageIndex :: Maybe PackageIndex,
useProgramConfig :: ProgramConfiguration,
useDistPref :: FilePath,
useLoggingHandle :: Maybe Handle,
useWorkingDir :: Maybe FilePath
useCabalVersion :: VersionRange,
useCompiler :: Maybe Compiler,
usePackageDB :: PackageDBStack,
usePackageIndex :: Maybe PackageIndex,
useProgramConfig :: ProgramConfiguration,
useDistPref :: FilePath,
useLoggingHandle :: Maybe Handle,
useWorkingDir :: Maybe FilePath,
forceExternalSetupMethod :: Bool
}
defaultSetupScriptOptions :: SetupScriptOptions
defaultSetupScriptOptions = SetupScriptOptions {
useCabalVersion = anyVersion,
useCompiler = Nothing,
usePackageDB = [GlobalPackageDB, UserPackageDB],
usePackageIndex = Nothing,
useProgramConfig = emptyProgramConfiguration,
useDistPref = defaultDistPref,
useLoggingHandle = Nothing,
useWorkingDir = Nothing
useCabalVersion = anyVersion,
useCompiler = Nothing,
usePackageDB = [GlobalPackageDB, UserPackageDB],
usePackageIndex = Nothing,
useProgramConfig = emptyProgramConfiguration,
useDistPref = defaultDistPref,
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = False
}
setupWrapper :: Verbosity
......@@ -135,11 +136,12 @@ setupWrapper verbosity options mpkg cmd flags extraArgs = do
--
determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod
determineSetupMethod options buildType'
| forceExternalSetupMethod options = externalSetupMethod
| isJust (useLoggingHandle options)
|| buildType' == Custom = externalSetupMethod
|| buildType' == Custom = externalSetupMethod
| cabalVersion `withinRange`
useCabalVersion options = internalSetupMethod
| otherwise = externalSetupMethod
useCabalVersion options = internalSetupMethod
| otherwise = externalSetupMethod
type SetupMethod = Verbosity
-> SetupScriptOptions
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment