diff --git a/Control/Concurrent/Broadcast.hs b/Control/Concurrent/Broadcast.hs --- a/Control/Concurrent/Broadcast.hs +++ b/Control/Concurrent/Broadcast.hs @@ -49,7 +49,7 @@ ------------------------------------------------------------------------------- -- from base: -import Control.Monad ( (>>=), (>>), return, forM_, fail, when ) +import Control.Monad ( (>>=), (>>), return, fail, when ) import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar , takeMVar, putMVar, readMVar, modifyMVar_ ) @@ -58,6 +58,7 @@ import Data.Either ( Either(Left ,Right), either ) import Data.Function ( ($), const ) import Data.Functor ( fmap, (<$>) ) +import Data.Foldable ( for_ ) import Data.List ( delete, length ) import Data.Maybe ( Maybe(Nothing, Just), isNothing ) import Data.Ord ( Ord, max ) @@ -168,11 +169,7 @@ broadcast will be woken. -} broadcast ∷ Broadcast α → α → IO () -broadcast (Broadcast mv) x = modifyMVar_ mv $ \mx → do - case mx of - Left ls → do forM_ ls (`putMVar` x) - return $ Right x - Right _ → return $ Right x + {-| Broadcast a value before becoming \"silent\". @@ -186,11 +183,19 @@ @ -} signal ∷ Broadcast α → α → IO () -signal (Broadcast mv) x = modifyMVar_ mv $ \mx → do - case mx of - Left ls → do forM_ ls (`putMVar` x) - return $ Left [] - Right _ → return $ Left [] + +broadcast b x = broadcastThen (Right x) b x +signal b x = broadcastThen (Left []) b x + +-- | Internally used function that performs the actual broadcast in 'broadcast' +-- and 'signal' then changes to the given final state. +broadcastThen ∷ Either [MVar α] α → Broadcast α → α → IO () +broadcastThen finalState (Broadcast mv) x = + modifyMVar_ mv $ \mx → do + case mx of + Left ls → do for_ ls (`putMVar` x) + return finalState + Right _ → return finalState -- | Set a broadcast to the \"silent\" state. silence ∷ Broadcast α → IO () diff --git a/Control/Concurrent/Thread.hs b/Control/Concurrent/Thread.hs deleted file mode 100644 --- a/Control/Concurrent/Thread.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude, UnicodeSyntax #-} - -------------------------------------------------------------------------------- --- | --- Module : Control.Concurrent.Thread --- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- , Roel van Dijk --- --- Standard threads extended with the ability to wait for their termination. --- --- Inspired by: --- --- This module re-implements several functions from @Control.Concurrent@. Avoid --- ambiguities by importing one or both qualified. We suggest importing this --- module like: --- --- @ --- import qualified Control.Concurrent.Thread as Thread ( ... ) --- @ --- -------------------------------------------------------------------------------- - -module Control.Concurrent.Thread - ( ThreadId - , threadId - - -- * Forking threads - , forkIO - , forkOS - - -- * Waiting on threads - , wait - , wait_ - , unsafeWait - , unsafeWait_ - - -- ** Waiting with a timeout - , waitTimeout - , waitTimeout_ - , unsafeWaitTimeout - , unsafeWaitTimeout_ - - -- * Quering thread status - , isRunning - - -- * Convenience functions - , throwTo - , killThread - , killThreadTimeout - ) where - - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - --- from base: -import Control.Exception ( Exception, SomeException - , AsyncException(ThreadKilled) - , try, blocked, block, unblock - ) -#ifdef __HADDOCK__ -import Control.Exception ( BlockedIndefinitelyOnMVar, BlockedIndefinitelyOnSTM ) -#endif -import Control.Monad ( return, (>>=), fail, (>>) ) -import Data.Bool ( Bool(..) ) -import Data.Eq ( Eq, (==) ) -import Data.Either ( Either(..), either ) -import Data.Function ( ($), on ) -import Data.Functor ( fmap, (<$>) ) -import Data.Maybe ( Maybe(..), maybe, isNothing, isJust ) -import Data.Ord ( Ord, compare ) -import Data.Typeable ( Typeable ) -import Prelude ( Integer ) -import System.IO ( IO ) -import Text.Show ( Show, show ) - -import qualified Control.Concurrent as Conc - ( ThreadId, forkIO, forkOS, throwTo ) - --- from base-unicode-symbols: -import Data.Function.Unicode ( (∘) ) - --- from concurrent-extra: -import Control.Concurrent.Broadcast ( Broadcast ) -import qualified Control.Concurrent.Broadcast as Broadcast - ( new, broadcast, listen, tryListen, listenTimeout ) - -import Utils ( void, ifM, throwInner ) - - -------------------------------------------------------------------------------- --- Threads -------------------------------------------------------------------------------- - -{-| -A @'ThreadId' α@ is an abstract type representing a handle to a thread -that is executing or has executed a computation of type @'IO' α@. - -@'ThreadId' α@ is an instance of 'Eq', 'Ord' and 'Show', where the 'Ord' -instance implements an arbitrary total ordering over 'ThreadId's. The 'Show' -instance lets you convert an arbitrary-valued 'ThreadId' to string form; showing -a 'ThreadId' value is occasionally useful when debugging or diagnosing the -behaviour of a concurrent program. --} -data ThreadId α = ThreadId - { stopped ∷ Broadcast (Either SomeException α) - , threadId ∷ Conc.ThreadId -- ^ Extract the underlying 'Conc.ThreadId' - -- (@Conctrol.Concurrent.ThreadId@). - } deriving Typeable - -instance Eq (ThreadId α) where - (==) = (==) `on` threadId - -instance Ord (ThreadId α) where - compare = compare `on` threadId - -instance Show (ThreadId α) where - show = show ∘ threadId - - -------------------------------------------------------------------------------- --- * Forking threads -------------------------------------------------------------------------------- - -{-| -Sparks off a new thread to run the given 'IO' computation and returns the -'ThreadId' of the newly created thread. - -The new thread will be a lightweight thread; if you want to use a foreign -library that uses thread-local storage, use 'forkOS' instead. - -GHC note: the new thread inherits the blocked state of the parent (see -'Control.Exception.block'). - -The newly created thread has an exception handler that discards the exceptions -'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and 'ThreadKilled'. All -other exceptions are recorded in the 'ThreadId' and can be retrieved using -'wait'. --} -forkIO ∷ IO α → IO (ThreadId α) -forkIO = fork Conc.forkIO - -{-| -Like 'forkIO', this sparks off a new thread to run the given 'IO' computation -and returns the 'ThreadId' of the newly created thread. - -Unlike 'forkIO', 'forkOS' creates a /bound/ thread, which is necessary if you -need to call foreign (non-Haskell) libraries that make use of thread-local -state, such as OpenGL (see 'Control.Concurrent'). - -Using 'forkOS' instead of 'forkIO' makes no difference at all to the scheduling -behaviour of the Haskell runtime system. It is a common misconception that you -need to use 'forkOS' instead of 'forkIO' to avoid blocking all the Haskell -threads when making a foreign call; this isn't the case. To allow foreign calls -to be made without blocking all the Haskell threads (with GHC), it is only -necessary to use the @-threaded@ option when linking your program, and to make -sure the foreign import is not marked @unsafe@. --} -forkOS ∷ IO α → IO (ThreadId α) -forkOS = fork Conc.forkOS - -{-| -Internally used function which generalises 'forkIO' and 'forkOS'. Parametrised -by the function which does the actual forking. --} -fork ∷ (IO () → IO Conc.ThreadId) → IO α → IO (ThreadId α) -fork doFork a = do - stop ← Broadcast.new - let broadcastToStop = Broadcast.broadcast stop - tid ← ifM blocked ( doFork $ try a >>= broadcastToStop) - (block $ doFork $ try (unblock a) >>= broadcastToStop) - return $ ThreadId stop tid - - -------------------------------------------------------------------------------- --- * Waiting on threads -------------------------------------------------------------------------------- - -{-| -Block until the given thread is terminated. - -* Returns @'Right' x@ if the thread terminated normally and returned @x@. - -* Returns @'Left' e@ if some exception @e@ was thrown in the thread and wasn't -caught. --} -wait ∷ ThreadId α → IO (Either SomeException α) -wait = Broadcast.listen ∘ stopped - --- | Like 'wait' but will ignore the value returned by the thread. -wait_ ∷ ThreadId α → IO () -wait_ = void ∘ wait - --- | Like 'wait' but will either rethrow the exception that was thrown in the --- thread or return the value that was returned by the thread. -unsafeWait ∷ ThreadId α → IO α -unsafeWait tid = wait tid >>= either throwInner return - --- | Like 'unsafeWait' in that it will rethrow the exception that was thrown in --- the thread but it will ignore the value returned by the thread. -unsafeWait_ ∷ ThreadId α → IO () -unsafeWait_ = void ∘ unsafeWait - - --- ** Waiting with a timeout - -{-| -Block until the given thread is terminated or until a timer expires. - -* Returns 'Nothing' if a timeout occurred. - -* Returns 'Just' the result 'wait' would return when the thread finished within -the specified time. - -The timeout is specified in microseconds. --} -waitTimeout ∷ ThreadId α → Integer → IO (Maybe (Either SomeException α)) -waitTimeout = Broadcast.listenTimeout ∘ stopped - --- | Like 'waitTimeout' but will ignore the value returned by the thread. --- Returns 'False' when a timeout occurred and 'True' otherwise. -waitTimeout_ ∷ ThreadId α → Integer → IO Bool -waitTimeout_ tid t = isJust <$> waitTimeout tid t - -{-| -Like 'waitTimeout' but will rethrow the exception that was thrown in the -thread. Returns 'Nothing' if a timeout occured or 'Just' the value returned from -the target thread. --} -unsafeWaitTimeout ∷ ThreadId α → Integer → IO (Maybe α) -unsafeWaitTimeout tid t = waitTimeout tid t >>= maybe (return Nothing) - (either throwInner - (return ∘ Just)) - --- | Like 'unsafeWaitTimeout' in that it will rethrow the exception that was --- thrown in the thread but it will ignore the value returned by the thread. --- Returns 'False' when a timeout occurred and 'True' otherwise. -unsafeWaitTimeout_ ∷ ThreadId α → Integer → IO Bool -unsafeWaitTimeout_ tid t = isJust <$> unsafeWaitTimeout tid t - - -------------------------------------------------------------------------------- --- * Quering thread status -------------------------------------------------------------------------------- - -{-| -Returns 'True' if the given thread is currently running. - -Notice that this observation is only a snapshot of a thread's state. By the time -a program reacts on its result it may already be out of date. --} -isRunning ∷ ThreadId α → IO Bool -isRunning = fmap isNothing ∘ Broadcast.tryListen ∘ stopped - - -------------------------------------------------------------------------------- --- * Convenience functions -------------------------------------------------------------------------------- - -{-| -'throwTo' raises an arbitrary exception in the target thread (GHC only). - -'throwTo' does not return until the exception has been raised in the target -thread. The calling thread can thus be certain that the target thread has -received the exception. This is a useful property to know when dealing with race -conditions: eg. if there are two threads that can kill each other, it is -guaranteed that only one of the threads will get to kill the other. - -If the target thread is currently making a foreign call, then the exception will -not be raised (and hence 'throwTo' will not return) until the call has -completed. This is the case regardless of whether the call is inside a 'block' -or not. - -Important note: the behaviour of 'throwTo' differs from that described in the -paper \"Asynchronous exceptions in Haskell\" -(). In the paper, -'throwTo' is non-blocking; but the library implementation adopts a more -synchronous design in which 'throwTo' does not return until the exception is -received by the target thread. The trade-off is discussed in Section 9 of the -paper. Like any blocking operation, 'throwTo' is therefore interruptible (see -Section 5.3 of the paper). - -There is currently no guarantee that the exception delivered by 'throwTo' will -be delivered at the first possible opportunity. In particular, a thread may -'unblock' and then re-'block' exceptions without receiving a pending -'throwTo'. This is arguably undesirable behaviour. --} -throwTo ∷ Exception e ⇒ ThreadId α → e → IO () -throwTo = Conc.throwTo ∘ threadId - -{-| -'killThread' terminates the given thread (GHC only). Any work already done by -the thread isn't lost: the computation is suspended until required by another -thread. The memory used by the thread will be garbage collected if it isn't -referenced from anywhere. The 'killThread' function is defined in terms of -'throwTo'. - -This function blocks until the target thread is terminated. It is a no-op if the -target thread has already completed. --} -killThread ∷ ThreadId α → IO () -killThread tid = throwTo tid ThreadKilled >> wait_ tid - -{-| -Like 'killThread' but with a timeout. Returns 'True' if the target thread was -terminated within the given amount of time, 'False' otherwise. - -The timeout is specified in microseconds. - -Note that even when a timeout occurs, the target thread can still terminate at a -later time as a direct result of calling this function. --} -killThreadTimeout ∷ ThreadId α → Integer → IO Bool -killThreadTimeout tid time = throwTo tid ThreadKilled >> waitTimeout_ tid time - - --- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Thread/Test.hs b/Control/Concurrent/Thread/Test.hs deleted file mode 100644 --- a/Control/Concurrent/Thread/Test.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude - , UnicodeSyntax - #-} - -module Control.Concurrent.Thread.Test ( tests ) where - - -------------------------------------------------------------------------------- --- Imports -------------------------------------------------------------------------------- - --- from base: -import Control.Concurrent ( threadDelay ) -import Control.Exception ( unblock, block, blocked ) -import Control.Monad ( return, (>>=), fail, (>>) ) -import Data.Bool ( Bool(False, True), not ) -import Data.Function ( ($), id ) -import Data.Functor ( fmap ) -import Data.IORef ( newIORef, readIORef, writeIORef ) -import Data.Maybe ( maybe ) -import Prelude ( fromInteger, toInteger ) -import System.Timeout ( timeout ) - --- from base-unicode-symbols: -import Prelude.Unicode ( (⋅) ) - --- from concurrent-extra: -import qualified Control.Concurrent.Lock as Lock -import qualified Control.Concurrent.Thread as Thread -import TestUtils ( a_moment, within ) - --- from HUnit: -import Test.HUnit ( Assertion, assert ) - --- from test-framework: -import Test.Framework ( Test ) - --- from test-framework-hunit: -import Test.Framework.Providers.HUnit ( testCase ) - - -------------------------------------------------------------------------------- --- Tests for Thread -------------------------------------------------------------------------------- - -tests ∷ [Test] -tests = [ testCase "wait" test_wait - , testCase "waitTimeout" test_waitTimeout - , testCase "isRunning" test_isRunning - , testCase "blockedState" test_blockedState - , testCase "unblockedState" test_unblockedState - ] - -test_wait ∷ Assertion -test_wait = assert $ fmap (maybe False id) $ timeout (10 ⋅ a_moment) $ do - r ← newIORef False - tid ← Thread.forkIO $ do - threadDelay $ 2 ⋅ a_moment - writeIORef r True - _ ← Thread.wait tid - readIORef r - -test_waitTimeout ∷ Assertion -test_waitTimeout = assert $ within (10 ⋅ a_moment) $ do - l ← Lock.newAcquired - tid ← Thread.forkIO $ Lock.acquire l - _ ← Thread.waitTimeout tid (toInteger $ 5 ⋅ a_moment) - Lock.release l - -test_isRunning ∷ Assertion -test_isRunning = assert $ fmap (maybe False id) $ timeout (10 ⋅ a_moment) $ do - l ← Lock.newAcquired - tid ← Thread.forkIO $ Lock.acquire l - r ← Thread.isRunning tid - Lock.release l - return r - -test_blockedState ∷ Assertion -test_blockedState = (block $ Thread.forkIO $ blocked) >>= - Thread.unsafeWait >>= assert - -test_unblockedState ∷ Assertion -test_unblockedState = (unblock $ Thread.forkIO $ fmap not $ blocked) >>= - Thread.unsafeWait >>= assert - - --- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Timeout/Test.hs b/Control/Concurrent/Timeout/Test.hs --- a/Control/Concurrent/Timeout/Test.hs +++ b/Control/Concurrent/Timeout/Test.hs @@ -10,7 +10,7 @@ ------------------------------------------------------------------------------- -- from base: -import Control.Concurrent ( ) +import Control.Concurrent ( forkIO, killThread ) import Control.Exception ( block ) import Control.Monad ( (>>=), fail, (>>) ) import Data.Function ( ($) ) @@ -21,9 +21,9 @@ -- from concurrent-extra: import qualified Control.Concurrent.Lock as Lock -import qualified Control.Concurrent.Thread as Thread import Control.Concurrent.Timeout ( timeout ) import TestUtils ( a_moment, within ) +import Utils ( void ) -- from HUnit: import Test.HUnit ( Assertion, assert ) @@ -45,10 +45,9 @@ test_timeout_exception ∷ Assertion test_timeout_exception = assert $ within (10 ⋅ a_moment) $ do l ← Lock.newAcquired - tid ← block $ Thread.forkIO - $ timeout (toInteger $ 1000 ⋅ a_moment) - $ Lock.acquire l - Thread.killThread tid + tid ← block $ forkIO $ + void $ timeout (toInteger $ 1000 ⋅ a_moment) $ Lock.acquire l + killThread tid Lock.release l diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -8,12 +8,13 @@ -- from base: import Control.Concurrent.MVar ( MVar, takeMVar, putMVar ) -import Control.Exception ( SomeException(SomeException), block, throwIO ) +import Control.Exception ( block ) import Control.Monad ( Monad, return, (>>=), (>>), fail ) import Data.Bool ( Bool ) import Data.Function ( ($) ) import Data.Functor ( Functor, (<$) ) import Data.IORef ( IORef, readIORef, writeIORef ) +import Prelude ( ($!) ) import System.IO ( IO ) -- from base-unicode-symbols: @@ -24,21 +25,21 @@ -- Utility functions -------------------------------------------------------------------------------- +-- | Strict function composition. +(∘!) ∷ (β → γ) → (α → β) → (α → γ) +f ∘! g = (f $!) ∘ g + void ∷ Functor f ⇒ f α → f () void = (() <$) ifM ∷ Monad m ⇒ m Bool → m α → m α → m α ifM c t e = c >>= \b → if b then t else e -throwInner ∷ SomeException → IO α -throwInner (SomeException e) = throwIO e - purelyModifyMVar ∷ MVar α → (α → α) → IO () -purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘ f +purelyModifyMVar mv f = block $ takeMVar mv >>= putMVar mv ∘! f modifyIORefM ∷ IORef α → (α → IO (α, β)) → IO β -modifyIORefM r f = do x ← readIORef r - (y, z) ← f x +modifyIORefM r f = do (y, z) ← readIORef r >>= f writeIORef r y return z 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.4 +version: 0.5 cabal-version: >= 1.6 build-type: Custom stability: experimental @@ -34,9 +34,6 @@ . Besides these synchronisation primitives the package also provides: . - * @Thread@: Threads extended with the ability to wait for their - termination. - . * @Thread.Delay@: Arbitrarily long thread delays. . * @Timeout@: Wait arbitrarily long for an IO computation to finish. @@ -69,14 +66,13 @@ library build-depends: base >= 3 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.2 + , base-unicode-symbols >= 0.1.1 && < 0.3 exposed-modules: Control.Concurrent.Lock , Control.Concurrent.RLock , Control.Concurrent.Event , Control.Concurrent.Broadcast , Control.Concurrent.ReadWriteLock , Control.Concurrent.ReadWriteVar - , Control.Concurrent.Thread , Control.Concurrent.Thread.Delay , Control.Concurrent.Timeout other-modules: Utils @@ -95,14 +91,15 @@ , Control.Concurrent.Broadcast.Test , Control.Concurrent.ReadWriteLock.Test , Control.Concurrent.ReadWriteVar.Test - , Control.Concurrent.Thread.Test , Control.Concurrent.Timeout.Test , TestUtils ghc-options: -Wall if flag(test) - build-depends: HUnit >= 1.2.2 && < 1.3 + build-depends: base >= 3 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , HUnit >= 1.2.2 && < 1.3 , QuickCheck >= 2.1.0 && < 2.2 , test-framework >= 0.2.4 && < 0.3 , test-framework-hunit >= 0.2.4 && < 0.3 @@ -113,3 +110,5 @@ if flag(hpc) ghc-options: -fhpc + +------------------------------------------------------------------------------- diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -16,7 +16,6 @@ import qualified Control.Concurrent.Broadcast.Test as Broadcast ( tests ) import qualified Control.Concurrent.ReadWriteLock.Test as RWLock ( tests ) import qualified Control.Concurrent.ReadWriteVar.Test as RWVar ( tests ) -import qualified Control.Concurrent.Thread.Test as Thread ( tests ) import qualified Control.Concurrent.Timeout.Test as Timeout ( tests ) -- from test-framework: @@ -38,7 +37,6 @@ , testGroup "Broadcast" Broadcast.tests , testGroup "ReadWriteLock" RWLock.tests , testGroup "ReadWriteVar" RWVar.tests - , testGroup "Thread" Thread.tests ] , testGroup "Timeout" Timeout.tests ]