stm 2.4.4.1 → 2.5.3.1
raw patch · 20 files changed
Files
- Control/Concurrent/STM.hs +3/−3
- Control/Concurrent/STM/TArray.hs +89/−22
- Control/Concurrent/STM/TBQueue.hs +107/−55
- Control/Concurrent/STM/TChan.hs +6/−0
- Control/Concurrent/STM/TMVar.hs +10/−0
- Control/Concurrent/STM/TQueue.hs +42/−15
- Control/Concurrent/STM/TSem.hs +58/−6
- Control/Concurrent/STM/TVar.hs +21/−1
- Control/Monad/STM.hs +40/−6
- Control/Sequential/STM.hs +2/−0
- README.md +4/−0
- changelog.md +78/−4
- stm.cabal +27/−8
- 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
Control/Concurrent/STM.hs view
@@ -20,9 +20,9 @@ -- abstraction. See -- -- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon--- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles--- and Practice of Parallel Programming/ 2005.--- <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>+-- Peyton Jones, and Maurice Herlihy, in+-- /ACM Conference on Principles and Practice of Parallel Programming/ 2005.+-- <https://www.microsoft.com/en-us/research/publication/composable-memory-transactions/> -- -----------------------------------------------------------------------------
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,8 +1,10 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,48 +19,53 @@ -- -- '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,- peekTBQueue,- tryPeekTBQueue,- writeTBQueue,- unGetTBQueue,- isEmptyTBQueue,- isFullTBQueue,+ -- * TBQueue+ TBQueue,+ newTBQueue,+ newTBQueueIO,+ readTBQueue,+ tryReadTBQueue,+ flushTBQueue,+ peekTBQueue,+ tryPeekTBQueue,+ writeTBQueue,+ unGetTBQueue,+ lengthTBQueue,+ isEmptyTBQueue,+ isFullTBQueue,+ capacityTBQueue, ) where -import Data.Typeable-import GHC.Conc--#define _UPK_(x) {-# UNPACK #-} !(x)+import Control.Monad (unless)+import Data.Typeable (Typeable)+import GHC.Conc (STM, TVar, newTVar, newTVarIO, orElse,+ readTVar, retry, writeTVar)+import Numeric.Natural (Natural)+import Prelude hiding (read) -- | 'TBQueue' is an abstract type representing a bounded FIFO channel. -- -- @since 2.4 data TBQueue a- = TBQueue _UPK_(TVar Int) -- CR: read capacity- _UPK_(TVar [a]) -- R: elements waiting to be read- _UPK_(TVar Int) -- CW: write capacity- _UPK_(TVar [a]) -- W: elements written (head is most recent)+ = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR: read capacity+ {-# UNPACK #-} !(TVar [a]) -- R: elements waiting to be read+ {-# UNPACK #-} !(TVar Natural) -- CW: write capacity+ {-# UNPACK #-} !(TVar [a]) -- W: elements written (head is most recent)+ !(Natural) -- CAP: initial capacity deriving Typeable instance Eq (TBQueue a) where- TBQueue a _ _ _ == TBQueue b _ _ _ = a == b+ TBQueue a _ _ _ _ == TBQueue b _ _ _ _ = a == b -- Total channel capacity remaining is CR + CW. Reads only need to -- access CR, writes usually need to access only CW but sometimes need@@ -74,49 +81,49 @@ -- then CW := CR - 1; CR := 0 -- else **FULL** --- |Build and returns a new instance of 'TBQueue'-newTBQueue :: Int -- ^ maximum number of elements the queue can hold+-- | Builds and returns a new instance of 'TBQueue'.+newTBQueue :: Natural -- ^ maximum number of elements the queue can hold -> STM (TBQueue a) newTBQueue size = do read <- newTVar [] write <- newTVar [] rsize <- newTVar 0 wsize <- newTVar size- return (TBQueue rsize read wsize write)+ 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.-newTBQueueIO :: Int -> IO (TBQueue a)+newTBQueueIO :: Natural -> IO (TBQueue a) newTBQueueIO size = do read <- newTVarIO [] write <- newTVarIO [] rsize <- newTVarIO 0 wsize <- newTVarIO size- return (TBQueue rsize read wsize write)+ return (TBQueue rsize read wsize write size) -- |Write a value to a 'TBQueue'; blocks if the queue is full. writeTBQueue :: TBQueue a -> a -> STM ()-writeTBQueue (TBQueue rsize _read wsize write) a = do+writeTBQueue (TBQueue rsize _read wsize write _size) a = do w <- readTVar wsize- if (w /= 0)- then do writeTVar wsize (w - 1)+ if (w > 0)+ then do writeTVar wsize $! w - 1 else do r <- readTVar rsize- if (r /= 0)+ if (r > 0) then do writeTVar rsize 0- writeTVar wsize (r - 1)+ writeTVar wsize $! r - 1 else retry listend <- readTVar write writeTVar write (a:listend) -- |Read the next value from the 'TBQueue'. readTBQueue :: TBQueue a -> STM a-readTBQueue (TBQueue rsize read _wsize write) = do+readTBQueue (TBQueue rsize read _wsize write _size) = do xs <- readTVar read r <- readTVar rsize- writeTVar rsize (r + 1)+ writeTVar rsize $! r + 1 case xs of (x:xs') -> do writeTVar read xs'@@ -126,8 +133,11 @@ case ys of [] -> retry _ -> do- let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be- -- short, otherwise it will conflict+ -- NB. lazy: we want the transaction to be+ -- short, otherwise it will conflict+ let ~(z,zs) = case reverse ys of+ z':zs' -> (z',zs')+ _ -> error "readTBQueue: impossible" writeTVar write [] writeTVar read zs return z@@ -135,15 +145,42 @@ -- | 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.+--+-- @since 2.4.5+flushTBQueue :: TBQueue a -> STM [a]+flushTBQueue (TBQueue rsize read wsize write size) = do+ xs <- readTVar read+ ys <- readTVar write+ if null xs && null ys+ then return []+ else do+ unless (null xs) $ writeTVar read []+ unless (null ys) $ writeTVar write []+ writeTVar rsize 0+ writeTVar wsize size+ return (xs ++ reverse ys)+ -- | 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.@@ -156,24 +193,33 @@ 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) a = do+unGetTBQueue (TBQueue rsize read wsize _write _size) a = do r <- readTVar rsize if (r > 0)- then do writeTVar rsize (r - 1)+ then do writeTVar rsize $! r - 1 else do w <- readTVar wsize if (w > 0)- then writeTVar wsize (w - 1)+ then writeTVar wsize $! w - 1 else retry xs <- readTVar read writeTVar read (a:xs) --- |Returns 'True' if the supplied 'TBQueue' is empty.+-- | Return the length of a 'TBQueue'.+--+-- @since 2.5.0.0+lengthTBQueue :: TBQueue a -> STM Natural+lengthTBQueue (TBQueue rsize _read wsize _write size) = do+ r <- readTVar rsize+ w <- readTVar wsize+ return $! size - r - w++-- | Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool-isEmptyTBQueue (TBQueue _rsize read _wsize write) = do+isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do xs <- readTVar read case xs of (_:_) -> return False@@ -182,11 +228,11 @@ [] -> 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-isFullTBQueue (TBQueue rsize _read wsize _write) = do+isFullTBQueue (TBQueue rsize _read wsize _write _size) = do w <- readTVar wsize if (w > 0) then return False@@ -195,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/TChan.hs view
@@ -135,6 +135,8 @@ -- | A version of 'readTChan' which does not retry. Instead it -- returns @Nothing@ if no value is available.+--+-- @since 2.3 tryReadTChan :: TChan a -> STM (Maybe a) tryReadTChan (TChan read _write) = do listhead <- readTVar read@@ -147,6 +149,8 @@ -- | Get the next value from the @TChan@ without removing it, -- retrying if the channel is empty.+--+-- @since 2.3 peekTChan :: TChan a -> STM a peekTChan (TChan read _write) = do listhead <- readTVar read@@ -157,6 +161,8 @@ -- | A version of 'peekTChan' which does not retry. Instead it -- returns @Nothing@ if no value is available.+--+-- @since 2.3 tryPeekTChan :: TChan a -> STM (Maybe a) tryPeekTChan (TChan read _write) = do listhead <- readTVar read
Control/Concurrent/STM/TMVar.hs view
@@ -30,6 +30,7 @@ takeTMVar, putTMVar, readTMVar,+ writeTMVar, tryReadTMVar, swapTMVar, tryTakeTMVar,@@ -135,6 +136,8 @@ -- | A version of 'readTMVar' which does not retry. Instead it -- returns @Nothing@ if no value is available.+--+-- @since 2.3 tryReadTMVar :: TMVar a -> STM (Maybe a) tryReadTMVar (TMVar t) = readTVar t @@ -145,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/TQueue.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701@@ -38,6 +39,7 @@ newTQueueIO, readTQueue, tryReadTQueue,+ flushTQueue, peekTQueue, tryPeekTQueue, writeTQueue,@@ -46,7 +48,7 @@ ) where import GHC.Conc-+import Control.Monad (unless) import Data.Typeable (Typeable) -- | 'TQueue' is an abstract type representing an unbounded FIFO channel.@@ -87,29 +89,54 @@ readTQueue (TQueue read write) = do xs <- readTVar read case xs of- (x:xs') -> do writeTVar read xs'- return x- [] -> do ys <- readTVar write- case ys of- [] -> retry- _ -> case reverse ys of- [] -> error "readTQueue"- (z:zs) -> do writeTVar write []- writeTVar read zs- return z+ (x:xs') -> do+ writeTVar read xs'+ 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 'readTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTQueue :: TQueue a -> STM (Maybe a) tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing +-- | Efficiently read the entire contents of a 'TQueue' into a list. This+-- function never retries.+--+-- @since 2.4.5+flushTQueue :: TQueue a -> STM [a]+flushTQueue (TQueue read write) = do+ xs <- readTVar read+ ys <- readTVar write+ unless (null xs) $ writeTVar read []+ unless (null ys) $ writeTVar write []+ return (xs ++ reverse ys)+ -- | 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.
Control/Concurrent/STM/TSem.hs view
@@ -3,7 +3,7 @@ -- Module : Control.Concurrent.STM.TSem -- Copyright : (c) The University of Glasgow 2012 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -14,13 +14,20 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-}-module Control.Concurrent.STM.TSem (- TSem, newTSem, waitTSem, signalTSem+module Control.Concurrent.STM.TSem+ ( TSem+ , newTSem++ , waitTSem++ , signalTSem+ , signalTSemN ) where import Control.Concurrent.STM import Control.Monad import Data.Typeable+import Numeric.Natural -- | 'TSem' is a transactional semaphore. It holds a certain number -- of units, and units may be acquired or released by 'waitTSem' and@@ -36,20 +43,65 @@ -- composable. -- -- @since 2.4.2-newtype TSem = TSem (TVar Int)+newtype TSem = TSem (TVar Integer) deriving (Eq, Typeable) -newTSem :: Int -> STM TSem-newTSem i = fmap TSem (newTVar i)+-- | Construct new 'TSem' with an initial counter value.+--+-- A positive initial counter value denotes availability of+-- units 'waitTSem' can acquire.+--+-- The initial counter value can be negative which denotes a resource+-- \"debt\" that requires a respective amount of 'signalTSem'+-- operations to counter-balance.+--+-- @since 2.4.2+newTSem :: Integer -> STM TSem+newTSem i = fmap TSem (newTVar $! i) +-- NOTE: we can't expose a good `TSem -> STM Int' operation as blocked+-- 'waitTSem' aren't reliably reflected in a negative counter value.++-- | Wait on 'TSem' (aka __P__ operation).+--+-- This operation acquires a unit from the semaphore (i.e. decreases+-- the internal counter) and blocks (via 'retry') if no units are+-- available (i.e. if the counter is /not/ positive).+--+-- @since 2.4.2 waitTSem :: TSem -> STM () waitTSem (TSem t) = do i <- readTVar t when (i <= 0) retry writeTVar t $! (i-1) ++-- Alternatively, the implementation could block (via 'retry') when+-- the next increment would overflow, i.e. testing for 'maxBound'++-- | Signal a 'TSem' (aka __V__ operation).+--+-- This operation adds\/releases a unit back to the semaphore+-- (i.e. increments the internal counter).+--+-- @since 2.4.2 signalTSem :: TSem -> STM () signalTSem (TSem t) = do i <- readTVar t writeTVar t $! i+1 ++-- | Multi-signal a 'TSem'+--+-- This operation adds\/releases multiple units back to the semaphore+-- (i.e. increments the internal counter).+--+-- > signalTSem == signalTSemN 1+--+-- @since 2.4.5+signalTSemN :: Natural -> TSem -> STM ()+signalTSemN 0 _ = return ()+signalTSemN 1 s = signalTSem s+signalTSemN n (TSem t) = do+ i <- readTVar t+ writeTVar t $! i+(toInteger n)
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 #-}@@ -28,6 +28,7 @@ writeTVar, modifyTVar, modifyTVar',+ stateTVar, swapTVar, #ifdef __GLASGOW_HASKELL__ registerDelay,@@ -46,6 +47,8 @@ -- Like 'modifyIORef' but for 'TVar'. -- | Mutate the contents of a 'TVar'. /N.B./, this version is -- non-strict.+--+-- @since 2.3 modifyTVar :: TVar a -> (a -> a) -> STM () modifyTVar var f = do x <- readTVar var@@ -54,6 +57,8 @@ -- | Strict version of 'modifyTVar'.+--+-- @since 2.3 modifyTVar' :: TVar a -> (a -> a) -> STM () modifyTVar' var f = do x <- readTVar var@@ -61,8 +66,23 @@ {-# INLINE modifyTVar' #-} +-- | Like 'modifyTVar'' but the function is a simple state transition that can+-- return a side value which is passed on as the result of the 'STM'.+--+-- @since 2.5.0+stateTVar :: TVar s -> (s -> (a, s)) -> STM a+stateTVar var f = do+ s <- readTVar var+ let !(a, s') = f s+ writeTVar var s'+ return a+{-# INLINE stateTVar #-}++ -- Like 'swapTMVar' but for 'TVar'. -- | Swap the contents of a 'TVar' for a new value.+--+-- @since 2.3 swapTVar :: TVar a -> a -> STM a swapTVar var new = do old <- readTVar var
Control/Monad/STM.hs view
@@ -19,20 +19,26 @@ -- abstraction. See -- -- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon--- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles--- and Practice of Parallel Programming/ 2005.--- <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>+-- Peyton Jones, and Maurice Herlihy, in+-- /ACM Conference on Principles and Practice of Parallel Programming/ 2005.+-- <https://www.microsoft.com/en-us/research/publication/composable-memory-transactions/> -- -- This module only defines the 'STM' monad; you probably want to -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM").+--+-- Note that invariant checking (namely the @always@ and @alwaysSucceeds@+-- functions) has been removed. See ticket [#14324](https://ghc.haskell.org/trac/ghc/ticket/14324) and+-- the [removal proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst).+-- Existing users are encouraged to encapsulate their STM operations in safe+-- abstractions which can perform the invariant checking without help from the+-- runtime system.+ ----------------------------------------------------------------------------- module Control.Monad.STM ( STM, atomically, #ifdef __GLASGOW_HASKELL__- always,- alwaysSucceeds, retry, orElse, check,@@ -62,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@@ -78,6 +94,11 @@ (<|>) = orElse #endif +-- | Check that the boolean condition is true and, if not, 'retry'.+--+-- In other words, @check b = unless b retry@.+--+-- @since 2.1.1 check :: Bool -> STM () check b = if b then return () else retry #endif@@ -94,7 +115,8 @@ -- | A variant of 'throw' that can only be used within the 'STM' monad. -- -- Throwing an exception in @STM@ aborts the transaction and propagates the--- exception.+-- exception. (Note: Allocation effects, such as 'newTVar' are not rolled back+-- when this happens. All other effects are discarded. See <https://gitlab.haskell.org/ghc/ghc/-/issues/18453 ghc#18453.>) -- -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the -- two functions are subtly different:@@ -119,8 +141,20 @@ liftSTM :: STM a -> State# RealWorld -> STMret a liftSTM (STM m) = \s -> case m s of (# s', r #) -> STMret s' r +-- | @since 2.3 instance MonadFix STM where mfix k = STM $ \s -> 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
Control/Sequential/STM.hs view
@@ -51,6 +51,7 @@ rollback <- readIORef r rollback +-- | @since 2.2.0 throwSTM :: Exception e => e -> STM a throwSTM = STM . const . throwIO @@ -83,6 +84,7 @@ readTVar :: TVar a -> STM a readTVar (TVar ref) = STM (const (readIORef ref)) +-- | @since 2.1.2 readTVarIO :: TVar a -> IO a readTVarIO (TVar ref) = readIORef ref
+ README.md view
@@ -0,0 +1,4 @@+The `stm` Package [](https://travis-ci.org/haskell/stm)+=================++See [`stm` on Hackage](http://hackage.haskell.org/package/stm) for more information.
changelog.md view
@@ -1,12 +1,86 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) -## 2.4.4.1 *Dec 2015*+## 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)++ * Document particulars of effect-rollback of `Control.Monad.STM.throwSTM` (#32)++## 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)++ * Add `lengthTBQueue` to `Control.Concurrent.STM.TBQueue` (gh-9)++ * Add `stateTVar :: TVar s -> (s -> (a, s)) -> STM a` combinator (gh-14)++ * Switched `newTBQueue` and `newTBQueueIO` to accept `Natural` as size (gh-17)++ * Switched `signalTSemN` and `newTSem` to accept `Natural` and `Integer` respectively (gh-17)++----++#### 2.4.5.1 *Sep 2018*++ * Fix incorrect bookkeeping of write capacity in `flushTBQueue` (gh-9)++ * Avoid redundant `writeTVar`s in `flushTQueue` to avoid unnecessarily+ invalidating other transactions (gh-6)++### 2.4.5.0 *Feb 2018*++ * Fix space leak in `TBQueue` (gh-2, GHC#14494)++ * Make `signalTSem` resilient against `Int` overflows (gh-4)++ * Make definition of `readTQueue` consistent with `readTBQueue` (gh-3, GHC#9539)++ * Add `flushTQueue` to `Control.Concurrent.STM.TQueue` (gh-1)++ * Add `flushTBQueue` to `Control.Concurrent.STM.TBQueue` (gh-1)++ * Add `signalTSemN` operation (gh-5)+++#### 2.4.4.1 *Dec 2015*+ * Add support for `base-4.9.0.0` * Drop support for GHC 6.12 / `base-4.2` -## 2.4.4 *Dec 2014*+### 2.4.4 *Dec 2014* * Add support for `base-4.8.0.0` @@ -16,7 +90,7 @@ * Add `@since`-annotations -## 2.4.3 *Mar 2014*+### 2.4.3 *Mar 2014* * Update behaviour of `newBroadcastTChanIO` to match `newBroadcastTChan` in causing an error on a read from the@@ -31,7 +105,7 @@ * Update to Cabal 1.10 format -## 2.4.2 *Nov 2012*+### 2.4.2 *Nov 2012* * Add `Control.Concurrent.STM.TSem` (transactional semaphore)
stm.cabal view
@@ -1,23 +1,36 @@+cabal-version: >=1.10 name: stm-version: 2.4.4.1+version: 2.5.3.1 -- don't forget to update changelog.md file!+ license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org-bug-reports: https://ghc.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29&keywords=stm+homepage: https://wiki.haskell.org/Software_transactional_memory+bug-reports: https://github.com/haskell/stm/issues synopsis: Software Transactional Memory category: Concurrency-description: A modular composable concurrency abstraction. build-type: Simple-cabal-version: >=1.10-tested-with: 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:+ Software Transactional Memory, or STM, is an abstraction for+ concurrent communication. The main benefits of STM are+ /composability/ and /modularity/. That is, using STM you can write+ concurrent abstractions that can be easily composed with any other+ abstraction built using STM, without exposing the details of how+ your abstraction ensures safety. This is typically not the case+ with other forms of concurrent communication, such as locks or+ 'MVar's. extra-source-files: changelog.md+ README.md+ testsuite/src/*.hs+ testsuite/testsuite.cabal source-repository head type: git- location: http://git.haskell.org/packages/stm.git+ location: https://github.com/haskell/stm.git library default-language: Haskell2010@@ -33,8 +46,14 @@ if impl(ghc >= 7.9) other-extensions: Safe + 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.10,+ base >= 4.4 && < 4.21, array >= 0.3 && < 0.6 exposed-modules:@@ -50,4 +69,4 @@ other-modules: Control.Sequential.STM - ghc-options: -Wall+ ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
+ testsuite/src/Issue17.hs view
@@ -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"
+ testsuite/src/Issue9.hs view
@@ -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
+ testsuite/src/Main.hs view
@@ -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+ ]+ ]+
+ testsuite/src/Stm052.hs view
@@ -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"
+ testsuite/src/Stm064.hs view
@@ -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
+ testsuite/src/Stm065.hs view
@@ -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)
+ testsuite/testsuite.cabal view
@@ -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==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+ 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.4 && < 4.20+ , 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