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,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} @@ -18,33 +19,34 @@ -- -- '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, - flushTBQueue, - peekTBQueue, - tryPeekTBQueue, - writeTBQueue, - unGetTBQueue, - lengthTBQueue, - isEmptyTBQueue, - isFullTBQueue, + -- * 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) @@ -89,7 +91,7 @@ wsize <- newTVar size 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. @@ -143,7 +145,7 @@ -- | 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. @@ -156,8 +158,8 @@ if null xs && null ys then return [] else do - writeTVar read [] - writeTVar write [] + unless (null xs) $ writeTVar read [] + unless (null ys) $ writeTVar write [] writeTVar rsize 0 writeTVar wsize size return (xs ++ reverse ys) @@ -191,7 +193,7 @@ 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 _size) a = do @@ -206,7 +208,7 @@ xs <- readTVar read writeTVar read (a:xs) --- |Return the length of a 'TBQueue'. +-- | Return the length of a 'TBQueue'. -- -- @since 2.5.0.0 lengthTBQueue :: TBQueue a -> STM Natural @@ -215,7 +217,7 @@ w <- readTVar wsize return $! size - r - w --- |Returns 'True' if the supplied 'TBQueue' is empty. +-- | Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do xs <- readTVar read @@ -226,7 +228,7 @@ [] -> return True _ -> return False --- |Returns 'True' if the supplied 'TBQueue' is full. +-- | Returns 'True' if the supplied 'TBQueue' is full. -- -- @since 2.4.3 isFullTBQueue :: TBQueue a -> STM Bool @@ -239,3 +241,9 @@ if (r > 0) then return False else return True + +-- | The maximum number of elements the queue can hold. +-- +-- @since 2.5.2.0 +capacityTBQueue :: TBQueue a -> Natural +capacityTBQueue (TBQueue _ _ _ _ cap) = fromIntegral cap 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 @@ -30,6 +30,7 @@ takeTMVar, putTMVar, readTMVar, + writeTMVar, tryReadTMVar, swapTMVar, tryTakeTMVar, @@ -147,6 +148,13 @@ case m of Nothing -> retry Just old -> do writeTVar t (Just new); return old + +-- | Non-blocking write of a new value to a 'TMVar' +-- Puts if empty. Replaces if populated. +-- +-- @since 2.5.1 +writeTMVar :: TMVar a -> a -> STM () +writeTMVar (TMVar t) new = writeTVar t (Just new) -- |Check whether a given 'TMVar' is empty. isEmptyTMVar :: TMVar a -> STM Bool 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, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} @@ -73,7 +73,7 @@ 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 + let !(a, s') = f s writeTVar var s' return a {-# INLINE stateTVar #-} diff --git a/Control/Monad/STM.hs b/Control/Monad/STM.hs --- a/Control/Monad/STM.hs +++ b/Control/Monad/STM.hs @@ -68,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 @@ -137,3 +147,14 @@ 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/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,32 @@ # 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) @@ -29,7 +56,7 @@ * Fix incorrect bookkeeping of write capacity in `flushTBQueue` (gh-9) - * Avoid redundant `writeTVar`s in `flushTQueue` to avoid unncessarily + * Avoid redundant `writeTVar`s in `flushTQueue` to avoid unnecessarily invalidating other transactions (gh-6) ### 2.4.5.0 *Feb 2018* diff --git a/stm.cabal b/stm.cabal --- a/stm.cabal +++ b/stm.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: stm -version: 2.5.0.2 +version: 2.5.3.1 -- don't forget to update changelog.md file! license: BSD3 @@ -11,7 +11,7 @@ synopsis: Software Transactional Memory category: Concurrency build-type: Simple -tested-with: GHC==8.10.*, GHC==8.8.*, 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.* +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 @@ -49,8 +49,11 @@ if !impl(ghc >= 7.10) build-depends: nats (>= 0.1.3 && < 0.3) || (>= 1 && < 1.2) + if !impl(ghc >= 8.0) + build-depends: semigroups >=0.18.6 && <0.21 + build-depends: - base >= 4.3 && < 4.17, + base >= 4.4 && < 4.21, array >= 0.3 && < 0.6 exposed-modules: diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal --- a/testsuite/testsuite.cabal +++ b/testsuite/testsuite.cabal @@ -6,7 +6,7 @@ category: Testing license: BSD-3-Clause maintainer: hvr@gnu.org -tested-with: GHC==8.8.*, 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.* +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 @@ -36,7 +36,7 @@ -- build-depends: - , base >= 4.3 && < 4.17 + , base >= 4.4 && < 4.20 , test-framework ^>= 0.8.2.0 , test-framework-hunit ^>= 0.3.0.2 , HUnit ^>= 1.6.0.0