diff --git a/ChangeLog.md b/ChangeLog.md index dc1eb30d0f..443c8243fd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -14,6 +14,7 @@ * Rename `stack docker exec` to `stack exec --plain` * Add the `--skip-msys` flag [#377](https://github.com/commercialhaskell/stack/issues/377) * `--keep-going`, turned on by default for tests and benchmarks [#478](https://github.com/commercialhaskell/stack/issues/478) +* `concurrent-tests: BOOL` [#492](https://github.com/commercialhaskell/stack/issues/492) ## 0.1.1.0 diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index f2d8e42d60..31f912f483 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -45,6 +45,7 @@ data ExecuteState = ExecuteState , esExceptions :: TVar [SomeException] , esInAction :: TVar (Set ActionId) , esCompleted :: TVar Int + , esFinalLock :: Maybe (TMVar ()) , esKeepGoing :: Bool } @@ -59,15 +60,19 @@ 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 actions0 withProgress = do +runActions threads keepGoing concurrentFinal actions0 withProgress = do es <- ExecuteState <$> newTVarIO 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 @@ -100,6 +105,13 @@ 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 @@ -112,6 +124,7 @@ runActions' ExecuteState {..} = { acRemaining = remaining } 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 3ff099ea03..78f0ddc1b3 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -333,6 +333,7 @@ executePlan' plan ee@ExecuteEnv {..} = do (planTasks plan) (planFinals plan) threads <- asks $ configJobs . getConfig + concurrentTests <- asks $ configConcurrentTests . getConfig let keepGoing = case boptsKeepGoing eeBuildOpts of Just kg -> kg @@ -340,8 +341,12 @@ executePlan' plan ee@ExecuteEnv {..} = do case boptsFinalAction eeBuildOpts of DoNothing -> False _ -> True + concurrentFinal = + case boptsFinalAction eeBuildOpts of + DoTests _ -> concurrentTests + _ -> True terminal <- asks getTerminal - errs <- liftIO $ runActions threads keepGoing actions $ \doneVar -> do + errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do let total = length actions loop prev | prev == total = diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f59c201cc7..da6395c855 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -154,6 +154,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = case configMonoidJobs of Nothing -> liftIO getNumCapabilities Just i -> return i + let configConcurrentTests = fromMaybe True configMonoidConcurrentTests return Config {..} diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 7b338751df..4053b33cc2 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -101,6 +101,8 @@ data Config = -- ^ --extra-lib-dirs arguments ,configConfigMonoid :: !ConfigMonoid -- ^ @ConfigMonoid@ used to generate this + ,configConcurrentTests :: !Bool + -- ^ Run test suites concurrently } -- | Information on a single package index @@ -432,6 +434,8 @@ data ConfigMonoid = -- ^ See: 'configExtraIncludeDirs' ,configMonoidExtraLibDirs :: !(Set Text) -- ^ See: 'configExtraLibDirs' + ,configMonoidConcurrentTests :: !(Maybe Bool) + -- ^ See: 'configConcurrentTests' } deriving Show @@ -452,6 +456,7 @@ instance Monoid ConfigMonoid where , configMonoidJobs = Nothing , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty + , configMonoidConcurrentTests = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -470,6 +475,7 @@ instance Monoid ConfigMonoid where , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) + , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r } instance FromJSON ConfigMonoid where @@ -493,6 +499,7 @@ instance FromJSON ConfigMonoid where configMonoidJobs <- obj .:? "jobs" configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty + configMonoidConcurrentTests <- obj .:? "concurrent-tests" return ConfigMonoid {..} -- | Newtype for non-orphan FromJSON instance.