mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

use DList for the transfer queue

Browse source 
Some nice efficiency gains here for list appending, although mostly
the small size of the transfer queue makes them irrelivant.
This commit is contained in:
Joey Hess 2013-04-25 01:33:44 -04:00
parent c6da464051
commit 362ed9f0e3
4 changed files with 21 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Assistant/Changes.hs
View file

@ -32,7 +32,7 @@ getChanges = (atomically . getTList) <<~ changePool
{- Gets all unhandled changes, without blocking. -} {- Gets all unhandled changes, without blocking. -}
getAnyChanges :: Assistant [Change] getAnyChanges :: Assistant [Change]
getAnyChanges = (atomically . readTList) <<~ changePool getAnyChanges = (atomically . takeTList) <<~ changePool
{- Puts unhandled changes back into the pool. {- Puts unhandled changes back into the pool.
- Note: Original order is not preserved. -} - Note: Original order is not preserved. -}

20
Assistant/TransferQueue.hs
View file

@ -39,7 +39,7 @@ type Reason = String
{- Reads the queue's content without blocking or changing it. -} {- Reads the queue's content without blocking or changing it. -}
getTransferQueue :: Assistant [(Transfer, TransferInfo)] getTransferQueue :: Assistant [(Transfer, TransferInfo)]
getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue
stubInfo :: AssociatedFile -> Remote -> TransferInfo stubInfo :: AssociatedFile -> Remote -> TransferInfo
stubInfo f r = stubTransferInfo stubInfo f r = stubTransferInfo
@ -126,10 +126,9 @@ queueDeferredDownloads reason schedule = do
enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant () enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
enqueue reason schedule t info enqueue reason schedule t info
| schedule == Next = go (new:) | schedule == Next = go consTList
| otherwise = go (\l -> l++[new]) | otherwise = go snocTList
where where
new = (t, info)
go modlist = whenM (add modlist) $ do go modlist = whenM (add modlist) $ do
debug [ "queued", describeTransfer t info, ": " ++ reason ] debug [ "queued", describeTransfer t info, ": " ++ reason ]
notifyTransfer notifyTransfer
@ -139,11 +138,11 @@ enqueue reason schedule t info
liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t) liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
( return False ( return False
, do , do
l <- readTVar (queuelist q) l <- readTList (queuelist q)
if (t `notElem` map fst l) if (t `notElem` map fst l)
then do then do
void $ modifyTVar' (queuesize q) succ void $ modifyTVar' (queuesize q) succ
void $ modifyTVar' (queuelist q) modlist void $ modlist (queuelist q) (t, info)
return True return True
else return False else return False
) )
@ -184,9 +183,9 @@ getNextTransfer acceptable = do
if sz < 1 if sz < 1
then retry -- blocks until queuesize changes then retry -- blocks until queuesize changes
else do else do
(r@(t,info):rest) <- readTVar (queuelist q) (r@(t,info):rest) <- readTList (queuelist q)
writeTVar (queuelist q) rest
void $ modifyTVar' (queuesize q) pred void $ modifyTVar' (queuesize q) pred
setTList (queuelist q) rest
if acceptable info if acceptable info
then do then do
adjustTransfersSTM dstatus $ adjustTransfersSTM dstatus $
@ -218,8 +217,7 @@ dequeueTransfers c = do
dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]
dequeueTransfersSTM q c = do dequeueTransfersSTM q c = do
(removed, ts) <- partition (c . fst) (removed, ts) <- partition (c . fst) <$> readTList (queuelist q)
<$> readTVar (queuelist q)
void $ writeTVar (queuesize q) (length ts) void $ writeTVar (queuesize q) (length ts)
void $ writeTVar (queuelist q) ts setTList (queuelist q) ts
return removed return removed

4
Assistant/Types/TransferQueue.hs
View file

@ -16,7 +16,7 @@ import Utility.TList
data TransferQueue = TransferQueue data TransferQueue = TransferQueue
{ queuesize :: TVar Int { queuesize :: TVar Int
, queuelist :: TVar [(Transfer, TransferInfo)] , queuelist :: TList (Transfer, TransferInfo)
, deferreddownloads :: TList (Key, AssociatedFile) , deferreddownloads :: TList (Key, AssociatedFile)
} }
@ -26,5 +26,5 @@ data Schedule = Next | Later
newTransferQueue :: IO TransferQueue newTransferQueue :: IO TransferQueue
newTransferQueue = atomically $ TransferQueue newTransferQueue = atomically $ TransferQueue
<$> newTVar 0 <$> newTVar 0
<*> newTVar [] <*> newTList
<*> newTList <*> newTList

11
Utility/TList.hs
View file

@ -25,10 +25,14 @@ newTList = newEmptyTMVar
getTList :: TList a -> STM [a] getTList :: TList a -> STM [a]
getTList tlist = D.toList <$> takeTMVar tlist getTList tlist = D.toList <$> takeTMVar tlist
{- Gets anything currently in the TList, without blocking. {- Takes anything currently in the TList, without blocking.
- TList is left empty. -} - TList is left empty. -}
takeTList :: TList a -> STM [a]
takeTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist
{- Reads anything in the list, without modifying it, or blocking. -}
readTList :: TList a -> STM [a] readTList :: TList a -> STM [a]
readTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist readTList tlist = maybe [] D.toList <$> tryReadTMVar tlist
{- Mutates a TList. -} {- Mutates a TList. -}
modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM () modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM ()
@ -50,3 +54,6 @@ snocTList tlist v = modifyTList tlist $ \dl -> D.snoc dl v
appendTList :: TList a -> [a] -> STM () appendTList :: TList a -> [a] -> STM ()
appendTList tlist l = modifyTList tlist $ \dl -> D.append dl (D.fromList l) appendTList tlist l = modifyTList tlist $ \dl -> D.append dl (D.fromList l)
setTList :: TList a -> [a] -> STM ()
setTList tlist l = modifyTList tlist $ const $ D.fromList l