stm 2.5.0.0 → 2.5.0.1

raw patch · 12 files changed

+356/−11 lines, 12 filesdep ~basenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Concurrent/STM/TBQueue.hs +14/−4
• Control/Concurrent/STM/TQueue.hs +14/−4
• README.md +4/−0
• changelog.md +5/−0
• stm.cabal +6/−3
• testsuite/src/Issue17.hs +73/−0
• testsuite/src/Issue9.hs +41/−0
• testsuite/src/Main.hs +28/−0
• testsuite/src/Stm052.hs +70/−0
• testsuite/src/Stm064.hs +28/−0
• testsuite/src/Stm065.hs +15/−0
• testsuite/testsuite.cabal +58/−0

@@ -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.

@@ -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.

@@ -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.

@@ -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)

@@ -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:

@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}++-- see https://github.com/haskell/stm/pull/19+--+-- Test-case contributed by Alexey Kuleshevich <alexey@kukeshevi.ch>+--+-- 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"

@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}++-- see https://github.com/haskell/stm/pull/9+--+-- Test-case contributed by Mitchell Rosen <mitchellwrosen@gmail.com>+--+-- 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

@@ -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+        ]+      ]+

@@ -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"

@@ -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

@@ -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)

@@ -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