diff --git a/Control/Concurrent/STM.hs b/Control/Concurrent/STM.hs --- a/Control/Concurrent/STM.hs +++ b/Control/Concurrent/STM.hs @@ -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,22 +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. --- +-- Peyton Jones, and Maurice Herlihy, in +-- /ACM Conference on Principles and Practice of Parallel Programming/ 2005. +-- -- ----------------------------------------------------------------------------- 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.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 diff --git a/Control/Concurrent/STM/TArray.hs b/Control/Concurrent/STM/TArray.hs --- a/Control/Concurrent/STM/TArray.hs +++ b/Control/Concurrent/STM/TArray.hs @@ -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 diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs --- a/Control/Concurrent/STM/TBQueue.hs +++ b/Control/Concurrent/STM/TBQueue.hs @@ -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 ----------------------------------------------------------------------------- @@ -10,51 +12,60 @@ -- 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' 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, + -- * 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 @@ -70,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' @@ -122,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 @@ -131,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. @@ -152,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 @@ -177,3 +227,23 @@ 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 diff --git a/Control/Concurrent/STM/TChan.hs b/Control/Concurrent/STM/TChan.hs --- a/Control/Concurrent/STM/TChan.hs +++ b/Control/Concurrent/STM/TChan.hs @@ -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,25 +22,25 @@ module Control.Concurrent.STM.TChan ( #ifdef __GLASGOW_HASKELL__ - -- * TChans - TChan, + -- * TChans + TChan, -- ** Construction newTChan, - newTChanIO, - newBroadcastTChan, - newBroadcastTChanIO, + newTChanIO, + newBroadcastTChan, + newBroadcastTChanIO, dupTChan, + cloneTChan, -- ** Reading and writing - readTChan, - tryReadTChan, - peekTChan, - tryPeekTChan, - writeTChan, + readTChan, + tryReadTChan, + peekTChan, + tryPeekTChan, + writeTChan, unGetTChan, - isEmptyTChan, - cloneTChan + isEmptyTChan #endif ) where @@ -95,6 +95,8 @@ -- 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 @@ -103,11 +105,12 @@ return (TChan read write) -- | @IO@ version of 'newBroadcastTChan'. +-- +-- @since 2.4 newBroadcastTChanIO :: IO (TChan a) newBroadcastTChanIO = do - dummy_hole <- newTVarIO TNil write_hole <- newTVarIO TNil - read <- newTVarIO dummy_hole + read <- newTVarIO (error "reading from a TChan created by newBroadcastTChanIO; use dupTChan first") write <- newTVarIO write_hole return (TChan read write) @@ -127,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 @@ -144,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 @@ -154,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 @@ -168,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) @@ -190,6 +199,8 @@ -- |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 diff --git a/Control/Concurrent/STM/TMVar.hs b/Control/Concurrent/STM/TMVar.hs --- a/Control/Concurrent/STM/TMVar.hs +++ b/Control/Concurrent/STM/TMVar.hs @@ -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 diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs --- a/Control/Concurrent/STM/TQueue.hs +++ b/Control/Concurrent/STM/TQueue.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 @@ -10,7 +11,7 @@ -- 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) @@ -28,27 +29,31 @@ -- 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, - peekTQueue, - tryPeekTQueue, - writeTQueue, + 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 @@ -84,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. diff --git a/Control/Concurrent/STM/TSem.hs b/Control/Concurrent/STM/TSem.hs --- a/Control/Concurrent/STM/TSem.hs +++ b/Control/Concurrent/STM/TSem.hs @@ -3,24 +3,31 @@ -- 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 +module Control.Concurrent.STM.TSem + ( TSem + , newTSem + + , waitTSem + + , signalTSem + , signalTSemN ) where import Control.Concurrent.STM import Control.Monad import Data.Typeable -import Control.Exception +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 @@ -35,20 +42,66 @@ -- resource. However, like other STM abstractions, 'TSem' is -- composable. -- -newtype TSem = TSem (TVar Int) +-- @since 2.4.2 +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) diff --git a/Control/Concurrent/STM/TVar.hs b/Control/Concurrent/STM/TVar.hs --- a/Control/Concurrent/STM/TVar.hs +++ b/Control/Concurrent/STM/TVar.hs @@ -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 #) diff --git a/Control/Monad/STM.hs b/Control/Monad/STM.hs --- a/Control/Monad/STM.hs +++ b/Control/Monad/STM.hs @@ -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. --- +-- Peyton Jones, and Maurice Herlihy, in +-- /ACM Conference on Principles and Practice of Parallel Programming/ 2005. +-- -- --- 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 @@ -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 ) -- -- 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 diff --git a/Control/Sequential/STM.hs b/Control/Sequential/STM.hs --- a/Control/Sequential/STM.hs +++ b/Control/Sequential/STM.hs @@ -4,20 +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 @@ -37,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) @@ -97,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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +The `stm` Package [![Build Status](https://travis-ci.org/haskell/stm.svg?branch=master)](https://travis-ci.org/haskell/stm) +================= + +See [`stm` on Hackage](http://hackage.haskell.org/package/stm) for more information. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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` diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -1,62 +1,72 @@ -name: stm -version: 2.4.2 -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 +build-type: Simple +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: - A modular composable concurrency abstraction. - . - Changes in version 2.4.2 - . - * Added "Control.Concurrent.STM.TSem" (transactional semaphore) - . - Changes in version 2.4.1 - . - * Added Applicative/Alternative instances of STM for GHC <7.0 - . - Changes in version 2.4 - . - * Added "Control.Concurrent.STM.TQueue" (a faster @TChan@) - . - * Added "Control.Concurrent.STM.TBQueue" (a bounded channel based on @TQueue@) - . - * @TChan@ has an @Eq@ instances - . - * Added @newBroadcastTChan@ and @newBroadcastTChanIO@ - . - * Some performance improvements for @TChan@ - . - * Added @cloneTChan@ + 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. -build-type: Simple -cabal-version: >=1.6 +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.Concurrent.STM.TQueue - Control.Concurrent.STM.TBQueue - Control.Concurrent.STM.TSem - 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 diff --git a/testsuite/src/Issue17.hs b/testsuite/src/Issue17.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Issue17.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +-- see https://github.com/haskell/stm/pull/19 +-- +-- Test-case contributed by Alexey Kuleshevich +-- +-- This bug is observable in all versions with TBQueue from `stm-2.4` to +-- `stm-2.4.5.1` inclusive. + +module Issue17 (main) where + +import Control.Concurrent.STM +import Test.HUnit.Base (assertBool, assertEqual) + +main :: IO () +main = do + -- New queue capacity is set to 0 + queueIO <- newTBQueueIO 0 + assertNoCapacityTBQueue queueIO + + -- Same as above, except created within STM + queueSTM <- atomically $ newTBQueue 0 + assertNoCapacityTBQueue queueSTM + +#if !MIN_VERSION_stm(2,5,0) + -- NB: below are expected failures + + -- New queue capacity is set to a negative numer + queueIO' <- newTBQueueIO (-1 :: Int) + assertNoCapacityTBQueue queueIO' + + -- Same as above, except created within STM and different negative number + queueSTM' <- atomically $ newTBQueue (minBound :: Int) + assertNoCapacityTBQueue queueSTM' +#endif + +assertNoCapacityTBQueue :: TBQueue Int -> IO () +assertNoCapacityTBQueue queue = do + assertEmptyTBQueue queue + assertFullTBQueue queue + + -- Attempt to write into the queue. + eValWrite <- atomically $ orElse (fmap Left (writeTBQueue queue 217)) + (fmap Right (tryReadTBQueue queue)) + assertEqual "Expected queue with no capacity: writeTBQueue" eValWrite (Right Nothing) + eValUnGet <- atomically $ orElse (fmap Left (unGetTBQueue queue 218)) + (fmap Right (tryReadTBQueue queue)) + assertEqual "Expected queue with no capacity: unGetTBQueue" eValUnGet (Right Nothing) + + -- Make sure that attempt to write didn't affect the queue + assertEmptyTBQueue queue + assertFullTBQueue queue + + +assertEmptyTBQueue :: TBQueue Int -> IO () +assertEmptyTBQueue queue = do + atomically (isEmptyTBQueue queue) >>= + assertBool "Expected empty: isEmptyTBQueue should return True" + + atomically (tryReadTBQueue queue) >>= + assertEqual "Expected empty: tryReadTBQueue should return Nothing" Nothing + + atomically (tryPeekTBQueue queue) >>= + assertEqual "Expected empty: tryPeekTBQueue should return Nothing" Nothing + + atomically (flushTBQueue queue) >>= + assertEqual "Expected empty: flushTBQueue should return []" [] + + +assertFullTBQueue :: TBQueue Int -> IO () +assertFullTBQueue queue = do + atomically (isFullTBQueue queue) >>= + assertBool "Expected full: isFullTBQueue shoule return True" diff --git a/testsuite/src/Issue9.hs b/testsuite/src/Issue9.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Issue9.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +-- see https://github.com/haskell/stm/pull/9 +-- +-- Test-case contributed by Mitchell Rosen +-- +-- This bug is observable in version `stm-2.4.5.0` + +module Issue9 (main) where + +import Control.Concurrent.STM +import Data.Foldable + +main :: IO () +#if MIN_VERSION_stm(2,4,5) +main = do + -- New queue with capacity 5 + queue <- newTBQueueIO 5 + + -- Fill it up with [1..5] + for_ [1..5] $ \i -> + atomically (writeTBQueue queue (i :: Int)) + + -- Read 1 + 1 <- atomically (readTBQueue queue) + + -- Flush [2..5] + [2,3,4,5] <- atomically (flushTBQueue queue) + + -- The bug: now the queue capacity is 4, not 5. + -- To trigger it, first fill up [1..4]... + for_ [1..4] $ \i -> + atomically (writeTBQueue queue i) + + -- ... then observe that writing a 5th element will fail + -- with "thread blocked indefinitely in an STM transaction" + atomically (writeTBQueue queue 5) +#else +-- test-case not applicable; `flushTBQueue` was only added in 2.4.5.0 +main = return () +#endif diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit + +import qualified Issue9 +import qualified Issue17 +import qualified Stm052 +import qualified Stm064 +import qualified Stm065 + +main :: IO () +main = do + putStrLn ("'stm' version under test: " ++ VERSION_stm) + defaultMain tests + where + tests = [ + testGroup "regression" + [ testCase "issue #9" Issue9.main + , testCase "issue #17" Issue17.main + , testCase "stm052" Stm052.main + , testCase "stm064" Stm064.main + , testCase "stm065" Stm065.main + ] + ] + diff --git a/testsuite/src/Stm052.hs b/testsuite/src/Stm052.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm052.hs @@ -0,0 +1,70 @@ +-- STM stress test + +module Stm052 (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad (mapM_, when) +import Data.Array +import Data.List +import Foreign +import Foreign.C +import GHC.Conc +import GHC.Conc (unsafeIOToSTM) +import System.Environment +import System.IO +import System.IO.Unsafe +import System.Random + +-- | The number of array elements +n_elems :: Int +n_elems = 20 + +-- | The number of threads swapping elements +n_threads :: Int +n_threads = 2 + +-- | The number of swaps for each thread to perform +iterations :: Int +iterations = 20000 + +type Elements = Array Int (TVar Int) + +thread :: TVar Int -> Elements -> IO () +thread done elements = loop iterations + where loop 0 = atomically $ do x <- readTVar done; writeTVar done (x+1) + loop n = do + i1 <- randomRIO (1,n_elems) + i2 <- randomRIO (1,n_elems) + let e1 = elements ! i1 + let e2 = elements ! i2 + atomically $ do + e1_v <- readTVar e1 + e2_v <- readTVar e2 + writeTVar e1 e2_v + writeTVar e2 e1_v + loop (n-1) + +await_end :: TVar Int -> IO () +await_end done = atomically $ do x <- readTVar done + if (x == n_threads) then return () else retry + +main :: IO () +main = do + _ <- Foreign.newStablePtr stdout + setStdGen (read "526454551 6356") + let init_vals = [1..n_elems] -- take n_elems + tvars <- atomically $ mapM newTVar init_vals + let elements = listArray (1,n_elems) tvars + done <- atomically (newTVar 0) + _ <- sequence [ forkIO (thread done elements) | _id <- [1..n_threads] ] + await_end done + fin_vals <- mapM (\t -> atomically $ readTVar t) (elems elements) + + when (sort fin_vals /= init_vals) $ do + putStr("Before: ") + mapM_ (\v -> putStr ((show v) ++ " " )) init_vals + putStr("\nAfter: ") + mapM_ (\v -> putStr ((show v) ++ " " )) (sort fin_vals) + putStr("\n") + fail "mismatch" diff --git a/testsuite/src/Stm064.hs b/testsuite/src/Stm064.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm064.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +{- NB: This one fails for GHC < 7.6 which had a bug exposed via + nested uses of `orElse` in `stmCommitNestedTransaction` + +This was fixed in GHC via + f184d9caffa09750ef6a374a7987b9213d6db28e +-} + +module Stm064 (main) where + +import Control.Concurrent.STM +import Control.Monad (unless) + +main :: IO () +#if __GLASGOW_HASKELL__ >= 706 && !defined(GHC_7_6_1) +main = do + x <- atomically $ do + t <- newTVar (1 :: Integer) + writeTVar t 2 + ((readTVar t >> retry) `orElse` return ()) `orElse` return () + readTVar t + + unless (x == 2) $ + fail (show x) +#else +main = putStrLn "Warning: test disabled for GHC < 7.6" +#endif diff --git a/testsuite/src/Stm065.hs b/testsuite/src/Stm065.hs new file mode 100644 --- /dev/null +++ b/testsuite/src/Stm065.hs @@ -0,0 +1,15 @@ +module Stm065 (main) where + +import Control.Concurrent.STM +import Control.Monad (unless) + +main :: IO () +main = do + x <- atomically $ do + r <- newTVar [] + writeTVar r [2 :: Integer] + writeTVar r [] `orElse` return () + readTVar r + + unless (null x) $ do + fail (show x) diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal new file mode 100644 --- /dev/null +++ b/testsuite/testsuite.cabal @@ -0,0 +1,58 @@ +cabal-version: 2.2 +name: testsuite +version: 0 + +synopsis: External testsuite for stm package +category: Testing +license: BSD-3-Clause +maintainer: hvr@gnu.org +tested-with: GHC==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