diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs --- a/Control/Concurrent/STM/TBQueue.hs +++ b/Control/Concurrent/STM/TBQueue.hs @@ -161,10 +161,20 @@ -- | 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 (z: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 --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -122,10 +122,20 @@ -- | 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 (z:zs) + return z -- | A version of 'peekTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +The `stm` Package [![Build Status](https://travis-ci.org/haskell/stm.svg?branch=master)](https://travis-ci.org/haskell/stm) +================= + +See [`stm` on Hackage](http://hackage.haskell.org/package/stm) for more information. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) +## 2.5.0.1 *May 2020* + + * Optimise implementation of `peekTQueue` and `peekTBQueue` to reduce + probability of transaction conflicts. + ## 2.5.0.0 *Sep 2018* * Removed `alwaysSucceeds` and `always`, GHC's invariant checking primitives. (GHC #14324) diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: stm -version: 2.5.0.0 +version: 2.5.0.1 -- don't forget to update changelog.md file! license: BSD3 @@ -11,7 +11,7 @@ synopsis: Software Transactional Memory category: Concurrency build-type: Simple -tested-with: GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* +tested-with: GHC==8.8.*, GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* description: Software Transactional Memory, or STM, is an abstraction for concurrent communication. The main benefits of STM are @@ -24,6 +24,9 @@ extra-source-files: changelog.md + README.md + testsuite/src/*.hs + testsuite/testsuite.cabal source-repository head type: git @@ -47,7 +50,7 @@ build-depends: nats (>= 0.1.3 && < 0.3) || (>= 1 && < 1.2) build-depends: - base >= 4.3 && < 4.13, + base >= 4.3 && < 4.15, array >= 0.3 && < 0.6 exposed-modules: diff --git a/testsuite/src/Issue17.hs b/testsuite/src/Issue17.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Issue17.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +-- see https://github.com/haskell/stm/pull/19 +-- +-- Test-case contributed by Alexey Kuleshevich +-- +-- This bug is observable in all versions with TBQueue from `stm-2.4` to +-- `stm-2.4.5.1` inclusive. + +module Issue17 (main) where + +import Control.Concurrent.STM +import Test.HUnit.Base (assertBool, assertEqual) + +main :: IO () +main = do + -- New queue capacity is set to 0 + queueIO <- newTBQueueIO 0 + assertNoCapacityTBQueue queueIO + + -- Same as above, except created within STM + queueSTM <- atomically $ newTBQueue 0 + assertNoCapacityTBQueue queueSTM + +#if !MIN_VERSION_stm(2,5,0) + -- NB: below are expected failures + + -- New queue capacity is set to a negative numer + queueIO' <- newTBQueueIO (-1 :: Int) + assertNoCapacityTBQueue queueIO' + + -- Same as above, except created within STM and different negative number + queueSTM' <- atomically $ newTBQueue (minBound :: Int) + assertNoCapacityTBQueue queueSTM' +#endif + +assertNoCapacityTBQueue :: TBQueue Int -> IO () +assertNoCapacityTBQueue queue = do + assertEmptyTBQueue queue + assertFullTBQueue queue + + -- Attempt to write into the queue. + eValWrite <- atomically $ orElse (fmap Left (writeTBQueue queue 217)) + (fmap Right (tryReadTBQueue queue)) + assertEqual "Expected queue with no capacity: writeTBQueue" eValWrite (Right Nothing) + eValUnGet <- atomically $ orElse (fmap Left (unGetTBQueue queue 218)) + (fmap Right (tryReadTBQueue queue)) + assertEqual "Expected queue with no capacity: unGetTBQueue" eValUnGet (Right Nothing) + + -- Make sure that attempt to write didn't affect the queue + assertEmptyTBQueue queue + assertFullTBQueue queue + + +assertEmptyTBQueue :: TBQueue Int -> IO () +assertEmptyTBQueue queue = do + atomically (isEmptyTBQueue queue) >>= + assertBool "Expected empty: isEmptyTBQueue should return True" + + atomically (tryReadTBQueue queue) >>= + assertEqual "Expected empty: tryReadTBQueue should return Nothing" Nothing + + atomically (tryPeekTBQueue queue) >>= + assertEqual "Expected empty: tryPeekTBQueue should return Nothing" Nothing + + atomically (flushTBQueue queue) >>= + assertEqual "Expected empty: flushTBQueue should return []" [] + + +assertFullTBQueue :: TBQueue Int -> IO () +assertFullTBQueue queue = do + atomically (isFullTBQueue queue) >>= + assertBool "Expected full: isFullTBQueue shoule return True" diff --git a/testsuite/src/Issue9.hs b/testsuite/src/Issue9.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Issue9.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +-- see https://github.com/haskell/stm/pull/9 +-- +-- Test-case contributed by Mitchell Rosen +-- +-- This bug is observable in version `stm-2.4.5.0` + +module Issue9 (main) where + +import Control.Concurrent.STM +import Data.Foldable + +main :: IO () +#if MIN_VERSION_stm(2,4,5) +main = do + -- New queue with capacity 5 + queue <- newTBQueueIO 5 + + -- Fill it up with [1..5] + for_ [1..5] $ \i -> + atomically (writeTBQueue queue (i :: Int)) + + -- Read 1 + 1 <- atomically (readTBQueue queue) + + -- Flush [2..5] + [2,3,4,5] <- atomically (flushTBQueue queue) + + -- The bug: now the queue capacity is 4, not 5. + -- To trigger it, first fill up [1..4]... + for_ [1..4] $ \i -> + atomically (writeTBQueue queue i) + + -- ... then observe that writing a 5th element will fail + -- with "thread blocked indefinitely in an STM transaction" + atomically (writeTBQueue queue 5) +#else +-- test-case not applicable; `flushTBQueue` was only added in 2.4.5.0 +main = return () +#endif diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit + +import qualified Issue9 +import qualified Issue17 +import qualified Stm052 +import qualified Stm064 +import qualified Stm065 + +main :: IO () +main = do + putStrLn ("'stm' version under test: " ++ VERSION_stm) + defaultMain tests + where + tests = [ + testGroup "regression" + [ testCase "issue #9" Issue9.main + , testCase "issue #17" Issue17.main + , testCase "stm052" Stm052.main + , testCase "stm064" Stm064.main + , testCase "stm065" Stm065.main + ] + ] + diff --git a/testsuite/src/Stm052.hs b/testsuite/src/Stm052.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm052.hs @@ -0,0 +1,70 @@ +-- STM stress test + +module Stm052 (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad (mapM_, when) +import Data.Array +import Data.List +import Foreign +import Foreign.C +import GHC.Conc +import GHC.Conc (unsafeIOToSTM) +import System.Environment +import System.IO +import System.IO.Unsafe +import System.Random + +-- | The number of array elements +n_elems :: Int +n_elems = 20 + +-- | The number of threads swapping elements +n_threads :: Int +n_threads = 2 + +-- | The number of swaps for each thread to perform +iterations :: Int +iterations = 20000 + +type Elements = Array Int (TVar Int) + +thread :: TVar Int -> Elements -> IO () +thread done elements = loop iterations + where loop 0 = atomically $ do x <- readTVar done; writeTVar done (x+1) + loop n = do + i1 <- randomRIO (1,n_elems) + i2 <- randomRIO (1,n_elems) + let e1 = elements ! i1 + let e2 = elements ! i2 + atomically $ do + e1_v <- readTVar e1 + e2_v <- readTVar e2 + writeTVar e1 e2_v + writeTVar e2 e1_v + loop (n-1) + +await_end :: TVar Int -> IO () +await_end done = atomically $ do x <- readTVar done + if (x == n_threads) then return () else retry + +main :: IO () +main = do + _ <- Foreign.newStablePtr stdout + setStdGen (read "526454551 6356") + let init_vals = [1..n_elems] -- take n_elems + tvars <- atomically $ mapM newTVar init_vals + let elements = listArray (1,n_elems) tvars + done <- atomically (newTVar 0) + _ <- sequence [ forkIO (thread done elements) | _id <- [1..n_threads] ] + await_end done + fin_vals <- mapM (\t -> atomically $ readTVar t) (elems elements) + + when (sort fin_vals /= init_vals) $ do + putStr("Before: ") + mapM_ (\v -> putStr ((show v) ++ " " )) init_vals + putStr("\nAfter: ") + mapM_ (\v -> putStr ((show v) ++ " " )) (sort fin_vals) + putStr("\n") + fail "mismatch" diff --git a/testsuite/src/Stm064.hs b/testsuite/src/Stm064.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm064.hs @@ -0,0 +1,28 @@ +{-# 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 Stm064 (main) where + +import Control.Concurrent.STM +import Control.Monad (unless) + +main :: IO () +#if __GLASGOW_HASKELL__ >= 706 && !defined(GHC_7_6_1) +main = do + x <- atomically $ do + t <- newTVar (1 :: Integer) + writeTVar t 2 + ((readTVar t >> retry) `orElse` return ()) `orElse` return () + readTVar t + + unless (x == 2) $ + fail (show x) +#else +main = putStrLn "Warning: test disabled for GHC < 7.6" +#endif diff --git a/testsuite/src/Stm065.hs b/testsuite/src/Stm065.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm065.hs @@ -0,0 +1,15 @@ +module Stm065 (main) where + +import Control.Concurrent.STM +import Control.Monad (unless) + +main :: IO () +main = do + x <- atomically $ do + r <- newTVar [] + writeTVar r [2 :: Integer] + writeTVar r [] `orElse` return () + readTVar r + + unless (null x) $ do + fail (show x) diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal new file mode 100644 --- /dev/null +++ b/testsuite/testsuite.cabal @@ -0,0 +1,58 @@ +cabal-version: 2.2 +name: testsuite +version: 0 + +synopsis: External testsuite for stm package +category: Testing +license: BSD-3-Clause +maintainer: hvr@gnu.org +tested-with: GHC==8.8.*, GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* +description: + This testsuite is intended to be compatible with different versions + of `stm` (via use of @CPP@ if needed) in order to more easily + verify regression tests. + . + See also @README.md@ for more information. + +test-suite stm + hs-source-dirs: src + + main-is: Main.hs + other-modules: + Issue9 + Issue17 + Stm052 + Stm064 + Stm065 + + type: exitcode-stdio-1.0 + + default-language: Haskell2010 + other-extensions: CPP + + -- IUT + build-depends: + , stm >= 2.4 && < 2.6 + + -- + build-depends: + , base >= 4.3 && < 4.14 + , test-framework ^>= 0.8.2.0 + , test-framework-hunit ^>= 0.3.0.2 + , HUnit ^>= 1.6.0.0 + -- Testing with GHC < 7.4 requires 'HUnit-1.3.1.2' which didn't depend on 'call-stack' (which requires GHC >= 7.4) + || ^>= 1.3.1.2 + + -- some tests need 'array' & 'random' + , array ^>= 0.3.0.2 || ^>= 0.4.0.0 || ^>= 0.5.0.0 + , random ^>= 1.1 + + -- The __GLASGOW_HASKELL_PATCHLEVEL1__ macro wasn't available until GHC 7.10.1, + -- so we must use the .cabal file to detect if we're compiling with GHC 7.6.1 + -- in particular. See the comments in Stm065 for more information about why we + -- must single out this version of GHC. + if impl(ghc==7.6.1) + cpp-options: "-DGHC_7_6_1" + + ghc-options: -Wall -fno-warn-unused-imports + ghc-options: -threaded