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