{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Concurrent.Execute
( ActionType (..)
, ActionId (..)
, ActionContext (..)
, Action (..)
, Concurrency(..)
, runActions
) where
import Control.Concurrent.STM (retry)
import Stack.Prelude
import Data.List (sortBy)
import qualified Data.Set as Set
data ActionType
= ATBuild
| ATBuildFinal
| ATRunTests
| ATRunBenchmarks
deriving (Int -> ActionType -> ShowS
[ActionType] -> ShowS
ActionType -> String
(Int -> ActionType -> ShowS)
-> (ActionType -> String)
-> ([ActionType] -> ShowS)
-> Show ActionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionType] -> ShowS
$cshowList :: [ActionType] -> ShowS
show :: ActionType -> String
$cshow :: ActionType -> String
showsPrec :: Int -> ActionType -> ShowS
$cshowsPrec :: Int -> ActionType -> ShowS
Show, ActionType -> ActionType -> Bool
(ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool) -> Eq ActionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionType -> ActionType -> Bool
$c/= :: ActionType -> ActionType -> Bool
== :: ActionType -> ActionType -> Bool
$c== :: ActionType -> ActionType -> Bool
Eq, Eq ActionType
Eq ActionType
-> (ActionType -> ActionType -> Ordering)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> ActionType)
-> (ActionType -> ActionType -> ActionType)
-> Ord ActionType
ActionType -> ActionType -> Bool
ActionType -> ActionType -> Ordering
ActionType -> ActionType -> ActionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ActionType -> ActionType -> ActionType
$cmin :: ActionType -> ActionType -> ActionType
max :: ActionType -> ActionType -> ActionType
$cmax :: ActionType -> ActionType -> ActionType
>= :: ActionType -> ActionType -> Bool
$c>= :: ActionType -> ActionType -> Bool
> :: ActionType -> ActionType -> Bool
$c> :: ActionType -> ActionType -> Bool
<= :: ActionType -> ActionType -> Bool
$c<= :: ActionType -> ActionType -> Bool
< :: ActionType -> ActionType -> Bool
$c< :: ActionType -> ActionType -> Bool
compare :: ActionType -> ActionType -> Ordering
$ccompare :: ActionType -> ActionType -> Ordering
$cp1Ord :: Eq ActionType
Ord)
data ActionId = ActionId !PackageIdentifier !ActionType
deriving (Int -> ActionId -> ShowS
[ActionId] -> ShowS
ActionId -> String
(Int -> ActionId -> ShowS)
-> (ActionId -> String) -> ([ActionId] -> ShowS) -> Show ActionId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionId] -> ShowS
$cshowList :: [ActionId] -> ShowS
show :: ActionId -> String
$cshow :: ActionId -> String
showsPrec :: Int -> ActionId -> ShowS
$cshowsPrec :: Int -> ActionId -> ShowS
Show, ActionId -> ActionId -> Bool
(ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool) -> Eq ActionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionId -> ActionId -> Bool
$c/= :: ActionId -> ActionId -> Bool
== :: ActionId -> ActionId -> Bool
$c== :: ActionId -> ActionId -> Bool
Eq, Eq ActionId
Eq ActionId
-> (ActionId -> ActionId -> Ordering)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> ActionId)
-> (ActionId -> ActionId -> ActionId)
-> Ord ActionId
ActionId -> ActionId -> Bool
ActionId -> ActionId -> Ordering
ActionId -> ActionId -> ActionId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ActionId -> ActionId -> ActionId
$cmin :: ActionId -> ActionId -> ActionId
max :: ActionId -> ActionId -> ActionId
$cmax :: ActionId -> ActionId -> ActionId
>= :: ActionId -> ActionId -> Bool
$c>= :: ActionId -> ActionId -> Bool
> :: ActionId -> ActionId -> Bool
$c> :: ActionId -> ActionId -> Bool
<= :: ActionId -> ActionId -> Bool
$c<= :: ActionId -> ActionId -> Bool
< :: ActionId -> ActionId -> Bool
$c< :: ActionId -> ActionId -> Bool
compare :: ActionId -> ActionId -> Ordering
$ccompare :: ActionId -> ActionId -> Ordering
$cp1Ord :: Eq ActionId
Ord)
data Action = Action
{ Action -> ActionId
actionId :: !ActionId
, Action -> Set ActionId
actionDeps :: !(Set ActionId)
, Action -> ActionContext -> IO ()
actionDo :: !(ActionContext -> IO ())
, Action -> Concurrency
actionConcurrency :: !Concurrency
}
data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed
deriving (Concurrency -> Concurrency -> Bool
(Concurrency -> Concurrency -> Bool)
-> (Concurrency -> Concurrency -> Bool) -> Eq Concurrency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Concurrency -> Concurrency -> Bool
$c/= :: Concurrency -> Concurrency -> Bool
== :: Concurrency -> Concurrency -> Bool
$c== :: Concurrency -> Concurrency -> Bool
Eq)
data ActionContext = ActionContext
{ ActionContext -> Set ActionId
acRemaining :: !(Set ActionId)
, ActionContext -> [Action]
acDownstream :: [Action]
, ActionContext -> Concurrency
acConcurrency :: !Concurrency
}
data ExecuteState = ExecuteState
{ ExecuteState -> TVar [Action]
esActions :: TVar [Action]
, ExecuteState -> TVar [SomeException]
esExceptions :: TVar [SomeException]
, ExecuteState -> TVar (Set ActionId)
esInAction :: TVar (Set ActionId)
, ExecuteState -> TVar Int
esCompleted :: TVar Int
, ExecuteState -> Bool
esKeepGoing :: Bool
}
data ExecuteException
= InconsistentDependencies
deriving Typeable
instance Exception ExecuteException
instance Show ExecuteException where
show :: ExecuteException -> String
show ExecuteException
InconsistentDependencies =
String
"Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team."
runActions :: Int
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> IO [SomeException]
runActions :: Int
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> IO [SomeException]
runActions Int
threads Bool
keepGoing [Action]
actions0 TVar Int -> TVar (Set ActionId) -> IO ()
withProgress = do
ExecuteState
es <- TVar [Action]
-> TVar [SomeException]
-> TVar (Set ActionId)
-> TVar Int
-> Bool
-> ExecuteState
ExecuteState
(TVar [Action]
-> TVar [SomeException]
-> TVar (Set ActionId)
-> TVar Int
-> Bool
-> ExecuteState)
-> IO (TVar [Action])
-> IO
(TVar [SomeException]
-> TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action] -> IO (TVar [Action])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([Action] -> [Action]
sortActions [Action]
actions0)
IO
(TVar [SomeException]
-> TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
-> IO (TVar [SomeException])
-> IO (TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeException] -> IO (TVar [SomeException])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
IO (TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
-> IO (TVar (Set ActionId))
-> IO (TVar Int -> Bool -> ExecuteState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set ActionId -> IO (TVar (Set ActionId))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set ActionId
forall a. Set a
Set.empty
IO (TVar Int -> Bool -> ExecuteState)
-> IO (TVar Int) -> IO (Bool -> ExecuteState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
IO (Bool -> ExecuteState) -> IO Bool -> IO ExecuteState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
keepGoing
Async ()
_ <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ TVar Int -> TVar (Set ActionId) -> IO ()
withProgress (ExecuteState -> TVar Int
esCompleted ExecuteState
es) (ExecuteState -> TVar (Set ActionId)
esInAction ExecuteState
es)
if Int
threads Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
then ExecuteState -> IO ()
runActions' ExecuteState
es
else Int -> IO () -> IO ()
forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
threads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecuteState -> IO ()
runActions' ExecuteState
es
TVar [SomeException] -> IO [SomeException]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar [SomeException] -> IO [SomeException])
-> TVar [SomeException] -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$ ExecuteState -> TVar [SomeException]
esExceptions ExecuteState
es
sortActions :: [Action] -> [Action]
sortActions :: [Action] -> [Action]
sortActions = (Action -> Action -> Ordering) -> [Action] -> [Action]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Concurrency -> Concurrency -> Ordering
compareConcurrency (Concurrency -> Concurrency -> Ordering)
-> (Action -> Concurrency) -> Action -> Action -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Action -> Concurrency
actionConcurrency)
where
compareConcurrency :: Concurrency -> Concurrency -> Ordering
compareConcurrency Concurrency
ConcurrencyAllowed Concurrency
ConcurrencyDisallowed = Ordering
LT
compareConcurrency Concurrency
ConcurrencyDisallowed Concurrency
ConcurrencyAllowed = Ordering
GT
compareConcurrency Concurrency
_ Concurrency
_ = Ordering
EQ
runActions' :: ExecuteState -> IO ()
runActions' :: ExecuteState -> IO ()
runActions' ExecuteState {Bool
TVar Int
TVar [SomeException]
TVar [Action]
TVar (Set ActionId)
esKeepGoing :: Bool
esCompleted :: TVar Int
esInAction :: TVar (Set ActionId)
esExceptions :: TVar [SomeException]
esActions :: TVar [Action]
esKeepGoing :: ExecuteState -> Bool
esCompleted :: ExecuteState -> TVar Int
esInAction :: ExecuteState -> TVar (Set ActionId)
esExceptions :: ExecuteState -> TVar [SomeException]
esActions :: ExecuteState -> TVar [Action]
..} =
IO ()
loop
where
breakOnErrs :: STM (m ()) -> STM (m ())
breakOnErrs STM (m ())
inner = do
[SomeException]
errs <- TVar [SomeException] -> STM [SomeException]
forall a. TVar a -> STM a
readTVar TVar [SomeException]
esExceptions
if [SomeException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs Bool -> Bool -> Bool
|| Bool
esKeepGoing
then STM (m ())
inner
else m () -> STM (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
withActions :: ([Action] -> STM (m ())) -> STM (m ())
withActions [Action] -> STM (m ())
inner = do
[Action]
as <- TVar [Action] -> STM [Action]
forall a. TVar a -> STM a
readTVar TVar [Action]
esActions
if [Action] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
as
then m () -> STM (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else [Action] -> STM (m ())
inner [Action]
as
loop :: IO ()
loop = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> STM (IO ())
forall (m :: * -> *). Monad m => STM (m ()) -> STM (m ())
breakOnErrs (STM (IO ()) -> STM (IO ())) -> STM (IO ()) -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ ([Action] -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *).
Monad m =>
([Action] -> STM (m ())) -> STM (m ())
withActions (([Action] -> STM (IO ())) -> STM (IO ()))
-> ([Action] -> STM (IO ())) -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ \[Action]
as ->
case (Action -> Bool) -> [Action] -> ([Action], [Action])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Set ActionId -> Bool
forall a. Set a -> Bool
Set.null (Set ActionId -> Bool)
-> (Action -> Set ActionId) -> Action -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> Set ActionId
actionDeps) [Action]
as of
([Action]
_, []) -> do
Set ActionId
inAction <- TVar (Set ActionId) -> STM (Set ActionId)
forall a. TVar a -> STM a
readTVar TVar (Set ActionId)
esInAction
if Set ActionId -> Bool
forall a. Set a -> Bool
Set.null Set ActionId
inAction
then do
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
esKeepGoing (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
TVar [SomeException]
-> ([SomeException] -> [SomeException]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions (ExecuteException -> SomeException
forall e. Exception e => e -> SomeException
toException ExecuteException
InconsistentDependenciesSomeException -> [SomeException] -> [SomeException]
forall a. a -> [a] -> [a]
:)
IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else STM (IO ())
forall a. STM a
retry
([Action]
xs, Action
action:[Action]
ys) -> do
Set ActionId
inAction <- TVar (Set ActionId) -> STM (Set ActionId)
forall a. TVar a -> STM a
readTVar TVar (Set ActionId)
esInAction
case Action -> Concurrency
actionConcurrency Action
action of
Concurrency
ConcurrencyAllowed -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Concurrency
ConcurrencyDisallowed -> Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set ActionId -> Bool
forall a. Set a -> Bool
Set.null Set ActionId
inAction) STM ()
forall a. STM a
retry
let as' :: [Action]
as' = [Action]
xs [Action] -> [Action] -> [Action]
forall a. [a] -> [a] -> [a]
++ [Action]
ys
remaining :: Set ActionId
remaining = Set ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => Set a -> Set a -> Set a
Set.union
([ActionId] -> Set ActionId
forall a. Ord a => [a] -> Set a
Set.fromList ([ActionId] -> Set ActionId) -> [ActionId] -> Set ActionId
forall a b. (a -> b) -> a -> b
$ (Action -> ActionId) -> [Action] -> [ActionId]
forall a b. (a -> b) -> [a] -> [b]
map Action -> ActionId
actionId [Action]
as')
Set ActionId
inAction
TVar [Action] -> [Action] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Action]
esActions [Action]
as'
TVar (Set ActionId) -> (Set ActionId -> Set ActionId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.insert (ActionId -> Set ActionId -> Set ActionId)
-> ActionId -> Set ActionId -> Set ActionId
forall a b. (a -> b) -> a -> b
$ Action -> ActionId
actionId Action
action)
IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Either SomeException ()
eres <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Action -> ActionContext -> IO ()
actionDo Action
action ActionContext :: Set ActionId -> [Action] -> Concurrency -> ActionContext
ActionContext
{ acRemaining :: Set ActionId
acRemaining = Set ActionId
remaining
, acDownstream :: [Action]
acDownstream = ActionId -> [Action] -> [Action]
downstreamActions (Action -> ActionId
actionId Action
action) [Action]
as'
, acConcurrency :: Concurrency
acConcurrency = Action -> Concurrency
actionConcurrency Action
action
}
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TVar (Set ActionId) -> (Set ActionId -> Set ActionId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.delete (ActionId -> Set ActionId -> Set ActionId)
-> ActionId -> Set ActionId -> Set ActionId
forall a b. (a -> b) -> a -> b
$ Action -> ActionId
actionId Action
action)
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
esCompleted (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
case Either SomeException ()
eres of
Left SomeException
err -> TVar [SomeException]
-> ([SomeException] -> [SomeException]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions (SomeException
errSomeException -> [SomeException] -> [SomeException]
forall a. a -> [a] -> [a]
:)
Right () ->
let dropDep :: Action -> Action
dropDep Action
a = Action
a { actionDeps :: Set ActionId
actionDeps = ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.delete (Action -> ActionId
actionId Action
action) (Set ActionId -> Set ActionId) -> Set ActionId -> Set ActionId
forall a b. (a -> b) -> a -> b
$ Action -> Set ActionId
actionDeps Action
a }
in TVar [Action] -> ([Action] -> [Action]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [Action]
esActions (([Action] -> [Action]) -> STM ())
-> ([Action] -> [Action]) -> STM ()
forall a b. (a -> b) -> a -> b
$ (Action -> Action) -> [Action] -> [Action]
forall a b. (a -> b) -> [a] -> [b]
map Action -> Action
dropDep
IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
loop
downstreamActions :: ActionId -> [Action] -> [Action]
downstreamActions :: ActionId -> [Action] -> [Action]
downstreamActions ActionId
aid = (Action -> Bool) -> [Action] -> [Action]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Action
a -> ActionId
aid ActionId -> Set ActionId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Action -> Set ActionId
actionDeps Action
a)