Fix cabal issue 7557: don’t run benchmarks in parallel or with the build

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

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

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

cabal-testsuite/PackageTests/NewBuild/CmdBench/Sequential/cabal.project

@@ -0,0 +1 @@
+packages: pkg-a pkg-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)

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"

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

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"