make WorkerStage an open type

Rather than limiting it to PerformStage and CleanupStage, this opens it
up so any number of stages can be added as needed by commands.

Each concurrent command has a set of stages that it uses, and only
transitions between those can block waiting for a free slot in the
worker pool. Calling enteringStage for some other stage does not block,
and has very little overhead.

Note that while before the Annex state was duplicated on the first call
to commandAction, this now happens earlier, in startConcurrency.
That means that seek stage actions should that use startConcurrency
and then modify Annex state won't modify the state of worker threads
they then start. I audited all of them, and only Command.Seek
did so; prepMerge changes the working directory and so has to come
before startConcurrency.

Also, the remote list is built before duplicating the state, which means
that it gets built earlier now than it used to. This would only have an
effect of making commands that end up not needing to perform any actions
unncessary build the remote list (only when they're run with concurrency
enable), but that's a minor overhead compared to commands seeking
through the work tree and determining they don't need to do anything.
This commit is contained in:
Joey Hess 2019-06-19 12:35:08 -04:00
parent e19408ed9d
commit 53882ab4a7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
17 changed files with 230 additions and 147 deletions

View file

@ -63,16 +63,24 @@ instance MkActionItem StartMessage where
{- A command is defined by specifying these things. -}
data Command = Command
{ cmdcheck :: [CommandCheck] -- check stage
, cmdnocommit :: Bool -- don't commit journalled state changes
, cmdnomessages :: Bool -- don't output normal messages
{ cmdcheck :: [CommandCheck]
-- ^ check stage
, cmdnocommit :: Bool
-- ^ don't commit journalled state changes
, cmdnomessages :: Bool
-- ^ don't output normal messages
, cmdname :: String
, cmdparamdesc :: CmdParamsDesc -- description of params for usage
, cmdparamdesc :: CmdParamsDesc
-- ^ description of params for usage
, cmdsection :: CommandSection
, cmddesc :: String -- description of command for usage
, cmdparser :: CommandParser -- command line parser
, cmdglobaloptions :: [GlobalOption] -- additional global options
, cmdnorepo :: Maybe (Parser (IO ())) -- used when not in a repo
, cmddesc :: String
-- ^ description of command for usage
, cmdparser :: CommandParser
-- ^ command line parser
, cmdglobaloptions :: [GlobalOption]
-- ^ additional global options
, cmdnorepo :: Maybe (Parser (IO ()))
-- ^used when not in a repo
}
{- Command-line parameters, after the command is selected and options

View file

@ -1,4 +1,4 @@
{- Command worker pool.
{- Worker thread pool.
-
- Copyright 2019 Joey Hess <id@joeyh.name>
-
@ -9,11 +9,12 @@ module Types.WorkerPool where
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Set as S
-- | Pool of worker threads.
data WorkerPool t
= UnallocatedWorkerPool
| WorkerPool [Worker t]
| WorkerPool UsedStages [Worker t]
deriving (Show)
-- | A worker can either be idle or running an Async action.
@ -26,9 +27,53 @@ instance Show (Worker t) where
show (IdleWorker _ s) = "IdleWorker " ++ show s
show (ActiveWorker _ s) = "ActiveWorker " ++ show s
-- | These correspond to CommandPerform and CommandCleanup.
data WorkerStage = PerformStage | CleanupStage
deriving (Show, Eq)
data WorkerStage
= PerformStage
-- ^ Running a CommandPerform action.
| CleanupStage
-- ^ Running a CommandCleanup action.
| TransferStage
-- ^ Transferring content to or from a remote.
| VerifyStage
-- ^ Verifying content, eg by calculating a checksum.
deriving (Show, Eq, Ord)
-- | Set of stages that make sense to be used while performing an action,
-- and the stage to use initially.
--
-- Transitions between these stages will block as needed until there's a
-- free Worker in the pool for the new stage.
--
-- Actions that indicate they are in some other stage won't change the
-- stage, and so there will be no blocking before starting them.
data UsedStages = UsedStages
{ initialStage :: WorkerStage
, usedStages :: S.Set WorkerStage
}
deriving (Show)
memberStage :: WorkerStage -> UsedStages -> Bool
memberStage s u = S.member s (usedStages u)
-- | The default is to use only the CommandPerform and CommandCleanup
-- stages. Since cleanup actions often don't contend much with
-- perform actions, this prevents blocking starting the next perform action
-- on finishing the previous cleanup action.
commandStages :: UsedStages
commandStages = UsedStages
{ initialStage = PerformStage
, usedStages = S.fromList [PerformStage, CleanupStage]
}
-- | When a command is transferring content, it can use this instead.
-- Transfers are often bottlenecked on the network another disk than the one
-- containing the repository, while verification bottlenecks on
-- the disk containing the repository or on the CPU.
transferStages :: UsedStages
transferStages = UsedStages
{ initialStage = TransferStage
, usedStages = S.fromList [TransferStage, VerifyStage]
}
workerStage :: Worker t -> WorkerStage
workerStage (IdleWorker _ s) = s
@ -42,19 +87,19 @@ workerAsync (ActiveWorker aid _) = Just aid
-- in it, of each stage.
--
-- The stages are distributed evenly throughout.
allocateWorkerPool :: t -> Int -> WorkerPool t
allocateWorkerPool t n = WorkerPool $ take (n+n) $
allocateWorkerPool :: t -> Int -> UsedStages -> WorkerPool t
allocateWorkerPool t n u = WorkerPool u $ take (n+n) $
map (uncurry IdleWorker) $ zip (repeat t) stages
where
stages = concat $ repeat [PerformStage, CleanupStage]
stages = concat $ repeat $ S.toList $ usedStages u
addWorkerPool :: Worker t -> WorkerPool t -> WorkerPool t
addWorkerPool w (WorkerPool l) = WorkerPool (w:l)
addWorkerPool w UnallocatedWorkerPool = WorkerPool [w]
addWorkerPool w (WorkerPool u l) = WorkerPool u (w:l)
addWorkerPool _ UnallocatedWorkerPool = UnallocatedWorkerPool
idleWorkers :: WorkerPool t -> [t]
idleWorkers UnallocatedWorkerPool = []
idleWorkers (WorkerPool l) = go l
idleWorkers (WorkerPool _ l) = go l
where
go [] = []
go (IdleWorker t _ : rest) = t : go rest
@ -65,17 +110,17 @@ idleWorkers (WorkerPool l) = go l
-- Each Async has its own ThreadId, so this stops once it finds
-- a match.
removeThreadIdWorkerPool :: ThreadId -> WorkerPool t -> Maybe ((Async t, WorkerStage), WorkerPool t)
removeThreadIdWorkerPool _ UnallocatedWorkerPool = Nothing
removeThreadIdWorkerPool tid (WorkerPool l) = go [] l
removeThreadIdWorkerPool _ UnallocatedWorkerPool = Nothing
removeThreadIdWorkerPool tid (WorkerPool u l) = go [] l
where
go _ [] = Nothing
go c (ActiveWorker a stage : rest)
| asyncThreadId a == tid = Just ((a, stage), WorkerPool (c++rest))
| asyncThreadId a == tid = Just ((a, stage), WorkerPool u (c++rest))
go c (v : rest) = go (v:c) rest
deactivateWorker :: WorkerPool t -> Async t -> t -> WorkerPool t
deactivateWorker UnallocatedWorkerPool _ _ = UnallocatedWorkerPool
deactivateWorker (WorkerPool l) aid t = WorkerPool $ go l
deactivateWorker (WorkerPool u l) aid t = WorkerPool u $ go l
where
go [] = []
go (w@(IdleWorker _ _) : rest) = w : go rest