diff --git a/ChangeLog.md b/ChangeLog.md index be8d9d32dc..804a13256d 100644 --- a/ChangeLog.md +++ b/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: 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