From 0a1e13814cad1b1a92822f64fd3ecceccdcccc08 Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 2 Oct 2026 17:33:27 +0000 Subject: [PATCH 1/7] Run benchmarks one at a time in `cabal bench` (#7557) With `-j`, every plan node runs in parallel, and with per-component builds each benchmark suite is its own node, so `cabal bench` could run several benchmarks at the same time, from the same package or across a project. Concurrent benchmarks compete for resources and skew each other's results. Add a `benchLock`, created in `rebuildTargets` next to `registerLock` and `cacheLock`, and take it around the bench phase in `buildAndRegisterUnpackedPackage`. Benchmarks now run one at a time, while configuring and building other components stays parallel. The lock is taken outside `timedDelegate`, so `--build-timings` does not count time spent waiting for other benchmarks. Add a cabal-testsuite test with three benchmarks in two packages, run with `-j3`, each of which fails if another benchmark runs at the same time. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_016nzdeKCYFDCkWsyM6etgkL --- .../Distribution/Client/ProjectBuilding.hs | 9 ++++ .../Client/ProjectBuilding/UnpackedPackage.hs | 44 +++++++++++++++---- .../CmdBench/Sequential/cabal.project | 1 + .../CmdBench/Sequential/cabal.test.hs | 9 ++++ .../CmdBench/Sequential/pkg-a/Bench.hs | 18 ++++++++ .../CmdBench/Sequential/pkg-a/pkg-a.cabal | 16 +++++++ .../CmdBench/Sequential/pkg-b/Bench.hs | 18 ++++++++ .../CmdBench/Sequential/pkg-b/pkg-b.cabal | 10 +++++ changelog.d/issue-7557.md | 14 ++++++ doc/cabal-commands.rst | 5 +++ 10 files changed, 135 insertions(+), 9 deletions(-) create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.project create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/Bench.hs create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/pkg-a.cabal create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/Bench.hs create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal create mode 100644 changelog.d/issue-7557.md diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 459cee1bdea..31e6ee70d53 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -355,6 +355,7 @@ rebuildTargets registerLock <- newLock -- serialise registration cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache + benchLock <- newLock -- serialise running benchmarks info verbosity $ "Executing install plan " ++ case buildSettingNumJobs of @@ -410,6 +411,7 @@ rebuildTargets downloadMap registerLock cacheLock + benchLock sharedPackageConfig installPlan ipiTVar @@ -538,7 +540,11 @@ rebuildTarget -> BuildTimeSettings -> AsyncFetchMap -> Lock + -- ^ Serialises package registration -> Lock + -- ^ Serialises access to the setup executable cache + -> Lock + -- ^ Serialises running benchmarks -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TVar InstalledPackageIndex @@ -554,6 +560,7 @@ rebuildTarget downloadMap registerLock cacheLock + benchLock sharedPackageConfig plan ipiTVar @@ -640,6 +647,7 @@ rebuildTarget buildSettings registerLock cacheLock + benchLock sharedPackageConfig plan rpkg @@ -657,6 +665,7 @@ rebuildTarget buildSettings registerLock cacheLock + benchLock sharedPackageConfig plan rpkg diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 9f6b202830c..867b6a11ec1 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -170,7 +170,11 @@ buildAndRegisterUnpackedPackage -- name of the semaphore is created freshly each time. -> BuildTimeSettings -> Lock + -- ^ Serialises package registration -> Lock + -- ^ Serialises access to the setup executable cache + -> Lock + -- ^ Serialises running benchmarks -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -193,6 +197,7 @@ buildAndRegisterUnpackedPackage } registerLock cacheLock + benchLock pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigCompilerProgs = progdb @@ -285,16 +290,25 @@ buildAndRegisterUnpackedPackage (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase + -- + -- Benchmarks are run one at a time, even when building in parallel, as + -- concurrently running benchmarks would compete for resources and skew + -- each other's results (#7557). Other components may still be built while + -- a benchmark is running. + -- + -- The lock is taken outside of 'timedDelegate', so that @--build-timings@ + -- does not count the time spent waiting for other benchmarks to finish. whenBench $ - timedDelegate $ - PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ - setup - benchCommand - Cabal.benchmarkCommonFlags - (return . benchFlags) - benchArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) + criticalSection benchLock $ + timedDelegate $ + PBBenchPhase $ + annotateFailure mlogFile BenchFailed $ + setup + benchCommand + Cabal.benchmarkCommonFlags + (return . benchFlags) + benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ @@ -521,7 +535,11 @@ buildInplaceUnpackedPackage -> Maybe SemaphoreIdentifier -> BuildTimeSettings -> Lock + -- ^ Serialises package registration + -> Lock + -- ^ Serialises access to the setup executable cache -> Lock + -- ^ Serialises running benchmarks -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -541,6 +559,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock + benchLock pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} plan rpkg@(ReadyPackage pkg) @@ -564,6 +583,7 @@ buildInplaceUnpackedPackage buildSettings registerLock cacheLock + benchLock pkgshared plan rpkg @@ -755,7 +775,11 @@ buildAndInstallUnpackedPackage -- name of the semaphore is created freshly each time. -> BuildTimeSettings -> Lock + -- ^ Serialises package registration + -> Lock + -- ^ Serialises access to the setup executable cache -> Lock + -- ^ Serialises running benchmarks -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -773,6 +797,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock + benchLock pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigPlatform = platform @@ -804,6 +829,7 @@ buildAndInstallUnpackedPackage buildSettings registerLock cacheLock + benchLock pkgshared plan rpkg diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.project b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.project new file mode 100644 index 00000000000..33f2d949688 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.project @@ -0,0 +1 @@ +packages: pkg-a pkg-b diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs new file mode 100644 index 00000000000..ba09b38517a --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +-- #7557: benchmarks must not run concurrently, even when building in +-- parallel. Each benchmark fails if another one is running at the same time, +-- see Bench.hs. +main = cabalTest $ + -- Parallel flag means output of this test is nondeterministic + recordMode DoNotRecord $ + cabal "v2-bench" ["-j3", "all"] diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/Bench.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/Bench.hs new file mode 100644 index 00000000000..6fbd3e30eb4 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/Bench.hs @@ -0,0 +1,18 @@ +import Control.Concurrent (threadDelay) +import System.Directory (createDirectory, removeDirectory) +import System.Exit (die) +import System.IO.Error (catchIOError, isAlreadyExistsError) + +-- All the benchmarks of this test, in both packages, claim the same marker +-- directory while they run. Creating it fails if it already exists, that is, +-- if another benchmark is running at the same time. +main :: IO () +main = do + createDirectory marker `catchIOError` \e -> + if isAlreadyExistsError e + then die "Another benchmark is running at the same time" + else ioError e + threadDelay 2000000 + removeDirectory marker + where + marker = "../benchmark-running" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/pkg-a.cabal b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/pkg-a.cabal new file mode 100644 index 00000000000..098b4a09f33 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-a/pkg-a.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.0 +name: pkg-a +version: 1.0 +build-type: Simple + +benchmark a1 + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: base, directory + default-language: Haskell2010 + +benchmark a2 + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: base, directory + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/Bench.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/Bench.hs new file mode 100644 index 00000000000..6fbd3e30eb4 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/Bench.hs @@ -0,0 +1,18 @@ +import Control.Concurrent (threadDelay) +import System.Directory (createDirectory, removeDirectory) +import System.Exit (die) +import System.IO.Error (catchIOError, isAlreadyExistsError) + +-- All the benchmarks of this test, in both packages, claim the same marker +-- directory while they run. Creating it fails if it already exists, that is, +-- if another benchmark is running at the same time. +main :: IO () +main = do + createDirectory marker `catchIOError` \e -> + if isAlreadyExistsError e + then die "Another benchmark is running at the same time" + else ioError e + threadDelay 2000000 + removeDirectory marker + where + marker = "../benchmark-running" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal new file mode 100644 index 00000000000..118630d7585 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: pkg-b +version: 1.0 +build-type: Simple + +benchmark b1 + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: base, directory + default-language: Haskell2010 diff --git a/changelog.d/issue-7557.md b/changelog.d/issue-7557.md new file mode 100644 index 00000000000..96ca1bc177d --- /dev/null +++ b/changelog.d/issue-7557.md @@ -0,0 +1,14 @@ +--- +synopsis: "`cabal bench` no longer runs benchmarks in parallel" +packages: [cabal-install] +prs: 0000 +issues: 7557 +--- + +When building in parallel (e.g. with `-j`), `cabal bench` used to run several +benchmarks at the same time, so that they competed for resources and skewed each +other's results. Benchmarks are now run one at a time, while components are +still built in parallel. + +Note that other components may still be built while a benchmark is running. +Use `-j1` to avoid that. diff --git a/doc/cabal-commands.rst b/doc/cabal-commands.rst index 0c4fb040375..a852300501e 100644 --- a/doc/cabal-commands.rst +++ b/doc/cabal-commands.rst @@ -1337,6 +1337,11 @@ they are up to date. ``cabal bench`` inherits flags of the ``bench`` subcommand of ``Setup.hs``, :ref:`see the corresponding section `. +When building in parallel (e.g. with ``-j``), the benchmarks are still run one +at a time, so that they do not compete for resources and skew each other's +results. Other components may still be built while a benchmark is running; +use ``-j1`` to avoid that. + cabal test ^^^^^^^^^^ From 3f154f4c9240f2303bd76e51deab3e56b104253e Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 2 Oct 2026 20:24:51 +0000 Subject: [PATCH 2/7] Run benchmarks only once everything is built (#7557) Holding a lock while running a benchmark keeps benchmarks from running at the same time, but other components could still be built while a benchmark runs, which skews its results just as much. Instead, the bench phase of a package no longer runs its benchmarks, but records them. Once all the packages of the plan are built (still in parallel), `rebuildTargets` runs the recorded benchmarks one at a time, in plan order, and records their failures in the build outcomes. Unless we keep going after failures, no benchmark is run if a package failed to build, and no more benchmarks are run once one of them failed. See Note [Running benchmarks]. This replaces the `benchLock` introduced by the previous commit. The Sequential test now also checks that nothing is built once the first benchmark started: pkg-b's benchmark depends on a library, so that it is still being built when pkg-a's benchmarks are ready to run. The golden outputs of MultipleBenchmarks and T5309 change accordingly: builds now come before benchmark runs. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_016nzdeKCYFDCkWsyM6etgkL --- .../Distribution/Client/ProjectBuilding.hs | 81 ++++++++++++++++--- .../Client/ProjectBuilding/UnpackedPackage.hs | 43 +++++----- .../CmdBench/MultipleBenchmarks/cabal.out | 4 +- .../CmdBench/Sequential/cabal.test.hs | 22 +++-- .../CmdBench/Sequential/pkg-b/PkgB.hs | 4 + .../CmdBench/Sequential/pkg-b/pkg-b.cabal | 9 ++- .../PackageTests/Regression/T5309/cabal.out | 6 +- changelog.d/issue-7557.md | 15 ++-- doc/cabal-commands.rst | 9 ++- 9 files changed, 141 insertions(+), 52 deletions(-) create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/PkgB.hs diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 31e6ee70d53..79199ddc3bf 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -83,8 +83,9 @@ import qualified Data.Set as Set import qualified Text.PrettyPrint as Disp -import Control.Concurrent.STM (TVar, newTVarIO) -import Control.Exception (assert, handle) +import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO) +import Control.Exception (assert, handle, try) +import Data.Either (isLeft) import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) @@ -95,7 +96,7 @@ import Distribution.Client.Errors import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.ProjectBuilding.UnpackedPackage (DeferredBenchmarks, annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) ------------------------------------------------------------------------------ @@ -355,7 +356,10 @@ rebuildTargets registerLock <- newLock -- serialise registration cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache - benchLock <- newLock -- serialise running benchmarks + + -- See Note [Running benchmarks] + deferredBenchmarks <- newTVarIO [] + info verbosity $ "Executing install plan " ++ case buildSettingNumJobs of @@ -382,7 +386,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + buildOutcomes <- withJobControl (newJobControlFromParStrat verbosity (Just 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 @@ -411,12 +415,17 @@ rebuildTargets downloadMap registerLock cacheLock - benchLock + deferredBenchmarks sharedPackageConfig installPlan ipiTVar pkg pkgBuildStatus + + -- Once the packages are built, run their benchmarks. + -- See Note [Running benchmarks] + runDeferredBenchmarks keepGoing installPlan buildOutcomes + =<< readTVarIO deferredBenchmarks where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -499,6 +508,56 @@ configuring individual packages. invocation. -} +{- Note [Running benchmarks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Benchmarks must not run at the same time as other benchmarks, or while other +packages are being built: they would compete for resources, which skews their +results (#7557). Yet the packages of the plan are built in parallel, and with +per-component builds every benchmark suite is a package of its own. + +So, the bench phase of a package (see 'buildAndRegisterUnpackedPackage') does +not run its benchmarks, but adds them to the 'DeferredBenchmarks'. Once all +the packages are built, 'rebuildTargets' runs them one at a time, in plan +order, with 'runDeferredBenchmarks', and records their failures in the +'BuildOutcomes'. + +Unless we keep going after failures, no benchmark is run if a package failed +to build, and no more benchmarks are run once one of them failed. +-} + +-- | Run the deferred benchmarks of the packages that were built successfully, +-- one at a time, in plan order. See Note [Running benchmarks]. +runDeferredBenchmarks + :: Bool + -- ^ Keep going after failure + -> ElaboratedInstallPlan + -> BuildOutcomes + -> [(UnitId, IO ())] + -> IO BuildOutcomes +runDeferredBenchmarks keepGoing installPlan buildOutcomes deferred + | not keepGoing && any isLeft buildOutcomes = return buildOutcomes + | otherwise = go buildOutcomes benchmarks + where + deferredMap = Map.fromList deferred + benchmarks = + [ (uid, bench) + | pkg <- InstallPlan.executionOrder installPlan + , let uid = nodeKey pkg + , Just (Right _) <- [Map.lookup uid buildOutcomes] + , Just bench <- [Map.lookup uid deferredMap] + ] + + go outcomes [] = return outcomes + go outcomes ((uid, bench) : rest) = do + result <- try bench + case result of + Right () -> go outcomes rest + Left (failure :: BuildFailure) + | keepGoing -> go outcomes' rest + | otherwise -> return outcomes' + where + outcomes' = Map.insert uid (Left failure) outcomes + -- | Create a package DB if it does not currently exist. createPackageDBIfMissing :: Verbosity @@ -543,8 +602,8 @@ rebuildTarget -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> Lock - -- ^ Serialises running benchmarks + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the packages are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TVar InstalledPackageIndex @@ -560,7 +619,7 @@ rebuildTarget downloadMap registerLock cacheLock - benchLock + deferredBenchmarks sharedPackageConfig plan ipiTVar @@ -647,7 +706,7 @@ rebuildTarget buildSettings registerLock cacheLock - benchLock + deferredBenchmarks sharedPackageConfig plan rpkg @@ -665,7 +724,7 @@ rebuildTarget buildSettings registerLock cacheLock - benchLock + deferredBenchmarks sharedPackageConfig plan rpkg diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 867b6a11ec1..e98c1d175f6 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -20,6 +20,7 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage -- ** Auxiliary definitions , buildAndRegisterUnpackedPackage , PackageBuildingPhase + , DeferredBenchmarks -- ** Utilities , annotateFailure @@ -157,6 +158,11 @@ data PackageBuildingPhase r where PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () +-- | The benchmarks of the packages built so far, which are run once all the +-- packages are built. +-- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". +type DeferredBenchmarks = TVar [(UnitId, IO ())] + -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain -- building style (notably, inplace vs install) to the delegate function that @@ -173,8 +179,8 @@ buildAndRegisterUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> Lock - -- ^ Serialises running benchmarks + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the packages are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -197,7 +203,7 @@ buildAndRegisterUnpackedPackage } registerLock cacheLock - benchLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigCompilerProgs = progdb @@ -291,15 +297,10 @@ buildAndRegisterUnpackedPackage -- Bench phase -- - -- Benchmarks are run one at a time, even when building in parallel, as - -- concurrently running benchmarks would compete for resources and skew - -- each other's results (#7557). Other components may still be built while - -- a benchmark is running. - -- - -- The lock is taken outside of 'timedDelegate', so that @--build-timings@ - -- does not count the time spent waiting for other benchmarks to finish. + -- The benchmarks are not run here, but once all the packages are built. + -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". whenBench $ - criticalSection benchLock $ + deferBenchmark $ timedDelegate $ PBBenchPhase $ annotateFailure mlogFile BenchFailed $ @@ -326,6 +327,10 @@ buildAndRegisterUnpackedPackage where uid = installedUnitId rpkg + deferBenchmark :: IO () -> IO () + deferBenchmark bench = + atomically $ modifyTVar deferredBenchmarks ((uid, bench) :) + timedDelegate :: forall r. PackageBuildingPhase r -> IO r timedDelegate phase | buildSettingBuildTimings = do @@ -538,8 +543,8 @@ buildInplaceUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> Lock - -- ^ Serialises running benchmarks + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the packages are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -559,7 +564,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - benchLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} plan rpkg@(ReadyPackage pkg) @@ -583,7 +588,7 @@ buildInplaceUnpackedPackage buildSettings registerLock cacheLock - benchLock + deferredBenchmarks pkgshared plan rpkg @@ -778,8 +783,8 @@ buildAndInstallUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> Lock - -- ^ Serialises running benchmarks + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the packages are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -797,7 +802,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - benchLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigPlatform = platform @@ -829,7 +834,7 @@ buildAndInstallUnpackedPackage buildSettings registerLock cacheLock - benchLock + deferredBenchmarks pkgshared plan rpkg diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out index cff1673e167..e0c9cea2e80 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out @@ -17,11 +17,11 @@ In order, the following will be built: Configuring benchmark 'bar' for MultipleBenchmarks-1.0... Preprocessing benchmark 'bar' for MultipleBenchmarks-1.0... Building benchmark 'bar' for MultipleBenchmarks-1.0... +Preprocessing benchmark 'foo' for MultipleBenchmarks-1.0... +Building benchmark 'foo' for MultipleBenchmarks-1.0... Running 1 benchmarks... Benchmark bar: RUNNING... Benchmark bar: FINISH -Preprocessing benchmark 'foo' for MultipleBenchmarks-1.0... -Building benchmark 'foo' for MultipleBenchmarks-1.0... Running 1 benchmarks... Benchmark foo: RUNNING... Benchmark foo: FINISH diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs index ba09b38517a..65e453205fb 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs @@ -1,9 +1,21 @@ import Test.Cabal.Prelude --- #7557: benchmarks must not run concurrently, even when building in --- parallel. Each benchmark fails if another one is running at the same time, --- see Bench.hs. +import Data.List (isInfixOf, isPrefixOf, isSuffixOf) + +-- #7557: benchmarks are only run once everything is built, and one at a time, +-- even when building in parallel. main = cabalTest $ -- Parallel flag means output of this test is nondeterministic - recordMode DoNotRecord $ - cabal "v2-bench" ["-j3", "all"] + recordMode DoNotRecord $ do + -- Each benchmark fails if another one is running at the same time, + -- see Bench.hs. + res <- cabal' "v2-bench" ["-j3", "all"] + let isBuildStep l = + any (`isPrefixOf` l) ["Configuring ", "Preprocessing ", "Building ", "Linking "] + || any (`isInfixOf` l) ["] Compiling ", "] Linking "] + isBenchmarkRun l = "Benchmark " `isPrefixOf` l && ": RUNNING..." `isSuffixOf` l + output = lines (filter (/= '\r') (resultOutput res)) + afterFirstRun = dropWhile (not . isBenchmarkRun) output + assertEqual "Number of benchmarks run" 3 (length (filter isBenchmarkRun output)) + assertBool "Something was built after the first benchmark started" $ + not (any isBuildStep afterFirstRun) diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/PkgB.hs b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/PkgB.hs new file mode 100644 index 00000000000..8dceeaf7f22 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/PkgB.hs @@ -0,0 +1,4 @@ +module PkgB (pkgB) where + +pkgB :: String +pkgB = "pkg-b" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal index 118630d7585..b3a0d86e7f5 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal @@ -3,8 +3,15 @@ name: pkg-b version: 1.0 build-type: Simple +-- The benchmark depends on a library, so that it is still being built when +-- the benchmarks of pkg-a are ready to run. +library + exposed-modules: PkgB + build-depends: base + default-language: Haskell2010 + benchmark b1 type: exitcode-stdio-1.0 main-is: Bench.hs - build-depends: base, directory + build-depends: base, directory, pkg-b default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/Regression/T5309/cabal.out b/cabal-testsuite/PackageTests/Regression/T5309/cabal.out index e799843e5b6..6a7dfd612d6 100644 --- a/cabal-testsuite/PackageTests/Regression/T5309/cabal.out +++ b/cabal-testsuite/PackageTests/Regression/T5309/cabal.out @@ -43,12 +43,12 @@ In order, the following will be built: Configuring benchmark 'bench-no-lib' for T5309-1.0.0.0... Preprocessing benchmark 'bench-no-lib' for T5309-1.0.0.0... Building benchmark 'bench-no-lib' for T5309-1.0.0.0... -Running 1 benchmarks... -Benchmark bench-no-lib: RUNNING... -Benchmark bench-no-lib: FINISH Configuring benchmark 'bench-with-lib' for T5309-1.0.0.0... Preprocessing benchmark 'bench-with-lib' for T5309-1.0.0.0... Building benchmark 'bench-with-lib' for T5309-1.0.0.0... Running 1 benchmarks... +Benchmark bench-no-lib: RUNNING... +Benchmark bench-no-lib: FINISH +Running 1 benchmarks... Benchmark bench-with-lib: RUNNING... Benchmark bench-with-lib: FINISH diff --git a/changelog.d/issue-7557.md b/changelog.d/issue-7557.md index 96ca1bc177d..67cfa8015c9 100644 --- a/changelog.d/issue-7557.md +++ b/changelog.d/issue-7557.md @@ -1,14 +1,15 @@ --- -synopsis: "`cabal bench` no longer runs benchmarks in parallel" +synopsis: "`cabal bench` runs benchmarks one at a time, once everything is built" packages: [cabal-install] prs: 0000 issues: 7557 --- -When building in parallel (e.g. with `-j`), `cabal bench` used to run several -benchmarks at the same time, so that they competed for resources and skewed each -other's results. Benchmarks are now run one at a time, while components are -still built in parallel. +`cabal bench` used to run each benchmark as soon as it was built. When building +in parallel (e.g. with `-j`), several benchmarks could thus run at the same time, +and while other components were still being built, so that they competed for +resources, which skewed their results. -Note that other components may still be built while a benchmark is running. -Use `-j1` to avoid that. +Now, `cabal bench` first builds everything (still in parallel), and only then +runs the benchmarks, one at a time. Without `--keep-going`, no benchmark is run +if the build fails. diff --git a/doc/cabal-commands.rst b/doc/cabal-commands.rst index a852300501e..5854e98de53 100644 --- a/doc/cabal-commands.rst +++ b/doc/cabal-commands.rst @@ -1337,10 +1337,11 @@ they are up to date. ``cabal bench`` inherits flags of the ``bench`` subcommand of ``Setup.hs``, :ref:`see the corresponding section `. -When building in parallel (e.g. with ``-j``), the benchmarks are still run one -at a time, so that they do not compete for resources and skew each other's -results. Other components may still be built while a benchmark is running; -use ``-j1`` to avoid that. +``cabal bench`` first builds everything that is needed (in parallel, e.g. with +``-j``), and only then runs the benchmarks, one at a time, so that they do not +compete for resources with each other or with the build, which would skew +their results. Without ``--keep-going``, no benchmark is run if the build +fails. cabal test ^^^^^^^^^^ From c7512bf60670bc529ac40f78c23476e092039f26 Mon Sep 17 00:00:00 2001 From: Claude Date: Sat, 3 Oct 2026 00:36:22 +0000 Subject: [PATCH 3/7] Describe plan units accurately in Note [Running benchmarks] A benchmark suite is not a package of its own: the units of the install plan are single components, or whole packages when they cannot be built per component. Say so in Note [Running benchmarks], and refer to units rather than packages in the related comments. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01GVJmRffSh16Wx8JR7Kd1dC --- .../Distribution/Client/ProjectBuilding.hs | 39 +++++++++++-------- .../Client/ProjectBuilding/UnpackedPackage.hs | 12 +++--- 2 files changed, 29 insertions(+), 22 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 79199ddc3bf..509c4a38136 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -422,7 +422,7 @@ rebuildTargets pkg pkgBuildStatus - -- Once the packages are built, run their benchmarks. + -- Once the units are built, run their benchmarks. -- See Note [Running benchmarks] runDeferredBenchmarks keepGoing installPlan buildOutcomes =<< readTVarIO deferredBenchmarks @@ -510,22 +510,29 @@ configuring individual packages. {- Note [Running benchmarks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Benchmarks must not run at the same time as other benchmarks, or while other -packages are being built: they would compete for resources, which skews their -results (#7557). Yet the packages of the plan are built in parallel, and with -per-component builds every benchmark suite is a package of its own. - -So, the bench phase of a package (see 'buildAndRegisterUnpackedPackage') does -not run its benchmarks, but adds them to the 'DeferredBenchmarks'. Once all -the packages are built, 'rebuildTargets' runs them one at a time, in plan -order, with 'runDeferredBenchmarks', and records their failures in the -'BuildOutcomes'. - -Unless we keep going after failures, no benchmark is run if a package failed -to build, and no more benchmarks are run once one of them failed. +Benchmarks must not run at the same time as other benchmarks, or while +something else is being built: they would compete for resources, which skews +their results (#7557). + +Yet 'InstallPlan.execute' builds the units of the plan in parallel. A unit is +a single component of a package, or a whole package when it cannot be built +per component (see 'NotPerComponentReason'). So the benchmark suites of a +project, even those of the same package, are usually separate units. If each +unit ran its benchmarks in its bench phase, right after it is built, they +could run at the same time as each other, or while other units are still +being built. (A whole-package unit runs all of its benchmarks with a single +@Setup bench@ invocation, which runs them one at a time.) + +So, the bench phase of a unit (see 'buildAndRegisterUnpackedPackage') does not +run its benchmarks, but adds them to the 'DeferredBenchmarks'. Once all the +units are built, 'rebuildTargets' runs them one at a time, in plan order, with +'runDeferredBenchmarks', and records their failures in the 'BuildOutcomes'. + +Unless we keep going after failures, no benchmark is run if a unit failed to +build, and no more benchmarks are run once one of them failed. -} --- | Run the deferred benchmarks of the packages that were built successfully, +-- | Run the deferred benchmarks of the units that were built successfully, -- one at a time, in plan order. See Note [Running benchmarks]. runDeferredBenchmarks :: Bool @@ -603,7 +610,7 @@ rebuildTarget -> Lock -- ^ Serialises access to the setup executable cache -> DeferredBenchmarks - -- ^ Benchmarks to run once all the packages are built + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TVar InstalledPackageIndex diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index e98c1d175f6..7ebb3eb4297 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -158,8 +158,8 @@ data PackageBuildingPhase r where PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () --- | The benchmarks of the packages built so far, which are run once all the --- packages are built. +-- | The benchmarks of the units built so far, which are run once all the units +-- of the plan are built. -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". type DeferredBenchmarks = TVar [(UnitId, IO ())] @@ -180,7 +180,7 @@ buildAndRegisterUnpackedPackage -> Lock -- ^ Serialises access to the setup executable cache -> DeferredBenchmarks - -- ^ Benchmarks to run once all the packages are built + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -297,7 +297,7 @@ buildAndRegisterUnpackedPackage -- Bench phase -- - -- The benchmarks are not run here, but once all the packages are built. + -- The benchmarks are not run here, but once all the units are built. -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". whenBench $ deferBenchmark $ @@ -544,7 +544,7 @@ buildInplaceUnpackedPackage -> Lock -- ^ Serialises access to the setup executable cache -> DeferredBenchmarks - -- ^ Benchmarks to run once all the packages are built + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -784,7 +784,7 @@ buildAndInstallUnpackedPackage -> Lock -- ^ Serialises access to the setup executable cache -> DeferredBenchmarks - -- ^ Benchmarks to run once all the packages are built + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage From 9e82afc70a8d229acccf4f2104458b6b53e193df Mon Sep 17 00:00:00 2001 From: Claude Date: Sat, 3 Oct 2026 03:22:11 +0000 Subject: [PATCH 4/7] Use an IORef for the deferred benchmarks Each update of the deferred benchmarks is a transaction of its own, and they are only read once all the units are built, so a TVar buys nothing over an IORef updated with atomicModifyIORef'. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01GVJmRffSh16Wx8JR7Kd1dC --- cabal-install/src/Distribution/Client/ProjectBuilding.hs | 7 ++++--- .../Distribution/Client/ProjectBuilding/UnpackedPackage.hs | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 509c4a38136..4713c43c35b 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -83,9 +83,10 @@ import qualified Data.Set as Set import qualified Text.PrettyPrint as Disp -import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO) +import Control.Concurrent.STM (TVar, newTVarIO) import Control.Exception (assert, handle, try) import Data.Either (isLeft) +import Data.IORef (newIORef, readIORef) import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) @@ -358,7 +359,7 @@ rebuildTargets -- TODO: [code cleanup] eliminate setup exe cache -- See Note [Running benchmarks] - deferredBenchmarks <- newTVarIO [] + deferredBenchmarks <- newIORef [] info verbosity $ "Executing install plan " @@ -425,7 +426,7 @@ rebuildTargets -- Once the units are built, run their benchmarks. -- See Note [Running benchmarks] runDeferredBenchmarks keepGoing installPlan buildOutcomes - =<< readTVarIO deferredBenchmarks + =<< readIORef deferredBenchmarks where keepGoing = buildSettingKeepGoing withRepoCtx = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 7ebb3eb4297..5386ba1f22d 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -114,7 +114,7 @@ import qualified Data.List.NonEmpty as NE import Control.Concurrent.STM (TVar, atomically, modifyTVar) import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import GHC.Clock (getMonotonicTime) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory) import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) @@ -161,7 +161,7 @@ data PackageBuildingPhase r where -- | The benchmarks of the units built so far, which are run once all the units -- of the plan are built. -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". -type DeferredBenchmarks = TVar [(UnitId, IO ())] +type DeferredBenchmarks = IORef [(UnitId, IO ())] -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain @@ -329,7 +329,7 @@ buildAndRegisterUnpackedPackage deferBenchmark :: IO () -> IO () deferBenchmark bench = - atomically $ modifyTVar deferredBenchmarks ((uid, bench) :) + atomicModifyIORef' deferredBenchmarks (\queued -> ((uid, bench) : queued, ())) timedDelegate :: forall r. PackageBuildingPhase r -> IO r timedDelegate phase From d013dd5be3849e9261b630362d8f89a0f15f9557 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Thu, 8 Oct 2026 10:23:55 -0400 Subject: [PATCH 5/7] Address review: simplify runDeferredBenchmarks, mark changelog significant - Walk the plan's execution order directly instead of building an intermediate list of benchmarks; give `go` a signature and drop the now-redundant `BuildFailure` annotation. - changelog.d/issue-7557.md: set the PR number, add `significance: significant`, and spell out the user-visible consequences. Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_0176vAefrw8jPKXdh9h1wKuj --- .../Distribution/Client/ProjectBuilding.hs | 35 ++++++++++--------- changelog.d/issue-7557.md | 17 ++++++--- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 4713c43c35b..fae8f966b78 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -544,27 +544,28 @@ runDeferredBenchmarks -> IO BuildOutcomes runDeferredBenchmarks keepGoing installPlan buildOutcomes deferred | not keepGoing && any isLeft buildOutcomes = return buildOutcomes - | otherwise = go buildOutcomes benchmarks + | otherwise = go buildOutcomes (InstallPlan.executionOrder installPlan) where deferredMap = Map.fromList deferred - benchmarks = - [ (uid, bench) - | pkg <- InstallPlan.executionOrder installPlan - , let uid = nodeKey pkg - , Just (Right _) <- [Map.lookup uid buildOutcomes] - , Just bench <- [Map.lookup uid deferredMap] - ] + -- Run the benchmarks of the given units, in order, and record their + -- failures. Unless we keep going, stop at the first failure. + go :: BuildOutcomes -> [ElaboratedReadyPackage] -> IO BuildOutcomes go outcomes [] = return outcomes - go outcomes ((uid, bench) : rest) = do - result <- try bench - case result of - Right () -> go outcomes rest - Left (failure :: BuildFailure) - | keepGoing -> go outcomes' rest - | otherwise -> return outcomes' - where - outcomes' = Map.insert uid (Left failure) outcomes + go outcomes (pkg : pkgs) + | Just (Right _) <- Map.lookup uid outcomes + , Just bench <- Map.lookup uid deferredMap = do + result <- try bench + case result of + Right () -> go outcomes pkgs + Left failure + | keepGoing -> go outcomes' pkgs + | otherwise -> return outcomes' + where + outcomes' = Map.insert uid (Left failure) outcomes + | otherwise = go outcomes pkgs + where + uid = nodeKey pkg -- | Create a package DB if it does not currently exist. createPackageDBIfMissing diff --git a/changelog.d/issue-7557.md b/changelog.d/issue-7557.md index 67cfa8015c9..ca5dfd8995e 100644 --- a/changelog.d/issue-7557.md +++ b/changelog.d/issue-7557.md @@ -1,8 +1,9 @@ --- synopsis: "`cabal bench` runs benchmarks one at a time, once everything is built" packages: [cabal-install] -prs: 0000 +prs: 12407 issues: 7557 +significance: significant --- `cabal bench` used to run each benchmark as soon as it was built. When building @@ -10,6 +11,14 @@ in parallel (e.g. with `-j`), several benchmarks could thus run at the same time and while other components were still being built, so that they competed for resources, which skewed their results. -Now, `cabal bench` first builds everything (still in parallel), and only then -runs the benchmarks, one at a time. Without `--keep-going`, no benchmark is run -if the build fails. +Now, `cabal bench` first builds everything that is needed (still in parallel), +and only then runs the benchmarks, one at a time, in the order of the build +plan. Consequently: + +- The first benchmark starts only once everything is built, so its results + come later than before, and all the build output now precedes the output of + the benchmarks. +- Without `--keep-going`, no benchmark is run if anything fails to build, and + no further benchmark is run once one of them has failed. With + `--keep-going`, the benchmarks of everything that was built successfully are + run. From e799189b8ee1524dea6c86f9218c1dd421fe38f0 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Fri, 9 Oct 2026 12:49:40 -0400 Subject: [PATCH 6/7] Return deferred benchmarks instead of collecting them in an IORef The bench phase of a unit now returns its deferred benchmark, which `rebuildTarget` returns alongside the unit's `BuildResult`, so that `InstallPlan.execute` collects it with the other outcomes. `runDeferredBenchmarks` then reads both from the same map, and the `IORef` threaded through the build functions is gone. Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_0176vAefrw8jPKXdh9h1wKuj --- .../Distribution/Client/ProjectBuilding.hs | 67 ++- .../Client/ProjectBuilding/UnpackedPackage.hs | 406 +++++++++--------- 2 files changed, 228 insertions(+), 245 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index fae8f966b78..b323aa87538 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -86,7 +86,6 @@ import qualified Text.PrettyPrint as Disp import Control.Concurrent.STM (TVar, newTVarIO) import Control.Exception (assert, handle, try) import Data.Either (isLeft) -import Data.IORef (newIORef, readIORef) import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Simple.PackageIndex (InstalledPackageIndex) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) @@ -97,7 +96,7 @@ import Distribution.Client.Errors import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Client.ProjectBuilding.UnpackedPackage (DeferredBenchmarks, annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.ProjectBuilding.UnpackedPackage (DeferredBenchmark, annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) ------------------------------------------------------------------------------ @@ -357,10 +356,6 @@ rebuildTargets registerLock <- newLock -- serialise registration cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache - - -- See Note [Running benchmarks] - deferredBenchmarks <- newIORef [] - info verbosity $ "Executing install plan " ++ case buildSettingNumJobs of @@ -387,7 +382,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - buildOutcomes <- withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + outcomes <- withJobControl (newJobControlFromParStrat verbosity (Just 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 @@ -416,7 +411,6 @@ rebuildTargets downloadMap registerLock cacheLock - deferredBenchmarks sharedPackageConfig installPlan ipiTVar @@ -425,8 +419,7 @@ rebuildTargets -- Once the units are built, run their benchmarks. -- See Note [Running benchmarks] - runDeferredBenchmarks keepGoing installPlan buildOutcomes - =<< readIORef deferredBenchmarks + runDeferredBenchmarks keepGoing installPlan outcomes where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -525,7 +518,8 @@ being built. (A whole-package unit runs all of its benchmarks with a single @Setup bench@ invocation, which runs them one at a time.) So, the bench phase of a unit (see 'buildAndRegisterUnpackedPackage') does not -run its benchmarks, but adds them to the 'DeferredBenchmarks'. Once all the +run its benchmarks, but returns them as a 'DeferredBenchmark', which +'rebuildTarget' returns along with the 'BuildResult' of the unit. Once all the units are built, 'rebuildTargets' runs them one at a time, in plan order, with 'runDeferredBenchmarks', and records their failures in the 'BuildOutcomes'. @@ -539,31 +533,35 @@ runDeferredBenchmarks :: Bool -- ^ Keep going after failure -> ElaboratedInstallPlan - -> BuildOutcomes - -> [(UnitId, IO ())] + -> Map.Map UnitId (Either BuildFailure (BuildResult, Maybe DeferredBenchmark)) + -- ^ The outcomes of the build, along with the benchmarks of the units that + -- were built successfully -> IO BuildOutcomes -runDeferredBenchmarks keepGoing installPlan buildOutcomes deferred - | not keepGoing && any isLeft buildOutcomes = return buildOutcomes +runDeferredBenchmarks keepGoing installPlan outcomes + | not keepGoing && any isLeft outcomes = return buildOutcomes | otherwise = go buildOutcomes (InstallPlan.executionOrder installPlan) where - deferredMap = Map.fromList deferred + buildOutcomes :: BuildOutcomes + buildOutcomes = fmap (fmap fst) outcomes + + benchmarks :: Map.Map UnitId DeferredBenchmark + benchmarks = Map.mapMaybe (either (const Nothing) snd) outcomes -- Run the benchmarks of the given units, in order, and record their -- failures. Unless we keep going, stop at the first failure. go :: BuildOutcomes -> [ElaboratedReadyPackage] -> IO BuildOutcomes - go outcomes [] = return outcomes - go outcomes (pkg : pkgs) - | Just (Right _) <- Map.lookup uid outcomes - , Just bench <- Map.lookup uid deferredMap = do + go acc [] = return acc + go acc (pkg : pkgs) + | Just bench <- Map.lookup uid benchmarks = do result <- try bench case result of - Right () -> go outcomes pkgs + Right () -> go acc pkgs Left failure - | keepGoing -> go outcomes' pkgs - | otherwise -> return outcomes' + | keepGoing -> go acc' pkgs + | otherwise -> return acc' where - outcomes' = Map.insert uid (Left failure) outcomes - | otherwise = go outcomes pkgs + acc' = Map.insert uid (Left failure) acc + | otherwise = go acc pkgs where uid = nodeKey pkg @@ -611,14 +609,12 @@ rebuildTarget -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> DeferredBenchmarks - -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TVar InstalledPackageIndex -> ElaboratedReadyPackage -> BuildStatus - -> IO BuildResult + -> IO (BuildResult, Maybe DeferredBenchmark) rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} @@ -628,7 +624,6 @@ rebuildTarget downloadMap registerLock cacheLock - deferredBenchmarks sharedPackageConfig plan ipiTVar @@ -647,7 +642,7 @@ rebuildTarget BuildStatusDownload -> void $ waitAsyncPackageDownload verbosity downloadMap pkg _ -> return () - return $ BuildResult DocsNotTried TestsNotTried Nothing + return (BuildResult DocsNotTried TestsNotTried Nothing, Nothing) | otherwise = -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of @@ -661,7 +656,7 @@ rebuildTarget where unexpectedState = error "rebuildTarget: unexpected package status" - downloadPhase :: IO BuildResult + downloadPhase :: IO (BuildResult, Maybe DeferredBenchmark) downloadPhase = do downsrcloc <- annotateFailureNoLog DownloadFailed $ @@ -670,7 +665,7 @@ rebuildTarget DownloadedTarball tarball -> unpackTarballPhase tarball -- TODO: [nice to have] git/darcs repos etc - unpackTarballPhase :: FilePath -> IO BuildResult + unpackTarballPhase :: FilePath -> IO (BuildResult, Maybe DeferredBenchmark) unpackTarballPhase tarball = withTarballLocalDirectory verbosity @@ -690,7 +685,7 @@ rebuildTarget -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages -- would only start from download or unpack phases. -- - rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult + rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO (BuildResult, Maybe DeferredBenchmark) rebuildPhase buildStatus srcdir = assert (isInplaceBuildStyle $ elabBuildStyle pkg) @@ -705,7 +700,7 @@ rebuildTarget makeRelative (normalise $ getSymbolicPath srcdir) distdir -- TODO: [nice to have] ^^ do this relative stuff better - buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult + buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO (BuildResult, Maybe DeferredBenchmark) buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage verbosity @@ -715,7 +710,6 @@ rebuildTarget buildSettings registerLock cacheLock - deferredBenchmarks sharedPackageConfig plan rpkg @@ -723,7 +717,7 @@ rebuildTarget srcdir builddir - buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult + buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO (BuildResult, Maybe DeferredBenchmark) buildInplace buildStatus srcdir builddir = -- TODO: [nice to have] use a relative build dir rather than absolute buildInplaceUnpackedPackage @@ -733,7 +727,6 @@ rebuildTarget buildSettings registerLock cacheLock - deferredBenchmarks sharedPackageConfig plan rpkg diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 5386ba1f22d..b8a528a8ec2 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -20,7 +20,7 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage -- ** Auxiliary definitions , buildAndRegisterUnpackedPackage , PackageBuildingPhase - , DeferredBenchmarks + , DeferredBenchmark -- ** Utilities , annotateFailure @@ -114,7 +114,7 @@ import qualified Data.List.NonEmpty as NE import Control.Concurrent.STM (TVar, atomically, modifyTVar) import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException) -import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.IORef (newIORef, readIORef, writeIORef) import GHC.Clock (getMonotonicTime) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory) import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) @@ -158,10 +158,9 @@ data PackageBuildingPhase r where PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () --- | The benchmarks of the units built so far, which are run once all the units --- of the plan are built. --- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". -type DeferredBenchmarks = IORef [(UnitId, IO ())] +-- | The benchmarks of a unit, to be run once all the units of the plan are +-- built. See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". +type DeferredBenchmark = IO () -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain @@ -179,8 +178,6 @@ buildAndRegisterUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> DeferredBenchmarks - -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -192,7 +189,8 @@ buildAndRegisterUnpackedPackage -> Maybe FilePath -- ^ The path to an /initialized/ log file -> (forall r. PackageBuildingPhase r -> IO r) - -> IO () + -> IO (Maybe DeferredBenchmark) + -- ^ The benchmarks of the unit, if any, to run once all the units are built buildAndRegisterUnpackedPackage verbosity distDirLayout@DistDirLayout{distTempDirectory} @@ -203,7 +201,6 @@ buildAndRegisterUnpackedPackage } registerLock cacheLock - deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigCompilerProgs = progdb @@ -297,19 +294,22 @@ buildAndRegisterUnpackedPackage -- Bench phase -- - -- The benchmarks are not run here, but once all the units are built. + -- The benchmarks are not run here, but returned, to be run once all the + -- units are built. -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". - whenBench $ - deferBenchmark $ - timedDelegate $ - PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ - setup - benchCommand - Cabal.benchmarkCommonFlags - (return . benchFlags) - benchArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) + let deferredBenchmark + | null (elabBenchTargets pkg) = Nothing + | otherwise = + Just $ + timedDelegate $ + PBBenchPhase $ + annotateFailure mlogFile BenchFailed $ + setup + benchCommand + Cabal.benchmarkCommonFlags + (return . benchFlags) + benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ @@ -323,14 +323,10 @@ buildAndRegisterUnpackedPackage replArgs (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) - return () + return deferredBenchmark where uid = installedUnitId rpkg - deferBenchmark :: IO () -> IO () - deferBenchmark bench = - atomicModifyIORef' deferredBenchmarks (\queued -> ((uid, bench) : queued, ())) - timedDelegate :: forall r. PackageBuildingPhase r -> IO r timedDelegate phase | buildSettingBuildTimings = do @@ -366,10 +362,6 @@ buildAndRegisterUnpackedPackage | null (elabTestTargets pkg) = return () | otherwise = action - whenBench action - | null (elabBenchTargets pkg) = return () - | otherwise = action - whenRepl action | null (elabReplTarget pkg) = return () | otherwise = action @@ -543,8 +535,6 @@ buildInplaceUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> DeferredBenchmarks - -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -552,7 +542,7 @@ buildInplaceUnpackedPackage -> BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) - -> IO BuildResult + -> IO (BuildResult, Maybe DeferredBenchmark) buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout @@ -564,7 +554,6 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - deferredBenchmarks pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} plan rpkg@(ReadyPackage pkg) @@ -581,87 +570,89 @@ buildInplaceUnpackedPackage True (distPackageCacheDirectory dparams) - buildAndRegisterUnpackedPackage - verbosity - distDirLayout - maybe_semaphore - buildSettings - registerLock - cacheLock - deferredBenchmarks - pkgshared - plan - rpkg - ipiTVar - srcdir - builddir - Nothing -- no log file for inplace builds! - $ \case - PBConfigurePhase{runConfigure} -> - whenReconfigure $ do - mbLBI <- runConfigure - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg - return mbLBI - PBBuildPhase{runBuild} -> - whenRebuild $ withFileMonitor runBuild - PBReplPhase{runRepl} -> - withFileMonitor runRepl - PBHaddockPhase{runHaddock} -> do - withFileMonitor runHaddock - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = - distBuildDirectory distDirLayout dparams - "doc" - "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do - let dest = docDir "index.html" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = case distHaddockOutputDir of - Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name - Just dir -> dir - catch - (void $ openBrowser dest) - ( \(_ :: ErrorCall) -> - dieWithException verbosity $ - FindOpenProgramLocationErr $ - "Unsupported OS: " <> show os - ) - PBInstallPhase{runCopy = _runCopy, runRegister} -> do - -- PURPOSELY omitted: no copy! - - whenReRegister $ do - -- Register locally - mipkg <- - if elabRequiresRegistration pkg - then do - ipkg <- - runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - -- Keep the per-project running InstalledPackageIndex up to date. - -- See (ProjIPI2) from Note [Per-project InstalledPackageIndex] - -- in Distribution.Client.ProjectBuilding. - atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg) - return (Just ipkg) - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg - PBTestPhase{runTest} -> runTest - PBBenchPhase{runBench} -> runBench + deferredBenchmark <- + buildAndRegisterUnpackedPackage + verbosity + distDirLayout + maybe_semaphore + buildSettings + registerLock + cacheLock + pkgshared + plan + rpkg + ipiTVar + srcdir + builddir + Nothing -- no log file for inplace builds! + $ \case + PBConfigurePhase{runConfigure} -> + whenReconfigure $ do + mbLBI <- runConfigure + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg + return mbLBI + PBBuildPhase{runBuild} -> + whenRebuild $ withFileMonitor runBuild + PBReplPhase{runRepl} -> + withFileMonitor runRepl + PBHaddockPhase{runHaddock} -> do + withFileMonitor runHaddock + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = case distHaddockOutputDir of + Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name + Just dir -> dir + catch + (void $ openBrowser dest) + ( \(_ :: ErrorCall) -> + dieWithException verbosity $ + FindOpenProgramLocationErr $ + "Unsupported OS: " <> show os + ) + PBInstallPhase{runCopy = _runCopy, runRegister} -> do + -- PURPOSELY omitted: no copy! + + whenReRegister $ do + -- Register locally + mipkg <- + if elabRequiresRegistration pkg + then do + ipkg <- + runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + -- Keep the per-project running InstalledPackageIndex up to date. + -- See (ProjIPI2) from Note [Per-project InstalledPackageIndex] + -- in Distribution.Client.ProjectBuilding. + atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg) + return (Just ipkg) + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg + PBTestPhase{runTest} -> runTest + PBBenchPhase{runBench} -> runBench return - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } + ( BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + , deferredBenchmark + ) where docsResult = DocsNotTried testsResult = TestsNotTried @@ -783,15 +774,13 @@ buildAndInstallUnpackedPackage -- ^ Serialises package registration -> Lock -- ^ Serialises access to the setup executable cache - -> DeferredBenchmarks - -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> TVar InstalledPackageIndex -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) - -> IO BuildResult + -> IO (BuildResult, Maybe DeferredBenchmark) buildAndInstallUnpackedPackage verbosity distDirLayout @@ -802,7 +791,6 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigPlatform = platform @@ -827,91 +815,91 @@ buildAndInstallUnpackedPackage initLogFile - buildAndRegisterUnpackedPackage - verbosity - distDirLayout - maybe_semaphore - buildSettings - registerLock - cacheLock - deferredBenchmarks - pkgshared - plan - rpkg - ipiTVar - srcdir - builddir - mlogFile - $ \case - PBConfigurePhase{runConfigure} -> do - noticeProgress ProgressStarting - runConfigure - PBBuildPhase{runBuild} -> do - noticeProgress ProgressBuilding - _monitors <- runBuild - return () - PBHaddockPhase{runHaddock} -> do - noticeProgress ProgressHaddock - _monitors <- runHaddock - return () - PBInstallPhase{runCopy, runRegister, getInstalledPackageInfo} -> do - noticeProgress ProgressInstalling - - -- Create an IORef used to retrieve the InstalledPackageInfo computed - -- by running "register". - ipkgRef <- newIORef Nothing - - let registerPkg - | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid - | otherwise = do - assert - ( elabRegisterPackageDBStack pkg - == storePackageDBStack compiler (elabPackageDbs pkg) - ) - (return ()) - ipkg <- - runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - { Cabal.registerMultiInstance = True - , Cabal.registerSuppressFilesCheck = True - } - -- Write the InstalledPackageInfo to the IORef - writeIORef ipkgRef (Just ipkg) - - -- Actual installation - void $ - newStoreEntry - verbosity - storeDirLayout - compiler - uid - (copyPkgFiles verbosity pkgshared pkg runCopy) - registerPkg - - -- Keep the per-project running InstalledPackageIndex TVar up to date. - -- This must run regardless of whether newStoreEntry won or lost the - -- race (UseNewStoreEntry/UseExistingStoreEntry). - -- - -- See (ProjIPI2) in Note [Per-project InstalledPackageIndex]. - when (elabRequiresRegistration pkg) $ do - -- If we won the race, we use the InstalledPackageInfo that was - -- computed by 'runRegister'. If we lost, then we fall back to - -- 'getInstalledPackageInfo' which re-runs 'Cabal register' - -- (takes ~100ms). - mipkg <- readIORef ipkgRef - ipkg <- maybe getInstalledPackageInfo return mipkg - atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg) - - -- No tests on install - PBTestPhase{} -> return () - -- No bench on install - PBBenchPhase{} -> return () - -- No repl on install - PBReplPhase{} -> return () + deferredBenchmark <- + buildAndRegisterUnpackedPackage + verbosity + distDirLayout + maybe_semaphore + buildSettings + registerLock + cacheLock + pkgshared + plan + rpkg + ipiTVar + srcdir + builddir + mlogFile + $ \case + PBConfigurePhase{runConfigure} -> do + noticeProgress ProgressStarting + runConfigure + PBBuildPhase{runBuild} -> do + noticeProgress ProgressBuilding + _monitors <- runBuild + return () + PBHaddockPhase{runHaddock} -> do + noticeProgress ProgressHaddock + _monitors <- runHaddock + return () + PBInstallPhase{runCopy, runRegister, getInstalledPackageInfo} -> do + noticeProgress ProgressInstalling + + -- Create an IORef used to retrieve the InstalledPackageInfo computed + -- by running "register". + ipkgRef <- newIORef Nothing + + let registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | otherwise = do + assert + ( elabRegisterPackageDBStack pkg + == storePackageDBStack compiler (elabPackageDbs pkg) + ) + (return ()) + ipkg <- + runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } + -- Write the InstalledPackageInfo to the IORef + writeIORef ipkgRef (Just ipkg) + + -- Actual installation + void $ + newStoreEntry + verbosity + storeDirLayout + compiler + uid + (copyPkgFiles verbosity pkgshared pkg runCopy) + registerPkg + + -- Keep the per-project running InstalledPackageIndex TVar up to date. + -- This must run regardless of whether newStoreEntry won or lost the + -- race (UseNewStoreEntry/UseExistingStoreEntry). + -- + -- See (ProjIPI2) in Note [Per-project InstalledPackageIndex]. + when (elabRequiresRegistration pkg) $ do + -- If we won the race, we use the InstalledPackageInfo that was + -- computed by 'runRegister'. If we lost, then we fall back to + -- 'getInstalledPackageInfo' which re-runs 'Cabal register' + -- (takes ~100ms). + mipkg <- readIORef ipkgRef + ipkg <- maybe getInstalledPackageInfo return mipkg + atomically $ modifyTVar ipiTVar (PackageIndex.insert ipkg) + + -- No tests on install + PBTestPhase{} -> return () + -- No bench on install + PBBenchPhase{} -> return () + -- No repl on install + PBReplPhase{} -> return () -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right -- thing. Although we do copy into an image dir and do the move into the @@ -930,11 +918,13 @@ buildAndInstallUnpackedPackage noticeProgress ProgressCompleted return - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = mlogFile - } + ( BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + , deferredBenchmark + ) where uid = installedUnitId rpkg pkgid = packageId rpkg From ba5377c239eed88e5458f6f6fece32b285669872 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Fri, 9 Oct 2026 13:24:48 -0400 Subject: [PATCH 7/7] Record the deferred benchmark in the unit's BuildResult Instead of being returned in a tuple next to the BuildResult, the deferred benchmark of a unit is now a field of its BuildResult, so the build functions keep their `IO BuildResult` type and `runDeferredBenchmarks` works on plain BuildOutcomes. DeferredBenchmark is a newtype over the action, which also gives it the Show instance that BuildResult derives. Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_0176vAefrw8jPKXdh9h1wKuj --- .../Distribution/Client/ProjectBuilding.hs | 67 +++++++++---------- .../ProjectBuilding/PackageFileMonitor.hs | 1 + .../Client/ProjectBuilding/Types.hs | 15 +++++ .../Client/ProjectBuilding/UnpackedPackage.hs | 37 +++++----- 4 files changed, 64 insertions(+), 56 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index b323aa87538..a6009f012a8 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -96,7 +96,7 @@ import Distribution.Client.Errors import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Client.ProjectBuilding.UnpackedPackage (DeferredBenchmark, annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) ------------------------------------------------------------------------------ @@ -382,7 +382,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - outcomes <- withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + buildOutcomes <- withJobControl (newJobControlFromParStrat verbosity (Just 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 @@ -419,7 +419,7 @@ rebuildTargets -- Once the units are built, run their benchmarks. -- See Note [Running benchmarks] - runDeferredBenchmarks keepGoing installPlan outcomes + runDeferredBenchmarks keepGoing installPlan buildOutcomes where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -518,9 +518,9 @@ being built. (A whole-package unit runs all of its benchmarks with a single @Setup bench@ invocation, which runs them one at a time.) So, the bench phase of a unit (see 'buildAndRegisterUnpackedPackage') does not -run its benchmarks, but returns them as a 'DeferredBenchmark', which -'rebuildTarget' returns along with the 'BuildResult' of the unit. Once all the -units are built, 'rebuildTargets' runs them one at a time, in plan order, with +run its benchmarks, but returns them as a 'DeferredBenchmark', which is +recorded in the 'BuildResult' of the unit. Once all the units are built, +'rebuildTargets' runs them one at a time, in plan order, with 'runDeferredBenchmarks', and records their failures in the 'BuildOutcomes'. Unless we keep going after failures, no benchmark is run if a unit failed to @@ -533,35 +533,28 @@ runDeferredBenchmarks :: Bool -- ^ Keep going after failure -> ElaboratedInstallPlan - -> Map.Map UnitId (Either BuildFailure (BuildResult, Maybe DeferredBenchmark)) - -- ^ The outcomes of the build, along with the benchmarks of the units that - -- were built successfully + -> BuildOutcomes -> IO BuildOutcomes -runDeferredBenchmarks keepGoing installPlan outcomes - | not keepGoing && any isLeft outcomes = return buildOutcomes +runDeferredBenchmarks keepGoing installPlan buildOutcomes + | not keepGoing && any isLeft buildOutcomes = return buildOutcomes | otherwise = go buildOutcomes (InstallPlan.executionOrder installPlan) where - buildOutcomes :: BuildOutcomes - buildOutcomes = fmap (fmap fst) outcomes - - benchmarks :: Map.Map UnitId DeferredBenchmark - benchmarks = Map.mapMaybe (either (const Nothing) snd) outcomes - -- Run the benchmarks of the given units, in order, and record their -- failures. Unless we keep going, stop at the first failure. go :: BuildOutcomes -> [ElaboratedReadyPackage] -> IO BuildOutcomes - go acc [] = return acc - go acc (pkg : pkgs) - | Just bench <- Map.lookup uid benchmarks = do - result <- try bench - case result of - Right () -> go acc pkgs + go outcomes [] = return outcomes + go outcomes (pkg : pkgs) + | Just (Right result) <- Map.lookup uid outcomes + , Just bench <- buildResultBenchmark result = do + outcome <- try (runDeferredBenchmark bench) + case outcome of + Right () -> go outcomes pkgs Left failure - | keepGoing -> go acc' pkgs - | otherwise -> return acc' + | keepGoing -> go outcomes' pkgs + | otherwise -> return outcomes' where - acc' = Map.insert uid (Left failure) acc - | otherwise = go acc pkgs + outcomes' = Map.insert uid (Left failure) outcomes + | otherwise = go outcomes pkgs where uid = nodeKey pkg @@ -614,7 +607,7 @@ rebuildTarget -> TVar InstalledPackageIndex -> ElaboratedReadyPackage -> BuildStatus - -> IO (BuildResult, Maybe DeferredBenchmark) + -> IO BuildResult rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} @@ -642,7 +635,13 @@ rebuildTarget BuildStatusDownload -> void $ waitAsyncPackageDownload verbosity downloadMap pkg _ -> return () - return (BuildResult DocsNotTried TestsNotTried Nothing, Nothing) + return + BuildResult + { buildResultDocs = DocsNotTried + , buildResultTests = TestsNotTried + , buildResultLogFile = Nothing + , buildResultBenchmark = Nothing + } | otherwise = -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of @@ -656,7 +655,7 @@ rebuildTarget where unexpectedState = error "rebuildTarget: unexpected package status" - downloadPhase :: IO (BuildResult, Maybe DeferredBenchmark) + downloadPhase :: IO BuildResult downloadPhase = do downsrcloc <- annotateFailureNoLog DownloadFailed $ @@ -665,7 +664,7 @@ rebuildTarget DownloadedTarball tarball -> unpackTarballPhase tarball -- TODO: [nice to have] git/darcs repos etc - unpackTarballPhase :: FilePath -> IO (BuildResult, Maybe DeferredBenchmark) + unpackTarballPhase :: FilePath -> IO BuildResult unpackTarballPhase tarball = withTarballLocalDirectory verbosity @@ -685,7 +684,7 @@ rebuildTarget -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages -- would only start from download or unpack phases. -- - rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO (BuildResult, Maybe DeferredBenchmark) + rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult rebuildPhase buildStatus srcdir = assert (isInplaceBuildStyle $ elabBuildStyle pkg) @@ -700,7 +699,7 @@ rebuildTarget makeRelative (normalise $ getSymbolicPath srcdir) distdir -- TODO: [nice to have] ^^ do this relative stuff better - buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO (BuildResult, Maybe DeferredBenchmark) + buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage verbosity @@ -717,7 +716,7 @@ rebuildTarget srcdir builddir - buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO (BuildResult, Maybe DeferredBenchmark) + buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildInplace buildStatus srcdir builddir = -- TODO: [nice to have] use a relative build dir rather than absolute buildInplaceUnpackedPackage diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs index f7ddca60251..27205f9dcad 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -199,6 +199,7 @@ checkPackageFileMonitorChanged { buildResultDocs = docsResult , buildResultTests = testsResult , buildResultLogFile = Nothing + , buildResultBenchmark = Nothing } where (docsResult, testsResult) = buildResult diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 864455cb540..36acf5113f3 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -15,6 +15,7 @@ module Distribution.Client.ProjectBuilding.Types , BuildOutcomes , BuildOutcome , BuildResult (..) + , DeferredBenchmark (..) , BuildFailure (..) , BuildFailureReason (..) ) where @@ -146,9 +147,23 @@ data BuildResult = BuildResult { buildResultDocs :: DocsResult , buildResultTests :: TestsResult , buildResultLogFile :: Maybe FilePath + , buildResultBenchmark :: Maybe DeferredBenchmark + -- ^ The benchmarks of the unit, if any, to be run once all the units of + -- the plan are built. } deriving (Show) +-- | The benchmarks of a unit, to be run once all the units of the plan are +-- built. See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". +newtype DeferredBenchmark = DeferredBenchmark + { runDeferredBenchmark :: IO () + -- ^ Run the benchmarks of the unit, as its bench phase would have. + -- Throws a 'BuildFailure' if they fail. + } + +instance Show DeferredBenchmark where + show _ = "" + -- | Information arising from the failure to build a single package. data BuildFailure = BuildFailure { buildFailureLogFile :: Maybe FilePath diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index b8a528a8ec2..1c48169e6bd 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -20,7 +20,6 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage -- ** Auxiliary definitions , buildAndRegisterUnpackedPackage , PackageBuildingPhase - , DeferredBenchmark -- ** Utilities , annotateFailure @@ -158,10 +157,6 @@ data PackageBuildingPhase r where PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase () PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase () --- | The benchmarks of a unit, to be run once all the units of the plan are --- built. See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". -type DeferredBenchmark = IO () - -- | Structures the phases of building and registering a package amongst others -- (see t'PackageBuildingPhase'). Delegates logic specific to a certain -- building style (notably, inplace vs install) to the delegate function that @@ -300,7 +295,7 @@ buildAndRegisterUnpackedPackage let deferredBenchmark | null (elabBenchTargets pkg) = Nothing | otherwise = - Just $ + Just . DeferredBenchmark $ timedDelegate $ PBBenchPhase $ annotateFailure mlogFile BenchFailed $ @@ -542,7 +537,7 @@ buildInplaceUnpackedPackage -> BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) - -> IO (BuildResult, Maybe DeferredBenchmark) + -> IO BuildResult buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout @@ -646,13 +641,12 @@ buildInplaceUnpackedPackage PBBenchPhase{runBench} -> runBench return - ( BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } - , deferredBenchmark - ) + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + , buildResultBenchmark = deferredBenchmark + } where docsResult = DocsNotTried testsResult = TestsNotTried @@ -780,7 +774,7 @@ buildAndInstallUnpackedPackage -> TVar InstalledPackageIndex -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) - -> IO (BuildResult, Maybe DeferredBenchmark) + -> IO BuildResult buildAndInstallUnpackedPackage verbosity distDirLayout @@ -918,13 +912,12 @@ buildAndInstallUnpackedPackage noticeProgress ProgressCompleted return - ( BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = mlogFile - } - , deferredBenchmark - ) + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + , buildResultBenchmark = deferredBenchmark + } where uid = installedUnitId rpkg pkgid = packageId rpkg