convert TMVars that are never left empty into TVars

This is probably more efficient, and it avoids mistakenly leaving them
empty.

Assistant/DaemonStatus.hs

@@ -30,7 +30,7 @@ import qualified Data.Set as S
 import qualified Data.Text as T
 
 getDaemonStatus :: Assistant DaemonStatus
-getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
+getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle
 
 modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
 modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
@@ -40,8 +40,8 @@ modifyDaemonStatus a = do
 	dstatus <- getAssistant daemonStatusHandle
 	liftIO $ do
 		(s, b) <- atomically $ do
-			r@(!s, _) <- a <$> takeTMVar dstatus
+			r@(!s, _) <- a <$> readTVar dstatus
-			putTMVar dstatus s
+			writeTVar dstatus s
 			return r
 		sendNotification $ changeNotifier s
 		return b
@@ -102,7 +102,7 @@ startDaemonStatus = do
 		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
 	transfers <- M.fromList <$> getTransfers
 	addsync <- calcSyncRemotes
-	liftIO $ atomically $ newTMVar $ addsync $ status
+	liftIO $ atomically $ newTVar $ addsync $ status
 		{ scanComplete = False
 		, sanityCheckRunning = False
 		, currentTransfers = transfers
@@ -162,14 +162,14 @@ tenMinutes = 10 * 60
  - to the caller. -}
 adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
 adjustTransfersSTM dstatus a = do
-	s <- takeTMVar dstatus
+	s <- readTVar dstatus
 	let !v = a (currentTransfers s)
-	putTMVar dstatus $ s { currentTransfers = v }
+	writeTVar dstatus $ s { currentTransfers = v }
 
 {- Checks if a transfer is currently running. -}
 checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
 checkRunningTransferSTM dstatus t = M.member t . currentTransfers
-	<$> readTMVar dstatus
+	<$> readTVar dstatus
 
 {- Alters a transfer's info, if the transfer is in the map. -}
 alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
@@ -207,14 +207,14 @@ notifyTransfer :: Assistant ()
 notifyTransfer = do
 	dstatus <- getAssistant daemonStatusHandle
 	liftIO $ sendNotification
-		=<< transferNotifier <$> atomically (readTMVar dstatus)
+		=<< transferNotifier <$> atomically (readTVar dstatus)
 
 {- Send a notification when alerts are changed. -}
 notifyAlert :: Assistant ()
 notifyAlert = do
 	dstatus <- getAssistant daemonStatusHandle
 	liftIO $ sendNotification
-		=<< alertNotifier <$> atomically (readTMVar dstatus)
+		=<< alertNotifier <$> atomically (readTVar dstatus)
 
 {- Returns the alert's identifier, which can be used to remove it. -}
 addAlert :: Alert -> Assistant AlertId

Assistant/Types/DaemonStatus.hs

@@ -86,8 +86,7 @@ data DaemonStatus = DaemonStatus
 
 type TransferMap = M.Map Transfer TransferInfo
 
-{- This TMVar is never left empty, so accessing it will never block. -}
+type DaemonStatusHandle = TVar DaemonStatus
-type DaemonStatusHandle = TMVar DaemonStatus
 
 newDaemonStatus :: IO DaemonStatus
 newDaemonStatus = DaemonStatus

Assistant/Types/TransferrerPool.hs

@@ -13,8 +13,7 @@ import Assistant.Types.DaemonStatus
 
 import Control.Concurrent.STM hiding (check)
 
-{- This TMVar is never left empty. -}
+type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem])
-type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])
 
 type CheckTransferrer = IO Bool
 type MkCheckTransferrer = IO (IO Bool)
@@ -31,24 +30,22 @@ data Transferrer = Transferrer
 	}
 
 newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
-newTransferrerPool c = newTMVarIO (c, [])
+newTransferrerPool c = newTVarIO (c, [])
 
 popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
 popTransferrerPool p = do
-	(c, l) <- takeTMVar p
+	(c, l) <- readTVar p
 	case l of
-		[] -> do
+		[] -> return (Nothing, 0)
-			putTMVar p (c, [])
-			return (Nothing, 0)
 		(i:is) -> do
-			putTMVar p (c, is)
+			writeTVar p (c, is)
 			return $ (Just i, length is)
 
 pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
 pushTransferrerPool p i = do
-	(c, l) <- takeTMVar p
+	(c, l) <- readTVar p
 	let l' = i:l
-	putTMVar p (c, l')
+	writeTVar p (c, l')
 
 {- Note that making a CheckTransferrer may allocate resources,
  - such as a NotificationHandle, so it's important that the returned
@@ -56,12 +53,12 @@ pushTransferrerPool p i = do
  - garbage collected. -}
 mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem
 mkTransferrerPoolItem p t = do
-	mkcheck <- atomically $ fst <$> readTMVar p
+	mkcheck <- atomically $ fst <$> readTVar p
 	check <- mkcheck
 	return $ TransferrerPoolItem (Just t) check
 
 checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
 checkNetworkConnections dstatushandle = do
-	dstatus <- atomically $ readTMVar dstatushandle
+	dstatus <- atomically $ readTVar dstatushandle
 	h <- newNotificationHandle False (networkConnectedNotifier dstatus)
 	return $ not <$> checkNotification h

Command/WebApp.hs

@@ -154,7 +154,7 @@ firstRun o = do
 	 - threadstate. -}
 	let st = error "annex state not available"
 	{- Get a DaemonStatus without running in the Annex monad. -}
-	dstatus <- atomically . newTMVar =<< newDaemonStatus
+	dstatus <- atomically . newTVar =<< newDaemonStatus
 	d <- newAssistantData st dstatus
 	urlrenderer <- newUrlRenderer
 	v <- newEmptyMVar

Remote/External.hs

@@ -127,7 +127,7 @@ externalSetup mu _ c gc = do
 				INITREMOTE_FAILURE errmsg -> Just $ error errmsg
 				_ -> Nothing
 			withExternalState external $
-				liftIO . atomically . readTMVar . externalConfig
+				liftIO . atomically . readTVar . externalConfig
 
 	gitConfigSpecialRemote u c'' "externaltype" externaltype
 	return (c'', u)
@@ -234,24 +234,22 @@ handleRequest' st external req mp responsehandler
 	handleRemoteRequest (DIRHASH_LOWER k) = 
 		send $ VALUE $ hashDirLower def k
 	handleRemoteRequest (SETCONFIG setting value) =
-		liftIO $ atomically $ do
+		liftIO $ atomically $ modifyTVar' (externalConfig st) $
-			let v = externalConfig st
+			M.insert setting value
-			m <- takeTMVar v
-			putTMVar v $ M.insert setting value m
 	handleRemoteRequest (GETCONFIG setting) = do
 		value <- fromMaybe "" . M.lookup setting
-			<$> liftIO (atomically $ readTMVar $ externalConfig st)
+			<$> liftIO (atomically $ readTVar $ externalConfig st)
 		send $ VALUE value
 	handleRemoteRequest (SETCREDS setting login password) = do
 		let v = externalConfig st
-		c <- liftIO $ atomically $ readTMVar v
+		c <- liftIO $ atomically $ readTVar v
 		let gc = externalGitConfig external
 		c' <- setRemoteCredPair encryptionAlreadySetup c gc
 			(credstorage setting)
 			(Just (login, password))
-		void $ liftIO $ atomically $ swapTMVar v c'
+		void $ liftIO $ atomically $ swapTVar v c'
 	handleRemoteRequest (GETCREDS setting) = do
-		c <- liftIO $ atomically $ readTMVar $ externalConfig st
+		c <- liftIO $ atomically $ readTVar $ externalConfig st
 		let gc = externalGitConfig external
 		creds <- fromMaybe ("", "") <$> 
 			getRemoteCredPair c gc (credstorage setting)
@@ -356,19 +354,15 @@ withExternalState external = bracket alloc dealloc
 
 	alloc = do
 		ms <- liftIO $ atomically $ do
-			l <- takeTMVar v
+			l <- readTVar v
 			case l of
-				[] -> do
+				[] -> return Nothing
-					putTMVar v l
-					return Nothing
 				(st:rest) -> do
-					putTMVar v rest
+					writeTVar v rest
 					return (Just st)
 		maybe (startExternal external) return ms
 	
-	dealloc st = liftIO $ atomically $ do
+	dealloc st = liftIO $ atomically $ modifyTVar' v (st:)
-		l <- takeTMVar v
-		putTMVar v (st:l)
 
 {- Starts an external remote process running, and checks VERSION. -}
 startExternal :: External -> Annex ExternalState
@@ -396,11 +390,11 @@ startExternal external = do
 		fileEncoding herr
 		stderrelay <- async $ errrelayer herr
 		checkearlytermination =<< getProcessExitCode ph
-		cv <- newTMVarIO $ externalDefaultConfig external
+		cv <- newTVarIO $ externalDefaultConfig external
-		pv <- newTMVarIO Unprepared
+		pv <- newTVarIO Unprepared
 		pid <- atomically $ do
-			n <- succ <$> takeTMVar (externalLastPid external)
+			n <- succ <$> readTVar (externalLastPid external)
-			putTMVar (externalLastPid external) n
+			writeTVar (externalLastPid external) n
 			return n
 		return $ ExternalState
 			{ externalSend = hin
@@ -431,17 +425,13 @@ startExternal external = do
 
 stopExternal :: External -> Annex ()
 stopExternal external = liftIO $ do
-	l <- atomically $ do
+	l <- atomically $ swapTVar (externalState external) []
-		l <- takeTMVar v
-		putTMVar v []
-		return l
 	mapM_ stop l
   where
 	stop st = do
 		hClose $ externalSend st
 		hClose $ externalReceive st
 		externalShutdown st
-	v = externalState external
 
 externalRemoteProgram :: ExternalType -> String
 externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype
@@ -459,7 +449,7 @@ checkVersion _ _ _ = Nothing
  - the error message. -}
 checkPrepared :: ExternalState -> External -> Annex ()
 checkPrepared st external = do
-	v <- liftIO $ atomically $ readTMVar $ externalPrepared st
+	v <- liftIO $ atomically $ readTVar $ externalPrepared st
 	case v of
 		Prepared -> noop
 		FailedPrepare errmsg -> error errmsg
@@ -474,7 +464,7 @@ checkPrepared st external = do
 					_ -> Nothing
   where
 	setprepared status = liftIO $ atomically $ void $
-		swapTMVar (externalPrepared st) status
+		swapTVar (externalPrepared st) status
 
 {- Caches the cost in the git config to avoid needing to start up an
  - external special remote every time time just to ask it what its

Remote/External/Types.hs

@@ -45,10 +45,10 @@ import Network.URI
 data External = External
 	{ externalType :: ExternalType
 	, externalUUID :: UUID
-	, externalState :: TMVar [ExternalState]
+	, externalState :: TVar [ExternalState]
-	-- ^ TMVar is never left empty; list contains states for external
+	-- ^ Contains states for external special remote processes
-	-- special remote processes that are not currently in use.
+	-- that are not currently in use.
-	, externalLastPid :: TMVar PID
+	, externalLastPid :: TVar PID
 	, externalDefaultConfig :: RemoteConfig
 	, externalGitConfig :: RemoteGitConfig
 	}
@@ -57,8 +57,8 @@ newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex
 newExternal externaltype u c gc = liftIO $ External
 	<$> pure externaltype
 	<*> pure u
-	<*> atomically (newTMVar [])
+	<*> atomically (newTVar [])
-	<*> atomically (newTMVar 0)
+	<*> atomically (newTVar 0)
 	<*> pure c
 	<*> pure gc
 
@@ -69,10 +69,8 @@ data ExternalState = ExternalState
 	, externalReceive :: Handle
 	, externalShutdown :: IO ()
 	, externalPid :: PID
-	, externalPrepared :: TMVar PrepareStatus
+	, externalPrepared :: TVar PrepareStatus
-	-- ^ Never left empty.
+	, externalConfig :: TVar RemoteConfig
-	, externalConfig :: TMVar RemoteConfig
-	-- ^ Never left empty.
 	}
 
 type PID = Int