Skip to content

Commit

Permalink
Never run benchmarks concurrently #3663
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
@mgsloan
mgsloan committed Dec 17, 2017
1 parent fbae9f3 commit 28e911c
Show file tree
Hide file tree
Showing 4 changed files with 100 additions and 54 deletions.
3 changes: 3 additions & 0 deletions ChangeLog.md
View file
Expand Up @@ -18,6 +18,9 @@ Bug fixes:
* Run the Cabal file checking in the `sdist` command more reliably by
allowing the Cabal library to flatten the
`GenericPackageDescription` itself.
* Benchmarks used to be run concurrently with other benchmarks
and build steps. This is now fixed. See
[#3663](https://github.com/commercialhaskell/stack/issues/3663).

## v1.6.1

Expand Down
57 changes: 37 additions & 20 deletions src/Control/Concurrent/Execute.hs
View file
Expand Up @@ -8,40 +8,56 @@ module Control.Concurrent.Execute
, ActionId (..)
, ActionContext (..)
, Action (..)
, Concurrency(..)
, runActions
) where

import Control.Concurrent.STM
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
}

Expand All @@ -56,26 +72,31 @@ 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
compareConcurrency ConcurrencyAllowed ConcurrencyDisallowed = LT
compareConcurrency ConcurrencyDisallowed ConcurrencyAllowed = GT
compareConcurrency _ _ = EQ

runActions' :: ExecuteState -> IO ()
runActions' ExecuteState {..} =
loop
Expand All @@ -101,16 +122,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'
Expand All @@ -119,9 +136,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
Expand Down
90 changes: 58 additions & 32 deletions src/Stack/Build/Execute.hs
View file
Expand Up @@ -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 =
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions src/Stack/SDist.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 28e911c

Please sign in to comment.