diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,9 +1,13 @@ === Haskell stm-chans package AUTHORS/THANKS file === -The stm-chans package was written (predominantly) by wren ng thornton -and is released under the terms in the LICENSE file. Some important -improvements to TBChan and TBMChan were contributed by Thomas -DuBuisson, incorporating parts of his bounded-tchan package. These -improvements reduce contention between readers and writers, improving -throughput by 2--3 times when producers and consumers are running -in separate OS threads. +The stm-chans package was written (predominantly) by wren gayle romano +and is released under the terms in the LICENSE file. I would also +like to give thanks to the following contributors: + +Thomas DuBuisson --- For important improvements to TBChan and + TBMChan, incorporating parts of his bounded-tchan package. These + improvements reduce contention between readers and writers, + improving throughput by 2--3 times when producers and consumers + are running in separate OS threads. + +kudah --- For adding TQueue support. diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,60 @@ +3.0.0.11 (2026-02-26): + - Updating the `Tested-With` field for ghc 9.14 (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) + - Also silencing some warnings on ghc >=9.12 about deriving Typeable. +3.0.0.10 (2024-08-28): + - Updating the `Tested-With` field for ghc 9.10 (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) +3.0.0.9 (2023-03-19): + - Added `Tested-With: GHC == 9.6.1` (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) +3.0.0.8 (2022-08-28): + - Added `Tested-With: GHC == 9.4.1` (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) +3.0.0.7 (2021-11-22): + - Added `Tested-With: GHC == 9.2.1` (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) +3.0.0.6 (2021-10-17): + - Removed old __HADDOCK__ hack + - Updating stale emails, urls, etc +3.0.0.5 (2021-10-16): + - Fixed the cabal file for Cabal >1.24 +3.0.0.4 (2015-05-30): + - Moved VERSION to CHANGELOG +3.0.0.3 (2015-03-29): + - Cleaning up headers to compile cleanly with GHC 7.10 +3.0.0 (2013-05-29): + - Removed the deprecated compatibility modules. + +2.1.0 (2013-05-29): + - Added UNPACK pragmas everywhere to reduce indirections. + - Added versions of newBroadcastT*Chan for TMChan + - Deprecated all the compatibility stuff, since newBroadcastTChan requires stm >= 2.4 anyways. +2.0.0 (2013-05-12): + - Add TQueue support + +1.3.1 (2012-02-29): + - Corrected the CPP macros now that stm-2.3 is released. +1.3.0 (2012-02-25): + - Added Control.Concurrent.STM.TMVar.Compat +1.2.0.3 (2012-02-12): + - Change stability from experimental to provisional. +1.2.0.2 (2012-02-12): + - Documentation fix for Control.Concurrent.STM.TMChan.writeTMChan +1.2.0.1 (2011-05-07): + - Moved old TBChan,TBMChan implementations to ./test/bench/ +1.2.0 (2011-05-07): + - Various optimizations. + - Switched to using 2 TVars in TBChan and TBMChan, reducing + contention between readers and writers and improving throughput + considerably (when multiple OS threads are used). + - Control.Concurrent.STM.TBChan: added estimateFreeSlotsTBChan, + freeSlotsTBChan + - Control.Concurrent.STM.TBMChan: added estimateFreeSlotsTBMChan, + freeSlotsTBMChan +1.1.0 (2011-04-05): + - Control.Concurrent.STM.TBChan: added tryWriteTBChan + - Control.Concurrent.STM.TBMChan: added tryWriteTBMChan +1.0.0 (2011-04-03): + - Initial version forked from Posta-IPC. + - Added tryRead* and tryPeek* functions for the various channels. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ === stm-chans license === -Copyright (c) 2011, 2012, wren ng thornton. +Copyright (c) 2011--2013, wren gayle romano. ALL RIGHTS RESERVED. Redistribution and use in source and binary forms, with or without diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,20 +0,0 @@ -stm-chans -========= - -In general, this is a simple package and should be easy to install. -It does require GHC however, because it relies on the -Control.Concurrent.STM.TChan type which (for some unknown reason) -is GHC-only. With the cabal-install program you can just do: - - $> cabal install stm-chans - -Or if you don't have cabal-install, then you can use the Cabal -library: - - $> runhaskell Setup.hs configure - $> runhaskell Setup.hs build - $> runhaskell Setup.hs test - $> runhaskell Setup.hs haddock --hyperlink-source - $> runhaskell Setup.hs install - ------------------------------------------------------------ fin. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +stm-chans +========= +[![CI Status](https://github.com/wrengr/stm-chans/actions/workflows/ci.yml/badge.svg)](https://github.com/wrengr/stm-chans/actions?query=workflow%3Aci+-event%3Apull_request) +[![Hackage version](https://img.shields.io/hackage/v/stm-chans.svg?style=flat)](https://hackage.haskell.org/package/stm-chans) +[![Stackage LTS version](https://stackage.org/package/stm-chans/badge/lts)](https://stackage.org/lts/package/stm-chans) +[![Stackage Nightly version](https://stackage.org/package/stm-chans/badge/nightly)](https://stackage.org/nightly/package/stm-chans) + +This package offers a collection of channel types, similar to +`Control.Concurrent.STM.{TChan,TQueue}` but with additional features. +In particular we offer the following data types: + +* `Control.Concurrent.STM.TBChan`: Bounded FIFO channels. + When the channel is full, writers will block/retry. This ensures + that the writers do not get too far ahead of the readers, which + helps to make sure that memory and cpu resources are used + responsibly. +* `Control.Concurrent.STM.TMChan`: Closeable FIFO channels. +* `Control.Concurrent.STM.TMQueue`: Closeable FIFO queues. + Like `TChan (Maybe a)` but with a monotonicity guarantee that + once `Nothing` is returned all future reads will be `Nothing` + as well. +* `Control.Concurrent.STM.TBMChan`: Bounded Closeable FIFO channels. +* `Control.Concurrent.STM.TBMQueue`: Bounded Closeable FIFO queues. + Combines the capabilities of `TBChan` and `TMChan`. + + +## Install + +In general, this is a simple package and should be easy to install. +It does require GHC however, because it relies on the +Control.Concurrent.STM.TChan type which (for some unknown reason) +is GHC-only. With the cabal-install program you can just do: + + $> cabal install stm-chans + + +## Links + +* [Website](http://wrengr.org/) +* [Blog](http://winterkoninkje.dreamwidth.org/) +* [Twitter](https://twitter.com/wrengr) +* [Hackage](http://hackage.haskell.org/package/stm-chans) +* [GitHub](https://github.com/wrengr/stm-chans) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,27 +1,7 @@ #!/usr/bin/env runhaskell --- Cf. --- -{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-missing-signatures #-} module Main (main) where import Distribution.Simple -import Distribution.Simple.LocalBuildInfo (withPrograms) -import Distribution.Simple.Program (userSpecifyArgs) ----------------------------------------------------------------- --- | Define __HADDOCK__ when building documentation. main :: IO () -main = defaultMainWithHooks - $ simpleUserHooks `modify_haddockHook` \oldHH pkg lbi hooks flags -> do - - -- Call the old haddockHook with a modified LocalBuildInfo - (\lbi' -> oldHH pkg lbi' hooks flags) - $ lbi `modify_withPrograms` \oldWP -> - userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] oldWP - - -modify_haddockHook hooks f = hooks { haddockHook = f (haddockHook hooks) } -modify_withPrograms lbi f = lbi { withPrograms = f (withPrograms lbi) } - ----------------------------------------------------------------- ------------------------------------------------------------ fin. +main = defaultMain diff --git a/VERSION b/VERSION deleted file mode 100644 --- a/VERSION +++ /dev/null @@ -1,25 +0,0 @@ -1.3.1 (2012-02-29): - - Corrected the CPP macros now that stm-2.3 is released. -1.3.0 (2012-02-25): - - Added Control.Concurrent.STM.TMVar.Compat -1.2.0.3 (2012-02-12): - - Change stability from experimental to provisional. -1.2.0.2 (2012-02-12): - - Documentation fix for Control.Concurrent.STM.TMChan.writeTMChan -1.2.0.1 (2011-05-07): - - Moved old TBChan,TBMChan implementations to ./test/bench/ -1.2.0 (2011-05-07): - - Various optimizations. - - Switched to using 2 TVars in TBChan and TBMChan, reducing - contention between readers and writers and improving throughput - considerably (when multiple OS threads are used). - - Control.Concurrent.STM.TBChan: added estimateFreeSlotsTBChan, - freeSlotsTBChan - - Control.Concurrent.STM.TBMChan: added estimateFreeSlotsTBMChan, - freeSlotsTBMChan -1.1.0 (2011-04-05): - - Control.Concurrent.STM.TBChan: added tryWriteTBChan - - Control.Concurrent.STM.TBMChan: added tryWriteTBMChan -1.0.0 (2011-04-03): - - Initial version forked from Posta-IPC. - - Added tryRead* and tryPeek* functions for the various channels. diff --git a/src/Control/Concurrent/STM/TBChan.hs b/src/Control/Concurrent/STM/TBChan.hs --- a/src/Control/Concurrent/STM/TBChan.hs +++ b/src/Control/Concurrent/STM/TBChan.hs @@ -1,12 +1,21 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 912 +-- ghc-9.12: "all types now auto-derive Typeable" +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif ---------------------------------------------------------------- --- 2011.04.06 +-- 2026-02-26 -- | -- Module : Control.Concurrent.STM.TBChan --- Copyright : Copyright (c) 2011--2012 wren ng thornton +-- Copyright : Copyright (c) 2011--2026 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- @@ -41,22 +50,23 @@ ) where import Prelude hiding (reads) +#if __GLASGOW_HASKELL__ < 912 import Data.Typeable (Typeable) -import Control.Monad.STM (STM, retry) -import Control.Concurrent.STM.TVar.Compat -import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only - --- N.B., we need a Custom cabal build-type for this to work. -#ifdef __HADDOCK__ -import Control.Monad.STM (atomically) -import System.IO.Unsafe (unsafePerformIO) #endif +import Control.Monad.STM (STM, retry) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TBChan@ is an abstract type representing a bounded FIFO -- channel. -data TBChan a = TBChan !(TVar Int) !(TVar Int) !(TChan a) +data TBChan a = TBChan + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TChan a) +#if __GLASGOW_HASKELL__ < 912 deriving (Typeable) +#endif -- The components are: -- * How many free slots we /know/ we have available. -- * How many slots have been freed up by successful reads since @@ -77,8 +87,9 @@ -- | @IO@ version of 'newTBChan'. This is useful for creating --- top-level @TBChan@s using 'unsafePerformIO', because using --- 'atomically' inside 'unsafePerformIO' isn't possible. +-- top-level @TBChan@s using 'System.IO.Unsafe.unsafePerformIO', +-- because using 'Control.Monad.STM.atomically' inside +-- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTBChanIO :: Int -> IO (TBChan a) newTBChanIO n = do slots <- newTVarIO n @@ -186,15 +197,15 @@ -- | Returns @True@ if the supplied @TBChan@ is empty (i.e., has --- no elements). /N.B./, a @TBChan@ can be both ``empty'' and --- ``full'' at the same time, if the initial limit was non-positive. +-- no elements). /N.B./, a @TBChan@ can be both \"empty\" and +-- \"full\" at the same time, if the initial limit was non-positive. isEmptyTBChan :: TBChan a -> STM Bool isEmptyTBChan (TBChan _slots _reads chan) = isEmptyTChan chan -- | Returns @True@ if the supplied @TBChan@ is full (i.e., is over --- its limit). /N.B./, a @TBChan@ can be both ``empty'' and ``full'' +-- its limit). /N.B./, a @TBChan@ can be both \"empty\" and \"full\" -- at the same time, if the initial limit was non-positive. /N.B./, -- a @TBChan@ may still be full after reading, if 'unGetTBChan' was -- used to go over the initial limit. diff --git a/src/Control/Concurrent/STM/TBMChan.hs b/src/Control/Concurrent/STM/TBMChan.hs --- a/src/Control/Concurrent/STM/TBMChan.hs +++ b/src/Control/Concurrent/STM/TBMChan.hs @@ -1,12 +1,21 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 912 +-- ghc-9.12: "all types now auto-derive Typeable" +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif ---------------------------------------------------------------- --- 2011.04.06 +-- 2026-02-26 -- | -- Module : Control.Concurrent.STM.TBMChan --- Copyright : Copyright (c) 2011--2012 wren ng thornton +-- Copyright : Copyright (c) 2011--2026 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- @@ -46,23 +55,27 @@ ) where import Prelude hiding (reads) +#if __GLASGOW_HASKELL__ < 912 import Data.Typeable (Typeable) +#endif +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) -import Control.Monad.STM (STM, retry) -import Control.Concurrent.STM.TVar.Compat -import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only - --- N.B., we need a Custom cabal build-type for this to work. -#ifdef __HADDOCK__ -import Control.Monad.STM (atomically) -import System.IO.Unsafe (unsafePerformIO) #endif +import Control.Monad.STM (STM, retry) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TBMChan@ is an abstract type representing a bounded closeable -- FIFO channel. -data TBMChan a = TBMChan !(TVar Bool) !(TVar Int) !(TVar Int) !(TChan a) +data TBMChan a = TBMChan + {-# UNPACK #-} !(TVar Bool) + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TChan a) +#if __GLASGOW_HASKELL__ < 912 deriving (Typeable) +#endif -- The components are: -- * Whether the channel has been closed. -- * How many free slots we /know/ we have available. @@ -85,8 +98,9 @@ -- | @IO@ version of 'newTBMChan'. This is useful for creating --- top-level @TBMChan@s using 'unsafePerformIO', because using --- 'atomically' inside 'unsafePerformIO' isn't possible. +-- top-level @TBMChan@s using 'System.IO.Unsafe.unsafePerformIO', +-- because using 'Control.Monad.STM.atomically' inside +-- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTBMChanIO :: Int -> IO (TBMChan a) newTBMChanIO n = do closed <- newTVarIO False @@ -114,7 +128,7 @@ x <- readTChan chan modifyTVar' reads (1 +) return (Just x) -{- +{- -- The above is slightly optimized over the clearer: readTBMChan (TBMChan closed _slots reads chan) = b <- readTVar closed @@ -151,7 +165,7 @@ Just _x -> do modifyTVar' reads (1 +) return (Just mx) -{- +{- -- The above is slightly optimized over the clearer: tryReadTBMChan (TBMChan closed _slots reads chan) = b <- readTVar closed @@ -186,7 +200,7 @@ peekTBMChan (TBMChan closed _slots _reads chan) = do b <- isEmptyTChan chan b' <- readTVar closed - if b && b' + if b && b' then return Nothing else Just <$> peekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? @@ -208,7 +222,7 @@ tryPeekTBMChan (TBMChan closed _slots _reads chan) = do b <- isEmptyTChan chan b' <- readTVar closed - if b && b' + if b && b' then return Nothing else Just <$> tryPeekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? @@ -288,16 +302,16 @@ -- | Returns @True@ if the supplied @TBMChan@ is empty (i.e., has --- no elements). /N.B./, a @TBMChan@ can be both ``empty'' and --- ``full'' at the same time, if the initial limit was non-positive. +-- no elements). /N.B./, a @TBMChan@ can be both \"empty\" and +-- \"full\" at the same time, if the initial limit was non-positive. isEmptyTBMChan :: TBMChan a -> STM Bool isEmptyTBMChan (TBMChan _closed _slots _reads chan) = isEmptyTChan chan -- | Returns @True@ if the supplied @TBMChan@ is full (i.e., is --- over its limit). /N.B./, a @TBMChan@ can be both ``empty'' and --- ``full'' at the same time, if the initial limit was non-positive. +-- over its limit). /N.B./, a @TBMChan@ can be both \"empty\" and +-- \"full\" at the same time, if the initial limit was non-positive. -- /N.B./, a @TBMChan@ may still be full after reading, if -- 'unGetTBMChan' was used to go over the initial limit. -- diff --git a/src/Control/Concurrent/STM/TBMQueue.hs b/src/Control/Concurrent/STM/TBMQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TBMQueue.hs @@ -0,0 +1,366 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 912 +-- ghc-9.12: "all types now auto-derive Typeable" +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif +---------------------------------------------------------------- +-- 2026-02-26 +-- | +-- Module : Control.Concurrent.STM.TBMQueue +-- Copyright : Copyright (c) 2011--2026 wren gayle romano +-- License : BSD +-- Maintainer : wren@cpan.org +-- Stability : provisional +-- Portability : non-portable (GHC STM, DeriveDataTypeable) +-- +-- A version of "Control.Concurrent.STM.TQueue" where the queue is +-- bounded in length and closeable. This combines the abilities of +-- "Control.Concurrent.STM.TBQueue" and "Control.Concurrent.STM.TMQueue". +-- +-- /Since: 2.0.0/ +---------------------------------------------------------------- +module Control.Concurrent.STM.TBMQueue + ( + -- * The TBMQueue type + TBMQueue() + -- ** Creating TBMQueues + , newTBMQueue + , newTBMQueueIO + -- ** Reading from TBMQueues + , readTBMQueue + , tryReadTBMQueue + , peekTBMQueue + , tryPeekTBMQueue + -- ** Writing to TBMQueues + , writeTBMQueue + , tryWriteTBMQueue + , unGetTBMQueue + -- ** Closing TBMQueues + , closeTBMQueue + -- ** Predicates + , isClosedTBMQueue + , isEmptyTBMQueue + , isFullTBMQueue + -- ** Other functionality + , estimateFreeSlotsTBMQueue + , freeSlotsTBMQueue + ) where + +import Prelude hiding (reads) +#if __GLASGOW_HASKELL__ < 912 +import Data.Typeable (Typeable) +#endif +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad.STM (STM, retry) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TQueue -- N.B., GHC only +---------------------------------------------------------------- + +-- | @TBMQueue@ is an abstract type representing a bounded closeable +-- FIFO queue. +data TBMQueue a = TBMQueue + {-# UNPACK #-} !(TVar Bool) + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TVar Int) + {-# UNPACK #-} !(TQueue a) +#if __GLASGOW_HASKELL__ < 912 + deriving (Typeable) +#endif +-- The components are: +-- * Whether the queue has been closed. +-- * How many free slots we /know/ we have available. +-- * How many slots have been freed up by successful reads since +-- the last time the slot count was synchronized by 'isFullTBQueue'. +-- * The underlying TQueue. + + +-- | Build and returns a new instance of @TBMQueue@ with the given +-- capacity. /N.B./, we do not verify the capacity is positive, but +-- if it is non-positive then 'writeTBMQueue' will always retry and +-- 'isFullTBMQueue' will always be true. +newTBMQueue :: Int -> STM (TBMQueue a) +newTBMQueue n = do + closed <- newTVar False + slots <- newTVar n + reads <- newTVar 0 + queue <- newTQueue + return (TBMQueue closed slots reads queue) + + +-- | @IO@ version of 'newTBMQueue'. This is useful for creating +-- top-level @TBMQueue@s using 'System.IO.Unsafe.unsafePerformIO', +-- because using 'Control.Monad.STM.atomically' inside +-- 'System.IO.Unsafe.unsafePerformIO' isn't possible. +newTBMQueueIO :: Int -> IO (TBMQueue a) +newTBMQueueIO n = do + closed <- newTVarIO False + slots <- newTVarIO n + reads <- newTVarIO 0 + queue <- newTQueueIO + return (TBMQueue closed slots reads queue) + + +-- | Read the next value from the @TBMQueue@, retrying if the queue +-- is empty (and not closed). We return @Nothing@ immediately if +-- the queue is closed and empty. +readTBMQueue :: TBMQueue a -> STM (Maybe a) +readTBMQueue (TBMQueue closed _slots reads queue) = do + b <- readTVar closed + if b + then do + mx <- tryReadTQueue queue + case mx of + Nothing -> return mx + Just _x -> do + modifyTVar' reads (1 +) + return mx + else do + x <- readTQueue queue + modifyTVar' reads (1 +) + return (Just x) +{- +-- The above is slightly optimized over the clearer: +readTBMQueue (TBMQueue closed _slots reads queue) = + b <- readTVar closed + b' <- isEmptyTQueue queue + if b && b' + then return Nothing + else do + x <- readTQueue queue + modifyTVar' reads (1 +) + return (Just x) +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | A version of 'readTBMQueue' which does not retry. Instead it +-- returns @Just Nothing@ if the queue is open but no value is +-- available; it still returns @Nothing@ if the queue is closed +-- and empty. +tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) +tryReadTBMQueue (TBMQueue closed _slots reads queue) = do + b <- readTVar closed + if b + then do + mx <- tryReadTQueue queue + case mx of + Nothing -> return Nothing + Just _x -> do + modifyTVar' reads (1 +) + return (Just mx) + else do + mx <- tryReadTQueue queue + case mx of + Nothing -> return (Just mx) + Just _x -> do + modifyTVar' reads (1 +) + return (Just mx) +{- +-- The above is slightly optimized over the clearer: +tryReadTBMQueue (TBMQueue closed _slots reads queue) = + b <- readTVar closed + b' <- isEmptyTQueue queue + if b && b' + then return Nothing + else do + mx <- tryReadTBMQueue queue + case mx of + Nothing -> return (Just mx) + Just _x -> do + modifyTVar' reads (1 +) + return (Just mx) +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | Get the next value from the @TBMQueue@ without removing it, +-- retrying if the queue is empty. +peekTBMQueue :: TBMQueue a -> STM (Maybe a) +peekTBMQueue (TBMQueue closed _slots _reads queue) = do + b <- readTVar closed + if b + then do + b' <- isEmptyTQueue queue + if b' + then return Nothing + else Just <$> peekTQueue queue + else Just <$> peekTQueue queue +{- +-- The above is lazier reading from @queue@ than the clearer: +peekTBMQueue (TBMQueue closed _slots _reads queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> peekTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | A version of 'peekTBMQueue' which does not retry. Instead it +-- returns @Just Nothing@ if the queue is open but no value is +-- available; it still returns @Nothing@ if the queue is closed +-- and empty. +tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) +tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do + b <- readTVar closed + if b + then fmap Just <$> tryPeekTQueue queue + else Just <$> tryPeekTQueue queue +{- +-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: +tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryPeekTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | Write a value to a @TBMQueue@, retrying if the queue is full. +-- If the queue is closed then the value is silently discarded. +-- Use 'isClosedTBMQueue' to determine if the queue is closed +-- before writing, as needed. +writeTBMQueue :: TBMQueue a -> a -> STM () +writeTBMQueue self@(TBMQueue closed slots _reads queue) x = do + b <- readTVar closed + if b + then return () -- Discard silently + else do + n <- estimateFreeSlotsTBMQueue self + if n <= 0 + then retry + else do + writeTVar slots $! n - 1 + writeTQueue queue x + + +-- | A version of 'writeTBMQueue' which does not retry. Returns @Just +-- True@ if the value was successfully written, @Just False@ if it +-- could not be written (but the queue was open), and @Nothing@ +-- if it was discarded (i.e., the queue was closed). +tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool) +tryWriteTBMQueue self@(TBMQueue closed slots _reads queue) x = do + b <- readTVar closed + if b + then return Nothing + else do + n <- estimateFreeSlotsTBMQueue self + if n <= 0 + then return (Just False) + else do + writeTVar slots $! n - 1 + writeTQueue queue x + return (Just True) + + +-- | Put a data item back onto a queue, where it will be the next +-- item read. If the queue is closed then the value is silently +-- discarded; you can use 'peekTBMQueue' to circumvent this in certain +-- circumstances. /N.B./, this could allow the queue to temporarily +-- become longer than the specified limit, which is necessary to +-- ensure that the item is indeed the next one read. +unGetTBMQueue :: TBMQueue a -> a -> STM () +unGetTBMQueue (TBMQueue closed slots _reads queue) x = do + b <- readTVar closed + if b + then return () -- Discard silently + else do + modifyTVar' slots (subtract 1) + unGetTQueue queue x + + +-- | Closes the @TBMQueue@, preventing any further writes. +closeTBMQueue :: TBMQueue a -> STM () +closeTBMQueue (TBMQueue closed _slots _reads _queue) = + writeTVar closed True + + +-- | Returns @True@ if the supplied @TBMQueue@ has been closed. +isClosedTBMQueue :: TBMQueue a -> STM Bool +isClosedTBMQueue (TBMQueue closed _slots _reads _queue) = + readTVar closed + +{- +-- | Returns @True@ if the supplied @TBMQueue@ has been closed. +isClosedTBMQueueIO :: TBMQueue a -> IO Bool +isClosedTBMQueueIO (TBMQueue closed _slots _reads _queue) = + readTVarIO closed +-} + + +-- | Returns @True@ if the supplied @TBMQueue@ is empty (i.e., has +-- no elements). /N.B./, a @TBMQueue@ can be both \"empty\" and +-- \"full\" at the same time, if the initial limit was non-positive. +isEmptyTBMQueue :: TBMQueue a -> STM Bool +isEmptyTBMQueue (TBMQueue _closed _slots _reads queue) = + isEmptyTQueue queue + + +-- | Returns @True@ if the supplied @TBMQueue@ is full (i.e., is +-- over its limit). /N.B./, a @TBMQueue@ can be both \"empty\" and +-- \"full\" at the same time, if the initial limit was non-positive. +-- /N.B./, a @TBMQueue@ may still be full after reading, if +-- 'unGetTBMQueue' was used to go over the initial limit. +-- +-- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMQueue@ +isFullTBMQueue :: TBMQueue a -> STM Bool +isFullTBMQueue (TBMQueue _closed slots reads _queue) = do + n <- readTVar slots + if n <= 0 + then do + m <- readTVar reads + let n' = n + m + writeTVar slots $! n' + writeTVar reads 0 + return $! n' <= 0 + else return False + + +-- | Estimate the number of free slots. If the result is positive, +-- then it's a minimum bound; if it's non-positive then it's exact. +-- It will only be negative if the initial limit was negative or +-- if 'unGetTBMQueue' was used to go over the initial limit. +-- +-- This function always contends with writers, but only contends +-- with readers when it has to; compare against 'freeSlotsTBMQueue'. +estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int +estimateFreeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do + n <- readTVar slots + if n > 0 + then return n + else do + m <- readTVar reads + let n' = n + m + writeTVar slots $! n' + writeTVar reads 0 + return n' + + +-- | Return the exact number of free slots. The result can be +-- negative if the initial limit was negative or if 'unGetTBMQueue' +-- was used to go over the initial limit. +-- +-- This function always contends with both readers and writers; +-- compare against 'estimateFreeSlotsTBMQueue'. +freeSlotsTBMQueue :: TBMQueue a -> STM Int +freeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do + n <- readTVar slots + m <- readTVar reads + let n' = n + m + writeTVar slots $! n' + writeTVar reads 0 + return n' + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TChan/Compat.hs b/src/Control/Concurrent/STM/TChan/Compat.hs deleted file mode 100644 --- a/src/Control/Concurrent/STM/TChan/Compat.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP #-} ----------------------------------------------------------------- --- 2012.02.29 --- | --- Module : Control.Concurrent.STM.TChan.Compat --- Copyright : Copyright (c) 2011--2012 wren ng thornton --- License : BSD --- Maintainer : wren@community.haskell.org --- Stability : provisional --- Portability : non-portable (GHC STM, CPP) --- --- Compatibility layer for older versions of the @stm@ library. --- Namely, we define 'tryReadTChan', 'peekTChan', and 'tryPeekTChan' --- which @stm<2.3.0@ lacks. These implementations are less efficient --- than the package versions due to the 'TChan' type being abstract. --- However, this module uses Cabal-style CPP macros in order to use --- the package versions when available. ----------------------------------------------------------------- -module Control.Concurrent.STM.TChan.Compat - ( - -- * The TChan type - TChan - -- ** Creating TChans - , newTChan -- :: STM (TChan a) - , newTChanIO -- :: IO (TChan a) - , dupTChan -- :: TChan a -> STM (TChan a) - -- ** Reading from TChans - , readTChan -- :: TChan a -> STM a - , tryReadTChan -- :: TChan a -> STM (Maybe a) - , peekTChan -- :: TChan a -> STM a - , tryPeekTChan -- :: TChan a -> STM (Maybe a) - -- ** Writing to TChans - , unGetTChan -- :: TChan a -> a -> STM () - , writeTChan -- :: TChan a -> a -> STM () - -- ** Predicates - , isEmptyTChan -- :: TChan a -> STM Bool - ) where - -import Control.Concurrent.STM.TChan -- N.B., GHC only - -#if ! (MIN_VERSION_stm(2,3,0)) -import Control.Applicative ((<$>)) -import Control.Monad.STM (STM) - ----------------------------------------------------------------- - --- | A version of 'readTChan' which does not retry. Instead it --- returns @Nothing@ if no value is available. -tryReadTChan :: TChan a -> STM (Maybe a) -tryReadTChan chan = do - b <- isEmptyTChan chan - if b then return Nothing else Just <$> readTChan chan -{- -- The optimized implementation in stm-2.3.0 -tryReadTChan (TChan read _write) = do - hd <- readTVar =<< readTVar read - case hd of - TNil -> return Nothing - TCons a tl -> do - writeTVar read tl - return (Just a) --} - - --- | Get the next value from the @TChan@ without removing it, --- retrying if the channel is empty. -peekTChan :: TChan a -> STM a -peekTChan chan = do - x <- readTChan chan - unGetTChan chan x - return x -{- -- The optimized implementation in stm-2.3.0 -peekTChan (TChan read _write) = do - hd <- readTVar =<< readTVar read - case hd of - TNil -> retry - TCons a _ -> return a --} - - --- | A version of 'peekTChan' which does not retry. Instead it --- returns @Nothing@ if no value is available. -tryPeekTChan :: TChan a -> STM (Maybe a) -tryPeekTChan chan = do - b <- isEmptyTChan chan - if b then return Nothing else Just <$> peekTChan chan -{- -- The optimized implementation in stm-2.3.0 -tryPeekTChan (TChan read _write) = do - hd <- readTVar =<< readTVar read - case hd of - TNil -> return Nothing - TCons a _ -> return (Just a) --} - -#endif - ----------------------------------------------------------------- ------------------------------------------------------------ fin. diff --git a/src/Control/Concurrent/STM/TMChan.hs b/src/Control/Concurrent/STM/TMChan.hs --- a/src/Control/Concurrent/STM/TMChan.hs +++ b/src/Control/Concurrent/STM/TMChan.hs @@ -1,12 +1,21 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 912 +-- ghc-9.12: "all types now auto-derive Typeable" +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif ---------------------------------------------------------------- --- 2012.02.12 +-- 2026-02-26 -- | -- Module : Control.Concurrent.STM.TMChan --- Copyright : Copyright (c) 2011--2012 wren ng thornton +-- Copyright : Copyright (c) 2011--2026 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- @@ -23,6 +32,8 @@ , newTMChan , newTMChanIO , dupTMChan + , newBroadcastTMChan + , newBroadcastTMChanIO -- ** Reading from TMChans , readTMChan , tryReadTMChan @@ -38,23 +49,25 @@ , isEmptyTMChan ) where +#if __GLASGOW_HASKELL__ < 912 import Data.Typeable (Typeable) +#endif +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) -import Control.Monad.STM (STM) -import Control.Concurrent.STM.TVar.Compat -import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only - --- N.B., we need a Custom cabal build-type for this to work. -#ifdef __HADDOCK__ -import Control.Monad.STM (atomically) -import System.IO.Unsafe (unsafePerformIO) #endif +import Control.Monad.STM (STM) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TMChan@ is an abstract type representing a closeable FIFO -- channel. -data TMChan a = TMChan !(TVar Bool) !(TChan a) +data TMChan a = TMChan + {-# UNPACK #-} !(TVar Bool) + {-# UNPACK #-} !(TChan a) +#if __GLASGOW_HASKELL__ < 912 deriving Typeable +#endif -- | Build and returns a new instance of @TMChan@. @@ -66,8 +79,9 @@ -- | @IO@ version of 'newTMChan'. This is useful for creating --- top-level @TMChan@s using 'unsafePerformIO', because using --- 'atomically' inside 'unsafePerformIO' isn't possible. +-- top-level @TMChan@s using 'System.IO.Unsafe.unsafePerformIO', +-- because using 'Control.Monad.STM.atomically' inside +-- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTMChanIO :: IO (TMChan a) newTMChanIO = do closed <- newTVarIO False @@ -75,6 +89,26 @@ return (TMChan closed chan) +-- | Like 'newBroadcastTChan'. +-- +-- /Since: 2.1.0/ +newBroadcastTMChan :: STM (TMChan a) +newBroadcastTMChan = do + closed <- newTVar False + chan <- newBroadcastTChan + return (TMChan closed chan) + + +-- | @IO@ version of 'newBroadcastTMChan'. +-- +-- /Since: 2.1.0/ +newBroadcastTMChanIO :: IO (TMChan a) +newBroadcastTMChanIO = do + closed <- newTVarIO False + chan <- newBroadcastTChanIO + return (TMChan closed chan) + + -- | Duplicate a @TMChan@: the duplicate channel begins empty, but -- data written to either channel from then on will be available -- from both, and closing one copy will close them all. Hence this @@ -146,7 +180,7 @@ peekTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed - if b && b' + if b && b' then return Nothing else Just <$> peekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? @@ -168,7 +202,7 @@ tryPeekTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed - if b && b' + if b && b' then return Nothing else Just <$> tryPeekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? diff --git a/src/Control/Concurrent/STM/TMQueue.hs b/src/Control/Concurrent/STM/TMQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TMQueue.hs @@ -0,0 +1,228 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 912 +-- ghc-9.12: "all types now auto-derive Typeable" +{-# LANGUAGE DeriveDataTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif +---------------------------------------------------------------- +-- 2026-02-26 +-- | +-- Module : Control.Concurrent.STM.TMQueue +-- Copyright : Copyright (c) 2011--2026 wren gayle romano +-- License : BSD +-- Maintainer : wren@cpan.org +-- Stability : provisional +-- Portability : non-portable (GHC STM, DeriveDataTypeable) +-- +-- A version of "Control.Concurrent.STM.TQueue" where the queue is +-- closeable. This is similar to a @TQueue (Maybe a)@ with a +-- monotonicity guarantee that once there's a @Nothing@ there will +-- always be @Nothing@. +-- +-- /Since: 2.0.0/ +---------------------------------------------------------------- +module Control.Concurrent.STM.TMQueue + ( + -- * The TMQueue type + TMQueue() + -- ** Creating TMQueues + , newTMQueue + , newTMQueueIO + -- ** Reading from TMQueues + , readTMQueue + , tryReadTMQueue + , peekTMQueue + , tryPeekTMQueue + -- ** Writing to TMQueues + , writeTMQueue + , unGetTMQueue + -- ** Closing TMQueues + , closeTMQueue + -- ** Predicates + , isClosedTMQueue + , isEmptyTMQueue + ) where + +#if __GLASGOW_HASKELL__ < 912 +import Data.Typeable (Typeable) +#endif +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad.STM (STM) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TQueue -- N.B., GHC only +---------------------------------------------------------------- + +-- | @TMQueue@ is an abstract type representing a closeable FIFO +-- queue. +data TMQueue a = TMQueue + {-# UNPACK #-} !(TVar Bool) + {-# UNPACK #-} !(TQueue a) +#if __GLASGOW_HASKELL__ < 912 + deriving Typeable +#endif + + +-- | Build and returns a new instance of @TMQueue@. +newTMQueue :: STM (TMQueue a) +newTMQueue = do + closed <- newTVar False + queue <- newTQueue + return (TMQueue closed queue) + + +-- | @IO@ version of 'newTMQueue'. This is useful for creating +-- top-level @TMQueue@s using 'System.IO.Unsafe.unsafePerformIO', +-- because using 'Control.Monad.STM.atomically' inside +-- 'System.IO.Unsafe.unsafePerformIO' isn't possible. +newTMQueueIO :: IO (TMQueue a) +newTMQueueIO = do + closed <- newTVarIO False + queue <- newTQueueIO + return (TMQueue closed queue) + + +-- | Read the next value from the @TMQueue@, retrying if the queue +-- is empty (and not closed). We return @Nothing@ immediately if +-- the queue is closed and empty. +readTMQueue :: TMQueue a -> STM (Maybe a) +readTMQueue (TMQueue closed queue) = do + b <- readTVar closed + if b + then tryReadTQueue queue + else Just <$> readTQueue queue +{- +-- The above is lazier reading from @queue@, and slightly optimized, compared to the clearer: +readTMQueue (TMQueue closed queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> readTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | A version of 'readTMQueue' which does not retry. Instead it +-- returns @Just Nothing@ if the queue is open but no value is +-- available; it still returns @Nothing@ if the queue is closed +-- and empty. +tryReadTMQueue :: TMQueue a -> STM (Maybe (Maybe a)) +tryReadTMQueue (TMQueue closed queue) = do + b <- readTVar closed + if b + then fmap Just <$> tryReadTQueue queue + else Just <$> tryReadTQueue queue +{- +-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: +tryReadTMQueue (TMQueue closed queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryReadTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | Get the next value from the @TMQueue@ without removing it, +-- retrying if the queue is empty. +peekTMQueue :: TMQueue a -> STM (Maybe a) +peekTMQueue (TMQueue closed queue) = do + b <- readTVar closed + if b + then do + b' <- isEmptyTQueue queue + if b' + then return Nothing + else Just <$> peekTQueue queue + else Just <$> peekTQueue queue +{- +-- The above is lazier reading from @queue@ than the clearer: +peekTMQueue (TMQueue closed queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> peekTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | A version of 'peekTMQueue' which does not retry. Instead it +-- returns @Just Nothing@ if the queue is open but no value is +-- available; it still returns @Nothing@ if the queue is closed +-- and empty. +tryPeekTMQueue :: TMQueue a -> STM (Maybe (Maybe a)) +tryPeekTMQueue (TMQueue closed queue) = do + b <- readTVar closed + if b + then fmap Just <$> tryPeekTQueue queue + else Just <$> tryPeekTQueue queue +{- +-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: +tryPeekTMQueue (TMQueue closed queue) = do + b <- isEmptyTQueue queue + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryPeekTQueue queue +-- TODO: compare Core and benchmarks; is the loss of clarity worth it? +-} + + +-- | Write a value to a @TMQueue@. If the queue is closed then the +-- value is silently discarded. Use 'isClosedTMQueue' to determine +-- if the queue is closed before writing, as needed. +writeTMQueue :: TMQueue a -> a -> STM () +writeTMQueue (TMQueue closed queue) x = do + b <- readTVar closed + if b + then return () -- discard silently + else writeTQueue queue x + + +-- | Put a data item back onto a queue, where it will be the next +-- item read. If the queue is closed then the value is silently +-- discarded; you can use 'peekTMQueue' to circumvent this in certain +-- circumstances. +unGetTMQueue :: TMQueue a -> a -> STM () +unGetTMQueue (TMQueue closed queue) x = do + b <- readTVar closed + if b + then return () -- discard silently + else unGetTQueue queue x + + +-- | Closes the @TMQueue@, preventing any further writes. +closeTMQueue :: TMQueue a -> STM () +closeTMQueue (TMQueue closed _queue) = + writeTVar closed True + + +-- | Returns @True@ if the supplied @TMQueue@ has been closed. +isClosedTMQueue :: TMQueue a -> STM Bool +isClosedTMQueue (TMQueue closed _queue) = + readTVar closed + +{- +-- | Returns @True@ if the supplied @TMQueue@ has been closed. +isClosedTMQueueIO :: TMQueue a -> IO Bool +isClosedTMQueueIO (TMQueue closed _queue) = + readTVarIO closed +-} + + +-- | Returns @True@ if the supplied @TMQueue@ is empty. +isEmptyTMQueue :: TMQueue a -> STM Bool +isEmptyTMQueue (TMQueue _closed queue) = + isEmptyTQueue queue + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TMVar/Compat.hs b/src/Control/Concurrent/STM/TMVar/Compat.hs deleted file mode 100644 --- a/src/Control/Concurrent/STM/TMVar/Compat.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP #-} ----------------------------------------------------------------- --- 2012.02.29 --- | --- Module : Control.Concurrent.STM.TMVar.Compat --- Copyright : Copyright (c) 2011--2012 wren ng thornton --- License : BSD --- Maintainer : wren@community.haskell.org --- Stability : provisional --- Portability : non-portable (STM, CPP) --- --- Compatibility layer for older versions of the @stm@ library. --- Namely, we define 'tryReadTMVar' which @stm<2.3.0@ lacks. This --- module uses Cabal-style CPP macros in order to use the package --- versions when available. This isn't actually used by the @stm-chans@ --- package, but we provide it anyways since we provide compatibility --- layers for @TVar@ and @TChan@. --- --- /Since: 1.3.0/ ----------------------------------------------------------------- -module Control.Concurrent.STM.TMVar.Compat - ( - -- * The TMVar type - TMVar() - -- ** Creating TMVars - , newTMVar -- :: a -> STM (TMVar a) - , newTMVarIO -- :: a -> IO (TMVar a) - , newEmptyTMVar -- :: STM (TMVar a) - , newEmptyTMVarIO -- :: IO (TMVar a) - -- ** Reading from TMVars - , readTMVar -- :: TMVar a -> STM a - , tryReadTMVar -- :: TMVar a -> STM (Maybe a) - , takeTMVar -- :: TMVar a -> STM a - , tryTakeTMVar -- :: TMVar a -> STM (Maybe a) - -- ** Writing to TMVars - , putTMVar -- :: TMVar a -> a -> STM () - , tryPutTMVar -- :: TMVar a -> a -> STM Bool - , swapTMVar -- :: TMVar a -> a -> STM a - -- TODO: make another patch for trySwapTMVar? - -- ** Other capabilities - , isEmptyTMVar -- :: TMVar a -> STM Bool - ) where - -import Control.Concurrent.STM.TMVar - -#if ! (MIN_VERSION_stm(2,3,0)) -import Control.Concurrent.STM (STM) ----------------------------------------------------------------- - --- | A version of 'readTMVar' which does not retry. Instead it --- returns @Nothing@ if no value is available. -tryReadTMVar :: TMVar a -> STM (Maybe a) -tryReadTMVar var = do - m <- tryTakeTMVar var - case m of - Nothing -> return Nothing - Just x -> putTMVar var x >> return (Just x) -{- -- The optimized implementation in stm-2.3.0 -tryReadTMVar (TMVar t) = readTVar t -{-# INLINE tryReadTMVar #-} --} - -#endif - ----------------------------------------------------------------- ------------------------------------------------------------ fin. diff --git a/src/Control/Concurrent/STM/TVar/Compat.hs b/src/Control/Concurrent/STM/TVar/Compat.hs deleted file mode 100644 --- a/src/Control/Concurrent/STM/TVar/Compat.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# OPTIONS_GHC -Wall -fwarn-tabs #-} -{-# LANGUAGE CPP #-} ----------------------------------------------------------------- --- 2012.02.29 --- | --- Module : Control.Concurrent.STM.TVar.Compat --- Copyright : Copyright (c) 2011--2012 wren ng thornton --- License : BSD --- Maintainer : wren@community.haskell.org --- Stability : provisional --- Portability : non-portable (STM, CPP) --- --- Compatibility layer for older versions of the @stm@ library. --- Namely, we define 'readTVarIO' which @stm<2.1.2@ lacks; and we --- define 'modifyTVar', 'modifyTVar'', and 'swapTVar' which @stm<2.3.0@ --- lacks. This module uses Cabal-style CPP macros in order to use --- the package versions when available. ----------------------------------------------------------------- -module Control.Concurrent.STM.TVar.Compat - ( - -- * The TVar type - TVar() - -- ** Creating TVars - , newTVar -- :: a -> STM (TVar a) - , newTVarIO -- :: a -> IO (TVar a) - -- ** Reading from TVars - , readTVar -- :: TVar a -> STM a - , readTVarIO -- :: TVar a -> IO a - -- ** Writing to TVars - , writeTVar -- :: TVar a -> a -> STM () - , modifyTVar -- :: TVar a -> (a -> a) -> STM () - , modifyTVar' -- :: TVar a -> (a -> a) -> STM () - , swapTVar -- :: TVar a -> a -> STM a - -- ** Other capabilities - , registerDelay -- :: Int -> IO (TVar Bool) - ) where - -import Control.Concurrent.STM.TVar - -#if ! (MIN_VERSION_stm(2,1,2)) -import Control.Concurrent.STM (atomically) -#endif - -#if ! (MIN_VERSION_stm(2,3,0)) -import Control.Concurrent.STM (STM) -#endif ----------------------------------------------------------------- - -#if ! (MIN_VERSION_stm(2,1,2)) --- | Return the current value stored in a TVar. This is equivalent to --- --- > readTVarIO = atomically . readTVar --- --- but works much faster (on @stm >= 2.1.2@), because it doesn't --- perform a complete transaction, it just reads the current value --- of the TVar. -readTVarIO :: TVar a -> IO a -readTVarIO = atomically . readTVar -{-# INLINE readTVarIO #-} -#endif - - -#if ! (MIN_VERSION_stm(2,3,0)) - --- Like 'modifyIORef' but for @TVar@. --- | Mutate the contents of a @TVar@. /N.B./, this version is --- non-strict. -modifyTVar :: TVar a -> (a -> a) -> STM () -modifyTVar var f = do - x <- readTVar var - writeTVar var (f x) -{-# INLINE modifyTVar #-} - - --- | Strict version of 'modifyTVar'. -modifyTVar' :: TVar a -> (a -> a) -> STM () -modifyTVar' var f = do - x <- readTVar var - writeTVar var $! f x -{-# INLINE modifyTVar' #-} - - --- Like 'swapTMVar' but for @TVar@. --- | Swap the contents of a @TVar@ for a new value. -swapTVar :: TVar a -> a -> STM a -swapTVar var new = do - old <- readTVar var - writeTVar var new - return old -{-# INLINE swapTVar #-} - -#endif - ----------------------------------------------------------------- ------------------------------------------------------------ fin. diff --git a/stm-chans.cabal b/stm-chans.cabal --- a/stm-chans.cabal +++ b/stm-chans.cabal @@ -1,52 +1,76 @@ +Cabal-Version: 2.2 +-- Cabal >=2.2 is required for: +-- +-- Since 2.1, the Cabal-Version must be the absolutely first thing +-- in the file, even before comments. Also, no longer uses ">=". +-- + ---------------------------------------------------------------- --- wren ng thornton ~ 2012.02.25 +-- wren gayle romano ~ 2026-02-26 ---------------------------------------------------------------- --- By and large Cabal >=1.2 is fine; but >= 1.6 gives tested-with: --- and source-repository:. -Cabal-Version: >= 1.6 --- We need a custom build in order to define __HADDOCK__ -Build-Type: Custom - Name: stm-chans -Version: 1.3.1 +Version: 3.0.0.11 +Build-Type: Simple Stability: provisional -Homepage: http://code.haskell.org/~wren/ -Author: wren ng thornton, Thomas DuBuisson -Maintainer: wren@community.haskell.org -Copyright: Copyright (c) 2011--2012 wren ng thornton -License: BSD3 +Homepage: https://wrengr.org/software/hackage.html +Bug-Reports: https://github.com/wrengr/stm-chans/issues +Author: wren gayle romano, Thomas DuBuisson +Maintainer: wren@cpan.org +Copyright: 2011–2025 wren romano +-- Cabal-2.2 requires us to say "BSD-3-Clause" not "BSD3" +License: BSD-3-Clause License-File: LICENSE Category: Concurrency Synopsis: Additional types of channels for STM. Description: Additional types of channels for STM. -Tested-With: - GHC == 6.12.1, GHC == 6.12.3 Extra-source-files: - AUTHORS, README, VERSION + AUTHORS, README.md, CHANGELOG + +-- This used to be tested on 7.8.3 and 7.10.1, but we don't verify that by CI. +-- +Tested-With: + GHC ==8.0.2, + GHC ==8.2.2, + GHC ==8.4.4, + GHC ==8.6.5, + GHC ==8.8.4, + GHC ==8.10.3, + GHC ==9.0.1, + GHC ==9.2.4, + GHC ==9.4.8, + GHC ==9.6.5, + GHC ==9.8.2, + GHC ==9.10.1, + GHC ==9.12.1, + GHC ==9.14.1 + +---------------------------------------------------------------- Source-Repository head - Type: darcs - Location: http://community.haskell.org/~wren/stm-chans + Type: git + Location: https://github.com/wrengr/stm-chans.git ---------------------------------------------------------------- Library - -- Not sure what the real minbounds are for base and stm... + Default-Language: Haskell2010 + -- N.B., the following versions are required for: + -- * stm >= 2.4: T{,B}Queue and newBroadcastTChan{,IO} + -- * stm >= 2.3.0: fast tryReadTChan, peekTChan, tryPeekTChan, + -- tryReadTMVar, modifyTVar, modifyTVar', swapTVar. + -- * stm >= 2.1.2: fast readTVarIO. -- - -- N.B., stm >= 2.1.2 is required for fast readTVarIO. And - -- stm >= 2.3.0 is required for fast tryReadTChan, peekTChan, - -- tryPeekTChan, tryReadTMVar, modifyTVar, modifyTVar', swapTVar. + -- Not sure what the real minbound is for base... Build-Depends: base >= 4.1 && < 5 - , stm >= 2.1.1 - + , stm >= 2.4 + Hs-Source-Dirs: src Exposed-Modules: Control.Concurrent.STM.TBChan , Control.Concurrent.STM.TBMChan , Control.Concurrent.STM.TMChan - , Control.Concurrent.STM.TChan.Compat - , Control.Concurrent.STM.TMVar.Compat - , Control.Concurrent.STM.TVar.Compat + , Control.Concurrent.STM.TBMQueue + , Control.Concurrent.STM.TMQueue ---------------------------------------------------------------- ----------------------------------------------------------- fin.