Never run benchmarks concurrently, always output to console #3663

ChangeLog.md

@@ -18,6 +18,11 @@ Other enhancements:
 
 Bug fixes:
 
+* Benchmarks used to be run concurrently with other benchmarks
+  and build steps. This is non-ideal because CPU usage of other processes
+  may interfere with benchmarks. It also prevented benchmark output from
+  being displayed by default. This is now fixed. See
+  [#3663](https://github.com/commercialhaskell/stack/issues/3663).
 
 ## v1.6.3
 
@@ -46,13 +51,11 @@ Bug fixes:
   surrounding documentation. See
   [#2275](https://github.com/commercialhaskell/stack/issues/2275).
 
-
 ## v1.6.1.1
 
 Hackage-only release with no user facing changes (updated to build with
 newer dependency versions).
 
-
 ## v1.6.1
 
 Major changes:

src/Control/Concurrent/Execute.hs

@@ -8,40 +8,56 @@ module Control.Concurrent.Execute
     , ActionId (..)
     , ActionContext (..)
     , Action (..)
+    , Concurrency(..)
     , runActions
     ) where
 
 import           Control.Concurrent.STM   (retry)
 import           Stack.Prelude
+import           Data.List (sortBy)
 import qualified Data.Set                 as Set
 import           Stack.Types.PackageIdentifier
 
 data ActionType
     = ATBuild
+      -- ^ Action for building a package's library and executables. If
+      -- 'taskAllInOne' is 'True', then this will also build benchmarks
+      -- and tests. It is 'False' when then library's benchmarks or
+      -- test-suites have cyclic dependencies.
     | ATBuildFinal
-    | ATFinal
+      -- ^ Task for building the package's benchmarks and test-suites.
+      -- Requires that the library was already built.
+    | ATRunTests
+      -- ^ Task for running the package's test-suites.
+    | ATRunBenchmarks
+      -- ^ Task for running the package's benchmarks.
     deriving (Show, Eq, Ord)
 data ActionId = ActionId !PackageIdentifier !ActionType
     deriving (Show, Eq, Ord)
 data Action = Action
-    { actionId   :: !ActionId
+    { actionId :: !ActionId
     , actionDeps :: !(Set ActionId)
-    , actionDo   :: !(ActionContext -> IO ())
+    , actionDo :: !(ActionContext -> IO ())
+    , actionConcurrency :: !Concurrency
     }
 
+data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed
+    deriving (Eq)
+
 data ActionContext = ActionContext
     { acRemaining :: !(Set ActionId)
     -- ^ Does not include the current action
     , acDownstream :: [Action]
     -- ^ Actions which depend on the current action
+    , acConcurrency :: !Concurrency
+    -- ^ Whether this action may be run concurrently with others
     }
 
 data ExecuteState = ExecuteState
     { esActions    :: TVar [Action]
     , esExceptions :: TVar [SomeException]
     , esInAction   :: TVar (Set ActionId)
     , esCompleted  :: TVar Int
-    , esFinalLock  :: Maybe (TMVar ())
     , esKeepGoing  :: Bool
     }
 
@@ -56,26 +72,34 @@ instance Show ExecuteException where
 
 runActions :: Int -- ^ threads
            -> Bool -- ^ keep going after one task has failed
-           -> Bool -- ^ run final actions concurrently?
            -> [Action]
            -> (TVar Int -> IO ()) -- ^ progress updated
            -> IO [SomeException]
-runActions threads keepGoing concurrentFinal actions0 withProgress = do
+runActions threads keepGoing actions0 withProgress = do
     es <- ExecuteState
-        <$> newTVarIO actions0
+        <$> newTVarIO (sortActions actions0)
         <*> newTVarIO []
         <*> newTVarIO Set.empty
         <*> newTVarIO 0
-        <*> (if concurrentFinal
-                then pure Nothing
-                else Just <$> atomically (newTMVar ()))
         <*> pure keepGoing
     _ <- async $ withProgress $ esCompleted es
     if threads <= 1
         then runActions' es
         else replicateConcurrently_ threads $ runActions' es
     readTVarIO $ esExceptions es
 
+-- | Sort actions such that those that can't be run concurrently are at
+-- the end.
+sortActions :: [Action] -> [Action]
+sortActions = sortBy (compareConcurrency `on` actionConcurrency)
+  where
+    -- NOTE: Could derive Ord. However, I like to make this explicit so
+    -- that changes to the datatype must consider how it's affecting
+    -- this.
+    compareConcurrency ConcurrencyAllowed ConcurrencyDisallowed = LT
+    compareConcurrency ConcurrencyDisallowed ConcurrencyAllowed = GT
+    compareConcurrency _ _ = EQ
+
 runActions' :: ExecuteState -> IO ()
 runActions' ExecuteState {..} =
     loop
@@ -101,16 +125,12 @@ runActions' ExecuteState {..} =
                         return $ return ()
                     else retry
             (xs, action:ys) -> do
-                unlock <-
-                    case (actionId action, esFinalLock) of
-                        (ActionId _ ATFinal, Just lock) -> do
-                            takeTMVar lock
-                            return $ putTMVar lock ()
-                        _ -> return $ return ()
-
-                let as' = xs ++ ys
                 inAction <- readTVar esInAction
-                let remaining = Set.union
+                case actionConcurrency action of
+                  ConcurrencyAllowed -> return ()
+                  ConcurrencyDisallowed -> unless (Set.null inAction) retry
+                let as' = xs ++ ys
+                    remaining = Set.union
                         (Set.fromList $ map actionId as')
                         inAction
                 writeTVar esActions as'
@@ -119,9 +139,9 @@ runActions' ExecuteState {..} =
                     eres <- try $ restore $ actionDo action ActionContext
                         { acRemaining = remaining
                         , acDownstream = downstreamActions (actionId action) as'
+                        , acConcurrency = actionConcurrency action
                         }
                     atomically $ do
-                        unlock
                         modifyTVar esInAction (Set.delete $ actionId action)
                         modifyTVar esCompleted (+1)
                         case eres of

src/Stack/Build/Execute.hs

@@ -616,25 +616,22 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
 
     run <- askRunInIO
 
-    let actions = concatMap (toActions installedMap' run ee) $ Map.elems $ Map.mergeWithKey
+    -- If running tests concurrently with eachother, then create an MVar
+    -- which is empty while each test is being run.
+    concurrentTests <- view $ configL.to configConcurrentTests
+    mtestLock <- if concurrentTests then return Nothing else Just <$> liftIO (newMVar ())
+
+    let actions = concatMap (toActions installedMap' mtestLock run ee) $ Map.elems $ Map.mergeWithKey
             (\_ b f -> Just (Just b, Just f))
             (fmap (\b -> (Just b, Nothing)))
             (fmap (\f -> (Nothing, Just f)))
             (planTasks plan)
             (planFinals plan)
     threads <- view $ configL.to configJobs
-    concurrentTests <- view $ configL.to configConcurrentTests
     let keepGoing =
-            fromMaybe (boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts) (boptsKeepGoing eeBuildOpts)
-        concurrentFinal =
-            -- TODO it probably makes more sense to use a lock for test suites
-            -- and just have the execution blocked. Turning off all concurrency
-            -- on finals based on the --test option doesn't fit in well.
-            if boptsTests eeBuildOpts
-                then concurrentTests
-                else True
+            fromMaybe (not (M.null (planFinals plan))) (boptsKeepGoing eeBuildOpts)
     terminal <- view terminalL
-    errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
+    errs <- liftIO $ runActions threads keepGoing actions $ \doneVar -> do
         let total = length actions
             loop prev
                 | prev == total =
@@ -677,11 +674,12 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
 
 toActions :: HasEnvConfig env
           => InstalledMap
+          -> Maybe (MVar ())
           -> (RIO env () -> IO ())
           -> ExecuteEnv
           -> (Maybe Task, Maybe Task) -- build and final
           -> [Action]
-toActions installedMap runInBase ee (mbuild, mfinal) =
+toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
     abuild ++ afinal
   where
     abuild =
@@ -693,40 +691,58 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
                     , actionDeps =
                         Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)
                     , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False
+                    , actionConcurrency = ConcurrencyAllowed
                     }
                 ]
     afinal =
         case mfinal of
             Nothing -> []
             Just task@Task {..} ->
-                (if taskAllInOne then [] else
-                    [Action
+                (if taskAllInOne then id else (:)
+                    Action
                         { actionId = ActionId taskProvides ATBuildFinal
                         , actionDeps = addBuild
                             (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
                         , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True
-                        }]) ++
-                [ Action
-                    { actionId = ActionId taskProvides ATFinal
-                    , actionDeps =
-                        if taskAllInOne
-                            then addBuild mempty
-                            else Set.singleton (ActionId taskProvides ATBuildFinal)
-                    , actionDo = \ac -> runInBase $ do
-                        let comps = taskComponents task
-                            tests = testComponents comps
-                            benches = benchComponents comps
-                        unless (Set.null tests) $ do
+                        , actionConcurrency = ConcurrencyAllowed
+                        }) $
+                -- These are the "final" actions - running tests and benchmarks.
+                (if Set.null tests then id else (:)
+                    Action
+                        { actionId = ActionId taskProvides ATRunTests
+                        , actionDeps = finalDeps
+                        , actionDo = \ac -> withLock mtestLock $ runInBase $ do
                             singleTest runInBase topts (Set.toList tests) ac ee task installedMap
-                        unless (Set.null benches) $ do
+                        -- Always allow tests tasks to run concurrently with
+                        -- other tasks, particularly build tasks. Note that
+                        -- 'mtestLock' can optionally make it so that only
+                        -- one test is run at a time.
+                        , actionConcurrency = ConcurrencyAllowed
+                        }) $
+                (if Set.null benches then id else (:)
+                    Action
+                        { actionId = ActionId taskProvides ATRunBenchmarks
+                        , actionDeps = finalDeps
+                        , actionDo = \ac -> runInBase $ do
                             singleBench runInBase beopts (Set.toList benches) ac ee task installedMap
-                    }
-                ]
+                        -- Never run benchmarks concurrently with any other task, see #3663
+                        , actionConcurrency = ConcurrencyDisallowed
+                        })
+                []
               where
+                comps = taskComponents task
+                tests = testComponents comps
+                benches = benchComponents comps
+                finalDeps =
+                    if taskAllInOne
+                        then addBuild mempty
+                        else Set.singleton (ActionId taskProvides ATBuildFinal)
                 addBuild =
                     case mbuild of
                         Nothing -> id
                         Just _ -> Set.insert $ ActionId taskProvides ATBuild
+    withLock Nothing f = f
+    withLock (Just lock) f = withMVar lock $ \() -> f
     bopts = eeBuildOpts ee
     topts = boptsTestOpts bopts
     beopts = boptsBenchmarkOpts bopts
@@ -907,9 +923,19 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
             TTFiles lp _ -> lpWanted lp
             TTIndex{} -> False
 
-    console = wanted
-           && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)
-           && eeTotalWanted == 1
+    -- Output to the console if this is the last task, and the user
+    -- asked to build it specifically. When the action is a
+    -- 'ConcurrencyDisallowed' action (benchmarks), then we can also be
+    -- sure to have excluse access to the console, so output is also
+    -- sent to the console in this case.
+    --
+    -- See the discussion on #426 for thoughts on sending output to the
+    -- console from concurrent tasks.
+    console =
+      (wanted &&
+       all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) &&
+       eeTotalWanted == 1
+      ) || (acConcurrency == ConcurrencyDisallowed)
 
     withPackage inner =
         case taskType of

src/Stack/SDist.hs

@@ -17,7 +17,7 @@ import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
 import qualified Codec.Compression.GZip as GZip
 import           Control.Applicative
-import           Control.Concurrent.Execute (ActionContext(..))
+import           Control.Concurrent.Execute (ActionContext(..), Concurrency(..))
 import           Stack.Prelude
 import           Control.Monad.Reader.Class (local)
 import qualified Data.ByteString as S
@@ -335,7 +335,7 @@ getSDistFileList lp =
                 return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
   where
     package = lpPackage lp
-    ac = ActionContext Set.empty []
+    ac = ActionContext Set.empty [] ConcurrencyAllowed
     task = Task
         { taskProvides = PackageIdentifier (packageName package) (packageVersion package)
         , taskType = TTFiles lp Local