From a4da10d95c37c54e7df57a04c6f9a39c0c38f40c Mon Sep 17 00:00:00 2001
From: Rodrigo Mesquita <rodrigo.m.mesquita@gmail.com>
Date: Wed, 7 Aug 2024 11:40:37 +0100
Subject: [PATCH] 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.
---
 .../src/Distribution/Client/CmdInstall.hs     |  1 +
 .../src/Distribution/Client/JobControl.hs     | 45 +++++++++-
 .../Distribution/Client/ProjectBuilding.hs    | 20 ++---
 .../src/Distribution/Client/ProjectConfig.hs  | 44 +++++++---
 .../Client/ProjectConfig/Legacy.hs            | 10 +--
 .../Distribution/Client/ProjectPlanning.hs    | 18 ++--
 .../src/Distribution/Client/RebuildMonad.hs   | 88 ++++++++++++-------
 .../src/Distribution/Client/ScriptUtils.hs    |  2 +-
 changelog.d/pr-10254                          | 16 ++++
 9 files changed, 172 insertions(+), 72 deletions(-)
 create mode 100644 changelog.d/pr-10254

diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index 210ac78ca01..1eb2f82c5f8 100644
--- 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
index 2b9f472d3dc..9cc7ac92a05 100644
--- 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
index 4d7bde7fc55..e70a89af8a3 100644
--- 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
index aabb318e9d9..de1964212b5 100644
--- 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,6 +1215,7 @@ mplusMaybeT ma mb = do
 fetchAndReadSourcePackages
   :: Verbosity
   -> DistDirLayout
+  -> Compiler
   -> ProjectConfigShared
   -> ProjectConfigBuildOnly
   -> [ProjectPackageLocation]
@@ -1216,6 +1223,7 @@ fetchAndReadSourcePackages
 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
index 7ed13df1232..3ea81d05229 100644
--- 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
index 93baa8bf78f..3b9b3b71951 100644
--- 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
diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs
index 2950d9f7a30..e6450addabc 100644
--- a/cabal-install/src/Distribution/Client/RebuildMonad.hs
+++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- | An abstraction for re-running actions if values or files have changed.
@@ -42,6 +43,7 @@ module Distribution.Client.RebuildMonad
   , FileMonitor (..)
   , newFileMonitor
   , rerunIfChanged
+  , rerunConcurrentlyIfChanged
 
     -- * Utils
   , delayInitSharedResource
@@ -64,11 +66,13 @@ import Prelude ()
 import Distribution.Client.FileMonitor
 import Distribution.Client.Glob hiding (matchFileGlob)
 import qualified Distribution.Client.Glob as Glob (matchFileGlob)
+import Distribution.Client.JobControl
 import Distribution.Simple.PreProcess.Types (Suffix (..))
 
 import Distribution.Simple.Utils (debug)
 
 import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)
+import Control.Monad
 import Control.Monad.Reader as Reader
 import Control.Monad.State as State
 import qualified Data.Map.Strict as Map
@@ -123,39 +127,61 @@ rerunIfChanged
   -> Rebuild b
   -> Rebuild b
 rerunIfChanged verbosity monitor key action = do
+  -- rerunIfChanged is implemented in terms of rerunConcurrentlyIfChanged, but
+  -- nothing concurrent will happen since the list of concurrent actions has a
+  -- single value that will be waited for alone.
+  rerunConcurrentlyIfChanged verbosity newSerialJobControl [(monitor, key, action)] >>= \case
+    [x] -> return x
+    _ -> error "rerunIfChanged: impossible!"
+
+-- | Like 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions
+-- that need to do be re-run-if-changed asynchronously. The function returns
+-- when all values have finished computing.
+rerunConcurrentlyIfChanged
+  :: (Binary a, Structured a, Binary b, Structured b)
+  => Verbosity
+  -> IO (JobControl IO (b, [MonitorFilePath]))
+  -> [(FileMonitor a b, a, Rebuild b)]
+  -> Rebuild [b]
+rerunConcurrentlyIfChanged verbosity mkJobControl triples = do
   rootDir <- askRoot
-  changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
-  case changed of
-    MonitorUnchanged result files -> do
-      liftIO $
-        debug verbosity $
-          "File monitor '"
-            ++ monitorName
-            ++ "' unchanged."
-      monitorFiles files
-      return result
-    MonitorChanged reason -> do
-      liftIO $
-        debug verbosity $
-          "File monitor '"
-            ++ monitorName
-            ++ "' changed: "
-            ++ showReason reason
-      startTime <- liftIO $ beginUpdateFileMonitor
-      (result, files) <- liftIO $ unRebuild rootDir action
-      liftIO $
-        updateFileMonitor
-          monitor
-          rootDir
-          (Just startTime)
-          files
-          key
-          result
-      monitorFiles files
-      return result
-  where
-    monitorName = takeFileName (fileMonitorCacheFile monitor)
+  dacts <- forM triples $ \(monitor, key, action) -> do
+    let monitorName = takeFileName (fileMonitorCacheFile monitor)
+    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
+    case changed of
+      MonitorUnchanged result files -> do
+        liftIO $
+          debug verbosity $
+            "File monitor '"
+              ++ monitorName
+              ++ "' unchanged."
+        monitorFiles files
+        return (return (result, []))
+      MonitorChanged reason -> do
+        liftIO $
+          debug verbosity $
+            "File monitor '"
+              ++ monitorName
+              ++ "' changed: "
+              ++ showReason reason
+        return $ do
+          startTime <- beginUpdateFileMonitor
+          (result, files) <- unRebuild rootDir action
+          updateFileMonitor
+            monitor
+            rootDir
+            (Just startTime)
+            files
+            key
+            result
+          return (result, files)
 
+  (results, files) <- liftIO $
+    withJobControl mkJobControl $ \jobControl -> do
+      unzip <$> mapConcurrentWithJobs jobControl id dacts
+  monitorFiles (concat files)
+  return results
+  where
     showReason (MonitoredFileChanged file) = "file " ++ file
     showReason (MonitoredValueChanged _) = "monitor value changed"
     showReason MonitorFirstRun = "first run"
diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs
index d4f152a4557..95db58bc8c1 100644
--- a/cabal-install/src/Distribution/Client/ScriptUtils.hs
+++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs
@@ -381,7 +381,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo
           createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
           (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
 
-          projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton
+          let projectCfg = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectCfgSkeleton
 
           let ctx' = ctx & lProjectConfig %~ (<> projectCfg)
 
diff --git a/changelog.d/pr-10254 b/changelog.d/pr-10254
new file mode 100644
index 00000000000..b07b66b561f
--- /dev/null
+++ b/changelog.d/pr-10254
@@ -0,0 +1,16 @@
+synopsis: Shallow and concurrent cloning of git repos
+packages: cabal-install
+prs: #10254
+
+description: {
+
+- Clone git repositories specified in source-repository-package stanzas
+  shallowly, since to build the package from the repository we only need to
+  read the commit specified. The rest of the repo is not needed.
+  Note that this does not change the behaviour of `cabal get -s`, which will
+  still clone the repository in full.
+- Clone VCS repositories concurrently, with a maximum of two concurrent tasks
+  at the same time (just like when downloading packages asynchronously)
+
+}
+