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.

cabal-install/Distribution/Client/Configure.hs

@@ -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

cabal-install/Distribution/Client/Install.hs

@@ -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

cabal-install/Distribution/Client/Setup.hs

@@ -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"]

cabal-install/Distribution/Client/SetupWrapper.hs

@@ -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