From eeed9868bf9c328835b336ddc947cdbf8d4e9c4f Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 17 Sep 2018 13:03:07 +0300 Subject: [PATCH 1/2] Optimize peekTQueue and peekTBQueue Reduce the amount of operations, avoiding redundant writes and hence reducing the chance of conflicts --- Control/Concurrent/STM/TBQueue.hs | 18 ++++++++++++++---- Control/Concurrent/STM/TQueue.hs | 18 ++++++++++++++---- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs index 8722511..16dc2a8 100644 --- a/Control/Concurrent/STM/TBQueue.hs +++ b/Control/Concurrent/STM/TBQueue.hs @@ -161,10 +161,20 @@ flushTBQueue (TBQueue rsize read wsize write size) = do -- | Get the next value from the @TBQueue@ without removing it, -- retrying if the channel is empty. peekTBQueue :: TBQueue a -> STM a -peekTBQueue c = do - x <- readTBQueue c - unGetTBQueue c x - return x +peekTBQueue (TBQueue _ read _ write _) = do + xs <- readTVar read + case xs of + (x:_) -> return x + [] -> do + ys <- readTVar write + case ys of + [] -> retry + _ -> do + let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be + -- short, otherwise it will conflict + writeTVar write [] + writeTVar read zs + return z -- | A version of 'peekTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 483db15..17d2de4 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -122,10 +122,20 @@ flushTQueue (TQueue read write) = do -- | Get the next value from the @TQueue@ without removing it, -- retrying if the channel is empty. peekTQueue :: TQueue a -> STM a -peekTQueue c = do - x <- readTQueue c - unGetTQueue c x - return x +peekTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (x:_) -> return x + [] -> do + ys <- readTVar write + case ys of + [] -> retry + _ -> do + let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be + -- short, otherwise it will conflict + writeTVar write [] + writeTVar read zs + return z -- | A version of 'peekTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. From 2636e453dc554a58b098b3668c0b060c072647ca Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 17 Sep 2018 13:09:41 +0300 Subject: [PATCH 2/2] Fix the head removal issue --- Control/Concurrent/STM/TBQueue.hs | 2 +- Control/Concurrent/STM/TQueue.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs index 16dc2a8..7b82388 100644 --- a/Control/Concurrent/STM/TBQueue.hs +++ b/Control/Concurrent/STM/TBQueue.hs @@ -173,7 +173,7 @@ peekTBQueue (TBQueue _ read _ write _) = do let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict writeTVar write [] - writeTVar read zs + writeTVar read (z:zs) return z -- | A version of 'peekTBQueue' which does not retry. Instead it diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 17d2de4..33052cf 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -134,7 +134,7 @@ peekTQueue (TQueue read write) = do let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict writeTVar write [] - writeTVar read zs + writeTVar read (z:zs) return z -- | A version of 'peekTQueue' which does not retry. Instead it