Skip to content

Commit 4346cfd

Browse files
mgsloanmgsloan
committed
Never run benchmarks concurrently, always output to console commercialhaskell#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.
1 parent 6c8fd9c commit 4346cfd

4 files changed

Lines changed: 105 additions & 56 deletions

File tree

‎ChangeLog.md‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -42,14 +42,17 @@ Bug fixes:
4242
arguments. See [#3658](https://github.com/commercialhaskell/stack/issues/3658).
4343
In particular, this makes it possible to pass `-- +RTS ... -RTS` to specify
4444
RTS arguments used when running the script.
45-
45+
* Benchmarks used to be run concurrently with other benchmarks
46+
and build steps. This is non-ideal because CPU usage of other processes
47+
may interfere with benchmarks. It also prevented benchmark output from
48+
being displayed by default. This is now fixed. See
49+
[#3663](https://github.com/commercialhaskell/stack/issues/3663).
4650

4751
## v1.6.1.1
4852

4953
Hackage-only release with no user facing changes (updated to build with
5054
newer dependency versions).
5155

52-
5356
## v1.6.1
5457

5558
Major changes:

‎src/Control/Concurrent/Execute.hs‎

Lines changed: 40 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -8,40 +8,56 @@ module Control.Concurrent.Execute
88
, ActionId (..)
99
, ActionContext (..)
1010
, Action (..)
11+
, Concurrency(..)
1112
, runActions
1213
) where
1314

1415
import Control.Concurrent.STM (retry)
1516
import Stack.Prelude
17+
import Data.List (sortBy)
1618
import qualified Data.Set as Set
1719
import Stack.Types.PackageIdentifier
1820

1921
data ActionType
2022
= ATBuild
23+
-- ^ Action for building a package's library and executables. If
24+
-- 'taskAllInOne' is 'True', then this will also build benchmarks
25+
-- and tests. It is 'False' when then library's benchmarks or
26+
-- test-suites have cyclic dependencies.
2127
| ATBuildFinal
22-
| ATFinal
28+
-- ^ Task for building the package's benchmarks and test-suites.
29+
-- Requires that the library was already built.
30+
| ATRunTests
31+
-- ^ Task for running the package's test-suites.
32+
| ATRunBenchmarks
33+
-- ^ Task for running the package's benchmarks.
2334
deriving (Show, Eq, Ord)
2435
data ActionId = ActionId !PackageIdentifier !ActionType
2536
deriving (Show, Eq, Ord)
2637
data Action = Action
27-
{ actionId :: !ActionId
38+
{ actionId :: !ActionId
2839
, actionDeps :: !(Set ActionId)
29-
, actionDo :: !(ActionContext -> IO ())
40+
, actionDo :: !(ActionContext -> IO ())
41+
, actionConcurrency :: !Concurrency
3042
}
3143

44+
data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed
45+
deriving (Eq)
46+
3247
data ActionContext = ActionContext
3348
{ acRemaining :: !(Set ActionId)
3449
-- ^ Does not include the current action
3550
, acDownstream :: [Action]
3651
-- ^ Actions which depend on the current action
52+
, acConcurrency :: !Concurrency
53+
-- ^ Whether this action may be run concurrently with others
3754
}
3855

3956
data ExecuteState = ExecuteState
4057
{ esActions :: TVar [Action]
4158
, esExceptions :: TVar [SomeException]
4259
, esInAction :: TVar (Set ActionId)
4360
, esCompleted :: TVar Int
44-
, esFinalLock :: Maybe (TMVar ())
4561
, esKeepGoing :: Bool
4662
}
4763

@@ -56,26 +72,34 @@ instance Show ExecuteException where
5672

5773
runActions :: Int -- ^ threads
5874
-> Bool -- ^ keep going after one task has failed
59-
-> Bool -- ^ run final actions concurrently?
6075
-> [Action]
6176
-> (TVar Int -> IO ()) -- ^ progress updated
6277
-> IO [SomeException]
63-
runActions threads keepGoing concurrentFinal actions0 withProgress = do
78+
runActions threads keepGoing actions0 withProgress = do
6479
es <- ExecuteState
65-
<$> newTVarIO actions0
80+
<$> newTVarIO (sortActions actions0)
6681
<*> newTVarIO []
6782
<*> newTVarIO Set.empty
6883
<*> newTVarIO 0
69-
<*> (if concurrentFinal
70-
then pure Nothing
71-
else Just <$> atomically (newTMVar ()))
7284
<*> pure keepGoing
7385
_ <- async $ withProgress $ esCompleted es
7486
if threads <= 1
7587
then runActions' es
7688
else replicateConcurrently_ threads $ runActions' es
7789
readTVarIO $ esExceptions es
7890

91+
-- | Sort actions such that those that can't be run concurrently are at
92+
-- the end.
93+
sortActions :: [Action] -> [Action]
94+
sortActions = sortBy (compareConcurrency `on` actionConcurrency)
95+
where
96+
-- NOTE: Could derive Ord. However, I like to make this explicit so
97+
-- that changes to the datatype must consider how it's affecting
98+
-- this.
99+
compareConcurrency ConcurrencyAllowed ConcurrencyDisallowed = LT
100+
compareConcurrency ConcurrencyDisallowed ConcurrencyAllowed = GT
101+
compareConcurrency _ _ = EQ
102+
79103
runActions' :: ExecuteState -> IO ()
80104
runActions' ExecuteState {..} =
81105
loop
@@ -101,16 +125,12 @@ runActions' ExecuteState {..} =
101125
return $ return ()
102126
else retry
103127
(xs, action:ys) -> do
104-
unlock <-
105-
case (actionId action, esFinalLock) of
106-
(ActionId _ ATFinal, Just lock) -> do
107-
takeTMVar lock
108-
return $ putTMVar lock ()
109-
_ -> return $ return ()
110-
111-
let as' = xs ++ ys
112128
inAction <- readTVar esInAction
113-
let remaining = Set.union
129+
case actionConcurrency action of
130+
ConcurrencyAllowed -> return ()
131+
ConcurrencyDisallowed -> unless (Set.null inAction) retry
132+
let as' = xs ++ ys
133+
remaining = Set.union
114134
(Set.fromList $ map actionId as')
115135
inAction
116136
writeTVar esActions as'
@@ -119,9 +139,9 @@ runActions' ExecuteState {..} =
119139
eres <- try $ restore $ actionDo action ActionContext
120140
{ acRemaining = remaining
121141
, acDownstream = downstreamActions (actionId action) as'
142+
, acConcurrency = actionConcurrency action
122143
}
123144
atomically $ do
124-
unlock
125145
modifyTVar esInAction (Set.delete $ actionId action)
126146
modifyTVar esCompleted (+1)
127147
case eres of

‎src/Stack/Build/Execute.hs‎

Lines changed: 58 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -616,25 +616,22 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
616616

617617
run <- askRunInIO
618618

619-
let actions = concatMap (toActions installedMap' run ee) $ Map.elems $ Map.mergeWithKey
619+
-- If running tests concurrently with eachother, then create an MVar
620+
-- which is empty while each test is being run.
621+
concurrentTests <- view $ configL.to configConcurrentTests
622+
mtestLock <- if concurrentTests then return Nothing else Just <$> liftIO (newMVar ())
623+
624+
let actions = concatMap (toActions installedMap' mtestLock run ee) $ Map.elems $ Map.mergeWithKey
620625
(\_ b f -> Just (Just b, Just f))
621626
(fmap (\b -> (Just b, Nothing)))
622627
(fmap (\f -> (Nothing, Just f)))
623628
(planTasks plan)
624629
(planFinals plan)
625630
threads <- view $ configL.to configJobs
626-
concurrentTests <- view $ configL.to configConcurrentTests
627631
let keepGoing =
628-
fromMaybe (boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts) (boptsKeepGoing eeBuildOpts)
629-
concurrentFinal =
630-
-- TODO it probably makes more sense to use a lock for test suites
631-
-- and just have the execution blocked. Turning off all concurrency
632-
-- on finals based on the --test option doesn't fit in well.
633-
if boptsTests eeBuildOpts
634-
then concurrentTests
635-
else True
632+
fromMaybe (not (M.null (planFinals plan))) (boptsKeepGoing eeBuildOpts)
636633
terminal <- view terminalL
637-
errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
634+
errs <- liftIO $ runActions threads keepGoing actions $ \doneVar -> do
638635
let total = length actions
639636
loop prev
640637
| prev == total =
@@ -677,11 +674,12 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
677674

678675
toActions :: HasEnvConfig env
679676
=> InstalledMap
677+
-> Maybe (MVar ())
680678
-> (RIO env () -> IO ())
681679
-> ExecuteEnv
682680
-> (Maybe Task, Maybe Task) -- build and final
683681
-> [Action]
684-
toActions installedMap runInBase ee (mbuild, mfinal) =
682+
toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
685683
abuild ++ afinal
686684
where
687685
abuild =
@@ -693,40 +691,58 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
693691
, actionDeps =
694692
Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)
695693
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False
694+
, actionConcurrency = ConcurrencyAllowed
696695
}
697696
]
698697
afinal =
699698
case mfinal of
700699
Nothing -> []
701700
Just task@Task {..} ->
702-
(if taskAllInOne then [] else
703-
[Action
701+
(if taskAllInOne then id else (:)
702+
Action
704703
{ actionId = ActionId taskProvides ATBuildFinal
705704
, actionDeps = addBuild
706705
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
707706
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True
708-
}]) ++
709-
[ Action
710-
{ actionId = ActionId taskProvides ATFinal
711-
, actionDeps =
712-
if taskAllInOne
713-
then addBuild mempty
714-
else Set.singleton (ActionId taskProvides ATBuildFinal)
715-
, actionDo = \ac -> runInBase $ do
716-
let comps = taskComponents task
717-
tests = testComponents comps
718-
benches = benchComponents comps
719-
unless (Set.null tests) $ do
707+
, actionConcurrency = ConcurrencyAllowed
708+
}) $
709+
-- These are the "final" actions - running tests and benchmarks.
710+
(if Set.null tests then id else (:)
711+
Action
712+
{ actionId = ActionId taskProvides ATRunTests
713+
, actionDeps = finalDeps
714+
, actionDo = \ac -> withLock mtestLock $ runInBase $ do
720715
singleTest runInBase topts (Set.toList tests) ac ee task installedMap
721-
unless (Set.null benches) $ do
716+
-- Always allow tests tasks to run concurrently with
717+
-- other tasks, particularly build tasks. Note that
718+
-- 'mtestLock' can optionally make it so that only
719+
-- one test is run at a time.
720+
, actionConcurrency = ConcurrencyAllowed
721+
}) $
722+
(if Set.null benches then id else (:)
723+
Action
724+
{ actionId = ActionId taskProvides ATRunBenchmarks
725+
, actionDeps = finalDeps
726+
, actionDo = \ac -> runInBase $ do
722727
singleBench runInBase beopts (Set.toList benches) ac ee task installedMap
723-
}
724-
]
728+
-- Never run benchmarks concurrently with any other task, see #3663
729+
, actionConcurrency = ConcurrencyDisallowed
730+
})
731+
[]
725732
where
733+
comps = taskComponents task
734+
tests = testComponents comps
735+
benches = benchComponents comps
736+
finalDeps =
737+
if taskAllInOne
738+
then addBuild mempty
739+
else Set.singleton (ActionId taskProvides ATBuildFinal)
726740
addBuild =
727741
case mbuild of
728742
Nothing -> id
729743
Just _ -> Set.insert $ ActionId taskProvides ATBuild
744+
withLock Nothing f = f
745+
withLock (Just lock) f = withMVar lock $ \() -> f
730746
bopts = eeBuildOpts ee
731747
topts = boptsTestOpts bopts
732748
beopts = boptsBenchmarkOpts bopts
@@ -907,9 +923,19 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
907923
TTFiles lp _ -> lpWanted lp
908924
TTIndex{} -> False
909925

910-
console = wanted
911-
&& all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)
912-
&& eeTotalWanted == 1
926+
-- Output to the console if this is the last task, and the user
927+
-- asked to build it specifically. When the action is a
928+
-- 'ConcurrencyDisallowed' action (benchmarks), then we can also be
929+
-- sure to have excluse access to the console, so output is also
930+
-- sent to the console in this case.
931+
--
932+
-- See the discussion on #426 for thoughts on sending output to the
933+
-- console from concurrent tasks.
934+
console =
935+
(wanted &&
936+
all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) &&
937+
eeTotalWanted == 1
938+
) || (acConcurrency == ConcurrencyDisallowed)
913939

914940
withPackage inner =
915941
case taskType of

‎src/Stack/SDist.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import qualified Codec.Archive.Tar as Tar
1717
import qualified Codec.Archive.Tar.Entry as Tar
1818
import qualified Codec.Compression.GZip as GZip
1919
import Control.Applicative
20-
import Control.Concurrent.Execute (ActionContext(..))
20+
import Control.Concurrent.Execute (ActionContext(..), Concurrency(..))
2121
import Stack.Prelude
2222
import Control.Monad.Reader.Class (local)
2323
import qualified Data.ByteString as S
@@ -335,7 +335,7 @@ getSDistFileList lp =
335335
return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
336336
where
337337
package = lpPackage lp
338-
ac = ActionContext Set.empty []
338+
ac = ActionContext Set.empty [] ConcurrencyAllowed
339339
task = Task
340340
{ taskProvides = PackageIdentifier (packageName package) (packageVersion package)
341341
, taskType = TTFiles lp Local

0 commit comments

Comments
 (0)