speed up enteringStage in non-concurrent mode

Avoid a STM transaction.

Also got rid of UnallocatedWorkerPool.

Annex.hs

@@ -142,7 +142,7 @@ data AnnexState = AnnexState
 	, tempurls :: M.Map Key URLString
 	, existinghooks :: M.Map Git.Hook.Hook Bool
 	, desktopnotify :: DesktopNotify
-	, workers :: TMVar (WorkerPool AnnexState)
+	, workers :: Maybe (TMVar (WorkerPool AnnexState))
 	, activekeys :: TVar (M.Map Key ThreadId)
 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
 	, keysdbhandle :: Maybe Keys.DbHandle
@@ -155,7 +155,6 @@ newState :: GitConfig -> Git.Repo -> IO AnnexState
 newState c r = do
 	emptyactiveremotes <- newMVar M.empty
 	emptyactivekeys <- newTVarIO M.empty
-	emptyworkerpool <- newTMVarIO UnallocatedWorkerPool
 	o <- newMessageState
 	sc <- newTMVarIO False
 	return $ AnnexState
@@ -200,7 +199,7 @@ newState c r = do
 		, tempurls = M.empty
 		, existinghooks = M.empty
 		, desktopnotify = mempty
-		, workers = emptyworkerpool
+		, workers = Nothing
 		, activekeys = emptyactivekeys
 		, activeremotes = emptyactiveremotes
 		, keysdbhandle = Nothing

Annex/Concurrent.hs

@@ -91,12 +91,13 @@ stopCoProcesses = do
  - of it and the current thread are swapped.
  -}
 enteringStage :: WorkerStage -> Annex a -> Annex a
-enteringStage newstage a = do
+enteringStage newstage a = Annex.getState Annex.workers >>= \case
-	mytid <- liftIO myThreadId
+	Nothing -> a
-	tv <- Annex.getState Annex.workers
+	Just tv -> do
-	let set = changeStageTo mytid tv newstage
+		mytid <- liftIO myThreadId
-	let restore = maybe noop (void . changeStageTo mytid tv)
+		let set = changeStageTo mytid tv newstage
-	bracket set restore (const a)
+		let restore = maybe noop (void . changeStageTo mytid tv)
+		bracket set restore (const a)
 
 changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> WorkerStage -> Annex (Maybe WorkerStage)
 changeStageTo mytid tv newstage = liftIO $ atomically $ do
@@ -124,16 +125,12 @@ changeStageTo mytid tv newstage = liftIO $ atomically $ do
 --
 -- If the worker pool is not already allocated, returns Nothing.
 waitInitialWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage))
-waitInitialWorkerSlot tv =
+waitInitialWorkerSlot tv = do
-	takeTMVar tv >>= \case
+	WorkerPool usedstages l <- takeTMVar tv
-		UnallocatedWorkerPool -> do
+	let stage = initialStage usedstages
-			putTMVar tv UnallocatedWorkerPool 
+	(st, pool') <- waitWorkerSlot usedstages stage l
-			return Nothing
+	putTMVar tv pool'
-		WorkerPool usedstages l -> do
+	return $ Just (st, stage)
-			let stage = initialStage usedstages
-			(st, pool') <- waitWorkerSlot usedstages stage l
-			putTMVar tv pool'
-			return $ Just (st, stage)
 
 -- | Waits until there's an idle worker for the specified stage, and returns
 -- its state and a WorkerPool containing all the other workers.

CmdLine/Action.hs

@@ -60,10 +60,11 @@ commandAction start = Annex.getState Annex.concurrency >>= \case
 	ConcurrentPerCpu -> runconcurrent
   where
 	runnonconcurrent = void $ includeCommandAction start
-	runconcurrent = do
+	runconcurrent = Annex.getState Annex.workers >>= \case
-		tv <- Annex.getState Annex.workers
+		Nothing -> runnonconcurrent
-		liftIO (atomically (waitInitialWorkerSlot tv)) >>=
+		Just tv -> 
-			maybe runnonconcurrent (runconcurrent' tv)
+			liftIO (atomically (waitInitialWorkerSlot tv)) >>=
+				maybe runnonconcurrent (runconcurrent' tv)
 	runconcurrent' tv (workerst, workerstage) = do
 		aid <- liftIO $ async $ snd <$> Annex.run workerst
 			(concurrentjob workerst)
@@ -124,13 +125,12 @@ commandAction start = Annex.getState Annex.concurrency >>= \case
  - back into the current Annex's state.
  -}
 finishCommandActions :: Annex ()
-finishCommandActions = do
+finishCommandActions = Annex.getState Annex.workers >>= \case
-	tv <- Annex.getState Annex.workers
+	Nothing -> noop
-	pool <- liftIO $ atomically $
+	Just tv -> do
-		swapTMVar tv UnallocatedWorkerPool
+		Annex.changeState $ \s -> s { Annex.workers = Nothing }
-	case pool of
+		WorkerPool _ l <- liftIO $ atomically $ takeTMVar tv
-		UnallocatedWorkerPool -> noop
+		forM_ (mapMaybe workerAsync l) $ \aid ->
-		WorkerPool _ l -> forM_ (mapMaybe workerAsync l) $ \aid ->
 			liftIO (waitCatch aid) >>= \case
 				Left _ -> noop
 				Right st -> mergeState st
@@ -248,9 +248,9 @@ startConcurrency usedstages a = do
 		-- setConfig.
 		_ <- remoteList
 		st <- dupState
-		tv <- Annex.getState Annex.workers
+		tv <- liftIO $ newTMVarIO $
-		liftIO $ atomically $ putTMVar tv $
 			allocateWorkerPool st (max n 1) usedstages
+		Annex.changeState $ \s -> s { Annex.workers = Just tv }
 
 {- Ensures that only one thread processes a key at a time.
  - Other threads will block until it's done.

Types/WorkerPool.hs

@@ -12,9 +12,7 @@ import Control.Concurrent.Async
 import qualified Data.Set as S
 
 -- | Pool of worker threads. 
-data WorkerPool t
+data WorkerPool t = WorkerPool UsedStages [Worker t]
-	= UnallocatedWorkerPool
-	| WorkerPool UsedStages [Worker t]
 	deriving (Show)
 
 -- | A worker can either be idle or running an Async action.
@@ -95,10 +93,8 @@ allocateWorkerPool t n u = WorkerPool u $ take (n+n) $
 
 addWorkerPool :: Worker t -> WorkerPool t -> WorkerPool t
 addWorkerPool w (WorkerPool u l) = WorkerPool u (w:l)
-addWorkerPool _ UnallocatedWorkerPool = UnallocatedWorkerPool
 
 idleWorkers :: WorkerPool t -> [t]
-idleWorkers UnallocatedWorkerPool = []
 idleWorkers (WorkerPool _ l) = go l
   where
 	go [] = []
@@ -110,7 +106,6 @@ 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 u l) = go [] l
   where
 	go _ [] = Nothing
@@ -119,7 +114,6 @@ removeThreadIdWorkerPool tid (WorkerPool u l) = go [] l
 	go c (v : rest) = go (v:c) rest
 
 deactivateWorker :: WorkerPool t -> Async t -> t -> WorkerPool t
-deactivateWorker UnallocatedWorkerPool _ _ = UnallocatedWorkerPool
 deactivateWorker (WorkerPool u l) aid t = WorkerPool u $ go l
   where
 	go [] = []