diff --git a/Control/Concurrent/STM.hs b/Control/Concurrent/STM.hs --- a/Control/Concurrent/STM.hs +++ b/Control/Concurrent/STM.hs @@ -20,9 +20,9 @@ -- abstraction. See -- -- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon --- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles --- and Practice of Parallel Programming/ 2005. --- +-- Peyton Jones, and Maurice Herlihy, in +-- /ACM Conference on Principles and Practice of Parallel Programming/ 2005. +-- -- ----------------------------------------------------------------------------- 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 @@ -34,6 +34,7 @@ newTBQueueIO, readTBQueue, tryReadTBQueue, + flushTBQueue, peekTBQueue, tryPeekTBQueue, writeTBQueue, @@ -101,12 +102,12 @@ writeTBQueue (TBQueue rsize _read wsize write) a = do w <- readTVar wsize if (w /= 0) - then do writeTVar wsize (w - 1) + then do writeTVar wsize $! w - 1 else do r <- readTVar rsize 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) @@ -116,7 +117,7 @@ readTBQueue (TBQueue rsize read _wsize write) = do xs <- readTVar read r <- readTVar rsize - writeTVar rsize (r + 1) + writeTVar rsize $! r + 1 case xs of (x:xs') -> do writeTVar read xs' @@ -137,6 +138,22 @@ tryReadTBQueue :: TBQueue a -> STM (Maybe a) tryReadTBQueue c = fmap Just (readTBQueue c) `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) = do + xs <- readTVar read + ys <- readTVar write + r <- readTVar rsize + w <- readTVar wsize + writeTVar read [] + writeTVar write [] + writeTVar rsize 0 + writeTVar wsize (r + w) + 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 @@ -162,11 +179,11 @@ unGetTBQueue (TBQueue rsize read wsize _write) 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) 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 @@ -135,6 +135,8 @@ -- | A version of 'readTChan' which does not retry. Instead it -- returns @Nothing@ if no value is available. +-- +-- @since 2.3 tryReadTChan :: TChan a -> STM (Maybe a) tryReadTChan (TChan read _write) = do listhead <- readTVar read @@ -147,6 +149,8 @@ -- | Get the next value from the @TChan@ without removing it, -- retrying if the channel is empty. +-- +-- @since 2.3 peekTChan :: TChan a -> STM a peekTChan (TChan read _write) = do listhead <- readTVar read @@ -157,6 +161,8 @@ -- | A version of 'peekTChan' which does not retry. Instead it -- returns @Nothing@ if no value is available. +-- +-- @since 2.3 tryPeekTChan :: TChan a -> STM (Maybe a) tryPeekTChan (TChan read _write) = do listhead <- readTVar read 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 @@ -135,6 +135,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 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 @@ -38,6 +38,7 @@ newTQueueIO, readTQueue, tryReadTQueue, + flushTQueue, peekTQueue, tryPeekTQueue, writeTQueue, @@ -87,21 +88,36 @@ 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 + writeTVar read [] + writeTVar write [] + return (xs ++ reverse ys) -- | Get the next value from the @TQueue@ without removing it, -- retrying if the channel is empty. 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,7 +3,7 @@ -- Module : Control.Concurrent.STM.TSem -- Copyright : (c) The University of Glasgow 2012 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) @@ -14,13 +14,20 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} -module Control.Concurrent.STM.TSem ( - TSem, newTSem, waitTSem, signalTSem +module Control.Concurrent.STM.TSem + ( TSem + , newTSem + + , waitTSem + + , signalTSem + , signalTSemN ) where import Control.Concurrent.STM import Control.Monad import Data.Typeable +import Data.Word as Word -- | 'TSem' is a transactional semaphore. It holds a certain number -- of units, and units may be acquired or released by 'waitTSem' and @@ -36,20 +43,65 @@ -- composable. -- -- @since 2.4.2 -newtype TSem = TSem (TVar Int) +newtype TSem = TSem (TVar Integer) deriving (Eq, Typeable) +-- | 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 :: Int -> STM TSem -newTSem i = fmap TSem (newTVar i) +newTSem i = fmap TSem (newTVar $! toInteger 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 :: Word.Word -> 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 @@ -46,6 +46,8 @@ -- Like 'modifyIORef' but for 'TVar'. -- | Mutate the contents of a 'TVar'. /N.B./, this version is -- non-strict. +-- +-- @since 2.3 modifyTVar :: TVar a -> (a -> a) -> STM () modifyTVar var f = do x <- readTVar var @@ -54,6 +56,8 @@ -- | Strict version of 'modifyTVar'. +-- +-- @since 2.3 modifyTVar' :: TVar a -> (a -> a) -> STM () modifyTVar' var f = do x <- readTVar var @@ -63,6 +67,8 @@ -- 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 diff --git a/Control/Monad/STM.hs b/Control/Monad/STM.hs --- a/Control/Monad/STM.hs +++ b/Control/Monad/STM.hs @@ -19,9 +19,9 @@ -- abstraction. See -- -- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon --- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles --- and Practice of Parallel Programming/ 2005. --- +-- 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 -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM"). @@ -78,6 +78,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 @@ -119,6 +124,7 @@ 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 diff --git a/Control/Sequential/STM.hs b/Control/Sequential/STM.hs --- a/Control/Sequential/STM.hs +++ b/Control/Sequential/STM.hs @@ -51,6 +51,7 @@ rollback <- readIORef r rollback +-- | @since 2.2.0 throwSTM :: Exception e => e -> STM a throwSTM = STM . const . throwIO @@ -83,6 +84,7 @@ readTVar :: TVar a -> STM a readTVar (TVar ref) = STM (const (readIORef ref)) +-- | @since 2.1.2 readTVarIO :: TVar a -> IO a readTVarIO (TVar ref) = readIORef ref diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,20 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) +## 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` diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -1,23 +1,32 @@ name: stm -version: 2.4.4.1 +version: 2.4.5.0 -- don't forget to update changelog.md file! license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org -bug-reports: https://ghc.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29&keywords=stm +homepage: https://wiki.haskell.org/Software_transactional_memory +bug-reports: https://github.com/haskell/stm/issues synopsis: Software Transactional Memory category: Concurrency -description: A modular composable concurrency abstraction. build-type: Simple cabal-version: >=1.10 tested-with: GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* +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 source-repository head type: git - location: http://git.haskell.org/packages/stm.git + location: https://github.com/haskell/stm.git library default-language: Haskell2010 @@ -34,7 +43,7 @@ other-extensions: Safe build-depends: - base >= 4.3 && < 4.10, + base >= 4.3 && < 4.12, array >= 0.3 && < 0.6 exposed-modules: