From b6c28eef30b12eb5bc9a3fb49fe7b06fc0b1774b Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 6 Aug 2024 14:39:38 +0100 Subject: [PATCH 1/2] source-repository: Use git shallow clones Cloning the entire repository for the purpose of compiling packages specified in source-repository-packages is wasted effort. To read and compile the package, we need only the HEAD of the repository, thus a shallow clone is sufficient. Note that this doesn't change the behaviour of `cabal get -s` which still does a full clone (--depth=1 is only used in vcsSyncRepo, not in vcsCloneRepo) Fixes #7264 --- cabal-install/src/Distribution/Client/VCS.hs | 17 +++++++++++++++-- .../PackageTests/ExtraProgPath/setup.out | 4 ++-- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 57c0a82376e..029e190a790 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -483,6 +483,9 @@ vcsGit = resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"] verboseArg = ["--quiet" | verbosity < Verbosity.normal] + -- Note: No --depth=1 for vcsCloneRepo since that is used for `cabal get -s`, + -- whereas `vcsSyncRepo` is used for source-repository-package where we do want shallow clones. + vcsSyncRepos :: Verbosity -> ConfiguredProgram @@ -529,7 +532,10 @@ vcsGit = (removePathForcibly gitModulesDir) (\e -> if isPermissionError e then removePathForcibly gitModulesDir else throw e) else removeDirectoryRecursive gitModulesDir - git localDir resetArgs + when (resetTarget /= "HEAD") $ do + git localDir fetchArgs -- first fetch the tag if needed + git localDir setTagArgs + git localDir resetArgs -- only then reset to the commit git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] @@ -543,13 +549,20 @@ vcsGit = } cloneArgs = - ["clone", "--no-checkout", loc, localDir] + ["clone", "--depth=1", "--no-checkout", loc, localDir] ++ case peer of Nothing -> [] Just peerLocalDir -> ["--reference", peerLocalDir] ++ verboseArg where loc = srpLocation + -- To checkout/reset to a particular commit, we must first fetch it + -- (since the base clone is shallow). + fetchArgs = "fetch" : verboseArg ++ ["origin", resetTarget] + -- And then create the Tag from the FETCH_HEAD (which we should have just fetched) + setTagArgs = ["tag", "-f", resetTarget, "FETCH_HEAD"] + -- Then resetting to that tag will work (if we don't create the tag + -- locally from FETCH_HEAD, it won't exist). resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--"] resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) verboseArg = ["--quiet" | verbosity < Verbosity.normal] diff --git a/cabal-testsuite/PackageTests/ExtraProgPath/setup.out b/cabal-testsuite/PackageTests/ExtraProgPath/setup.out index a64476a2939..ed22f251035 100644 --- a/cabal-testsuite/PackageTests/ExtraProgPath/setup.out +++ b/cabal-testsuite/PackageTests/ExtraProgPath/setup.out @@ -1,8 +1,8 @@ # cabal v2-build -Configuration is affected by the following files: -- cabal.project Warning: cannot determine version of /pkg-config : "" +Configuration is affected by the following files: +- cabal.project Resolving dependencies... Error: [Cabal-7107] Could not resolve dependencies: From c89ab54e13f1eb808dcdd470edecd7eaaa594cec Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 7 Aug 2024 11:40:37 +0100 Subject: [PATCH 2/2] 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/Install.hs | 4 +- .../src/Distribution/Client/JobControl.hs | 45 +++++++++- .../Distribution/Client/ProjectBuilding.hs | 20 ++--- .../src/Distribution/Client/ProjectConfig.hs | 58 +++++++++--- .../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 ++++ 10 files changed, 188 insertions(+), 74 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 1587b20a44d..a5df21b185b 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/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index b6a8198ae5c..635cd7e1689 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -142,6 +142,7 @@ import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage as SourcePackage +import Distribution.Client.ProjectConfig import Distribution.Client.Utils ( MergeResult (..) , ProgressPhase (..) @@ -1443,7 +1444,7 @@ performInstallations if parallelInstall then newParallelJobControl numJobs else newSerialJobControl - fetchLimit <- newJobLimit (min numJobs numFetchJobs) + fetchLimit <- newJobLimit (min numJobs maxNumFetchJobs) installLock <- newLock -- serialise installation cacheLock <- newLock -- serialise access to setup exe cache executeInstallPlan @@ -1486,7 +1487,6 @@ performInstallations cinfo = compilerInfo comp numJobs = determineNumJobs (installNumJobs installFlags) - numFetchJobs = 2 parallelInstall = numJobs >= 2 keepGoing = fromFlag (installKeepGoing installFlags) distPref = 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 89de6ea869c..eea6b958b70 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -55,10 +55,14 @@ module Distribution.Client.ProjectConfig , resolveSolverSettings , BuildTimeSettings (..) , resolveBuildTimeSettings + , resolveNumJobsSetting -- * Checking configuration , checkBadPerPackageCompilerPaths , BadPerPackageCompilerPaths (..) + + -- * Globals + , maxNumFetchJobs ) where import Distribution.Client.Compat.Prelude @@ -68,6 +72,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 @@ -434,12 +439,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 @@ -535,6 +535,20 @@ resolveBuildTimeSettings | isParallelBuild buildSettingNumJobs = False | otherwise = False +-- | Determine the number of jobs (ParStrat) from the project config +resolveNumJobsSetting + :: Flag Bool + -- ^ Whether to use a semaphore (-jsem) + -> Flag (Maybe Int) + -- ^ The number of jobs to run concurrently + -> 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 -- @@ -1213,6 +1227,7 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout + -> Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1220,6 +1235,7 @@ fetchAndReadSourcePackages fetchAndReadSourcePackages verbosity distDirLayout + compiler projectConfigShared projectConfigBuildOnly pkgLocations = do @@ -1256,7 +1272,9 @@ fetchAndReadSourcePackages syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout + compiler projectConfigShared + projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) [repo | ProjectPackageRemoteRepo repo <- pkgLocations] @@ -1373,16 +1391,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' <- @@ -1408,10 +1433,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 (Just maxNumFetchJobs)) + [ ( monitor + , repoGroup' + , do + vcs' <- getConfiguredVCS repoType + syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' + ) | repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation , let repoGroup' = map fst repoGroup pathStem = @@ -1424,6 +1454,7 @@ syncAndReadSourcePackagesRemoteRepos monitor = newFileMonitor (pathStem <.> "cache") ] where + parStrat = resolveNumJobsSetting projectConfigUseSemaphore projectConfigNumJobs syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath @@ -1760,3 +1791,10 @@ onlyTopLevelProvenance :: Set ProjectConfigProvenance -> Set ProjectConfigProven onlyTopLevelProvenance = Set.filter $ \case Implicit -> False Explicit ps -> isTopLevelConfigPath ps + +-- | The maximum amount of fetch jobs that can run concurrently. +-- For instance, this is used to limit the amount of concurrent downloads from +-- hackage, or the amount of concurrent git clones for +-- source-repository-package stanzas. +maxNumFetchJobs :: Int +maxNumFetchJobs = 2 diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 7354e5e9cb3..49720fdd8ea 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 30a0bd17341..ccace6f8025 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -385,17 +385,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) let configfiles = @@ -427,9 +426,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 @@ -444,6 +445,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) + +} +