stm 2.2.0.1 → 2.3
raw patch · 8 files changed
+150/−21 lines, 8 files
Files
- Control/Concurrent/STM.hs +6/−0
- Control/Concurrent/STM/TArray.hs +18/−3
- Control/Concurrent/STM/TChan.hs +40/−1
- Control/Concurrent/STM/TMVar.hs +14/−10
- Control/Concurrent/STM/TVar.hs +40/−2
- Control/Monad/STM.hs +20/−2
- Control/Sequential/STM.hs +6/−0
- stm.cabal +6/−3
Control/Concurrent/STM.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM
Control/Concurrent/STM/TArray.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TArray@@ -18,7 +22,6 @@ TArray ) where -import Control.Monad (replicateM) import Data.Array (Array, bounds) import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..), IArray(numElements))@@ -43,11 +46,23 @@ instance MArray TArray e STM where getBounds (TArray a) = return (bounds a) newArray b e = do- a <- replicateM (rangeSize b) (newTVar e)+ a <- rep (rangeSize b) (newTVar e) return $ TArray (listArray b a) newArray_ b = do- a <- replicateM (rangeSize b) (newTVar arrEleBottom)+ 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)
Control/Concurrent/STM/TChan.hs view
@@ -1,6 +1,10 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TChan@@ -23,6 +27,9 @@ newTChan, newTChanIO, readTChan,+ tryReadTChan,+ peekTChan,+ tryPeekTChan, writeTChan, dupTChan, unGetTChan,@@ -78,6 +85,38 @@ 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
Control/Concurrent/STM/TMVar.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TMVar@@ -26,6 +30,7 @@ takeTMVar, putTMVar, readTMVar, + tryReadTMVar, swapTMVar, tryTakeTMVar, tryPutTMVar,@@ -115,10 +120,9 @@ 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.--}+-- | 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@@ -126,6 +130,11 @@ 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@@ -135,11 +144,6 @@ Just old -> do writeTVar t (Just new); return old -- |Check whether a given 'TMVar' is empty.------ Notice that the boolean value returned is just a snapshot of--- the state of the 'TMVar'. By the time you get to react on its result,--- the 'TMVar' may have been filled (or emptied) - so be extremely--- careful when using this operation. Use 'tryTakeTMVar' instead if possible. isEmptyTMVar :: TMVar a -> STM Bool isEmptyTMVar (TMVar t) = do m <- readTVar t
Control/Concurrent/STM/TVar.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TVar@@ -16,10 +22,13 @@ -- * TVars TVar, newTVar,+ newTVarIO, readTVar,+ readTVarIO, writeTVar,- newTVarIO,- readTVarIO,+ modifyTVar,+ modifyTVar',+ swapTVar, #ifdef __GLASGOW_HASKELL__ registerDelay #endif@@ -34,3 +43,32 @@ #if ! (MIN_VERSION_base(4,2,0)) readTVarIO = atomically . readTVar #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 #-}+
Control/Monad/STM.hs view
@@ -1,5 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.STM@@ -40,11 +45,12 @@ #if ! (MIN_VERSION_base(4,3,0)) import GHC.Conc hiding (catchSTM) import Control.Monad ( MonadPlus(..) )-import GHC.Exts (raiseIO#, catchSTM#) import Control.Exception #else import GHC.Conc #endif+import GHC.Exts+import Control.Monad.Fix #else import Control.Sequential.STM #endif@@ -90,3 +96,15 @@ 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 #)
Control/Sequential/STM.hs view
@@ -2,6 +2,12 @@ -- Transactions do not run concurrently, but are atomic in the face -- of exceptions. +{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ -- #hide module Control.Sequential.STM ( STM, atomically, throwSTM, catchSTM,
stm.cabal view
@@ -1,5 +1,5 @@ name: stm-version: 2.2.0.1+version: 2.3 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org@@ -7,8 +7,12 @@ category: Concurrency description: A modular composable concurrency abstraction. build-type: Simple-cabal-version: >=1.2+cabal-version: >=1.6 +source-repository head+ type: git+ location: http://darcs.haskell.org/packages/stm.git/+ flag base4 library@@ -29,4 +33,3 @@ build-depends: base <4 if impl(ghc >= 6.10) build-depends: base >=4- extensions: CPP