From fe042c6b169b68dca9bd6d13061a28e80892753c Mon Sep 17 00:00:00 2001 From: Adrian May Date: Thu, 23 Jan 2025 15:12:05 +0000 Subject: [PATCH 1/6] Good enough for now --- Control/Concurrent/STM/TQueue.hs | 59 ++++++++++++++++++++++++++++++++ testsuite/src/Main.hs | 2 ++ testsuite/src/Stm066.hs | 30 ++++++++++++++++ testsuite/testsuite.cabal | 1 + 4 files changed, 92 insertions(+) create mode 100644 testsuite/src/Stm066.hs diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 720cfa7..2ed560d 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -38,6 +38,7 @@ module Control.Concurrent.STM.TQueue ( newTQueue, newTQueueIO, readTQueue, + readTQueueN, tryReadTQueue, flushTQueue, peekTQueue, @@ -103,6 +104,64 @@ readTQueue (TQueue read write) = do writeTVar read zs return z + +-- +-----------+--------------- +-----------------+ +-- | write = 0 | write < N-read | write >= N-read | +-- +--------------+-----------+--------------- +-----------------+ +-- | read == 0 | retry | case 2 | case 3 | +-- | 0 < read < N | retry | retry | case 4 | +-- +--------------+-----------+--------------- +-----------------+ +-- | read >= N | . . . . . . . case 1 . . . . . . . . . | +-- +----=--------------------------------------------------------+ + +-- case 1a: More than N: splitAt N read -> put suffix in read and return prefix +-- case 1b: Exactly N: Reverse write into read, and return all of the old read +-- case 2: Move reverse write to read, retry +-- case 3: Reverse write -> splitAt N, put suffix in read and return prefix +-- case 4: Like case 3 but prepend read onto return value + +-- |Reads N values, blocking until enough are available +readTQueueN :: Int -> TQueue a -> STM [a] +readTQueueN n (TQueue read write) = do + xs <- readTVar read + let xl = length xs + if xl > n then do -- case 1a + let (as,bs) = splitAt n xs + writeTVar read bs + pure as + else if xl == n then do -- case 1b + ys <- readTVar write + case ys of + [] -> do + writeTVar read [] + retry + _ -> do + let zs = reverse ys + writeTVar write [] + writeTVar read zs + pure xs + else do + ys <- readTVar write + let yl = length ys + if yl == 0 then + retry + else if yl < n - xl then + if xl == 0 then do -- case 2 + let zs = reverse ys + writeTVar write [] + writeTVar read zs + retry + else + retry + else do -- cases 3 and 4 + let (as,bs) = splitAt (n-xl) (reverse ys) + writeTVar read bs + pure $ xs <> as + + + + + -- | A version of 'readTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTQueue :: TQueue a -> STM (Maybe a) diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs index 09802d2..1fd6b4e 100644 --- a/testsuite/src/Main.hs +++ b/testsuite/src/Main.hs @@ -10,6 +10,7 @@ import qualified Issue17 import qualified Stm052 import qualified Stm064 import qualified Stm065 +import qualified Stm066 main :: IO () main = do @@ -23,6 +24,7 @@ main = do , testCase "stm052" Stm052.main , testCase "stm064" Stm064.main , testCase "stm065" Stm065.main + , testCase "stm066" Stm066.main ] ] diff --git a/testsuite/src/Stm066.hs b/testsuite/src/Stm066.hs new file mode 100644 index 0000000..b450174 --- /dev/null +++ b/testsuite/src/Stm066.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + +{- NB: This one fails for GHC < 7.6 which had a bug exposed via + nested uses of `orElse` in `stmCommitNestedTransaction` + +This was fixed in GHC via + f184d9caffa09750ef6a374a7987b9213d6db28e +-} + +module Stm066 (main) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TQueue +import Control.Monad (unless) + +main :: IO () +main = do + q <- atomically $ newTQueue + _ <- forkIO $ atomically $ do + writeTQueue q (1::Int) + writeTQueue q 2 + writeTQueue q 3 + writeTQueue q 4 + l <- atomically $ do + _ <- readTQueueN 1 q + readTQueueN 3 q + + unless (l == [2,3,4]) $ + fail (show l) diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal index c4617b1..8343bbd 100644 --- a/testsuite/testsuite.cabal +++ b/testsuite/testsuite.cabal @@ -37,6 +37,7 @@ test-suite stm Stm052 Stm064 Stm065 + Stm066 type: exitcode-stdio-1.0 From d17d54126c3d408fc84c818797eba89498cb8178 Mon Sep 17 00:00:00 2001 From: Adrian May Date: Thu, 23 Jan 2025 15:49:56 +0000 Subject: [PATCH 2/6] Bump version --- stm.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stm.cabal b/stm.cabal index 8bc4322..e29849d 100644 --- a/stm.cabal +++ b/stm.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: stm -version: 2.5.3.1 +version: 2.5.4 -- don't forget to update changelog.md file! license: BSD3 From 92e7ee704d9e9487ecf7c5ffb8a91304e5aaff6f Mon Sep 17 00:00:00 2001 From: Adrian May Date: Thu, 6 Feb 2025 16:11:38 +0000 Subject: [PATCH 3/6] Sane parameter ordering --- Control/Concurrent/STM/TQueue.hs | 4 ++-- testsuite/src/Stm066.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 2ed560d..09b491e 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -121,8 +121,8 @@ readTQueue (TQueue read write) = do -- case 4: Like case 3 but prepend read onto return value -- |Reads N values, blocking until enough are available -readTQueueN :: Int -> TQueue a -> STM [a] -readTQueueN n (TQueue read write) = do +readTQueueN :: TQueue a -> Int -> STM [a] +readTQueueN (TQueue read write) n = do xs <- readTVar read let xl = length xs if xl > n then do -- case 1a diff --git a/testsuite/src/Stm066.hs b/testsuite/src/Stm066.hs index b450174..03caaaf 100644 --- a/testsuite/src/Stm066.hs +++ b/testsuite/src/Stm066.hs @@ -23,8 +23,8 @@ main = do writeTQueue q 3 writeTQueue q 4 l <- atomically $ do - _ <- readTQueueN 1 q - readTQueueN 3 q + _ <- readTQueueN q 1 + readTQueueN q 3 unless (l == [2,3,4]) $ fail (show l) From 869674304d2253308e12f281c239033744747160 Mon Sep 17 00:00:00 2001 From: Adrian May Date: Tue, 29 Apr 2025 15:46:50 +0100 Subject: [PATCH 4/6] Write lenTQueue --- Control/Concurrent/STM/TQueue.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 09b491e..38c8ae1 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -39,6 +39,7 @@ module Control.Concurrent.STM.TQueue ( newTQueueIO, readTQueue, readTQueueN, + lenTQueue, tryReadTQueue, flushTQueue, peekTQueue, @@ -158,9 +159,14 @@ readTQueueN (TQueue read write) n = do writeTVar read bs pure $ xs <> as +lenTQueue :: TQueue a -> STM Int +lenTQueue = lenTQueue_ 0 - - +lenTQueue_ :: Int -> TQueue a -> STM Int +lenTQueue_ i q = do + tryReadTQueue q >>= maybe + (pure i) + (const $ lenTQueue_ (1+i) q) -- | A version of 'readTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. From ad3e61e6ec6209ee6709509f8460eacdc92f61d4 Mon Sep 17 00:00:00 2001 From: Adrian May Date: Wed, 30 Apr 2025 11:34:17 +0100 Subject: [PATCH 5/6] Remove case 2 and lenTQueue. Add health warnings. --- Control/Concurrent/STM/TQueue.hs | 32 +++++++++++--------------------- 1 file changed, 11 insertions(+), 21 deletions(-) diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index 38c8ae1..f515d24 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -39,7 +39,6 @@ module Control.Concurrent.STM.TQueue ( newTQueueIO, readTQueue, readTQueueN, - lenTQueue, tryReadTQueue, flushTQueue, peekTQueue, @@ -106,10 +105,11 @@ readTQueue (TQueue read write) = do return z +-- Logic of readTQueueN: -- +-----------+--------------- +-----------------+ -- | write = 0 | write < N-read | write >= N-read | -- +--------------+-----------+--------------- +-----------------+ --- | read == 0 | retry | case 2 | case 3 | +-- | read == 0 | retry | retry | case 3 | -- | 0 < read < N | retry | retry | case 4 | -- +--------------+-----------+--------------- +-----------------+ -- | read >= N | . . . . . . . case 1 . . . . . . . . . | @@ -117,11 +117,17 @@ readTQueue (TQueue read write) = do -- case 1a: More than N: splitAt N read -> put suffix in read and return prefix -- case 1b: Exactly N: Reverse write into read, and return all of the old read --- case 2: Move reverse write to read, retry +-- case 2: No longer exists -- case 3: Reverse write -> splitAt N, put suffix in read and return prefix -- case 4: Like case 3 but prepend read onto return value --- |Reads N values, blocking until enough are available +-- |Reads N values, blocking until enough are available. +-- This is likely never to return if another thread is +-- blocking on readTQueue. It has quadratic complexity +-- in n due to each write triggering readTQueueN to calculate +-- the length of the write side as Int -> STM [a] readTQueueN (TQueue read write) n = do xs <- readTVar read @@ -146,28 +152,12 @@ readTQueueN (TQueue read write) n = do let yl = length ys if yl == 0 then retry - else if yl < n - xl then - if xl == 0 then do -- case 2 - let zs = reverse ys - writeTVar write [] - writeTVar read zs - retry - else - retry + else if yl < n - xl then retry else do -- cases 3 and 4 let (as,bs) = splitAt (n-xl) (reverse ys) writeTVar read bs pure $ xs <> as -lenTQueue :: TQueue a -> STM Int -lenTQueue = lenTQueue_ 0 - -lenTQueue_ :: Int -> TQueue a -> STM Int -lenTQueue_ i q = do - tryReadTQueue q >>= maybe - (pure i) - (const $ lenTQueue_ (1+i) q) - -- | A version of 'readTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTQueue :: TQueue a -> STM (Maybe a) From b889299cadcc48bcb051bbcbbfddf1a143c33059 Mon Sep 17 00:00:00 2001 From: Adrian May Date: Tue, 6 May 2025 12:17:46 +0100 Subject: [PATCH 6/6] Review comments --- Control/Concurrent/STM/TQueue.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs index f515d24..d4a48e1 100644 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -105,27 +105,26 @@ readTQueue (TQueue read write) = do return z --- Logic of readTQueueN: +-- Logic of `readTQueueN`: -- +-----------+--------------- +-----------------+ -- | write = 0 | write < N-read | write >= N-read | -- +--------------+-----------+--------------- +-----------------+ --- | read == 0 | retry | retry | case 3 | --- | 0 < read < N | retry | retry | case 4 | +-- | read == 0 | retry | retry | case 2 | +-- | 0 < read < N | retry | retry | case 3 | -- +--------------+-----------+--------------- +-----------------+ -- | read >= N | . . . . . . . case 1 . . . . . . . . . | -- +----=--------------------------------------------------------+ -- case 1a: More than N: splitAt N read -> put suffix in read and return prefix -- case 1b: Exactly N: Reverse write into read, and return all of the old read --- case 2: No longer exists --- case 3: Reverse write -> splitAt N, put suffix in read and return prefix --- case 4: Like case 3 but prepend read onto return value +-- case 2: Reverse write -> splitAt N, put suffix in read and return prefix +-- case 3: Like case 2 but prepend read onto return value -- |Reads N values, blocking until enough are available. -- This is likely never to return if another thread is --- blocking on readTQueue. It has quadratic complexity --- in n due to each write triggering readTQueueN to calculate --- the length of the write side as Int -> STM [a] @@ -153,7 +152,7 @@ readTQueueN (TQueue read write) n = do if yl == 0 then retry else if yl < n - xl then retry - else do -- cases 3 and 4 + else do -- cases 2 and 3 let (as,bs) = splitAt (n-xl) (reverse ys) writeTVar read bs pure $ xs <> as