diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 459cee1bdea..fae8f966b78 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -84,7 +84,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.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) @@ -95,7 +97,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,6 +357,10 @@ 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 @@ -381,7 +387,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 @@ -410,11 +416,17 @@ rebuildTargets downloadMap registerLock cacheLock + deferredBenchmarks sharedPackageConfig installPlan ipiTVar pkg pkgBuildStatus + + -- Once the units are built, run their benchmarks. + -- See Note [Running benchmarks] + runDeferredBenchmarks keepGoing installPlan buildOutcomes + =<< readIORef deferredBenchmarks where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -497,6 +509,64 @@ configuring individual packages. invocation. -} +{- Note [Running benchmarks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 units 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 (InstallPlan.executionOrder installPlan) + where + deferredMap = Map.fromList deferred + + -- 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 + 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 :: Verbosity @@ -538,7 +608,11 @@ rebuildTarget -> BuildTimeSettings -> AsyncFetchMap -> Lock + -- ^ 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 @@ -554,6 +628,7 @@ rebuildTarget downloadMap registerLock cacheLock + deferredBenchmarks sharedPackageConfig plan ipiTVar @@ -640,6 +715,7 @@ rebuildTarget buildSettings registerLock cacheLock + deferredBenchmarks sharedPackageConfig plan rpkg @@ -657,6 +733,7 @@ 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 9f6b202830c..5386ba1f22d 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 @@ -113,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, (<.>), ()) @@ -157,6 +158,11 @@ 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 ())] + -- | 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 @@ -170,7 +176,11 @@ buildAndRegisterUnpackedPackage -- name of the semaphore is created freshly each time. -> BuildTimeSettings -> Lock + -- ^ Serialises package registration -> Lock + -- ^ Serialises access to the setup executable cache + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -193,6 +203,7 @@ buildAndRegisterUnpackedPackage } registerLock cacheLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigCompilerProgs = progdb @@ -285,16 +296,20 @@ buildAndRegisterUnpackedPackage (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase + -- + -- The benchmarks are not run here, but once all the units are built. + -- See Note [Running benchmarks] in "Distribution.Client.ProjectBuilding". whenBench $ - timedDelegate $ - PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ - setup - benchCommand - Cabal.benchmarkCommonFlags - (return . benchFlags) - benchArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) + deferBenchmark $ + timedDelegate $ + PBBenchPhase $ + annotateFailure mlogFile BenchFailed $ + setup + benchCommand + Cabal.benchmarkCommonFlags + (return . benchFlags) + benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ @@ -312,6 +327,10 @@ buildAndRegisterUnpackedPackage 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 @@ -521,7 +540,11 @@ buildInplaceUnpackedPackage -> Maybe SemaphoreIdentifier -> BuildTimeSettings -> Lock + -- ^ Serialises package registration -> Lock + -- ^ Serialises access to the setup executable cache + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -541,6 +564,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} plan rpkg@(ReadyPackage pkg) @@ -564,6 +588,7 @@ buildInplaceUnpackedPackage buildSettings registerLock cacheLock + deferredBenchmarks pkgshared plan rpkg @@ -755,7 +780,11 @@ buildAndInstallUnpackedPackage -- name of the semaphore is created freshly each time. -> BuildTimeSettings -> Lock + -- ^ Serialises package registration -> Lock + -- ^ Serialises access to the setup executable cache + -> DeferredBenchmarks + -- ^ Benchmarks to run once all the units are built -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedReadyPackage @@ -773,6 +802,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock + deferredBenchmarks pkgshared@ElaboratedSharedConfig { pkgConfigCompiler = compiler , pkgConfigPlatform = platform @@ -804,6 +834,7 @@ buildAndInstallUnpackedPackage buildSettings registerLock cacheLock + 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.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..65e453205fb --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.test.hs @@ -0,0 +1,21 @@ +import Test.Cabal.Prelude + +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 $ 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-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/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 new file mode 100644 index 00000000000..b3a0d86e7f5 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/pkg-b/pkg-b.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.0 +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, 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 new file mode 100644 index 00000000000..ca5dfd8995e --- /dev/null +++ b/changelog.d/issue-7557.md @@ -0,0 +1,24 @@ +--- +synopsis: "`cabal bench` runs benchmarks one at a time, once everything is built" +packages: [cabal-install] +prs: 12407 +issues: 7557 +significance: significant +--- + +`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. + +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. diff --git a/doc/cabal-commands.rst b/doc/cabal-commands.rst index 0c4fb040375..5854e98de53 100644 --- a/doc/cabal-commands.rst +++ b/doc/cabal-commands.rst @@ -1337,6 +1337,12 @@ they are up to date. ``cabal bench`` inherits flags of the ``bench`` subcommand of ``Setup.hs``, :ref:`see the corresponding section `. +``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 ^^^^^^^^^^