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,8 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -39,24 +39,26 @@ tryPeekTBQueue, writeTBQueue, unGetTBQueue, + lengthTBQueue, isEmptyTBQueue, isFullTBQueue, ) where -import Data.Typeable -import GHC.Conc - -#define _UPK_(x) {-# UNPACK #-} !(x) +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) - _UPK_(Int) -- CAP: initial capacity + = 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 @@ -76,8 +78,8 @@ -- 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 [] @@ -90,7 +92,7 @@ -- '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 [] @@ -102,11 +104,11 @@ writeTBQueue :: TBQueue a -> a -> STM () writeTBQueue (TBQueue rsize _read wsize write _size) a = do w <- readTVar wsize - if (w /= 0) + 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 else retry @@ -189,6 +191,15 @@ 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 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 @@ -27,7 +27,7 @@ import Control.Concurrent.STM import Control.Monad import Data.Typeable -import Data.Word as Word +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 @@ -56,8 +56,8 @@ -- operations to counter-balance. -- -- @since 2.4.2 -newTSem :: Int -> STM TSem -newTSem i = fmap TSem (newTVar $! toInteger i) +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. @@ -99,7 +99,7 @@ -- > signalTSem == signalTSemN 1 -- -- @since 2.4.5 -signalTSemN :: Word.Word -> TSem -> STM () +signalTSemN :: Natural -> TSem -> STM () signalTSemN 0 _ = return () signalTSemN 1 s = signalTSem s signalTSemN n (TSem t) = do 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 @@ -28,6 +28,7 @@ writeTVar, modifyTVar, modifyTVar', + stateTVar, swapTVar, #ifdef __GLASGOW_HASKELL__ registerDelay, @@ -63,6 +64,19 @@ x <- readTVar var writeTVar var $! f x {-# 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 -- since we destructure this, we are strict in f + writeTVar var s' + return a +{-# INLINE stateTVar #-} -- Like 'swapTMVar' but for 'TVar'. diff --git a/Control/Monad/STM.hs b/Control/Monad/STM.hs --- a/Control/Monad/STM.hs +++ b/Control/Monad/STM.hs @@ -25,14 +25,20 @@ -- -- This module only defines the 'STM' monad; you probably want to -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM"). +-- +-- Note that invariant checking (namely the @always@ and @alwaysSucceeds@ +-- functions) has been removed. See ticket [#14324](https://ghc.haskell.org/trac/ghc/ticket/14324) and +-- the [removal proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst). +-- Existing users are encouraged to encapsulate their STM operations in safe +-- abstractions which can perform the invariant checking without help from the +-- runtime system. + ----------------------------------------------------------------------------- module Control.Monad.STM ( STM, atomically, #ifdef __GLASGOW_HASKELL__ - always, - alwaysSucceeds, retry, orElse, check, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,13 +1,27 @@ # Changelog for [`stm` package](http://hackage.haskell.org/package/stm) -## 2.4.5.1 *Sep 2018* +## 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 unncessarily invalidating other transactions (gh-6) -## 2.4.5.0 *Feb 2018* +### 2.4.5.0 *Feb 2018* * Fix space leak in `TBQueue` (gh-2, GHC#14494) @@ -22,13 +36,13 @@ * Add `signalTSemN` operation (gh-5) -## 2.4.4.1 *Dec 2015* +#### 2.4.4.1 *Dec 2015* * Add support for `base-4.9.0.0` * Drop support for GHC 6.12 / `base-4.2` -## 2.4.4 *Dec 2014* +### 2.4.4 *Dec 2014* * Add support for `base-4.8.0.0` @@ -38,7 +52,7 @@ * Add `@since`-annotations -## 2.4.3 *Mar 2014* +### 2.4.3 *Mar 2014* * Update behaviour of `newBroadcastTChanIO` to match `newBroadcastTChan` in causing an error on a read from the @@ -53,7 +67,7 @@ * Update to Cabal 1.10 format -## 2.4.2 *Nov 2012* +### 2.4.2 *Nov 2012* * Add `Control.Concurrent.STM.TSem` (transactional semaphore) diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: stm -version: 2.4.5.1 --- don't forget to update changelog.md file & source-repo tag! +version: 2.5.0.0 +-- don't forget to update changelog.md file! license: BSD3 license-file: LICENSE @@ -11,7 +11,7 @@ synopsis: Software Transactional Memory category: Concurrency build-type: Simple -tested-with: GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* +tested-with: GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.* description: Software Transactional Memory, or STM, is an abstraction for concurrent communication. The main benefits of STM are @@ -29,11 +29,6 @@ type: git location: https://github.com/haskell/stm.git -source-repository this - type: git - location: https://github.com/haskell/stm.git - tag: v2.4.5.1 - library default-language: Haskell2010 other-extensions: @@ -48,8 +43,11 @@ if impl(ghc >= 7.9) other-extensions: Safe + if !impl(ghc >= 7.10) + build-depends: nats (>= 0.1.3 && < 0.3) || (>= 1 && < 1.2) + build-depends: - base >= 4.3 && < 4.12, + base >= 4.3 && < 4.13, array >= 0.3 && < 0.6 exposed-modules: