Skip to content

Commit 85b2a5c

Browse files
alt-romesalt-romes
committed
Synchronize VCS repos concurrently
Cloning/synchronising VCS repos can be unnecessarily slow if done serially. By synchronizing the repos concurrently we make much better use of time. Introduces rerunConcurrentlyIfChanged, a Rebuild monad function that runs, from multiple actions, the actions that need rebuilding concurrently.
1 parent 64ffa84 commit 85b2a5c

File tree

9 files changed

+172
-72
lines changed

9 files changed

+172
-72
lines changed

‎cabal-install/src/Distribution/Client/CmdInstall.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -467,6 +467,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
467467
fetchAndReadSourcePackages
468468
verbosity
469469
distDirLayout
470+
compiler
470471
(projectConfigShared config)
471472
(projectConfigBuildOnly config)
472473
[ProjectPackageRemoteTarball uri | uri <- uris]

‎cabal-install/src/Distribution/Client/JobControl.hs‎

Lines changed: 44 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,11 @@ module Distribution.Client.JobControl
3131
, Lock
3232
, newLock
3333
, criticalSection
34+
35+
-- * Higher level utils
36+
, newJobControlFromParStrat
37+
, withJobControl
38+
, mapConcurrentWithJobs
3439
) where
3540

3641
import Distribution.Client.Compat.Prelude
@@ -40,11 +45,14 @@ import Control.Concurrent (forkIO, forkIOWithUnmask, threadDelay)
4045
import Control.Concurrent.MVar
4146
import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar)
4247
import Control.Concurrent.STM.TChan
43-
import Control.Exception (bracket_, mask_, try)
48+
import Control.Exception (bracket, bracket_, mask_, try)
4449
import Control.Monad (forever, replicateM_)
4550
import Distribution.Client.Compat.Semaphore
51+
import Distribution.Client.Utils (numberOfProcessors)
4652
import Distribution.Compat.Stack
53+
import Distribution.Simple.Compiler
4754
import Distribution.Simple.Utils
55+
import Distribution.Types.ParStrat
4856
import System.Semaphore
4957

5058
-- | A simple concurrency abstraction. Jobs can be spawned and can complete
@@ -262,3 +270,38 @@ newLock = fmap Lock $ newMVar ()
262270

263271
criticalSection :: Lock -> IO a -> IO a
264272
criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
273+
274+
--------------------------------------------------------------------------------
275+
-- More high level utils
276+
--------------------------------------------------------------------------------
277+
278+
newJobControlFromParStrat
279+
:: Verbosity
280+
-> Compiler
281+
-> ParStratInstall
282+
-- ^ The parallel strategy
283+
-> Maybe Int
284+
-- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy)
285+
-> IO (JobControl IO a)
286+
newJobControlFromParStrat verbosity compiler parStrat numJobsCap = case parStrat of
287+
Serial -> newSerialJobControl
288+
NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n))
289+
UseSem n ->
290+
if jsemSupported compiler
291+
then newSemaphoreJobControl verbosity (capJobs n)
292+
else do
293+
warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
294+
newParallelJobControl (capJobs n)
295+
where
296+
capJobs n = min (fromMaybe maxBound numJobsCap) n
297+
298+
withJobControl :: IO (JobControl IO a) -> (JobControl IO a -> IO b) -> IO b
299+
withJobControl mkJC = bracket mkJC cleanupJobControl
300+
301+
-- | Concurrently execute actions on a list using the given JobControl.
302+
-- The maximum number of concurrent jobs is tied to the JobControl instance.
303+
-- The resulting list does /not/ preserve the original order!
304+
mapConcurrentWithJobs :: JobControl IO b -> (a -> IO b) -> [a] -> IO [b]
305+
mapConcurrentWithJobs jobControl f xs = do
306+
traverse_ (spawnJob jobControl . f) xs
307+
traverse (const $ collectJob jobControl) xs

‎cabal-install/src/Distribution/Client/ProjectBuilding.hs‎

Lines changed: 5 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ import qualified Data.Set as Set
8888

8989
import qualified Text.PrettyPrint as Disp
9090

91-
import Control.Exception (assert, bracket, handle)
91+
import Control.Exception (assert, handle)
9292
import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
9393
import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
9494
import System.Semaphore (SemaphoreName (..))
@@ -98,7 +98,6 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
9898

9999
import Distribution.Client.ProjectBuilding.PackageFileMonitor
100100
import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
101-
import Distribution.Client.Utils (numberOfProcessors)
102101

103102
------------------------------------------------------------------------------
104103

@@ -355,17 +354,6 @@ rebuildTargets
355354
}
356355
| fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
357356
| otherwise = do
358-
-- Concurrency control: create the job controller and concurrency limits
359-
-- for downloading, building and installing.
360-
mkJobControl <- case buildSettingNumJobs of
361-
Serial -> newSerialJobControl
362-
NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n)
363-
UseSem n ->
364-
if jsemSupported compiler
365-
then newSemaphoreJobControl verbosity n
366-
else do
367-
warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
368-
newParallelJobControl n
369357
registerLock <- newLock -- serialise registration
370358
cacheLock <- newLock -- serialise access to setup exe cache
371359
-- TODO: [code cleanup] eliminate setup exe cache
@@ -380,7 +368,9 @@ rebuildTargets
380368
createDirectoryIfMissingVerbose verbosity True distTempDirectory
381369
traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
382370

383-
bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do
371+
-- Concurrency control: create the job controller and concurrency limits
372+
-- for downloading, building and installing.
373+
withJobControl (newJobControlFromParStrat verbosity compiler buildSettingNumJobs Nothing) $ \jobControl -> do
384374
-- Before traversing the install plan, preemptively find all packages that
385375
-- will need to be downloaded and start downloading them.
386376
asyncDownloadPackages
@@ -391,7 +381,7 @@ rebuildTargets
391381
$ \downloadMap ->
392382
-- For each package in the plan, in dependency order, but in parallel...
393383
InstallPlan.execute
394-
mkJobControl
384+
jobControl
395385
keepGoing
396386
(BuildFailure Nothing . DependentFailed . packageId)
397387
installPlan

‎cabal-install/src/Distribution/Client/ProjectConfig.hs‎

Lines changed: 34 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ module Distribution.Client.ProjectConfig
5454
, resolveSolverSettings
5555
, BuildTimeSettings (..)
5656
, resolveBuildTimeSettings
57+
, resolveNumJobsSetting
5758

5859
-- * Checking configuration
5960
, checkBadPerPackageCompilerPaths
@@ -67,6 +68,7 @@ import Prelude ()
6768
import Distribution.Client.Glob
6869
( isTrivialRootedGlob
6970
)
71+
import Distribution.Client.JobControl
7072
import Distribution.Client.ProjectConfig.Legacy
7173
import Distribution.Client.ProjectConfig.Types
7274
import Distribution.Client.RebuildMonad
@@ -433,12 +435,7 @@ resolveBuildTimeSettings
433435
-- buildSettingLogVerbosity -- defined below, more complicated
434436
buildSettingBuildReports = fromFlag projectConfigBuildReports
435437
buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
436-
buildSettingNumJobs =
437-
if fromFlag projectConfigUseSemaphore
438-
then UseSem (determineNumJobs projectConfigNumJobs)
439-
else case (determineNumJobs projectConfigNumJobs) of
440-
1 -> Serial
441-
n -> NumJobs (Just n)
438+
buildSettingNumJobs = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs
442439
buildSettingKeepGoing = fromFlag projectConfigKeepGoing
443440
buildSettingOfflineMode = fromFlag projectConfigOfflineMode
444441
buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
@@ -534,6 +531,15 @@ resolveBuildTimeSettings
534531
| isParallelBuild buildSettingNumJobs = False
535532
| otherwise = False
536533

534+
-- | Determine the number of jobs (ParStrat) from the project config
535+
resolveNumJobsSetting :: Flag Bool -> Flag (Maybe Int) -> ParStratX Int
536+
resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs =
537+
if fromFlag projectConfigUseSemaphore
538+
then UseSem (determineNumJobs projectConfigNumJobs)
539+
else case (determineNumJobs projectConfigNumJobs) of
540+
1 -> Serial
541+
n -> NumJobs (Just n)
542+
537543
---------------------------------------------
538544
-- Reading and writing project config files
539545
--
@@ -1212,13 +1218,15 @@ mplusMaybeT ma mb = do
12121218
fetchAndReadSourcePackages
12131219
:: Verbosity
12141220
-> DistDirLayout
1221+
-> Compiler
12151222
-> ProjectConfigShared
12161223
-> ProjectConfigBuildOnly
12171224
-> [ProjectPackageLocation]
12181225
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
12191226
fetchAndReadSourcePackages
12201227
verbosity
12211228
distDirLayout
1229+
compiler
12221230
projectConfigShared
12231231
projectConfigBuildOnly
12241232
pkgLocations = do
@@ -1255,7 +1263,9 @@ fetchAndReadSourcePackages
12551263
syncAndReadSourcePackagesRemoteRepos
12561264
verbosity
12571265
distDirLayout
1266+
compiler
12581267
projectConfigShared
1268+
projectConfigBuildOnly
12591269
(fromFlag (projectConfigOfflineMode projectConfigBuildOnly))
12601270
[repo | ProjectPackageRemoteRepo repo <- pkgLocations]
12611271

@@ -1372,16 +1382,23 @@ fetchAndReadSourcePackageRemoteTarball
13721382
syncAndReadSourcePackagesRemoteRepos
13731383
:: Verbosity
13741384
-> DistDirLayout
1385+
-> Compiler
13751386
-> ProjectConfigShared
1387+
-> ProjectConfigBuildOnly
13761388
-> Bool
13771389
-> [SourceRepoList]
13781390
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
13791391
syncAndReadSourcePackagesRemoteRepos
13801392
verbosity
13811393
DistDirLayout{distDownloadSrcDirectory}
1394+
compiler
13821395
ProjectConfigShared
13831396
{ projectConfigProgPathExtra
13841397
}
1398+
ProjectConfigBuildOnly
1399+
{ projectConfigUseSemaphore
1400+
, projectConfigNumJobs
1401+
}
13851402
offlineMode
13861403
repos = do
13871404
repos' <-
@@ -1407,10 +1424,15 @@ syncAndReadSourcePackagesRemoteRepos
14071424
in configureVCS verbosity progPathExtra vcs
14081425

14091426
concat
1410-
<$> sequenceA
1411-
[ rerunIfChanged verbosity monitor repoGroup' $ do
1412-
vcs' <- getConfiguredVCS repoType
1413-
syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
1427+
<$> rerunConcurrentlyIfChanged
1428+
verbosity
1429+
(newJobControlFromParStrat verbosity compiler parStrat maxNumFetchJobs)
1430+
[ ( monitor
1431+
, repoGroup'
1432+
, do
1433+
vcs' <- getConfiguredVCS repoType
1434+
syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
1435+
)
14141436
| repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation
14151437
, let repoGroup' = map fst repoGroup
14161438
pathStem =
@@ -1423,6 +1445,8 @@ syncAndReadSourcePackagesRemoteRepos
14231445
monitor = newFileMonitor (pathStem <.> "cache")
14241446
]
14251447
where
1448+
maxNumFetchJobs = Just 2 -- try to keep this in sync with Distribution.Client.Install's numFetchJobs.
1449+
parStrat = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs
14261450
syncRepoGroupAndReadSourcePackages
14271451
:: VCS ConfiguredProgram
14281452
-> FilePath

‎cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs‎

Lines changed: 4 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -206,12 +206,10 @@ type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig
206206
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
207207
singletonProjectConfigSkeleton x = CondNode x mempty mempty
208208

209-
instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
210-
instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
211-
| null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel)
212-
| otherwise = do
213-
(os, arch, impl) <- fetch
214-
pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
209+
instantiateProjectConfigSkeletonFetchingCompiler :: (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
210+
instantiateProjectConfigSkeletonFetchingCompiler (os, arch, impl) flags skel
211+
| null (toListOf traverseCondTreeV skel) = fst (ignoreConditions skel)
212+
| otherwise = instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
215213

216214
instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
217215
instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel

‎cabal-install/src/Distribution/Client/ProjectPlanning.hs‎

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -384,17 +384,16 @@ rebuildProjectConfig
384384
$ do
385385
liftIO $ info verbosity "Project settings changed, reconfiguring..."
386386
projectConfigSkeleton <- phaseReadProjectConfig
387-
let fetchCompiler = do
388-
-- have to create the cache directory before configuring the compiler
389-
liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
390-
(compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
391-
pure (os, arch, compilerInfo compiler)
392387

393-
projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
388+
-- have to create the cache directory before configuring the compiler
389+
liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
390+
(compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
391+
392+
let projectConfig = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectConfigSkeleton
394393
when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $
395394
liftIO $
396395
warn verbosity "The builddir option is not supported in project and config files. It will be ignored."
397-
localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)
396+
localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig)
398397
return (projectConfig, localPackages)
399398

400399
sequence_
@@ -426,9 +425,11 @@ rebuildProjectConfig
426425
-- NOTE: These are all packages mentioned in the project configuration.
427426
-- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`.
428427
phaseReadLocalPackages
429-
:: ProjectConfig
428+
:: Compiler
429+
-> ProjectConfig
430430
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
431431
phaseReadLocalPackages
432+
compiler
432433
projectConfig@ProjectConfig
433434
{ projectConfigShared
434435
, projectConfigBuildOnly
@@ -443,6 +444,7 @@ rebuildProjectConfig
443444
fetchAndReadSourcePackages
444445
verbosity
445446
distDirLayout
447+
compiler
446448
projectConfigShared
447449
projectConfigBuildOnly
448450
pkgLocations

0 commit comments

Comments
 (0)