From 4346cfd5ab8febfbe1108f3a41d84cc86f0f1c8f Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Sun, 17 Dec 2017 14:26:33 -0800 Subject: [PATCH] Never run benchmarks concurrently, always output to console #3663 Also generally cleans up code related to parallel execution of tasks. Instead of locking happening among "final tasks" (tests and benchmark running), it's now possible to mark some tasks as work that shouldn't be done in parallel with anything else. This is what makes sense for benchmark running - they shouldn't be run concurrently with either building or running tests. Previously benchmarks and tests shared the same final task. The mechanism to execute one task exclusively is part of Control.Concurrent.Execute. If they were kept in the same task, then if any benchmarks were enabled, then tests would be run without any concurrency. In order to have as much concurrency as possible, they are now split into two different "final" tasks. --- ChangeLog.md | 7 ++- src/Control/Concurrent/Execute.hs | 60 ++++++++++++++------- src/Stack/Build/Execute.hs | 90 ++++++++++++++++++++----------- src/Stack/SDist.hs | 4 +- 4 files changed, 105 insertions(+), 56 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index aeb4c06210..eb6bb57bea 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -42,14 +42,17 @@ Bug fixes: arguments. See [#3658](https://github.com/commercialhaskell/stack/issues/3658). In particular, this makes it possible to pass `-- +RTS ... -RTS` to specify RTS arguments used when running the script. - +* 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.1.1 Hackage-only release with no user facing changes (updated to build with newer dependency versions). - ## v1.6.1 Major changes: diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index cf50418370..2a10662d1a 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -8,32 +8,49 @@ 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 @@ -41,7 +58,6 @@ data ExecuteState = ExecuteState , esExceptions :: TVar [SomeException] , esInAction :: TVar (Set ActionId) , esCompleted :: TVar Int - , esFinalLock :: Maybe (TMVar ()) , esKeepGoing :: Bool } @@ -56,19 +72,15 @@ 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 @@ -76,6 +88,18 @@ runActions threads keepGoing concurrentFinal actions0 withProgress = do 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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index cdceb89633..c67b9d19a9 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 5d2e1ece0e..c92f6ff014 100644 --- a/src/Stack/SDist.hs +++ b/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