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.
alt-romes · Nov 7, 2024 · bf24ac6 · bf24ac6
1 parent 40f88e3
commit bf24ac6
Show file tree

Hide file tree

Showing 9 changed files with 172 additions and 72 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -467,6 +467,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
         fetchAndReadSourcePackages
           verbosity
           distDirLayout
+          compiler
           (projectConfigShared config)
           (projectConfigBuildOnly config)
           [ProjectPackageRemoteTarball uri | uri <- uris]

diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs
@@ -31,6 +31,11 @@ module Distribution.Client.JobControl
   , Lock
   , newLock
   , criticalSection
+
+    -- * Higher level utils
+  , newJobControlFromParStrat
+  , withJobControl
+  , mapConcurrentWithJobs
   ) where
 
 import Distribution.Client.Compat.Prelude
@@ -40,11 +45,14 @@ import Control.Concurrent (forkIO, forkIOWithUnmask, threadDelay)
 import Control.Concurrent.MVar
 import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar)
 import Control.Concurrent.STM.TChan
-import Control.Exception (bracket_, mask_, try)
+import Control.Exception (bracket, bracket_, mask_, try)
 import Control.Monad (forever, replicateM_)
 import Distribution.Client.Compat.Semaphore
+import Distribution.Client.Utils (numberOfProcessors)
 import Distribution.Compat.Stack
+import Distribution.Simple.Compiler
 import Distribution.Simple.Utils
+import Distribution.Types.ParStrat
 import System.Semaphore
 
 -- | A simple concurrency abstraction. Jobs can be spawned and can complete
@@ -262,3 +270,38 @@ newLock = fmap Lock $ newMVar ()
 
 criticalSection :: Lock -> IO a -> IO a
 criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
+
+--------------------------------------------------------------------------------
+-- More high level utils
+--------------------------------------------------------------------------------
+
+newJobControlFromParStrat
+  :: Verbosity
+  -> Compiler
+  -> ParStratInstall
+  -- ^ The parallel strategy
+  -> Maybe Int
+  -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy)
+  -> IO (JobControl IO a)
+newJobControlFromParStrat verbosity compiler parStrat numJobsCap = case parStrat of
+  Serial -> newSerialJobControl
+  NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n))
+  UseSem n ->
+    if jsemSupported compiler
+      then newSemaphoreJobControl verbosity (capJobs n)
+      else do
+        warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
+        newParallelJobControl (capJobs n)
+  where
+    capJobs n = min (fromMaybe maxBound numJobsCap) n
+
+withJobControl :: IO (JobControl IO a) -> (JobControl IO a -> IO b) -> IO b
+withJobControl mkJC = bracket mkJC cleanupJobControl
+
+-- | Concurrently execute actions on a list using the given JobControl.
+-- The maximum number of concurrent jobs is tied to the JobControl instance.
+-- The resulting list does /not/ preserve the original order!
+mapConcurrentWithJobs :: JobControl IO b -> (a -> IO b) -> [a] -> IO [b]
+mapConcurrentWithJobs jobControl f xs = do
+  traverse_ (spawnJob jobControl . f) xs
+  traverse (const $ collectJob jobControl) xs
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -88,7 +88,7 @@ import qualified Data.Set as Set
 
 import qualified Text.PrettyPrint as Disp
 
-import Control.Exception (assert, bracket, handle)
+import Control.Exception (assert, handle)
 import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
 import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
 import System.Semaphore (SemaphoreName (..))
@@ -98,7 +98,6 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
 
 import Distribution.Client.ProjectBuilding.PackageFileMonitor
 import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
-import Distribution.Client.Utils (numberOfProcessors)
 
 ------------------------------------------------------------------------------
 
@@ -355,17 +354,6 @@ rebuildTargets
     }
     | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
     | otherwise = do
-        -- Concurrency control: create the job controller and concurrency limits
-        -- for downloading, building and installing.
-        mkJobControl <- case buildSettingNumJobs of
-          Serial -> newSerialJobControl
-          NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n)
-          UseSem n ->
-            if jsemSupported compiler
-              then newSemaphoreJobControl verbosity n
-              else do
-                warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
-                newParallelJobControl n
         registerLock <- newLock -- serialise registration
         cacheLock <- newLock -- serialise access to setup exe cache
         -- TODO: [code cleanup] eliminate setup exe cache
@@ -380,7 +368,9 @@ rebuildTargets
         createDirectoryIfMissingVerbose verbosity True distTempDirectory
         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 
-        bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do
+        -- Concurrency control: create the job controller and concurrency limits
+        -- for downloading, building and installing.
+        withJobControl (newJobControlFromParStrat verbosity compiler buildSettingNumJobs Nothing) $ \jobControl -> do
           -- Before traversing the install plan, preemptively find all packages that
           -- will need to be downloaded and start downloading them.
           asyncDownloadPackages
@@ -391,7 +381,7 @@ rebuildTargets
             $ \downloadMap ->
               -- For each package in the plan, in dependency order, but in parallel...
               InstallPlan.execute
-                mkJobControl
+                jobControl
                 keepGoing
                 (BuildFailure Nothing . DependentFailed . packageId)
                 installPlan

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -54,6 +54,7 @@ module Distribution.Client.ProjectConfig
   , resolveSolverSettings
   , BuildTimeSettings (..)
   , resolveBuildTimeSettings
+  , resolveNumJobsSetting
 
     -- * Checking configuration
   , checkBadPerPackageCompilerPaths
@@ -67,6 +68,7 @@ import Prelude ()
 import Distribution.Client.Glob
   ( isTrivialRootedGlob
   )
+import Distribution.Client.JobControl
 import Distribution.Client.ProjectConfig.Legacy
 import Distribution.Client.ProjectConfig.Types
 import Distribution.Client.RebuildMonad
@@ -430,12 +432,7 @@ resolveBuildTimeSettings
       -- buildSettingLogVerbosity  -- defined below, more complicated
       buildSettingBuildReports = fromFlag projectConfigBuildReports
       buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
-      buildSettingNumJobs =
-        if fromFlag projectConfigUseSemaphore
-          then UseSem (determineNumJobs projectConfigNumJobs)
-          else case (determineNumJobs projectConfigNumJobs) of
-            1 -> Serial
-            n -> NumJobs (Just n)
+      buildSettingNumJobs = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs
       buildSettingKeepGoing = fromFlag projectConfigKeepGoing
       buildSettingOfflineMode = fromFlag projectConfigOfflineMode
       buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
@@ -531,6 +528,15 @@ resolveBuildTimeSettings
         | isParallelBuild buildSettingNumJobs = False
         | otherwise = False
 
+-- | Determine the number of jobs (ParStrat) from the project config
+resolveNumJobsSetting :: Flag Bool -> Flag (Maybe Int) -> ParStratX Int
+resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs =
+  if fromFlag projectConfigUseSemaphore
+    then UseSem (determineNumJobs projectConfigNumJobs)
+    else case (determineNumJobs projectConfigNumJobs) of
+      1 -> Serial
+      n -> NumJobs (Just n)
+
 ---------------------------------------------
 -- Reading and writing project config files
 --
@@ -1209,13 +1215,15 @@ mplusMaybeT ma mb = do
 fetchAndReadSourcePackages
   :: Verbosity
   -> DistDirLayout
+  -> Compiler
   -> ProjectConfigShared
   -> ProjectConfigBuildOnly
   -> [ProjectPackageLocation]
   -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
 fetchAndReadSourcePackages
   verbosity
   distDirLayout
+  compiler
   projectConfigShared
   projectConfigBuildOnly
   pkgLocations = do
@@ -1252,7 +1260,9 @@ fetchAndReadSourcePackages
       syncAndReadSourcePackagesRemoteRepos
         verbosity
         distDirLayout
+        compiler
         projectConfigShared
+        projectConfigBuildOnly
         (fromFlag (projectConfigOfflineMode projectConfigBuildOnly))
         [repo | ProjectPackageRemoteRepo repo <- pkgLocations]
 
@@ -1369,16 +1379,23 @@ fetchAndReadSourcePackageRemoteTarball
 syncAndReadSourcePackagesRemoteRepos
   :: Verbosity
   -> DistDirLayout
+  -> Compiler
   -> ProjectConfigShared
+  -> ProjectConfigBuildOnly
   -> Bool
   -> [SourceRepoList]
   -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
 syncAndReadSourcePackagesRemoteRepos
   verbosity
   DistDirLayout{distDownloadSrcDirectory}
+  compiler
   ProjectConfigShared
     { projectConfigProgPathExtra
     }
+  ProjectConfigBuildOnly
+    { projectConfigUseSemaphore
+    , projectConfigNumJobs
+    }
   offlineMode
   repos = do
     repos' <-
@@ -1404,10 +1421,15 @@ syncAndReadSourcePackagesRemoteRepos
        in configureVCS verbosity progPathExtra vcs
 
     concat
-      <$> sequenceA
-        [ rerunIfChanged verbosity monitor repoGroup' $ do
-          vcs' <- getConfiguredVCS repoType
-          syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
+      <$> rerunConcurrentlyIfChanged
+        verbosity
+        (newJobControlFromParStrat verbosity compiler parStrat maxNumFetchJobs)
+        [ ( monitor
+          , repoGroup'
+          , do
+              vcs' <- getConfiguredVCS repoType
+              syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
+          )
         | repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation
         , let repoGroup' = map fst repoGroup
               pathStem =
@@ -1420,6 +1442,8 @@ syncAndReadSourcePackagesRemoteRepos
               monitor = newFileMonitor (pathStem <.> "cache")
         ]
     where
+      maxNumFetchJobs = Just 2 -- try to keep this in sync with Distribution.Client.Install's numFetchJobs.
+      parStrat = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs
       syncRepoGroupAndReadSourcePackages
         :: VCS ConfiguredProgram
         -> FilePath

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -206,12 +206,10 @@ type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig
 singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
 singletonProjectConfigSkeleton x = CondNode x mempty mempty
 
-instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
-instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
-  | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel)
-  | otherwise = do
-      (os, arch, impl) <- fetch
-      pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
+instantiateProjectConfigSkeletonFetchingCompiler :: (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
+instantiateProjectConfigSkeletonFetchingCompiler (os, arch, impl) flags skel
+  | null (toListOf traverseCondTreeV skel) = fst (ignoreConditions skel)
+  | otherwise = instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
 
 instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
 instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -384,17 +384,16 @@ rebuildProjectConfig
         $ do
           liftIO $ info verbosity "Project settings changed, reconfiguring..."
           projectConfigSkeleton <- phaseReadProjectConfig
-          let fetchCompiler = do
-                -- have to create the cache directory before configuring the compiler
-                liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
-                (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
-                pure (os, arch, compilerInfo compiler)
 
-          projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
+          -- have to create the cache directory before configuring the compiler
+          liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
+          (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+
+          let projectConfig = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectConfigSkeleton
           when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $
             liftIO $
               warn verbosity "The builddir option is not supported in project and config files. It will be ignored."
-          localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)
+          localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig)
           return (projectConfig, localPackages)
 
     sequence_
@@ -426,9 +425,11 @@ rebuildProjectConfig
       -- NOTE: These are all packages mentioned in the project configuration.
       -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`.
       phaseReadLocalPackages
-        :: ProjectConfig
+        :: Compiler
+        -> ProjectConfig
         -> Rebuild [PackageSpecifier UnresolvedSourcePackage]
       phaseReadLocalPackages
+        compiler
         projectConfig@ProjectConfig
           { projectConfigShared
           , projectConfigBuildOnly
@@ -443,6 +444,7 @@ rebuildProjectConfig
           fetchAndReadSourcePackages
             verbosity
             distDirLayout
+            compiler
             projectConfigShared
             projectConfigBuildOnly
             pkgLocations