stm-2.4.4.1/0000755000000000000000000000000012636243673010665 5ustar0000000000000000stm-2.4.4.1/changelog.md0000644000000000000000000000237512636243673013145 0ustar0000000000000000# Changelog for [`stm` package](http://hackage.haskell.org/package/stm) ## 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` stm-2.4.4.1/stm.cabal0000644000000000000000000000272712636243673012464 0ustar0000000000000000name: stm version: 2.4.4.1 -- 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 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.* extra-source-files: changelog.md source-repository head type: git location: http://git.haskell.org/packages/stm.git library 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 build-depends: base >= 4.3 && < 4.10, 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 stm-2.4.4.1/Setup.hs0000644000000000000000000000012712636243673012321 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain stm-2.4.4.1/LICENSE0000644000000000000000000000311312636243673011670 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. stm-2.4.4.1/Control/0000755000000000000000000000000012636243673012305 5ustar0000000000000000stm-2.4.4.1/Control/Sequential/0000755000000000000000000000000012636243673014417 5ustar0000000000000000stm-2.4.4.1/Control/Sequential/STM.hs0000644000000000000000000000441412636243673015421 0ustar0000000000000000-- Transactional memory for sequential implementations. -- Transactions do not run concurrently, but are atomic in the face -- of exceptions. {-# LANGUAGE CPP #-} #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 ) 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 -- The reference contains a rollback action to be executed on exceptions newtype STM a = STM (IORef (IO ()) -> IO a) unSTM :: STM a -> IORef (IO ()) -> IO a unSTM (STM f) = f instance Functor STM where fmap f (STM m) = STM (fmap f . m) instance Applicative STM where pure = STM . const . pure STM mf <*> STM mx = STM $ \ r -> mf r <*> mx r instance Monad STM where return = pure STM m >>= k = STM $ \ r -> do x <- m r unSTM (k x) r atomically :: STM a -> IO a atomically (STM m) = do r <- newIORef (return ()) m r `onException` do rollback <- readIORef r rollback throwSTM :: Exception e => e -> STM a throwSTM = STM . const . throwIO catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a 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 newtype TVar a = TVar (IORef a) deriving (Eq) newTVar :: a -> STM (TVar a) newTVar a = STM (const (newTVarIO a)) newTVarIO :: a -> IO (TVar a) newTVarIO a = do ref <- newIORef a return (TVar ref) readTVar :: TVar a -> STM a readTVar (TVar ref) = STM (const (readIORef ref)) readTVarIO :: TVar a -> IO a readTVarIO (TVar ref) = readIORef ref writeTVar :: TVar a -> a -> STM () writeTVar (TVar ref) a = STM $ \ r -> do oldval <- readIORef ref modifyIORef r (writeIORef ref oldval >>) writeIORef ref a stm-2.4.4.1/Control/Monad/0000755000000000000000000000000012636243673013343 5ustar0000000000000000stm-2.4.4.1/Control/Monad/STM.hs0000644000000000000000000000701412636243673014344 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- Software Transactional Memory: a modular composable concurrency -- 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. -- -- -- This module only defines the 'STM' monad; you probably want to -- import "Control.Concurrent.STM" (which exports "Control.Monad.STM"). ----------------------------------------------------------------------------- module Control.Monad.STM ( STM, atomically, #ifdef __GLASGOW_HASKELL__ always, alwaysSucceeds, retry, orElse, check, #endif throwSTM, catchSTM ) where #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) import GHC.Conc hiding (catchSTM) import Control.Monad ( MonadPlus(..) ) import Control.Exception #else import GHC.Conc #endif import GHC.Exts import Control.Monad.Fix #else import Control.Sequential.STM #endif #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) import Control.Applicative import Control.Monad (ap) #endif #endif #ifdef __GLASGOW_HASKELL__ #if ! (MIN_VERSION_base(4,3,0)) instance MonadPlus STM where mzero = retry mplus = orElse instance Applicative STM where pure = return (<*>) = ap instance Alternative STM where empty = retry (<|>) = orElse #endif check :: Bool -> STM () check b = if b then return () else retry #endif #if ! (MIN_VERSION_base(4,3,0)) -- |Exception handling within STM actions. catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a catchSTM (STM m) handler = STM $ catchSTM# m handler' where handler' e = case fromException e of Just e' -> case handler e' of STM m' -> m' Nothing -> raiseIO# e -- | 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. -- -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the -- two functions are subtly different: -- -- > throw e `seq` x ===> throw e -- > throwSTM e `seq` x ===> x -- -- The first example will cause the exception @e@ to be raised, -- whereas the second one won\'t. In fact, 'throwSTM' will only cause -- an exception to be raised when it is used within the 'STM' monad. -- The 'throwSTM' variant should be used in preference to 'throw' to -- raise an exception within the 'STM' monad because it guarantees -- ordering with respect to other 'STM' operations, whereas 'throw' -- does not. throwSTM :: Exception e => e -> STM a throwSTM e = STM $ raiseIO# (toException e) #endif data STMret a = STMret (State# RealWorld) a liftSTM :: STM a -> State# RealWorld -> STMret a liftSTM (STM m) = \s -> case m s of (# s', r #) -> STMret s' r 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 #) stm-2.4.4.1/Control/Concurrent/0000755000000000000000000000000012636243673014427 5ustar0000000000000000stm-2.4.4.1/Control/Concurrent/STM.hs0000644000000000000000000000312112636243673015423 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- Software Transactional Memory: a modular composable concurrency -- 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. -- -- ----------------------------------------------------------------------------- module Control.Concurrent.STM ( module Control.Monad.STM, module Control.Concurrent.STM.TVar, #ifdef __GLASGOW_HASKELL__ 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 ) where import Control.Monad.STM import Control.Concurrent.STM.TVar #ifdef __GLASGOW_HASKELL__ import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TChan #endif import Control.Concurrent.STM.TArray import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TBQueue stm-2.4.4.1/Control/Concurrent/STM/0000755000000000000000000000000012636243673015072 5ustar0000000000000000stm-2.4.4.1/Control/Concurrent/STM/TVar.hs0000644000000000000000000000373112636243673016306 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- TVar: Transactional variables -- ----------------------------------------------------------------------------- module Control.Concurrent.STM.TVar ( -- * TVars TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar, modifyTVar, modifyTVar', swapTVar, #ifdef __GLASGOW_HASKELL__ registerDelay, #endif mkWeakTVar ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Conc import GHC.Weak #else import Control.Sequential.STM #endif -- 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 #-} -- | 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 #) stm-2.4.4.1/Control/Concurrent/STM/TSem.hs0000644000000000000000000000323412636243673016300 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 ) where import Control.Concurrent.STM import Control.Monad import Data.Typeable -- | 'TSem' is a transactional semaphore. It holds a certain number -- of units, and units may be acquired or released by 'waitTSem' and -- 'signalTSem' respectively. When the 'TSem' is empty, 'waitTSem' -- blocks. -- -- Note that 'TSem' has no concept of fairness, and there is no -- guarantee that threads blocked in `waitTSem` will be unblocked in -- the same order; in fact they will all be unblocked at the same time -- and will fight over the 'TSem'. Hence 'TSem' is not suitable if -- you expect there to be a high number of threads contending for the -- resource. However, like other STM abstractions, 'TSem' is -- composable. -- -- @since 2.4.2 newtype TSem = TSem (TVar Int) deriving (Eq, Typeable) newTSem :: Int -> STM TSem newTSem i = fmap TSem (newTVar i) waitTSem :: TSem -> STM () waitTSem (TSem t) = do i <- readTVar t when (i <= 0) retry writeTVar t $! (i-1) signalTSem :: TSem -> STM () signalTSem (TSem t) = do i <- readTVar t writeTVar t $! i+1 stm-2.4.4.1/Control/Concurrent/STM/TArray.hs0000644000000000000000000000443612636243673016637 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #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 -- ----------------------------------------------------------------------------- module Control.Concurrent.STM.TArray ( TArray ) where import Data.Array (Array, bounds) import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..), IArray(numElements)) import Data.Ix (rangeSize) import Data.Typeable (Typeable) import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar) #ifdef __GLASGOW_HASKELL__ import GHC.Conc (STM) #else import Control.Sequential.STM (STM) #endif -- |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). -- newtype TArray i e = TArray (Array i (TVar e)) deriving (Eq, Typeable) instance MArray TArray e STM where getBounds (TArray a) = return (bounds 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) return $ TArray (listArray b a) unsafeRead (TArray a) i = readTVar $ unsafeAt a i unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e getNumElements (TArray a) = return (numElements a) -- | 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] rep n m = go n [] where go 0 xs = return xs go i xs = do x <- m go (i-1) (x:xs) stm-2.4.4.1/Control/Concurrent/STM/TBQueue.hs0000644000000000000000000001357012636243673016746 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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 -- 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)/ -- enqueue and dequeue operations. -- -- @since 2.4 ----------------------------------------------------------------------------- module Control.Concurrent.STM.TBQueue ( -- * TBQueue TBQueue, newTBQueue, newTBQueueIO, readTBQueue, tryReadTBQueue, peekTBQueue, tryPeekTBQueue, writeTBQueue, unGetTBQueue, isEmptyTBQueue, isFullTBQueue, ) where import Data.Typeable import GHC.Conc #define _UPK_(x) {-# UNPACK #-} !(x) -- | '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) deriving Typeable instance Eq (TBQueue a) where 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 -- CR. So in the common case we avoid contention between CR and CW. -- -- - when removing an element from R: -- CR := CR + 1 -- -- - when adding an element to W: -- if CW is non-zero -- then CW := CW - 1 -- then if CR is non-zero -- 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 -> STM (TBQueue a) newTBQueue size = do read <- newTVar [] write <- newTVar [] rsize <- newTVar 0 wsize <- newTVar size return (TBQueue rsize read wsize write) -- |@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 size = do read <- newTVarIO [] write <- newTVarIO [] rsize <- newTVarIO 0 wsize <- newTVarIO size return (TBQueue rsize read wsize write) -- |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 w <- readTVar wsize if (w /= 0) then do writeTVar wsize (w - 1) else do r <- readTVar rsize if (r /= 0) then do writeTVar rsize 0 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 xs <- readTVar read r <- readTVar rsize writeTVar rsize (r + 1) case xs of (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 '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 -- | 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 -- | A version of 'peekTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryPeekTBQueue :: TBQueue a -> STM (Maybe a) tryPeekTBQueue c = do m <- tryReadTBQueue c case m of Nothing -> return Nothing Just x -> do unGetTBQueue c x return m -- |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 r <- readTVar rsize if (r > 0) then do writeTVar rsize (r - 1) else do w <- readTVar wsize if (w > 0) then writeTVar wsize (w - 1) else retry xs <- readTVar read writeTVar read (a:xs) -- |Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool isEmptyTBQueue (TBQueue _rsize read _wsize write) = do xs <- readTVar read case xs of (_:_) -> return False [] -> do ys <- readTVar write 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) = do w <- readTVar wsize if (w > 0) then return False else do r <- readTVar rsize if (r > 0) then return False else return True stm-2.4.4.1/Control/Concurrent/STM/TChan.hs0000644000000000000000000001401712636243673016426 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- TChan: Transactional channels -- (GHC only) -- ----------------------------------------------------------------------------- module Control.Concurrent.STM.TChan ( #ifdef __GLASGOW_HASKELL__ -- * TChans TChan, -- ** Construction newTChan, newTChanIO, newBroadcastTChan, newBroadcastTChanIO, dupTChan, cloneTChan, -- ** Reading and writing readTChan, tryReadTChan, peekTChan, tryPeekTChan, writeTChan, unGetTChan, isEmptyTChan #endif ) where #ifdef __GLASGOW_HASKELL__ import GHC.Conc import Data.Typeable (Typeable) #define _UPK_(x) {-# UNPACK #-} !(x) -- | 'TChan' is an abstract type representing an unbounded FIFO channel. data TChan a = TChan _UPK_(TVar (TVarList a)) _UPK_(TVar (TVarList a)) deriving (Eq, Typeable) type TVarList a = TVar (TList a) data TList a = TNil | TCons a _UPK_(TVarList a) -- |Build and return a new instance of 'TChan' newTChan :: STM (TChan a) newTChan = do hole <- newTVar TNil read <- newTVar hole write <- newTVar hole return (TChan read write) -- |@IO@ version of 'newTChan'. This is useful for creating top-level -- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTChanIO :: IO (TChan a) newTChanIO = do hole <- newTVarIO TNil read <- newTVarIO hole write <- newTVarIO hole return (TChan read write) -- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry' -- even after items have been written to the channel. The only way to read -- a broadcast channel is to duplicate it with 'dupTChan'. -- -- Consider a server that broadcasts messages to clients: -- -- >serve :: TChan Message -> Client -> IO loop -- >serve broadcastChan client = do -- > myChan <- dupTChan broadcastChan -- > forever $ do -- > message <- readTChan myChan -- > send client message -- -- The problem with using 'newTChan' to create the broadcast channel is that if -- 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 read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") write <- newTVar write_hole return (TChan read write) -- | @IO@ version of 'newBroadcastTChan'. -- -- @since 2.4 newBroadcastTChanIO :: IO (TChan a) newBroadcastTChanIO = do write_hole <- newTVarIO TNil read <- newTVarIO (error "reading from a TChan created by newBroadcastTChanIO; use dupTChan first") write <- newTVarIO write_hole return (TChan read write) -- |Write a value to a 'TChan'. writeTChan :: TChan a -> a -> STM () writeTChan (TChan _read write) a = do listend <- readTVar write -- listend == TVar pointing to TNil new_listend <- newTVar TNil writeTVar listend (TCons a new_listend) writeTVar write new_listend -- |Read the next value from the 'TChan'. readTChan :: TChan a -> STM a readTChan (TChan read _write) = do listhead <- readTVar read head <- readTVar listhead case head of TNil -> retry TCons a tail -> do writeTVar read tail return a -- | A version of 'readTChan' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTChan :: TChan a -> STM (Maybe a) tryReadTChan (TChan read _write) = do listhead <- readTVar read head <- readTVar listhead case head 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 (TChan read _write) = do listhead <- readTVar read head <- readTVar listhead case head 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 (TChan read _write) = do listhead <- readTVar read head <- readTVar listhead case head of TNil -> return Nothing TCons a _ -> return (Just a) -- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to -- either channel from then on will be available from both. Hence this creates -- a kind of broadcast channel, where data written by anyone is seen by -- everyone else. dupTChan :: TChan a -> STM (TChan a) dupTChan (TChan _read write) = do hole <- readTVar write new_read <- newTVar hole return (TChan new_read write) -- |Put a data item back onto a channel, where it will be the next item read. unGetTChan :: TChan a -> a -> STM () unGetTChan (TChan read _write) a = do listhead <- readTVar read newhead <- newTVar (TCons a listhead) writeTVar read newhead -- |Returns 'True' if the supplied 'TChan' is empty. isEmptyTChan :: TChan a -> STM Bool isEmptyTChan (TChan read _write) = do listhead <- readTVar read head <- readTVar listhead case head of TNil -> return True TCons _ _ -> return False -- |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 new_read <- newTVar readpos return (TChan new_read write) #endif stm-2.4.4.1/Control/Concurrent/STM/TMVar.hs0000644000000000000000000001143512636243673016423 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- TMVar: Transactional MVars, for use in the STM monad -- (GHC only) -- ----------------------------------------------------------------------------- module Control.Concurrent.STM.TMVar ( #ifdef __GLASGOW_HASKELL__ -- * TMVars TMVar, newTMVar, newEmptyTMVar, newTMVarIO, newEmptyTMVarIO, takeTMVar, putTMVar, readTMVar, tryReadTMVar, swapTMVar, tryTakeTMVar, tryPutTMVar, isEmptyTMVar, mkWeakTMVar #endif ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Conc import GHC.Weak import Data.Typeable (Typeable) newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable) {- ^ A 'TMVar' is a synchronising variable, used for communication between concurrent threads. It can be thought of as a box, which may be empty or full. -} -- |Create a 'TMVar' which contains the supplied value. newTMVar :: a -> STM (TMVar a) newTMVar a = do t <- newTVar (Just a) return (TMVar t) -- |@IO@ version of 'newTMVar'. This is useful for creating top-level -- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTMVarIO :: a -> IO (TMVar a) newTMVarIO a = do t <- newTVarIO (Just a) return (TMVar t) -- |Create a 'TMVar' which is initially empty. newEmptyTMVar :: STM (TMVar a) newEmptyTMVar = do t <- newTVar Nothing return (TMVar t) -- |@IO@ version of 'newEmptyTMVar'. This is useful for creating top-level -- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newEmptyTMVarIO :: IO (TMVar a) newEmptyTMVarIO = do t <- newTVarIO Nothing return (TMVar t) -- |Return the contents of the 'TMVar'. If the 'TMVar' is currently -- empty, the transaction will 'retry'. After a 'takeTMVar', -- the 'TMVar' is left empty. takeTMVar :: TMVar a -> STM a takeTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> retry Just a -> do writeTVar t Nothing; return a -- | A version of 'takeTMVar' that does not 'retry'. The 'tryTakeTMVar' -- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if -- the 'TMVar' was full with contents @a@. After 'tryTakeTMVar', the -- 'TMVar' is left empty. tryTakeTMVar :: TMVar a -> STM (Maybe a) tryTakeTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> return Nothing Just a -> do writeTVar t Nothing; return (Just a) -- |Put a value into a 'TMVar'. If the 'TMVar' is currently full, -- 'putTMVar' will 'retry'. putTMVar :: TMVar a -> a -> STM () putTMVar (TMVar t) a = do m <- readTVar t case m of Nothing -> do writeTVar t (Just a); return () Just _ -> retry -- | A version of 'putTMVar' that does not 'retry'. The 'tryPutTMVar' -- function attempts to put the value @a@ into the 'TMVar', returning -- 'True' if it was successful, or 'False' otherwise. tryPutTMVar :: TMVar a -> a -> STM Bool tryPutTMVar (TMVar t) a = do m <- readTVar t case m of Nothing -> do writeTVar t (Just a); return True Just _ -> return False -- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it -- takes the value from the 'TMVar', puts it back, and also returns -- it. readTMVar :: TMVar a -> STM a readTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> retry Just a -> return a -- | A version of 'readTMVar' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTMVar :: TMVar a -> STM (Maybe a) tryReadTMVar (TMVar t) = readTVar t -- |Swap the contents of a 'TMVar' for a new value. swapTMVar :: TMVar a -> a -> STM a swapTMVar (TMVar t) new = do m <- readTVar t case m of Nothing -> retry Just old -> do writeTVar t (Just new); return old -- |Check whether a given 'TMVar' is empty. isEmptyTMVar :: TMVar a -> STM Bool isEmptyTMVar (TMVar t) = do m <- readTVar t 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 stm-2.4.4.1/Control/Concurrent/STM/TQueue.hs0000644000000000000000000001013312636243673016634 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- -- A 'TQueue' is like a 'TChan', with two important differences: -- -- * it has faster throughput than both 'TChan' and 'Chan' (although -- the costs are amortised, so the cost of individual operations -- can vary a lot). -- -- * it does /not/ provide equivalents of the 'dupTChan' and -- 'cloneTChan' operations. -- -- The implementation is based on the traditional purely-functional -- 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, unGetTQueue, isEmptyTQueue, ) where import GHC.Conc 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 instance Eq (TQueue a) where TQueue a _ == TQueue b _ = a == b -- |Build and returns a new instance of 'TQueue' newTQueue :: STM (TQueue a) newTQueue = do read <- newTVar [] write <- newTVar [] return (TQueue read write) -- |@IO@ version of 'newTQueue'. This is useful for creating top-level -- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTQueueIO :: IO (TQueue a) newTQueueIO = do read <- newTVarIO [] write <- newTVarIO [] return (TQueue read write) -- |Write a value to a 'TQueue'. writeTQueue :: TQueue a -> a -> STM () writeTQueue (TQueue _read write) a = do listend <- readTVar write writeTVar write (a:listend) -- |Read the next value from the 'TQueue'. readTQueue :: TQueue a -> STM a 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 -- | 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 -- | 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 -- | A version of 'peekTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryPeekTQueue :: TQueue a -> STM (Maybe a) tryPeekTQueue c = do m <- tryReadTQueue c case m of Nothing -> return Nothing Just x -> do unGetTQueue c x return m -- |Put a data item back onto a channel, where it will be the next item read. unGetTQueue :: TQueue a -> a -> STM () unGetTQueue (TQueue read _write) a = do xs <- readTVar read writeTVar read (a:xs) -- |Returns 'True' if the supplied 'TQueue' is empty. isEmptyTQueue :: TQueue a -> STM Bool isEmptyTQueue (TQueue read write) = do xs <- readTVar read case xs of (_:_) -> return False [] -> do ys <- readTVar write case ys of [] -> return True _ -> return False