stm 2.3 → 2.5.3.1
raw patch · 20 files changed
Files
- Control/Concurrent/STM.hs +16/−10
- Control/Concurrent/STM/TArray.hs +89/−22
- Control/Concurrent/STM/TBQueue.hs +249/−0
- Control/Concurrent/STM/TChan.hs +82/−19
- Control/Concurrent/STM/TMVar.hs +38/−17
- Control/Concurrent/STM/TQueue.hs +167/−0
- Control/Concurrent/STM/TSem.hs +107/−0
- Control/Concurrent/STM/TVar.hs +44/−18
- Control/Monad/STM.hs +65/−15
- Control/Sequential/STM.hs +22/−32
- README.md +4/−0
- changelog.md +128/−0
- stm.cabal +65/−28
- 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
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif @@ -9,7 +11,7 @@ -- Module : Control.Concurrent.STM -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -18,20 +20,22 @@ -- 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/> -- ----------------------------------------------------------------------------- module Control.Concurrent.STM (- module Control.Monad.STM,- module Control.Concurrent.STM.TVar,+ module Control.Monad.STM,+ module Control.Concurrent.STM.TVar, #ifdef __GLASGOW_HASKELL__- module Control.Concurrent.STM.TMVar,- module Control.Concurrent.STM.TChan,+ module Control.Concurrent.STM.TMVar,+ module Control.Concurrent.STM.TChan,+ module Control.Concurrent.STM.TQueue,+ module Control.Concurrent.STM.TBQueue, #endif- module Control.Concurrent.STM.TArray+ module Control.Concurrent.STM.TArray ) where import Control.Monad.STM@@ -41,3 +45,5 @@ import Control.Concurrent.STM.TChan #endif import Control.Concurrent.STM.TArray+import Control.Concurrent.STM.TQueue+import Control.Concurrent.STM.TBQueue
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
@@ -0,0 +1,249 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.STM.TBQueue+-- 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)+--+-- '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' retries until an+-- element is removed from the queue.+--+-- 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,+ capacityTBQueue,+ ) where++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 {-# 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++-- Total channel capacity remaining is CR + CW. Reads only need to+-- access CR, writes usually need to access only CW but sometimes need+-- CR. So in the common case we avoid contention between CR and CW.+--+-- - when removing an element from R:+-- CR := CR + 1+--+-- - when adding an element to W:+-- if CW is non-zero+-- then CW := CW - 1+-- then if CR is non-zero+-- then CW := CR - 1; CR := 0+-- else **FULL**++-- | 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 size)++-- | @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 :: Natural -> IO (TBQueue a)+newTBQueueIO size = do+ read <- newTVarIO []+ write <- newTVarIO []+ rsize <- newTVarIO 0+ wsize <- newTVarIO size+ 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 _size) a = do+ w <- readTVar wsize+ if (w > 0)+ then do writeTVar wsize $! w - 1+ else do+ r <- readTVar rsize+ if (r > 0)+ then do writeTVar rsize 0+ 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 _size) = do+ xs <- readTVar read+ r <- readTVar rsize+ writeTVar rsize $! r + 1+ case xs of+ (x:xs') -> do+ writeTVar read xs'+ return x+ [] -> do+ ys <- readTVar write+ case ys of+ [] -> retry+ _ -> do+ -- 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++-- | A version of 'readTBQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTBQueue :: TBQueue a -> STM (Maybe a)+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 (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.+tryPeekTBQueue :: TBQueue a -> STM (Maybe a)+tryPeekTBQueue c = do+ m <- tryReadTBQueue c+ case m of+ Nothing -> return Nothing+ Just x -> do+ unGetTBQueue c x+ return m++-- | 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+ r <- readTVar rsize+ if (r > 0)+ then do writeTVar rsize $! r - 1+ else do+ w <- readTVar wsize+ if (w > 0)+ then writeTVar wsize $! w - 1+ else retry+ xs <- readTVar read+ writeTVar read (a:xs)++-- | 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 _size) = do+ xs <- readTVar read+ case xs of+ (_:_) -> return False+ [] -> do ys <- readTVar write+ case ys of+ [] -> return True+ _ -> return False++-- | Returns 'True' if the supplied 'TBQueue' is full.+--+-- @since 2.4.3+isFullTBQueue :: TBQueue a -> STM Bool+isFullTBQueue (TBQueue rsize _read wsize _write _size) = do+ w <- readTVar wsize+ if (w > 0)+ then return False+ else do+ r <- readTVar rsize+ 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
@@ -10,7 +10,7 @@ -- Module : Control.Concurrent.STM.TChan -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -22,18 +22,25 @@ module Control.Concurrent.STM.TChan ( #ifdef __GLASGOW_HASKELL__- -- * TChans- TChan,- newTChan,- newTChanIO,- readTChan,- tryReadTChan,- peekTChan,- tryPeekTChan,- writeTChan,- dupTChan,- unGetTChan,- isEmptyTChan+ -- * TChans+ TChan,++ -- ** Construction+ newTChan,+ newTChanIO,+ newBroadcastTChan,+ newBroadcastTChanIO,+ dupTChan,+ cloneTChan,++ -- ** Reading and writing+ readTChan,+ tryReadTChan,+ peekTChan,+ tryPeekTChan,+ writeTChan,+ unGetTChan,+ isEmptyTChan #endif ) where @@ -42,13 +49,17 @@ import Data.Typeable (Typeable) +#define _UPK_(x) {-# UNPACK #-} !(x)+ -- | 'TChan' is an abstract type representing an unbounded FIFO channel.-data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a)) deriving Typeable+data TChan a = TChan _UPK_(TVar (TVarList a))+ _UPK_(TVar (TVarList a))+ deriving (Eq, Typeable) type TVarList a = TVar (TList a)-data TList a = TNil | TCons a (TVarList a)+data TList a = TNil | TCons a _UPK_(TVarList a) --- |Build and returns a new instance of 'TChan'+-- |Build and return a new instance of 'TChan' newTChan :: STM (TChan a) newTChan = do hole <- newTVar TNil@@ -67,6 +78,42 @@ write <- newTVarIO hole return (TChan read write) +-- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry'+-- even after items have been written to the channel. The only way to read+-- a broadcast channel is to duplicate it with 'dupTChan'.+--+-- Consider a server that broadcasts messages to clients:+--+-- >serve :: TChan Message -> Client -> IO loop+-- >serve broadcastChan client = do+-- > myChan <- dupTChan broadcastChan+-- > forever $ do+-- > message <- readTChan myChan+-- > send client message+--+-- The problem with using 'newTChan' to create the broadcast channel is that if+-- it is only written to and never read, items will pile up in memory. By+-- using 'newBroadcastTChan' to create the broadcast channel, items can be+-- garbage collected after clients have seen them.+--+-- @since 2.4+newBroadcastTChan :: STM (TChan a)+newBroadcastTChan = do+ write_hole <- newTVar TNil+ read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")+ write <- newTVar write_hole+ return (TChan read write)++-- | @IO@ version of 'newBroadcastTChan'.+--+-- @since 2.4+newBroadcastTChanIO :: IO (TChan a)+newBroadcastTChanIO = do+ write_hole <- newTVarIO TNil+ read <- newTVarIO (error "reading from a TChan created by newBroadcastTChanIO; use dupTChan first")+ write <- newTVarIO write_hole+ return (TChan read write)+ -- |Write a value to a 'TChan'. writeTChan :: TChan a -> a -> STM () writeTChan (TChan _read write) a = do@@ -83,11 +130,13 @@ case head of TNil -> retry TCons a tail -> do- writeTVar read tail- return a+ writeTVar read tail+ return a -- | 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@@ -100,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@@ -110,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@@ -124,7 +177,7 @@ -- everyone else. dupTChan :: TChan a -> STM (TChan a) dupTChan (TChan _read write) = do- hole <- readTVar write + hole <- readTVar write new_read <- newTVar hole return (TChan new_read write) @@ -143,4 +196,14 @@ case head of TNil -> return True TCons _ _ -> return False++-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the+-- same content available as the original channel.+--+-- @since 2.4+cloneTChan :: TChan a -> STM (TChan a)+cloneTChan (TChan read write) = do+ readpos <- readTVar read+ new_read <- newTVar readpos+ return (TChan new_read write) #endif
Control/Concurrent/STM/TMVar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -9,7 +9,7 @@ -- Module : Control.Concurrent.STM.TMVar -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -21,25 +21,29 @@ module Control.Concurrent.STM.TMVar ( #ifdef __GLASGOW_HASKELL__- -- * TMVars- TMVar,- newTMVar,- newEmptyTMVar,- newTMVarIO,- newEmptyTMVarIO,- takeTMVar,- putTMVar,- readTMVar, - tryReadTMVar,- swapTMVar,- tryTakeTMVar,- tryPutTMVar,- isEmptyTMVar+ -- * TMVars+ TMVar,+ newTMVar,+ newEmptyTMVar,+ newTMVarIO,+ newEmptyTMVarIO,+ takeTMVar,+ putTMVar,+ readTMVar,+ writeTMVar,+ tryReadTMVar,+ swapTMVar,+ tryTakeTMVar,+ tryPutTMVar,+ isEmptyTMVar,+ mkWeakTMVar #endif ) where #ifdef __GLASGOW_HASKELL__+import GHC.Base import GHC.Conc+import GHC.Weak import Data.Typeable (Typeable) @@ -81,7 +85,7 @@ return (TMVar t) -- |Return the contents of the 'TMVar'. If the 'TMVar' is currently--- empty, the transaction will 'retry'. After a 'takeTMVar', +-- empty, the transaction will 'retry'. After a 'takeTMVar', -- the 'TMVar' is left empty. takeTMVar :: TMVar a -> STM a takeTMVar (TMVar t) = do@@ -132,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 @@ -143,6 +149,13 @@ 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 isEmptyTMVar (TMVar t) = do@@ -150,4 +163,12 @@ case m of Nothing -> return True Just _ -> return False++-- | Make a 'Weak' pointer to a 'TMVar', using the second argument as+-- a finalizer to run when the 'TMVar' is garbage-collected.+--+-- @since 2.4.4+mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))+mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s ->+ case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #) #endif
+ Control/Concurrent/STM/TQueue.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.STM.TQueue+-- 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)+--+-- A 'TQueue' is like a 'TChan', with two important differences:+--+-- * it has faster throughput than both 'TChan' and 'Chan' (although+-- the costs are amortised, so the cost of individual operations+-- can vary a lot).+--+-- * it does /not/ provide equivalents of the 'dupTChan' and+-- 'cloneTChan' operations.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-- @since 2.4+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TQueue (+ -- * TQueue+ TQueue,+ newTQueue,+ newTQueueIO,+ readTQueue,+ tryReadTQueue,+ flushTQueue,+ peekTQueue,+ tryPeekTQueue,+ writeTQueue,+ unGetTQueue,+ isEmptyTQueue,+ ) where++import GHC.Conc+import Control.Monad (unless)+import Data.Typeable (Typeable)++-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.+--+-- @since 2.4+data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])+ {-# UNPACK #-} !(TVar [a])+ deriving Typeable++instance Eq (TQueue a) where+ TQueue a _ == TQueue b _ = a == b++-- |Build and returns a new instance of 'TQueue'+newTQueue :: STM (TQueue a)+newTQueue = do+ read <- newTVar []+ write <- newTVar []+ return (TQueue read write)++-- |@IO@ version of 'newTQueue'. This is useful for creating top-level+-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTQueueIO :: IO (TQueue a)+newTQueueIO = do+ read <- newTVarIO []+ write <- newTVarIO []+ return (TQueue read write)++-- |Write a value to a 'TQueue'.+writeTQueue :: TQueue a -> a -> STM ()+writeTQueue (TQueue _read write) a = do+ listend <- readTVar write+ writeTVar write (a:listend)++-- |Read the next value from the 'TQueue'.+readTQueue :: TQueue a -> STM a+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+ _ -> 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 (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.+tryPeekTQueue :: TQueue a -> STM (Maybe a)+tryPeekTQueue c = do+ m <- tryReadTQueue c+ case m of+ Nothing -> return Nothing+ Just x -> do+ unGetTQueue c x+ return m++-- |Put a data item back onto a channel, where it will be the next item read.+unGetTQueue :: TQueue a -> a -> STM ()+unGetTQueue (TQueue read _write) a = do+ xs <- readTVar read+ writeTVar read (a:xs)++-- |Returns 'True' if the supplied 'TQueue' is empty.+isEmptyTQueue :: TQueue a -> STM Bool+isEmptyTQueue (TQueue read write) = do+ xs <- readTVar read+ case xs of+ (_:_) -> return False+ [] -> do ys <- readTVar write+ case ys of+ [] -> return True+ _ -> return False
+ Control/Concurrent/STM/TSem.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- 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)+--+-- 'TSem': transactional semaphores.+--+-- @since 2.4.2+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+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+-- 'signalTSem' respectively. When the 'TSem' is empty, 'waitTSem'+-- blocks.+--+-- Note that 'TSem' has no concept of fairness, and there is no+-- guarantee that threads blocked in `waitTSem` will be unblocked in+-- the same order; in fact they will all be unblocked at the same time+-- and will fight over the 'TSem'. Hence 'TSem' is not suitable if+-- you expect there to be a high number of threads contending for the+-- resource. However, like other STM abstractions, 'TSem' is+-- composable.+--+-- @since 2.4.2+newtype TSem = TSem (TVar Integer)+ deriving (Eq, Typeable)++-- | 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 #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}@@ -9,7 +9,7 @@ -- Module : Control.Concurrent.STM.TVar -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -19,35 +19,36 @@ ----------------------------------------------------------------------------- module Control.Concurrent.STM.TVar (- -- * TVars- TVar,- newTVar,- newTVarIO,- readTVar,- readTVarIO,- writeTVar,- modifyTVar,- modifyTVar',- swapTVar,+ -- * TVars+ TVar,+ newTVar,+ newTVarIO,+ readTVar,+ readTVarIO,+ writeTVar,+ modifyTVar,+ modifyTVar',+ stateTVar,+ swapTVar, #ifdef __GLASGOW_HASKELL__- registerDelay+ registerDelay, #endif+ mkWeakTVar ) where #ifdef __GLASGOW_HASKELL__+import GHC.Base import GHC.Conc+import GHC.Weak #else import Control.Sequential.STM #endif -#if ! (MIN_VERSION_base(4,2,0))-readTVarIO = atomically . readTVar-#endif-- -- 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@@ -56,6 +57,8 @@ -- | Strict version of 'modifyTVar'.+--+-- @since 2.3 modifyTVar' :: TVar a -> (a -> a) -> STM () modifyTVar' var f = do x <- readTVar var@@ -63,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@@ -72,3 +90,11 @@ return old {-# INLINE swapTVar #-} ++-- | Make a 'Weak' pointer to a 'TVar', using the second argument as+-- a finalizer to run when 'TVar' is garbage-collected+--+-- @since 2.4.3+mkWeakTVar :: TVar a -> IO () -> IO (Weak (TVar a))+mkWeakTVar t@(TVar t#) (IO finalizer) = IO $ \s ->+ case mkWeak# t# t finalizer s of (# s1, w #) -> (# s1, Weak w #)
Control/Monad/STM.hs view
@@ -10,7 +10,7 @@ -- Module : Control.Monad.STM -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM)@@ -19,23 +19,29 @@ -- 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 +-- 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,+ STM,+ atomically, #ifdef __GLASGOW_HASKELL__- always,- alwaysSucceeds,- retry,- orElse,- check,+ retry,+ orElse,+ check, #endif throwSTM, catchSTM@@ -57,13 +63,44 @@ #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0))+import Control.Applicative+import Control.Monad (ap)+#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 mzero = retry mplus = orElse++instance Applicative STM where+ pure = return+ (<*>) = ap++instance Alternative STM where+ empty = retry+ (<|>) = orElse #endif -check :: Bool -> STM a-check b = if b then return undefined else retry+-- | 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 #if ! (MIN_VERSION_base(4,3,0))@@ -78,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:@@ -103,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
@@ -4,18 +4,24 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif -- #hide module Control.Sequential.STM (- STM, atomically, throwSTM, catchSTM,- TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar+ STM, atomically, throwSTM, catchSTM,+ TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar ) where +#if __GLASGOW_HASKELL__ < 705 import Prelude hiding (catch)+#endif+#if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(pure, (<*>)))+#endif import Control.Exception import Data.IORef @@ -35,51 +41,34 @@ instance Monad STM where return = pure STM m >>= k = STM $ \ r -> do- x <- m r- unSTM (k x) r+ x <- m r+ unSTM (k x) r -#ifdef BASE4 atomically :: STM a -> IO a atomically (STM m) = do r <- newIORef (return ()) m r `onException` do- rollback <- readIORef r- rollback-#else-atomically :: STM a -> IO a-atomically (STM m) = do- r <- newIORef (return ())- m r `catch` \ ex -> do- rollback <- readIORef r- rollback- throw ex-#endif+ rollback <- readIORef r+ rollback -#ifdef BASE4+-- | @since 2.2.0 throwSTM :: Exception e => e -> STM a-#else-throwSTM :: Exception -> STM a-#endif throwSTM = STM . const . throwIO -#ifdef BASE4 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a-#else-catchSTM :: STM a -> (Exception -> STM a) -> STM a-#endif catchSTM (STM m) h = STM $ \ r -> do old_rollback <- readIORef r writeIORef r (return ()) res <- try (m r) rollback_m <- readIORef r case res of- Left ex -> do- rollback_m- writeIORef r old_rollback- unSTM (h ex) r- Right a -> do- writeIORef r (rollback_m >> old_rollback)- return a+ Left ex -> do+ rollback_m+ writeIORef r old_rollback+ unSTM (h ex) r+ Right a -> do+ writeIORef r (rollback_m >> old_rollback)+ return a newtype TVar a = TVar (IORef a) deriving (Eq)@@ -95,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
@@ -0,0 +1,128 @@+# 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)++ * 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*++ * Add support for `base-4.8.0.0`++ * Tighten Safe Haskell bounds++ * Add `mkWeakTMVar` to `Control.Concurrent.STM.TMVar`++ * Add `@since`-annotations++### 2.4.3 *Mar 2014*++ * Update behaviour of `newBroadcastTChanIO` to match+ `newBroadcastTChan` in causing an error on a read from the+ broadcast channel++ * Add `mkWeakTVar`++ * Add `isFullTBQueue`++ * Fix `TChan` created via `newBroadcastTChanIO` to throw same+ exception on a `readTChan` as when created via `newBroadcastTChan`++ * Update to Cabal 1.10 format++### 2.4.2 *Nov 2012*++ * Add `Control.Concurrent.STM.TSem` (transactional semaphore)++ * Add Applicative/Alternative instances of STM for GHC <7.0++ * Throw proper exception when `readTChan` called on a broadcast `TChan`++## 2.4 *Jul 2012*++ * Add `Control.Concurrent.STM.TQueue` (a faster `TChan`)++ * Add `Control.Concurrent.STM.TBQueue` (a bounded channel based on `TQueue`)++ * Add `Eq` instance for `TChan`++ * Add `newBroadcastTChan` and `newBroadcastTChanIO`++ * Some performance improvements for `TChan`++ * Add `cloneTChan`
stm.cabal view
@@ -1,35 +1,72 @@-name: stm-version: 2.3-license: BSD3-license-file: LICENSE-maintainer: libraries@haskell.org-synopsis: Software Transactional Memory+cabal-version: >=1.10+name: stm+version: 2.5.3.1+-- don't forget to update changelog.md file!++license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org+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.6+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://darcs.haskell.org/packages/stm.git/--flag base4+ location: https://github.com/haskell/stm.git library- exposed-modules:- Control.Concurrent.STM- Control.Concurrent.STM.TArray- Control.Concurrent.STM.TVar- Control.Concurrent.STM.TChan- Control.Concurrent.STM.TMVar- Control.Monad.STM- other-modules:- Control.Sequential.STM- build-depends: base < 5, array- if flag(base4)- build-depends: base >=4- cpp-options: -DBASE4- else- build-depends: base <4- if impl(ghc >= 6.10)- build-depends: base >=4+ default-language: Haskell2010+ other-extensions:+ CPP+ DeriveDataTypeable+ FlexibleInstances+ MagicHash+ MultiParamTypeClasses+ UnboxedTuples+ if impl(ghc >= 7.2)+ other-extensions: Trustworthy+ 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.4 && < 4.21,+ array >= 0.3 && < 0.6++ exposed-modules:+ Control.Concurrent.STM+ Control.Concurrent.STM.TArray+ Control.Concurrent.STM.TVar+ Control.Concurrent.STM.TChan+ Control.Concurrent.STM.TMVar+ Control.Concurrent.STM.TQueue+ Control.Concurrent.STM.TBQueue+ Control.Concurrent.STM.TSem+ Control.Monad.STM+ other-modules:+ Control.Sequential.STM++ 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