diff --git a/Control/Concurrent/Broadcast.hs b/Control/Concurrent/Broadcast.hs --- a/Control/Concurrent/Broadcast.hs +++ b/Control/Concurrent/Broadcast.hs @@ -53,7 +53,7 @@ import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, putMVar, readMVar, modifyMVar_ ) -import Control.Exception ( block, onException ) +import Control.Exception ( onException ) import Data.Eq ( Eq ) import Data.Either ( Either(Left ,Right), either ) import Data.Function ( ($), const ) @@ -69,8 +69,8 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra: -import Utils ( purelyModifyMVar ) +-- from concurrent-extra (this package): +import Utils ( purelyModifyMVar, mask_ ) import Control.Concurrent.Timeout ( timeout ) @@ -90,11 +90,11 @@ newtype Broadcast α = Broadcast {unBroadcast ∷ MVar (Either [MVar α] α)} deriving (Eq, Typeable) --- | @new@ Creates a broadcast in the \"silent\" state. +-- | @new@ creates a broadcast in the \"silent\" state. new ∷ IO (Broadcast α) new = Broadcast <$> newMVar (Left []) --- | @newBroadcasting x@ Creates a broadcast in the \"broadcasting @x@\" state. +-- | @newBroadcasting x@ creates a broadcast in the \"broadcasting @x@\" state. newBroadcasting ∷ α → IO (Broadcast α) newBroadcasting x = Broadcast <$> newMVar (Right x) @@ -108,7 +108,7 @@ @'broadcast's@ a value to the broadcast. -} listen ∷ Broadcast α → IO α -listen (Broadcast mv) = block $ do +listen (Broadcast mv) = mask_ $ do mx ← takeMVar mv case mx of Left ls → do l ← newEmptyMVar @@ -142,7 +142,7 @@ Negative timeouts are treated the same as a timeout of 0 μs. -} listenTimeout ∷ Broadcast α → Integer → IO (Maybe α) -listenTimeout (Broadcast mv) time = block $ do +listenTimeout (Broadcast mv) time = mask_ $ do mx ← takeMVar mv case mx of Left ls → do l ← newEmptyMVar diff --git a/Control/Concurrent/Event.hs b/Control/Concurrent/Event.hs --- a/Control/Concurrent/Event.hs +++ b/Control/Concurrent/Event.hs @@ -57,7 +57,7 @@ -- Imports ------------------------------------------------------------------------------- --- from base +-- from base: import Data.Bool ( Bool(..) ) import Data.Eq ( Eq ) import Data.Functor ( fmap, (<$>) ) @@ -69,10 +69,10 @@ import Prelude ( Integer ) import System.IO ( IO ) --- from base-unicode-symbols +-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra +-- from concurrent-extra (this package): import Control.Concurrent.Broadcast ( Broadcast ) import qualified Control.Concurrent.Broadcast as Broadcast ( new, newBroadcasting diff --git a/Control/Concurrent/Lock.hs b/Control/Concurrent/Lock.hs --- a/Control/Concurrent/Lock.hs +++ b/Control/Concurrent/Lock.hs @@ -59,10 +59,10 @@ import Control.Applicative ( liftA2 ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, tryTakeMVar - , tryPutMVar + , putMVar, tryPutMVar , isEmptyMVar ) -import Control.Exception ( block, bracket_, finally ) +import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK__ @@ -79,7 +79,10 @@ -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from concurrent-extra (this package): +import Utils ( mask, mask_ ) + -------------------------------------------------------------------------------- -- Locks -------------------------------------------------------------------------------- @@ -178,10 +181,12 @@ computation is returned. -} tryWith ∷ Lock → IO α → IO (Maybe α) -tryWith l a = block $ do +tryWith l a = mask $ \restore → do acquired ← tryAcquire l if acquired - then Just <$> a `finally` release l + then do r ← restore a `onException` release l + release l + return $ Just r else return Nothing {-| @@ -192,12 +197,12 @@ @wait@ does not alter the state of the lock. -Note that @wait@ is just a convenience function defined as: +Note that @wait@ is just a convenience function we can be defined as: @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait ∷ Lock → IO () -wait l = block $ acquire l >> release l +wait (Lock mv) = mask_ $ takeMVar mv >> putMVar mv () -------------------------------------------------------------------------------- diff --git a/Control/Concurrent/Lock/Test.hs b/Control/Concurrent/Lock/Test.hs --- a/Control/Concurrent/Lock/Test.hs +++ b/Control/Concurrent/Lock/Test.hs @@ -11,12 +11,14 @@ -- from base: import Control.Concurrent ( forkIO ) -import Control.Monad ( (>>=), fail, (>>) ) -import Data.Bool ( not ) +import Control.Monad ( return, (>>=), fail, (>>) ) +import Data.Bool ( Bool(False, True), not, (&&) ) import Data.Function ( ($) ) -import Data.Functor ( fmap ) +import Data.Functor ( fmap ) +import Data.IORef ( newIORef, writeIORef, readIORef ) import Prelude ( fromInteger ) + -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Prelude.Unicode ( (⋅) ) @@ -47,6 +49,7 @@ , testCase "newAcquired locked" test_lock_5 , testCase "acq rel unlocked" test_lock_6 , testCase "conc release" test_lock_7 + , testCase "wait" test_lock_8 ] test_lock_1 ∷ Assertion @@ -82,6 +85,18 @@ l ← Lock.newAcquired _ ← forkIO $ wait_a_moment >> Lock.release l Lock.acquire l + +test_lock_8 ∷ Assertion +test_lock_8 = assert $ do + ioRef ← newIORef False + l ← Lock.newAcquired + _ ← forkIO $ do wait_a_moment + writeIORef ioRef True + Lock.release l + Lock.wait l + set ← readIORef ioRef + locked ← Lock.locked l + return $ set && not locked -- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/RLock.hs b/Control/Concurrent/RLock.hs --- a/Control/Concurrent/RLock.hs +++ b/Control/Concurrent/RLock.hs @@ -65,7 +65,7 @@ import Control.Applicative ( liftA2 ) import Control.Concurrent ( ThreadId, myThreadId ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar ) -import Control.Exception ( block, bracket_, finally ) +import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), fail, (>>) ) import Data.Bool ( Bool(False, True), otherwise ) import Data.Eq ( Eq ) @@ -82,12 +82,14 @@ import Data.Function.Unicode ( (∘) ) import Data.Monoid.Unicode ( (⊕) ) --- from concurrent-extra: +-- from concurrent-extra (this package): import Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock ( new, newAcquired, acquire, release, wait ) +import Utils ( mask, mask_ ) + -------------------------------------------------------------------------------- -- Reentrant locks -------------------------------------------------------------------------------- @@ -165,7 +167,7 @@ acquire ∷ RLock → IO () acquire (RLock mv) = do myTID ← myThreadId - block $ let acq = do t@(mb, lock) ← takeMVar mv + mask_ $ let acq = do t@(mb, lock) ← takeMVar mv case mb of Nothing → do Lock.acquire lock putMVar mv (Just (myTID, 1), lock) @@ -190,7 +192,7 @@ tryAcquire ∷ RLock → IO Bool tryAcquire (RLock mv) = do myTID ← myThreadId - block $ do + mask_ $ do t@(mb, lock) ← takeMVar mv case mb of Nothing → do Lock.acquire lock @@ -216,7 +218,7 @@ release ∷ RLock → IO () release (RLock mv) = do myTID ← myThreadId - block $ do + mask_ $ do t@(mb, lock) ← takeMVar mv let err msg = do putMVar mv t error $ "Control.Concurrent.RLock.release: " ⊕ msg @@ -252,10 +254,12 @@ computation is returned. -} tryWith ∷ RLock → IO α → IO (Maybe α) -tryWith l a = block $ do +tryWith l a = mask $ \restore → do acquired ← tryAcquire l if acquired - then Just <$> a `finally` release l + then do r ← restore a `onException` release l + release l + return $ Just r else return Nothing {-| @@ -271,7 +275,7 @@ @wait l = 'block' '$' 'acquire' l '>>' 'release' l@ -} wait ∷ RLock → IO () -wait l = block $ acquire l >> release l +wait l = mask_ $ acquire l >> release l -------------------------------------------------------------------------------- diff --git a/Control/Concurrent/ReadWriteLock.hs b/Control/Concurrent/ReadWriteLock.hs --- a/Control/Concurrent/ReadWriteLock.hs +++ b/Control/Concurrent/ReadWriteLock.hs @@ -66,32 +66,31 @@ -- Imports ------------------------------------------------------------------------------- --- from base +-- from base: import Control.Applicative ( liftA2, liftA3 ) import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, swapMVar ) -import Control.Exception ( block, bracket_, finally ) +import Control.Exception ( bracket_, onException ) import Control.Monad ( return, (>>=), return, fail, (>>), when ) import Data.Bool ( Bool(False, True) ) import Data.Char ( String ) import Data.Eq ( Eq, (==) ) import Data.Function ( ($), on ) -import Data.Functor ( (<$>) ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just) ) import Data.Typeable ( Typeable ) import Prelude ( ($!), fromInteger, succ, pred, error ) import System.IO ( IO ) --- from base-unicode-symbols +-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Data.Monoid.Unicode ( (⊕) ) --- from concurrent-extra +-- from concurrent-extra (this package): import Control.Concurrent.Lock ( Lock ) import qualified Control.Concurrent.Lock as Lock ( new, newAcquired, acquire, tryAcquire, release, wait ) -import Utils ( void ) +import Utils ( void, mask, mask_ ) ------------------------------------------------------------------------------- @@ -160,7 +159,7 @@ simultaneous threads acquire the read lock. But that is unlikely. -} acquireRead ∷ RWLock → IO () -acquireRead (RWLock {state, readLock, writeLock}) = block acqRead +acquireRead (RWLock {state, readLock, writeLock}) = mask_ acqRead where acqRead = do st ← takeMVar state case st of @@ -178,7 +177,7 @@ \"read\", 'False' otherwise. -} tryAcquireRead ∷ RWLock → IO Bool -tryAcquireRead (RWLock {state, readLock}) = block $ do +tryAcquireRead (RWLock {state, readLock}) = mask_ $ do st ← takeMVar state case st of Free → do Lock.acquire readLock @@ -199,7 +198,7 @@ \"read\" state. -} releaseRead ∷ RWLock → IO () -releaseRead (RWLock {state, readLock}) = block $ do +releaseRead (RWLock {state, readLock}) = mask_ $ do st ← takeMVar state case st of Read 1 → do Lock.release readLock @@ -223,10 +222,12 @@ released and 'Just' the result of the computation is returned. -} tryWithRead ∷ RWLock → IO α → IO (Maybe α) -tryWithRead l a = block $ do +tryWithRead l a = mask $ \restore → do acquired ← tryAcquireRead l if acquired - then Just <$> a `finally` releaseRead l + then do r ← restore a `onException` releaseRead l + releaseRead l + return $ Just r else return Nothing {-| @@ -242,7 +243,7 @@ @waitRead l = 'block' '$' 'acquireRead' l '>>' 'releaseRead' l@ -} waitRead ∷ RWLock → IO () -waitRead l = block $ acquireRead l >> releaseRead l +waitRead l = mask_ $ acquireRead l >> releaseRead l ------------------------------------------------------------------------------- @@ -257,7 +258,7 @@ 'RWLock' will be \"write\". -} acquireWrite ∷ RWLock → IO () -acquireWrite (RWLock {state, readLock, writeLock}) = block acqWrite +acquireWrite (RWLock {state, readLock, writeLock}) = mask_ acqWrite where acqWrite = do st ← takeMVar state case st of @@ -277,7 +278,7 @@ \"write\", 'False' otherwise. -} tryAcquireWrite ∷ RWLock → IO Bool -tryAcquireWrite (RWLock {state, writeLock}) = block $ do +tryAcquireWrite (RWLock {state, writeLock}) = mask_ $ do st ← takeMVar state case st of Free → do Lock.acquire writeLock @@ -300,7 +301,7 @@ \"write\" state. -} releaseWrite ∷ RWLock → IO () -releaseWrite (RWLock {state, writeLock}) = block $ do +releaseWrite (RWLock {state, writeLock}) = mask_ $ do st ← takeMVar state case st of Write → do Lock.release writeLock @@ -323,10 +324,12 @@ released and 'Just' the result of the computation is returned. -} tryWithWrite ∷ RWLock → IO α → IO (Maybe α) -tryWithWrite l a = block $ do +tryWithWrite l a = mask $ \restore → do acquired ← tryAcquireWrite l if acquired - then Just <$> a `finally` releaseWrite l + then do r ← restore a `onException` releaseWrite l + releaseWrite l + return $ Just r else return Nothing {-| @@ -342,7 +345,7 @@ @waitWrite l = 'block' '$' 'acquireWrite' l '>>' 'releaseWrite' l@ -} waitWrite ∷ RWLock → IO () -waitWrite l = block $ acquireWrite l >> releaseWrite l +waitWrite l = mask_ $ acquireWrite l >> releaseWrite l moduleName ∷ String moduleName = "Control.Concurrent.ReadWriteLock" diff --git a/Control/Concurrent/ReadWriteVar.hs b/Control/Concurrent/ReadWriteVar.hs --- a/Control/Concurrent/ReadWriteVar.hs +++ b/Control/Concurrent/ReadWriteVar.hs @@ -61,7 +61,7 @@ -- Imports ------------------------------------------------------------------------------- --- from base +-- from base: import Control.Applicative ( liftA2 ) import Control.Monad ( (>>=) ) import Data.Bool ( Bool(..) ) @@ -77,10 +77,10 @@ import Prelude ( undefined ) #endif --- from base-unicode-symbols +-- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from concurrent-extra +-- from concurrent-extra (this package): import Control.Concurrent.ReadWriteLock ( RWLock ) import qualified Control.Concurrent.ReadWriteLock as RWLock diff --git a/Control/Concurrent/STM/Lock.hs b/Control/Concurrent/STM/Lock.hs --- a/Control/Concurrent/STM/Lock.hs +++ b/Control/Concurrent/STM/Lock.hs @@ -47,13 +47,13 @@ -- from base: import Control.Applicative ( liftA2 ) -import Control.Exception ( block, bracket_, finally ) +import Control.Exception ( bracket_, onException ) import Control.Monad ( Monad, return, (>>=), (>>), fail, when ) import Data.Bool ( Bool, not ) #ifdef __HADDOCK__ -import Data.Bool (Bool(False, True)) +import Data.Bool ( Bool(False, True) ) #endif --- TODO: import Data.Eq ( Eq ) +import Data.Eq ( Eq ) import Data.Function ( ($) ) import Data.Functor ( fmap, (<$>) ) import Data.Maybe ( Maybe(Nothing, Just), isJust ) @@ -68,23 +68,24 @@ #endif import Control.Concurrent.STM.TMVar ( TMVar, newTMVar, newEmptyTMVar , takeTMVar, tryTakeTMVar - , tryPutTMVar + , putTMVar, tryPutTMVar , isEmptyTMVar ) -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) +-- from concurrent-extra (this package): +import Utils ( mask ) + -------------------------------------------------------------------------------- -- Locks -------------------------------------------------------------------------------- -- | A lock is in one of two states: \"locked\" or \"unlocked\". newtype Lock = Lock {un ∷ TMVar ()} - deriving ( Typeable - -- TODO: , Eq -- I added an Eq instance for TMVar to the HEAD branch of stm. - ) + deriving (Typeable, Eq) -------------------------------------------------------------------------------- @@ -130,8 +131,8 @@ Note that it is an error to release a lock in the \"unlocked\" state! -} release ∷ Lock → STM () -release (Lock mv) = do - b ← tryPutTMVar mv () +release (Lock tmv) = do + b ← tryPutTMVar tmv () when (not b) $ error "Control.Concurrent.STM.Lock.release: Can't release unlocked Lock!" @@ -155,10 +156,12 @@ computation is returned. -} tryWith ∷ Lock → IO α → IO (Maybe α) -tryWith l a = block $ do +tryWith l a = mask $ \restore → do acquired ← atomically (tryAcquire l) if acquired - then Just <$> a `finally` atomically (release l) + then do r ← restore a `onException` atomically (release l) + atomically (release l) + return $ Just r else return Nothing {-| @@ -168,12 +171,12 @@ @wait@ does not alter the state of the lock. -Note that @wait@ is just a convenience function defined as: +Note that @wait@ is just a convenience function which can be defined as: @wait l = 'acquire' l '>>' 'release' l@ -} wait ∷ Lock → STM () -wait l = acquire l >> release l +wait (Lock tmv) = takeTMVar tmv >> putTMVar tmv () -------------------------------------------------------------------------------- diff --git a/Control/Concurrent/STM/Lock/Test.hs b/Control/Concurrent/STM/Lock/Test.hs --- a/Control/Concurrent/STM/Lock/Test.hs +++ b/Control/Concurrent/STM/Lock/Test.hs @@ -11,10 +11,11 @@ -- from base: import Control.Concurrent ( forkIO ) -import Control.Monad ( (>>=), fail, (>>) ) -import Data.Bool ( not ) +import Control.Monad ( return, (>>=), fail, (>>) ) +import Data.Bool ( Bool(False, True), not, (&&) ) import Data.Function ( ($) ) -import Data.Functor ( fmap ) +import Data.Functor ( fmap ) +import Data.IORef ( newIORef, writeIORef, readIORef ) import Prelude ( fromInteger ) -- from base-unicode-symbols: @@ -50,6 +51,7 @@ , testCase "newAcquired locked" test_lock_5 , testCase "acq rel unlocked" test_lock_6 , testCase "conc release" test_lock_7 + , testCase "wait" test_lock_8 ] test_lock_1 ∷ Assertion @@ -85,6 +87,19 @@ l ← atomically $ Lock.newAcquired _ ← forkIO $ wait_a_moment >> atomically (Lock.release l) atomically $ Lock.acquire l + +test_lock_8 ∷ Assertion +test_lock_8 = assert $ do + ioRef ← newIORef False + l ← atomically Lock.newAcquired + _ ← forkIO $ do wait_a_moment + writeIORef ioRef True + atomically $ Lock.release l + atomically $ Lock.wait l + set ← readIORef ioRef + locked ← atomically $ Lock.locked l + return $ set && not locked + -- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Timeout.hs b/Control/Concurrent/Timeout.hs --- a/Control/Concurrent/Timeout.hs +++ b/Control/Concurrent/Timeout.hs @@ -47,7 +47,7 @@ -- from base-unicode-symbols: import Data.Eq.Unicode ( (≡) ) --- from concurrent-extra: +-- from concurrent-extra (this package): import Control.Concurrent.Thread.Delay ( delay ) diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -1,6 +1,15 @@ -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} +{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} -module Utils where +module Utils + ( mask + , mask_ + , (∘!) + , void + , ifM + , purelyModifyMVar + , modifyIORefM + , modifyIORefM_ + ) where -------------------------------------------------------------------------------- -- Imports @@ -8,7 +17,6 @@ -- from base: import Control.Concurrent.MVar ( MVar, takeMVar, putMVar ) -import Control.Exception ( block ) import Control.Monad ( Monad, return, (>>=), (>>), fail ) import Data.Bool ( Bool ) import Data.Function ( ($) ) @@ -25,6 +33,18 @@ -- Utility functions -------------------------------------------------------------------------------- +#if MIN_VERSION_base(4,3,0) +import Control.Exception ( mask, mask_ ) +#else +import Control.Exception ( blocked, block, unblock ) + +mask ∷ ((IO α → IO α) → IO β) → IO β +mask io = blocked >>= \b → if b then io id else block $ io unblock + +mask_ ∷ IO α → IO α +mask_ = block +#endif + -- | Strict function composition. (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = (f $!) ∘ g @@ -36,7 +56,7 @@ ifM c t e = c >>= \b → if b then t else e purelyModifyMVar ∷ MVar α → (α → α) → IO () -purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘! f +purelyModifyMVar mv f = mask_ $ takeMVar mv >>= putMVar mv ∘! f modifyIORefM ∷ IORef α → (α → IO (α, β)) → IO β modifyIORefM r f = do (y, z) ← readIORef r >>= f diff --git a/concurrent-extra.cabal b/concurrent-extra.cabal --- a/concurrent-extra.cabal +++ b/concurrent-extra.cabal @@ -1,5 +1,5 @@ name: concurrent-extra -version: 0.5.1 +version: 0.6 cabal-version: >= 1.6 build-type: Custom stability: experimental @@ -20,7 +20,6 @@ . * @Event@: Wake multiple threads by signalling an event. . - * @Lock@: Enforce exclusive access to a resource. Also known as a binary semaphore or mutex. The package additionally provides an alternative that works in the @STM@ monad. @@ -67,9 +66,9 @@ ------------------------------------------------------------------------------- library - build-depends: base >= 3 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1 && < 2.2 + build-depends: base >= 3 && < 4.4 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , stm >= 2.1.2.1 && < 2.3 exposed-modules: Control.Concurrent.Lock , Control.Concurrent.STM.Lock , Control.Concurrent.RLock @@ -102,14 +101,14 @@ ghc-options: -Wall if flag(test) - build-depends: base >= 3 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1 && < 2.2 - , HUnit >= 1.2.2 && < 1.3 - , QuickCheck >= 2.1.0 && < 2.2 - , test-framework >= 0.2.4 && < 0.4 - , test-framework-hunit >= 0.2.4 && < 0.3 - , test-framework-quickcheck2 >= 0.2.4 && < 0.3 + build-depends: base >= 3 && < 4.4 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , stm >= 2.1.2.1 && < 2.3 + , HUnit >= 1.2.2 && < 1.3 + , QuickCheck >= 2.1.0 && < 2.2 + , test-framework >= 0.2.4 && < 0.4 + , test-framework-hunit >= 0.2.4 && < 0.3 + , test-framework-quickcheck2 >= 0.2.4 && < 0.3 buildable: True else buildable: False