Build executables in parallel

Cabal/Cabal.cabal

@@ -156,6 +156,7 @@ library
     Distribution.ReadE
     Distribution.Simple
     Distribution.Simple.Bench
+    Distribution.Simple.BoundedResource,
     Distribution.Simple.Build
     Distribution.Simple.Build.Macros
     Distribution.Simple.Build.PathsModule
@@ -173,6 +174,7 @@ library
     Distribution.Simple.Install
     Distribution.Simple.InstallDirs
     Distribution.Simple.JHC
+    Distribution.Simple.JobControl
     Distribution.Simple.LHC
     Distribution.Simple.LocalBuildInfo
     Distribution.Simple.NHC
@@ -220,7 +222,9 @@ library
 test-suite unit-tests
   type: exitcode-stdio-1.0
   hs-source-dirs: tests
-  other-modules: UnitTests.Distribution.Compat.ReadP
+  other-modules:
+    UnitTests.Distribution.Compat.ReadP
+    UnitTests.Distribution.Simple.JobControl
   main-is: UnitTests.hs
   build-depends:
     base,

Cabal/Distribution/Simple/BoundedResource.hs

@@ -0,0 +1,56 @@
+module Distribution.Simple.BoundedResource
+  ( BoundedResource
+  , newBoundedResource
+  , takeResource
+  , putResource
+  , withResource
+  ) where
+
+import Control.Concurrent.Chan
+import Control.Exception (bracket_)
+import Control.Monad
+
+
+-- | Manages sparse resources in IO, allowing you to use at maximum a certain
+-- number of them.
+--
+-- The number of available resources can be adjusted at run-time with
+-- `takeResource` and `putResource`.
+--
+-- Exception-safe use-and-free access is provided via `withResource`.
+--
+-- Uses O(n) memory in the number of free slots.
+newtype BoundedResource =
+    BoundedResource
+      (Chan ()) -- ^ a "slot" for each available resource (>= 0, <= N)
+
+
+-- | Create a new resource that can provide at maximum n slots.
+newBoundedResource :: Int -> IO BoundedResource
+newBoundedResource n = do
+  when (n < 0) $ error $ "newBoundedResource: negative size: " ++ show n
+  chan <- newChan
+  replicateM_ n $ writeChan chan () -- put n slots in
+  return $ BoundedResource chan
+
+
+-- | Take one slot away from the resource.
+-- If no slot is free, blocks until one becomes free.
+--
+-- Use `withResource` for use-free combinations.
+takeResource :: BoundedResource -> IO ()
+takeResource (BoundedResource slotChan) = readChan slotChan
+
+
+-- | Add a free slot to the resource.
+--
+-- Use `withResource` for use-free combinations.
+putResource :: BoundedResource -> IO ()
+putResource (BoundedResource slotChan) = writeChan slotChan ()
+
+
+-- | Perform an action, requiring one free slot from the resource.
+--
+-- Ensures that the action failing with an exception cannot break the Resource.
+withResource :: BoundedResource -> IO a -> IO a
+withResource res io = bracket_ (takeResource res) (putResource res) io

Cabal/Distribution/Simple/Build.hs

@@ -79,7 +79,8 @@ import qualified Distribution.ModuleName as ModuleName
 import Distribution.ModuleName (ModuleName)
 
 import Distribution.Simple.Setup
-         ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )
+         ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag
+         , fromFlagOrDefault )
 import Distribution.Simple.BuildTarget
          ( BuildTarget(..), readBuildTargets )
 import Distribution.Simple.PreProcess
@@ -102,18 +103,20 @@ import Distribution.Simple.Test ( stubFilePath, stubName )
 import Distribution.Simple.Utils
          ( createDirectoryIfMissingVerbose, rewriteFile
          , die, info, debug, warn, setupMessage )
+import Distribution.Simple.JobControl
+         ( newParallelJobControl, spawnJob, collectJob, newJobLimit, withJobLimit )
 
 import Distribution.Verbosity
          ( Verbosity )
 import Distribution.Text
          ( display )
 
 import Data.Maybe
-         ( maybeToList )
+         ( fromMaybe, maybeToList )
 import Data.Either
          ( partitionEithers )
 import Data.List
-         ( intersect, intercalate )
+         ( intersect, intercalate, partition )
 import Control.Monad
          ( when, unless, forM_ )
 import System.FilePath
@@ -130,31 +133,69 @@ build    :: PackageDescription  -- ^ Mostly information from the .cabal file
          -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
          -> IO ()
 build pkg_descr lbi flags suffixes = do
-  let distPref  = fromFlag (buildDistPref flags)
-      verbosity = fromFlag (buildVerbosity flags)
 
   targets  <- readBuildTargets pkg_descr (buildArgs flags)
   targets' <- checkBuildTargets verbosity pkg_descr targets
-  let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))
+  let componentsToBuild = componentsInBuildOrder lbi (map fst targets')
   info verbosity $ "Component build order: "
-                ++ intercalate ", " (map showComponentName componentsToBuild)
+                ++ intercalate ", " (map (showComponentName . fst) componentsToBuild)
 
   initialBuildSteps distPref pkg_descr lbi verbosity
   when (null targets) $
     -- Only bother with this message if we're building the whole package
     setupMessage verbosity "Building" (packageId pkg_descr)
 
+  -- Strategy for parallel building:
+  -- First build the library on its own, then build all executables /
+  -- tests / etc. in parallel since they cannot depend on each other.
+
+  let (libraries, nonLibraries) = partition (\(name, _) -> name == CLibName)
+                                            componentsToBuild
+
+  -- In case we ever allow multiple libraries, we probably need to change this
+  -- code (and we should build them in parallel).
+  -- Note that it is also perfectly ok to have 0 libraries (only executables).
+  when (length libraries > 1) $ error "build: Found more than 1 library"
+
+  -- Create internal package db on which the build will operate
   internalPackageDB <- createInternalPackageDB distPref
 
-  withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->
-    let bi     = componentBuildInfo comp
-        progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
-        lbi'   = lbi {
-                   withPrograms  = progs',
-                   withPackageDB = withPackageDB lbi ++ [internalPackageDB]
-                 }
-    in buildComponent verbosity (buildNumJobs flags) pkg_descr
-                      lbi' suffixes comp clbi distPref
+  -- Limit number of concurrent non-library builds to `numJobs`, or 1 if not given
+  buildJobLimit <- newJobLimit (fromMaybe 1 numJobs)
+
+  -- TODO make sure linker errors let cabal exit with code 1
+  -- TODO make sure Ctrl-C kills parallel builds
+
+  -- Build the library
+  withComponentsInBuildOrder pkg_descr lbi (map fst libraries)
+                             (buildComponentInternal internalPackageDB)
+
+  -- Build everything else in parallel
+  jobControl <- newParallelJobControl
+  forM_ nonLibraries $ \(cname, clbi) -> do
+    -- Run in parallel with job limit.
+    -- TODO Check what happens when a job throws an exception.
+    spawnJob jobControl $ withJobLimit buildJobLimit $
+      buildComponentInternal internalPackageDB
+                             (getComponent pkg_descr cname) clbi
+
+  forM_ nonLibraries (\_ -> collectJob jobControl)
+
+  where
+    distPref  = fromFlag (buildDistPref flags)
+    verbosity = fromFlag (buildVerbosity flags)
+    numJobs   = fromFlagOrDefault Nothing (buildNumJobs flags)
+
+    -- Builds the component against the internal package db
+    buildComponentInternal internalPackageDB comp clbi = do
+      let bi     = componentBuildInfo comp
+          progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
+          lbi'   = lbi {
+                     withPrograms  = progs',
+                     withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+                   }
+      buildComponent verbosity (buildNumJobs flags) pkg_descr
+                     lbi' suffixes comp clbi distPref
 
 
 repl     :: PackageDescription  -- ^ Mostly information from the .cabal file

cabal-install/Distribution/Client/JobControl.hs → Cabal/Distribution/Simple/JobControl.hs

@@ -1,6 +1,6 @@
 -----------------------------------------------------------------------------
 -- |
--- Module      :  Distribution.Client.JobControl
+-- Module      :  Distribution.Simple.JobControl
 -- Copyright   :  (c) Duncan Coutts 2012
 -- License     :  BSD-like
 --
@@ -10,7 +10,7 @@
 --
 -- A job control concurrency abstraction
 -----------------------------------------------------------------------------
-module Distribution.Client.JobControl (
+module Distribution.Simple.JobControl (
     JobControl,
     newSerialJobControl,
     newParallelJobControl,
@@ -26,10 +26,11 @@ module Distribution.Client.JobControl (
     criticalSection
   ) where
 
+import Control.Applicative
 import Control.Monad
-import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem)
+import Control.Concurrent
 import Control.Exception (SomeException, bracket_, mask, throw, try)
-import Distribution.Client.Compat.Semaphore
+import Distribution.Simple.BoundedResource
 
 data JobControl m a = JobControl {
        spawnJob    :: m a -> m (),
@@ -70,20 +71,19 @@ newParallelJobControl = do
     collect resultVar =
       takeMVar resultVar >>= either throw return
 
-data JobLimit = JobLimit QSem
+
+newtype JobLimit = JobLimit BoundedResource
 
 newJobLimit :: Int -> IO JobLimit
-newJobLimit n =
-  fmap JobLimit (newQSem n)
+newJobLimit n = JobLimit <$> newBoundedResource n
 
 withJobLimit :: JobLimit -> IO a -> IO a
-withJobLimit (JobLimit sem) =
-  bracket_ (waitQSem sem) (signalQSem sem)
+withJobLimit (JobLimit res) io = withResource res io
 
 newtype Lock = Lock (MVar ())
 
 newLock :: IO Lock
-newLock = fmap Lock $ newMVar ()
+newLock = Lock <$> newMVar ()
 
 criticalSection :: Lock -> IO a -> IO a
 criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act

Cabal/Distribution/Simple/LocalBuildInfo.hs

@@ -357,6 +357,10 @@ withAllComponentsInBuildOrder pkg lbi f =
       [ f (getComponent pkg cname) clbi
       | (cname, clbi) <- allComponentsInBuildOrder lbi ]
 
+-- | Like `withAllComponentsInBuildOrder`, but allows to pass in the
+-- components you are interested in. Your function may be called on more
+-- components than you passed in (namely on the transitive closure of
+-- dependencies as well).
 withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo
                                   -> [ComponentName]
                                   -> (Component -> ComponentLocalBuildInfo -> IO ())
@@ -372,6 +376,9 @@ allComponentsInBuildOrder lbi =
     componentsInBuildOrder lbi
       [ cname | (cname, _, _) <- componentsConfigs lbi ]
 
+-- | Given a list of components to build, calculates the build order of
+-- components to build (transitive closure). Therefore the output
+-- list can be longer than the input.
 componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]
                        -> [(ComponentName, ComponentLocalBuildInfo)]
 componentsInBuildOrder lbi cnames =

Cabal/tests/UnitTests.hs

@@ -5,11 +5,14 @@ module Main
 import Test.Framework
 
 import qualified UnitTests.Distribution.Compat.ReadP
+import qualified UnitTests.Distribution.Simple.JobControl
 
 tests :: [Test]
-tests = [
-    testGroup "Distribution.Compat.ReadP"
+tests =
+    [ testGroup "Distribution.Compat.ReadP"
         UnitTests.Distribution.Compat.ReadP.tests
+    , testGroup "Distribution.Simple.JobControl"
+        UnitTests.Distribution.Simple.JobControl.tests
     ]
 
 main :: IO ()