diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 0f47c379411..b5ac3963b3e 100644 --- a/Cabal/Cabal.cabal +++ b/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, diff --git a/Cabal/Distribution/Simple/BoundedResource.hs b/Cabal/Distribution/Simple/BoundedResource.hs new file mode 100644 index 00000000000..1697ae7c507 --- /dev/null +++ b/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 diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 627848bf72e..2c64fffaf41 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/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,6 +103,8 @@ 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 ) @@ -109,11 +112,11 @@ 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 diff --git a/cabal-install/Distribution/Client/JobControl.hs b/Cabal/Distribution/Simple/JobControl.hs similarity index 83% rename from cabal-install/Distribution/Client/JobControl.hs rename to Cabal/Distribution/Simple/JobControl.hs index a4d227f307c..f37481baafb 100644 --- a/cabal-install/Distribution/Client/JobControl.hs +++ b/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 diff --git a/Cabal/Distribution/Simple/LocalBuildInfo.hs b/Cabal/Distribution/Simple/LocalBuildInfo.hs index ed0b8f78868..ff0db5a5d55 100644 --- a/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/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 = diff --git a/Cabal/tests/UnitTests.hs b/Cabal/tests/UnitTests.hs index 36b68ce5946..2a075d28a2b 100644 --- a/Cabal/tests/UnitTests.hs +++ b/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 () diff --git a/Cabal/tests/UnitTests/Distribution/Simple/JobControl.hs b/Cabal/tests/UnitTests/Distribution/Simple/JobControl.hs new file mode 100644 index 00000000000..232e41ff172 --- /dev/null +++ b/Cabal/tests/UnitTests/Distribution/Simple/JobControl.hs @@ -0,0 +1,117 @@ +module UnitTests.Distribution.Simple.JobControl + ( tests + ) where + +import Control.Monad +import Control.Concurrent +import Control.Exception +import Data.IORef +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit (Assertion, assertBool, assertEqual) + +import Distribution.Simple.JobControl + + +tests :: [Test] +tests = + [ testCase "withJobLimit" test_withJobLimit + , testCase "withJobLimit with exceptions" test_withJobLimitExceptions + ] + + +-- Convenicence. +atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () +atomicModifyIORef_ ref f = atomicModifyIORef' ref (\x -> (f x, ())) + + + +test_withJobLimit :: Assertion +test_withJobLimit = do + + let maxJobs = 4 :: Int + numJobs = 100 :: Int + + -- How many threads are currently in our `withJobLimit` region. + -- This is only precise enough because we `threadDelay` to enforce our + -- ordering of events, but that is sufficient for this test to check if + -- `withJobLimit` does throttle the jobs or not. + insideRef <- newIORef (0 :: Int) + + limit <- newJobLimit maxJobs + + mvars <- forM [1..numJobs] $ \_ -> do + mvar <- newEmptyMVar -- to signal when job is finished + + -- Spawn new thread, inside limit to JobLimit + _ <- forkIO $ withJobLimit limit $ do + + -- Increase running jobs count and check its sanity + inside <- atomicModifyIORef' insideRef (\n -> (n+1, n+1)) + assertBool "running jobs exceeded job limit" $ inside <= maxJobs + assertBool "running jobs became too small" $ inside > 0 + + threadDelay 10000 -- wait 10 ms for job's "work" + + -- Decrease running jobs count + atomicModifyIORef_ insideRef pred + putMVar mvar () -- signal job finished + + return mvar + + -- Wait for all jobs to finish + forM_ mvars takeMVar + + +-- This test checks that a JobLimit doesn't get confused about the number of +-- running jobs when a job throws an exception (that the internal job +-- capacity does not change), and that a failed job does not impact other jobs +-- that are currently running or will be run in the future. +test_withJobLimitExceptions :: Assertion +test_withJobLimitExceptions = do + + let maxJobs = 4 :: Int + numJobs = 100 :: Int + + -- How many exceptions have been raised across all jobs + exceptionCounterRef <- newIORef (0 :: Int) + + -- When a job raises an exception and that propagates out of the + -- `withJobLimit`, we simply count it. + -- This is to test that a failed job has no impact on the other jobs. + let excHandler e = (e :: SomeException) `seq` + atomicModifyIORef_ exceptionCounterRef (+ 1) + + insideRef <- newIORef (0 :: Int) + + limit <- newJobLimit maxJobs + + mvars <- forM [1..numJobs] $ \jobNo -> do + mvar <- newEmptyMVar -- to signal when job is finished + + -- Spawn new thread, inside limit to JobLimit + _ <- forkIO $ handle excHandler $ withJobLimit limit $ do + + -- Increase running jobs count and check its sanity + inside <- atomicModifyIORef' insideRef (\n -> (n+1, n+1)) + assertBool "running jobs exceeded job limit" $ inside <= maxJobs + assertBool "running jobs became too small" $ inside > 0 + + threadDelay 10000 -- wait 10 ms for job's "work" + + -- Make every 5th job throw an exception (but still count the job as + -- finished) + finally (when (jobNo `mod` 5 == 0) $ error "job fails") + $ do + -- Decrease running jobs count + atomicModifyIORef_ insideRef pred + putMVar mvar () -- signal job finished + + return mvar + + -- Wait for all jobs to finish + forM_ mvars takeMVar + + -- Assert that the exceptions we expect really come through + exceptionCounter <- readIORef exceptionCounterRef + assertEqual "did not get enough jobs with exceptions" 20 exceptionCounter diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index afa9b2de626..ef2989a64f2 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -95,7 +95,7 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Client.Compat.ExecutablePath -import Distribution.Client.JobControl +import Distribution.Simple.JobControl import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index f4aec41e4c2..5fb5cbc3f86 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -64,7 +64,7 @@ import Distribution.Client.Config ( defaultCabalDir ) import Distribution.Client.IndexUtils ( getInstalledPackages ) -import Distribution.Client.JobControl +import Distribution.Simple.JobControl ( Lock, criticalSection ) import Distribution.Simple.Setup ( Flag(..) ) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index ae450e05ebc..8f762e88971 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -84,7 +84,6 @@ executable cabal Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink - Distribution.Client.JobControl Distribution.Client.List Distribution.Client.PackageIndex Distribution.Client.PackageUtils