stm 2.5.0.2 → 2.5.3.1
raw patch · 8 files changed
Files
- Control/Concurrent/STM/TArray.hs +89/−22
- Control/Concurrent/STM/TBQueue.hs +35/−27
- Control/Concurrent/STM/TMVar.hs +8/−0
- Control/Concurrent/STM/TVar.hs +2/−2
- Control/Monad/STM.hs +21/−0
- changelog.md +28/−1
- stm.cabal +6/−3
- testsuite/testsuite.cabal +2/−2
Control/Concurrent/STM/TArray.hs view
@@ -4,17 +4,25 @@ {-# LANGUAGE Trustworthy #-} #endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 904+#define HAS_UNLIFTED_ARRAY 1+#endif++#if defined(HAS_UNLIFTED_ARRAY)+{-# LANGUAGE MagicHash, UnboxedTuples #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TArray -- Copyright : (c) The University of Glasgow 2005 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) ----- TArrays: transactional arrays, for use in the STM monad+-- TArrays: transactional arrays, for use in the STM monad. -- ----------------------------------------------------------------------------- @@ -22,41 +30,99 @@ TArray ) where -import Data.Array (Array, bounds)-import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..),- IArray(numElements))-import Data.Ix (rangeSize)+import Control.Monad.STM (STM, atomically) import Data.Typeable (Typeable)-import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)-#ifdef __GLASGOW_HASKELL__-import GHC.Conc (STM)+#if defined(HAS_UNLIFTED_ARRAY)+import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)+import Data.Array.Base (safeRangeSize, MArray(..))+import Data.Ix (Ix)+import GHC.Conc (STM(..), TVar(..))+import GHC.Exts+import GHC.IO (IO(..)) #else-import Control.Sequential.STM (STM)+import Control.Concurrent.STM.TVar (TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar)+import Data.Array (Array, bounds, listArray)+import Data.Array.Base (safeRangeSize, unsafeAt, MArray(..), IArray(numElements)) #endif --- |TArray is a transactional array, supporting the usual 'MArray'+-- | 'TArray' is a transactional array, supporting the usual 'MArray' -- interface for mutable arrays. ----- It is currently implemented as @Array ix (TVar e)@,--- but it may be replaced by a more efficient implementation in the future--- (the interface will remain the same, however).---+-- It is conceptually implemented as @Array i (TVar e)@.+#if defined(HAS_UNLIFTED_ARRAY)+data TArray i e = TArray+ !i -- lower bound+ !i -- upper bound+ !Int -- size+ (Array# (TVar# RealWorld e))+ deriving (Typeable)++instance (Eq i, Eq e) => Eq (TArray i e) where+ (TArray l1 u1 n1 arr1#) == (TArray l2 u2 n2 arr2#) =+ -- each `TArray` has its own `TVar`s, so it's sufficient to compare the first one+ if n1 == 0 then n2 == 0 else l1 == l2 && u1 == u2 && isTrue# (sameTVar# (unsafeFirstT arr1#) (unsafeFirstT arr2#))+ where+ unsafeFirstT :: Array# (TVar# RealWorld e) -> TVar# RealWorld e+ unsafeFirstT arr# = case indexArray# arr# 0# of (# e #) -> e++newTArray# :: Ix i => (i, i) -> e -> State# RealWorld -> (# State# RealWorld, TArray i e #)+newTArray# b@(l, u) e = \s1# ->+ case safeRangeSize b of+ n@(I# n#) -> case newTVar# e s1# of+ (# s2#, initial_tvar# #) -> case newArray# n# initial_tvar# s2# of+ (# s3#, marr# #) ->+ let go i# = \s4# -> case newTVar# e s4# of+ (# s5#, tvar# #) -> case writeArray# marr# i# tvar# s5# of+ s6# -> if isTrue# (i# ==# n# -# 1#) then s6# else go (i# +# 1#) s6#+ in case unsafeFreezeArray# marr# (if n <= 1 then s3# else go 1# s3#) of+ (# s7#, arr# #) -> (# s7#, TArray l u n arr# #)++instance MArray TArray e STM where+ getBounds (TArray l u _ _) = return (l, u)+ getNumElements (TArray _ _ n _) = return n+ newArray b e = STM $ newTArray# b e+ unsafeRead (TArray _ _ _ arr#) (I# i#) = case indexArray# arr# i# of+ (# tvar# #) -> readTVar (TVar tvar#)+ unsafeWrite (TArray _ _ _ arr#) (I# i#) e = case indexArray# arr# i# of+ (# tvar# #) -> writeTVar (TVar tvar#) e++-- | Writes are slow in `IO`.+instance MArray TArray e IO where+ getBounds (TArray l u _ _) = return (l, u)+ getNumElements (TArray _ _ n _) = return n+ newArray b e = IO $ newTArray# b e+ unsafeRead (TArray _ _ _ arr#) (I# i#) = case indexArray# arr# i# of+ (# tvar# #) -> readTVarIO (TVar tvar#)+ unsafeWrite (TArray _ _ _ arr#) (I# i#) e = case indexArray# arr# i# of+ (# tvar# #) -> atomically $ writeTVar (TVar tvar#) e+#else newtype TArray i e = TArray (Array i (TVar e)) deriving (Eq, Typeable) instance MArray TArray e STM where getBounds (TArray a) = return (bounds a)+ getNumElements (TArray a) = return (numElements a) newArray b e = do- a <- rep (rangeSize b) (newTVar e)- return $ TArray (listArray b a)- newArray_ b = do- a <- rep (rangeSize b) (newTVar arrEleBottom)+ a <- rep (safeRangeSize b) (newTVar e) return $ TArray (listArray b a) unsafeRead (TArray a) i = readTVar $ unsafeAt a i unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e++ {-# INLINE newArray #-}++-- | Writes are slow in `IO`.+instance MArray TArray e IO where+ getBounds (TArray a) = return (bounds a) getNumElements (TArray a) = return (numElements a)+ newArray b e = do+ a <- rep (safeRangeSize b) (newTVarIO e)+ return $ TArray (listArray b a)+ unsafeRead (TArray a) i = readTVarIO $ unsafeAt a i+ unsafeWrite (TArray a) i e = atomically $ writeTVar (unsafeAt a i) e --- | Like 'replicateM' but uses an accumulator to prevent stack overflows.--- Unlike 'replicateM' the returned list is in reversed order.+ {-# INLINE newArray #-}++-- | Like 'replicateM', but uses an accumulator to prevent stack overflows.+-- Unlike 'replicateM', the returned list is in reversed order. -- This doesn't matter though since this function is only used to create -- arrays with identical elements. rep :: Monad m => Int -> m a -> m [a]@@ -65,4 +131,5 @@ go 0 xs = return xs go i xs = do x <- m- go (i-1) (x:xs)+ go (i - 1) (x : xs)+#endif
Control/Concurrent/STM/TBQueue.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -18,33 +19,34 @@ -- -- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum -- capacity set when it is created. If the queue already contains the--- maximum number of elements, then 'writeTBQueue' blocks until an+-- maximum number of elements, then 'writeTBQueue' retries until an -- element is removed from the queue. ----- The implementation is based on the traditional purely-functional--- queue representation that uses two lists to obtain amortised /O(1)/+-- The implementation is based on an array to obtain /O(1)/ -- enqueue and dequeue operations. -- -- @since 2.4 ----------------------------------------------------------------------------- module Control.Concurrent.STM.TBQueue (- -- * TBQueue- TBQueue,- newTBQueue,- newTBQueueIO,- readTBQueue,- tryReadTBQueue,- flushTBQueue,- peekTBQueue,- tryPeekTBQueue,- writeTBQueue,- unGetTBQueue,- lengthTBQueue,- isEmptyTBQueue,- isFullTBQueue,+ -- * TBQueue+ TBQueue,+ newTBQueue,+ newTBQueueIO,+ readTBQueue,+ tryReadTBQueue,+ flushTBQueue,+ peekTBQueue,+ tryPeekTBQueue,+ writeTBQueue,+ unGetTBQueue,+ lengthTBQueue,+ isEmptyTBQueue,+ isFullTBQueue,+ capacityTBQueue, ) where +import Control.Monad (unless) import Data.Typeable (Typeable) import GHC.Conc (STM, TVar, newTVar, newTVarIO, orElse, readTVar, retry, writeTVar)@@ -89,7 +91,7 @@ wsize <- newTVar size return (TBQueue rsize read wsize write size) --- |@IO@ version of 'newTBQueue'. This is useful for creating top-level+-- | @IO@ version of 'newTBQueue'. This is useful for creating top-level -- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible.@@ -143,7 +145,7 @@ -- | A version of 'readTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTBQueue :: TBQueue a -> STM (Maybe a)-tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing+tryReadTBQueue q = fmap Just (readTBQueue q) `orElse` return Nothing -- | Efficiently read the entire contents of a 'TBQueue' into a list. This -- function never retries.@@ -156,8 +158,8 @@ if null xs && null ys then return [] else do- writeTVar read []- writeTVar write []+ unless (null xs) $ writeTVar read []+ unless (null ys) $ writeTVar write [] writeTVar rsize 0 writeTVar wsize size return (xs ++ reverse ys)@@ -191,7 +193,7 @@ unGetTBQueue c x return m --- |Put a data item back onto a channel, where it will be the next item read.+-- | Put a data item back onto a channel, where it will be the next item read. -- Blocks if the queue is full. unGetTBQueue :: TBQueue a -> a -> STM () unGetTBQueue (TBQueue rsize read wsize _write _size) a = do@@ -206,7 +208,7 @@ xs <- readTVar read writeTVar read (a:xs) --- |Return the length of a 'TBQueue'.+-- | Return the length of a 'TBQueue'. -- -- @since 2.5.0.0 lengthTBQueue :: TBQueue a -> STM Natural@@ -215,7 +217,7 @@ w <- readTVar wsize return $! size - r - w --- |Returns 'True' if the supplied 'TBQueue' is empty.+-- | Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do xs <- readTVar read@@ -226,7 +228,7 @@ [] -> return True _ -> return False --- |Returns 'True' if the supplied 'TBQueue' is full.+-- | Returns 'True' if the supplied 'TBQueue' is full. -- -- @since 2.4.3 isFullTBQueue :: TBQueue a -> STM Bool@@ -239,3 +241,9 @@ if (r > 0) then return False else return True++-- | The maximum number of elements the queue can hold.+--+-- @since 2.5.2.0+capacityTBQueue :: TBQueue a -> Natural+capacityTBQueue (TBQueue _ _ _ _ cap) = fromIntegral cap
Control/Concurrent/STM/TMVar.hs view
@@ -30,6 +30,7 @@ takeTMVar, putTMVar, readTMVar,+ writeTMVar, tryReadTMVar, swapTMVar, tryTakeTMVar,@@ -147,6 +148,13 @@ case m of Nothing -> retry Just old -> do writeTVar t (Just new); return old++-- | Non-blocking write of a new value to a 'TMVar'+-- Puts if empty. Replaces if populated.+--+-- @since 2.5.1+writeTMVar :: TMVar a -> a -> STM ()+writeTMVar (TMVar t) new = writeTVar t (Just new) -- |Check whether a given 'TMVar' is empty. isEmptyTMVar :: TMVar a -> STM Bool
Control/Concurrent/STM/TVar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -73,7 +73,7 @@ stateTVar :: TVar s -> (s -> (a, s)) -> STM a stateTVar var f = do s <- readTVar var- let (a, s') = f s -- since we destructure this, we are strict in f+ let !(a, s') = f s writeTVar var s' return a {-# INLINE stateTVar #-}
Control/Monad/STM.hs view
@@ -68,7 +68,17 @@ #endif #endif +#if !MIN_VERSION_base(4,17,0)+import Control.Monad (liftM2)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..))+#endif+#endif + #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) instance MonadPlus STM where@@ -137,3 +147,14 @@ let ans = liftSTM (k r) s STMret _ r = ans in case ans of STMret s' x -> (# s', x #)++#if !MIN_VERSION_base(4,17,0)+instance Semigroup a => Semigroup (STM a) where+ (<>) = liftM2 (<>)++instance Monoid a => Monoid (STM a) where+ mempty = return mempty+#if !MIN_VERSION_base(4,13,0)+ mappend = liftM2 mappend+#endif+#endif
changelog.md view
@@ -1,5 +1,32 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) +## 2.5.3.1 *November 2023*++ * Drop unused testcase inadvertently introduced in previous reversion++## 2.5.3.0 *November 2023*++ * Revert array-based reimplementation of `TBQueue` due to [#76](https://github.com/haskell/stm/issues/76)++## 2.5.2.1 *September 2023*++ * Eliminate reliance on undefined CPP behavior ([#75](https://github.com/haskell/stm/issues/75))++## 2.5.2.0 *September 2023*++ * Fix strictness of `stateTVar` ([#30](https://github.com/haskell/stm/ssues/30))+ * Rewrite `TBQueue` to use a more-efficient array-based representation ([#65](https://github.com/haskell/stm/issues/65))+ * `newTBQueue 0` now fails as one would expect ([#28](https://github.com/haskell/stm/issues/28))+ * Add `capacityTBQueue` ([#61](https://github.com/haskell/stm/issues/61))+ * Add `MArray TArray e IO` instance+ * Use unlifted `Array#` for `TArray` ([#66](https://github.com/haskell/stm/pull/66))++## 2.5.1.0 *Aug 2022*++ * Teach `flushTBQueue` to only flush queue when necessary+ * Introduce `Control.Concurrent.STM.TMVar.writeTMVar`+ * Add `Semigroup` and `Monoid` instances for `STM`+ ## 2.5.0.2 *Dec 2021* * Fix non-exhaustive patterns warning (#49)@@ -29,7 +56,7 @@ * Fix incorrect bookkeeping of write capacity in `flushTBQueue` (gh-9) - * Avoid redundant `writeTVar`s in `flushTQueue` to avoid unncessarily+ * Avoid redundant `writeTVar`s in `flushTQueue` to avoid unnecessarily invalidating other transactions (gh-6) ### 2.4.5.0 *Feb 2018*
stm.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: stm-version: 2.5.0.2+version: 2.5.3.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.10.*, 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.*+tested-with: GHC==9.6.2, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 description: Software Transactional Memory, or STM, is an abstraction for concurrent communication. The main benefits of STM are@@ -49,8 +49,11 @@ if !impl(ghc >= 7.10) build-depends: nats (>= 0.1.3 && < 0.3) || (>= 1 && < 1.2) + if !impl(ghc >= 8.0)+ build-depends: semigroups >=0.18.6 && <0.21+ build-depends:- base >= 4.3 && < 4.17,+ base >= 4.4 && < 4.21, array >= 0.3 && < 0.6 exposed-modules:
testsuite/testsuite.cabal view
@@ -6,7 +6,7 @@ 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.*+tested-with: GHC==9.6.2, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 description: This testsuite is intended to be compatible with different versions of `stm` (via use of @CPP@ if needed) in order to more easily@@ -36,7 +36,7 @@ -- build-depends:- , base >= 4.3 && < 4.17+ , base >= 4.4 && < 4.20 , test-framework ^>= 0.8.2.0 , test-framework-hunit ^>= 0.3.0.2 , HUnit ^>= 1.6.0.0