1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE RecordWildCards    #-}
4-- Concurrent execution with dependencies. Types currently hard-coded for needs
5-- of stack, but could be generalized easily.
6module Control.Concurrent.Execute
7    ( ActionType (..)
8    , ActionId (..)
9    , ActionContext (..)
10    , Action (..)
11    , Concurrency(..)
12    , runActions
13    ) where
14
15import           Control.Concurrent.STM   (retry)
16import           Stack.Prelude
17import           Data.List (sortBy)
18import qualified Data.Set                 as Set
19
20data ActionType
21    = ATBuild
22      -- ^ Action for building a package's library and executables. If
23      -- 'taskAllInOne' is 'True', then this will also build benchmarks
24      -- and tests. It is 'False' when then library's benchmarks or
25      -- test-suites have cyclic dependencies.
26    | ATBuildFinal
27      -- ^ Task for building the package's benchmarks and test-suites.
28      -- Requires that the library was already built.
29    | ATRunTests
30      -- ^ Task for running the package's test-suites.
31    | ATRunBenchmarks
32      -- ^ Task for running the package's benchmarks.
33    deriving (Show, Eq, Ord)
34data ActionId = ActionId !PackageIdentifier !ActionType
35    deriving (Show, Eq, Ord)
36data Action = Action
37    { actionId :: !ActionId
38    , actionDeps :: !(Set ActionId)
39    , actionDo :: !(ActionContext -> IO ())
40    , actionConcurrency :: !Concurrency
41    }
42
43data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed
44    deriving (Eq)
45
46data ActionContext = ActionContext
47    { acRemaining :: !(Set ActionId)
48    -- ^ Does not include the current action
49    , acDownstream :: [Action]
50    -- ^ Actions which depend on the current action
51    , acConcurrency :: !Concurrency
52    -- ^ Whether this action may be run concurrently with others
53    }
54
55data ExecuteState = ExecuteState
56    { esActions    :: TVar [Action]
57    , esExceptions :: TVar [SomeException]
58    , esInAction   :: TVar (Set ActionId)
59    , esCompleted  :: TVar Int
60    , esKeepGoing  :: Bool
61    }
62
63data ExecuteException
64    = InconsistentDependencies
65    deriving Typeable
66instance Exception ExecuteException
67
68instance Show ExecuteException where
69    show InconsistentDependencies =
70        "Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team."
71
72runActions :: Int -- ^ threads
73           -> Bool -- ^ keep going after one task has failed
74           -> [Action]
75           -> (TVar Int -> TVar (Set ActionId) -> IO ()) -- ^ progress updated
76           -> IO [SomeException]
77runActions threads keepGoing actions0 withProgress = do
78    es <- ExecuteState
79        <$> newTVarIO (sortActions actions0)
80        <*> newTVarIO []
81        <*> newTVarIO Set.empty
82        <*> newTVarIO 0
83        <*> pure keepGoing
84    _ <- async $ withProgress (esCompleted es) (esInAction es)
85    if threads <= 1
86        then runActions' es
87        else replicateConcurrently_ threads $ runActions' es
88    readTVarIO $ esExceptions es
89
90-- | Sort actions such that those that can't be run concurrently are at
91-- the end.
92sortActions :: [Action] -> [Action]
93sortActions = sortBy (compareConcurrency `on` actionConcurrency)
94  where
95    -- NOTE: Could derive Ord. However, I like to make this explicit so
96    -- that changes to the datatype must consider how it's affecting
97    -- this.
98    compareConcurrency ConcurrencyAllowed ConcurrencyDisallowed = LT
99    compareConcurrency ConcurrencyDisallowed ConcurrencyAllowed = GT
100    compareConcurrency _ _ = EQ
101
102runActions' :: ExecuteState -> IO ()
103runActions' ExecuteState {..} =
104    loop
105  where
106    breakOnErrs inner = do
107        errs <- readTVar esExceptions
108        if null errs || esKeepGoing
109            then inner
110            else return $ return ()
111    withActions inner = do
112        as <- readTVar esActions
113        if null as
114            then return $ return ()
115            else inner as
116    loop = join $ atomically $ breakOnErrs $ withActions $ \as ->
117        case break (Set.null . actionDeps) as of
118            (_, []) -> do
119                inAction <- readTVar esInAction
120                if Set.null inAction
121                    then do
122                        unless esKeepGoing $
123                            modifyTVar esExceptions (toException InconsistentDependencies:)
124                        return $ return ()
125                    else retry
126            (xs, action:ys) -> do
127                inAction <- readTVar esInAction
128                case actionConcurrency action of
129                  ConcurrencyAllowed -> return ()
130                  ConcurrencyDisallowed -> unless (Set.null inAction) retry
131                let as' = xs ++ ys
132                    remaining = Set.union
133                        (Set.fromList $ map actionId as')
134                        inAction
135                writeTVar esActions as'
136                modifyTVar esInAction (Set.insert $ actionId action)
137                return $ mask $ \restore -> do
138                    eres <- try $ restore $ actionDo action ActionContext
139                        { acRemaining = remaining
140                        , acDownstream = downstreamActions (actionId action) as'
141                        , acConcurrency = actionConcurrency action
142                        }
143                    atomically $ do
144                        modifyTVar esInAction (Set.delete $ actionId action)
145                        modifyTVar esCompleted (+1)
146                        case eres of
147                            Left err -> modifyTVar esExceptions (err:)
148                            Right () ->
149                                let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }
150                                 in modifyTVar esActions $ map dropDep
151                    restore loop
152
153downstreamActions :: ActionId -> [Action] -> [Action]
154downstreamActions aid = filter (\a -> aid `Set.member` actionDeps a)
155