From d684c2f53135f51872c112732acc4079b2d4693d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 30 Sep 2016 19:51:16 -0400 Subject: convert TMVars that are never left empty into TVars This is probably more efficient, and it avoids mistakenly leaving them empty. --- Assistant/DaemonStatus.hs | 18 +++++++++--------- Assistant/Types/DaemonStatus.hs | 3 +-- Assistant/Types/TransferrerPool.hs | 21 +++++++++------------ 3 files changed, 19 insertions(+), 23 deletions(-) (limited to 'Assistant') diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 3b2c6f3cd..6e11b923e 100644 --- a/Assistant/DaemonStatus.hs +++ b/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 - putTMVar dstatus s + r@(!s, _) <- a <$> readTVar dstatus + 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 diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 8bb66261e..0e52d3477 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/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 = TMVar DaemonStatus +type DaemonStatusHandle = TVar DaemonStatus newDaemonStatus :: IO DaemonStatus newDaemonStatus = DaemonStatus diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs index a2425eb62..742d8437c 100644 --- a/Assistant/Types/TransferrerPool.hs +++ b/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 = TMVar (MkCheckTransferrer, [TransferrerPoolItem]) +type TransferrerPool = TVar (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 - putTMVar p (c, []) - return (Nothing, 0) + [] -> 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 -- cgit v1.2.3