diff --git a/Control/Concurrent/Thread.hs b/Control/Concurrent/Thread.hs --- a/Control/Concurrent/Thread.hs +++ b/Control/Concurrent/Thread.hs @@ -1,18 +1,14 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} - -#if MIN_VERSION_base(4,3,0) -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock -#endif +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, RankNTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread --- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk +-- Copyright : (c) 2010-2012 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. +-- Standard threads extended with the ability to /wait/ for their return value. -- -- This module exports equivalently named functions from @Control.Concurrent@ -- (and @GHC.Conc@). Avoid ambiguities by importing this module qualified. May @@ -41,12 +37,10 @@ ( -- * Forking threads forkIO , forkOS -#ifdef __GLASGOW_HASKELL__ - , forkOnIO -#if MIN_VERSION_base(4,3,0) - , forkIOUnmasked -#endif -#endif + , forkOn + , forkIOWithUnmask + , forkOnWithUnmask + -- * Results , Result , result @@ -58,111 +52,80 @@ -------------------------------------------------------------------------------- -- from base: -import qualified Control.Concurrent ( forkIO, forkOS ) +import qualified Control.Concurrent ( forkIO + , forkOS + , forkOn + , forkIOWithUnmask + , forkOnWithUnmask + ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) -import Control.Exception ( SomeException, try, throwIO ) -#if MIN_VERSION_base(4,3,0) -import Control.Exception ( block, unblock ) -#endif +import Control.Exception ( SomeException, try, throwIO, mask ) import Control.Monad ( return, (>>=) ) import Data.Either ( Either(..), either ) import Data.Function ( ($) ) -import System.IO ( IO ) - -#if __GLASGOW_HASKELL__ < 700 -import Control.Monad ( fail ) -#endif - -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.Conc ( forkOnIO ) import Data.Int ( Int ) -#endif +import System.IO ( IO ) -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) --- from ourselves: -import Mask ( mask ) - -------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------- -{-| -Sparks off a new thread to run the given 'IO' computation and returns the -'ThreadId' of the newly created thread paired with an IO computation that waits -for the result of the 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'). --} +-- | Like @Control.Concurrent.'Control.Concurrent.forkIO'@ but returns +-- a computation that when executed blocks until the thread terminates +-- then returns the final value of the thread. forkIO ∷ IO α → IO (ThreadId, IO (Result α)) forkIO = fork Control.Concurrent.forkIO -{-| -Like 'forkIO', this sparks off a new thread to run the given 'IO' computation -and returns the 'ThreadId' of the newly created thread paired with an IO -computation that waits for the result of the 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@. --} +-- | Like @Control.Concurrent.'Control.Concurrent.forkOS'@ but returns +-- a computation that when executed blocks until the thread terminates +-- then returns the final value of the thread. forkOS ∷ IO α → IO (ThreadId, IO (Result α)) forkOS = fork Control.Concurrent.forkOS -#ifdef __GLASGOW_HASKELL__ -{-| -Like 'forkIO', but lets you specify on which CPU the thread is -created. Unlike a 'forkIO' thread, a thread created by 'forkOnIO' -will stay on the same CPU for its entire lifetime ('forkIO' threads -can migrate between CPUs according to the scheduling policy). -'forkOnIO' is useful for overriding the scheduling policy when you -know in advance how best to distribute the threads. +-- | Like @Control.Concurrent.'Control.Concurrent.forkOn'@ but returns +-- a computation that when executed blocks until the thread terminates +-- then returns the final value of the thread. +forkOn ∷ Int → IO α → IO (ThreadId, IO (Result α)) +forkOn = fork ∘ Control.Concurrent.forkOn -The 'Int' argument specifies the CPU number; it is interpreted modulo -'numCapabilities' (note that it actually specifies a capability number -rather than a CPU number, but to a first approximation the two are -equivalent). --} -forkOnIO ∷ Int → IO α → IO (ThreadId, IO (Result α)) -forkOnIO = fork ∘ GHC.Conc.forkOnIO +-- | Like @Control.Concurrent.'Control.Concurrent.forkIOWithUnmask'@ but returns +-- a computation that when executed blocks until the thread terminates +-- then returns the final value of the thread. +forkIOWithUnmask ∷ ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask -#if MIN_VERSION_base(4,3,0) --- | Like 'forkIO', but the child thread is created with asynchronous exceptions --- unmasked (see 'Control.Exception.mask'). -forkIOUnmasked ∷ IO α → IO (ThreadId, IO (Result α)) -forkIOUnmasked a = do - res ← newEmptyMVar - tid ← block $ Control.Concurrent.forkIO $ try (unblock a) >>= putMVar res - return (tid, readMVar res) -#endif -#endif +-- | Like @Control.Concurrent.'Control.Concurrent.forkOnWithUnmask'@ but returns +-- a computation that when executed blocks until the thread terminates +-- then returns the final value of the thread. +forkOnWithUnmask ∷ Int → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask + -------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- --- | Internally used function which generalises 'forkIO', 'forkOS' and --- 'forkOnIO' by parameterizing the function which does the actual forking. fork ∷ (IO () → IO ThreadId) → (IO α → IO (ThreadId, IO (Result α))) fork doFork = \a → do res ← newEmptyMVar tid ← mask $ \restore → doFork $ try (restore a) >>= putMVar res return (tid, readMVar res) +forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId) + → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkWithUnmask doForkWithUnmask = \f → do + res ← newEmptyMVar + tid ← mask $ \restore → + doForkWithUnmask $ \unmask → + try (restore $ f unmask) >>= putMVar res + return (tid, readMVar res) + -------------------------------------------------------------------------------- -- Results -------------------------------------------------------------------------------- @@ -171,12 +134,8 @@ -- and wasn't catched or the actual value that was returned by the thread. type Result α = Either SomeException α -{-| Retrieve the actual value from the result. - -When the result is 'SomeException' the exception is thrown. --} +-- | Retrieve the actual value from the result. +-- +-- When the result is 'SomeException' the exception is thrown. result ∷ Result α → IO α result = either throwIO return - - --- The End --------------------------------------------------------------------- diff --git a/Control/Concurrent/Thread/Group.hs b/Control/Concurrent/Thread/Group.hs --- a/Control/Concurrent/Thread/Group.hs +++ b/Control/Concurrent/Thread/Group.hs @@ -2,16 +2,13 @@ , DeriveDataTypeable , NoImplicitPrelude , UnicodeSyntax + , RankNTypes #-} -#if MIN_VERSION_base(4,3,0) -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- For block and unblock -#endif - -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread.Group --- Copyright : (c) 2010 Bas van Dijk & Roel van Dijk +-- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk @@ -39,12 +36,9 @@ -- * Forking threads , forkIO , forkOS -#ifdef __GLASGOW_HASKELL__ - , forkOnIO -#if MIN_VERSION_base(4,3,0) - , forkIOUnmasked -#endif -#endif + , forkOn + , forkIOWithUnmask + , forkOnWithUnmask ) where @@ -53,31 +47,24 @@ -------------------------------------------------------------------------------- -- from base: -import qualified Control.Concurrent ( forkIO, forkOS ) +import qualified Control.Concurrent ( forkIO + , forkOS + , forkOn + , forkIOWithUnmask + , forkOnWithUnmask + ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) -import Control.Exception ( try ) -#if MIN_VERSION_base(4,3,0) -import Control.Exception ( block, unblock ) -#endif +import Control.Exception ( try, mask ) import Control.Monad ( return, (>>=), when ) import Data.Function ( ($) ) import Data.Functor ( fmap ) import Data.Eq ( Eq ) +import Data.Int ( Int ) import Data.Typeable ( Typeable ) -import Prelude ( ($!), Integer, succ, pred ) +import Prelude ( ($!), (+), subtract ) import System.IO ( IO ) -#if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger ) -import Control.Monad ( (>>), fail ) -#endif - -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.Conc ( forkOnIO ) -import Data.Int ( Int ) -#endif - -- from base-unicode-symbols: import Data.Eq.Unicode ( (≢) ) import Data.Function.Unicode ( (∘) ) @@ -92,19 +79,13 @@ #ifdef __HADDOCK__ import qualified Control.Concurrent.Thread as Thread ( forkIO , forkOS -#ifdef __GLASGOW_HASKELL__ - , forkOnIO -#if MIN_VERSION_base(4,3,0) - , forkIOUnmasked -#endif -#endif + , forkOn + , forkIOWithUnmask + , forkOnWithUnmask ) #endif --- from ourselves: -import Mask ( mask ) - -------------------------------------------------------------------------------- -- * Thread groups -------------------------------------------------------------------------------- @@ -125,7 +106,7 @@ * 'wait' blocks as long as the counter is not 0. -} -newtype ThreadGroup = ThreadGroup (TVar Integer) deriving (Eq, Typeable) +newtype ThreadGroup = ThreadGroup (TVar Int) deriving (Eq, Typeable) -- | Create an empty group of threads. new ∷ IO ThreadGroup @@ -137,7 +118,7 @@ Note that because this function yields a 'STM' computation, the returned number is guaranteed to be consistent inside the transaction. -} -nrOfRunning ∷ ThreadGroup → STM Integer +nrOfRunning ∷ ThreadGroup → STM Int nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV -- | Convenience function which blocks until all threads, that were added to the @@ -160,41 +141,47 @@ forkOS ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α)) forkOS = fork Control.Concurrent.forkOS -#ifdef __GLASGOW_HASKELL__ --- | Same as @Control.Concurrent.Thread.'Thread.forkOnIO'@ but --- additionaly adds the thread to the group. (GHC only) -forkOnIO ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) -forkOnIO = fork ∘ GHC.Conc.forkOnIO +-- | Same as @Control.Concurrent.Thread.'Thread.forkOn'@ but +-- additionaly adds the thread to the group. +forkOn ∷ Int → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) +forkOn = fork ∘ Control.Concurrent.forkOn -#if MIN_VERSION_base(4,3,0) --- | Same as @Control.Concurrent.Thread.'Thread.forkIOUnmasked'@ but --- additionaly adds the thread to the group. (GHC only) -forkIOUnmasked ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α)) -forkIOUnmasked (ThreadGroup numThreadsTV) a = do - res ← newEmptyMVar - tid ← block $ do - atomically $ modifyTVar numThreadsTV succ - Control.Concurrent.forkIO $ do - try (unblock a) >>= putMVar res - atomically $ modifyTVar numThreadsTV pred - return (tid, readMVar res) -#endif -#endif +-- | Same as @Control.Concurrent.Thread.'Thread.forkIOWithUnmask'@ but +-- additionaly adds the thread to the group. +forkIOWithUnmask ∷ ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask +-- | Like @Control.Concurrent.Thread.'Thread.forkOnWithUnmask'@ but +-- additionaly adds the thread to the group. +forkOnWithUnmask ∷ Int → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkOnWithUnmask = forkWithUnmask ∘ Control.Concurrent.forkOnWithUnmask + + -------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- --- | Internally used function which generalises 'forkIO', 'forkOS' and --- 'forkOnIO' by parameterizing the function which does the actual forking. fork ∷ (IO () → IO ThreadId) → ThreadGroup → IO α → IO (ThreadId, IO (Result α)) fork doFork (ThreadGroup numThreadsTV) a = do res ← newEmptyMVar tid ← mask $ \restore → do - atomically $ modifyTVar numThreadsTV succ + atomically $ modifyTVar numThreadsTV (+ 1) doFork $ do try (restore a) >>= putMVar res - atomically $ modifyTVar numThreadsTV pred + atomically $ modifyTVar numThreadsTV (subtract 1) return (tid, readMVar res) +forkWithUnmask ∷ (((∀ β. IO β → IO β) → IO ()) → IO ThreadId) + → ThreadGroup → ((∀ β. IO β → IO β) → IO α) → IO (ThreadId, IO (Result α)) +forkWithUnmask doForkWithUnmask = \(ThreadGroup numThreadsTV) f → do + res ← newEmptyMVar + tid ← mask $ \restore → do + atomically $ modifyTVar numThreadsTV (+ 1) + doForkWithUnmask $ \unmask → do + try (restore $ f unmask) >>= putMVar res + atomically $ modifyTVar numThreadsTV (subtract 1) + return (tid, readMVar res) + -- | Strictly modify the contents of a 'TVar'. modifyTVar ∷ TVar α → (α → α) → STM () modifyTVar tv f = readTVar tv >>= writeTVar tv ∘! f @@ -202,6 +189,3 @@ -- | Strict function composition (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = \x → f $! g x - - --- The End --------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010 Bas van Dijk & Roel van Dijk +Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk All rights reserved. diff --git a/Mask.hs b/Mask.hs deleted file mode 100644 --- a/Mask.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax #-} - -module Mask ( mask ) where - -#if MIN_VERSION_base(4,3,0) -import Control.Exception ( mask ) -#else -import Control.Monad ( (>>=) ) -import Control.Exception ( blocked, block, unblock ) -import Data.Function ( ($), id ) -import System.IO ( IO ) - -mask ∷ ((IO α → IO α) → IO β) → IO β -mask io = blocked >>= \b → if b then io id else block $ io unblock -#endif diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-} + +module Main where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( ThreadId, threadDelay, throwTo, killThread ) +import Control.Exception ( Exception, fromException + , AsyncException(ThreadKilled) + , throwIO + , unblock, block, blocked + ) +import Control.Monad ( return, (>>=), replicateM_ ) +import Data.Bool ( Bool(False, True), not ) +import Data.Eq ( Eq ) +import Data.Either ( either ) +import Data.Function ( ($), id, const, flip ) +import Data.Functor ( Functor(fmap), (<$>) ) +import Data.Int ( Int ) +import Data.Maybe ( Maybe, maybe ) +import Data.IORef ( newIORef, readIORef, writeIORef ) +import Data.Typeable ( Typeable ) +import System.Timeout ( timeout ) +import System.IO ( IO ) +import Text.Show ( Show ) + +-- from base-unicode-symbols: +import Data.Eq.Unicode ( (≡) ) +import Prelude.Unicode ( (⋅) ) +import Data.Function.Unicode ( (∘) ) + +-- from concurrent-extra: +import qualified Control.Concurrent.Lock as Lock + +-- from stm: +import Control.Concurrent.STM ( atomically ) + +-- from HUnit: +import Test.HUnit ( Assertion, assert ) + +-- from test-framework: +import Test.Framework ( Test, defaultMain, testGroup ) + +-- from test-framework-hunit: +import Test.Framework.Providers.HUnit ( testCase ) + +-- from threads: +import Control.Concurrent.Thread ( Result, result ) +import Control.Concurrent.Thread.Group ( ThreadGroup ) + +import qualified Control.Concurrent.Thread as Thread +import qualified Control.Concurrent.Thread.Group as ThreadGroup + + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMain tests + +tests ∷ [Test] +tests = [ testGroup "Thread" $ + [ testGroup "forkIO" $ + [ testCase "wait" $ test_wait Thread.forkIO + , testCase "blockedState" $ test_blockedState Thread.forkIO + , testCase "unblockedState" $ test_unblockedState Thread.forkIO + , testCase "sync exception" $ test_sync_exception Thread.forkIO + , testCase "async exception" $ test_async_exception Thread.forkIO + ] + , testGroup "forkOS" $ + [ testCase "wait" $ test_wait Thread.forkOS + , testCase "blockedState" $ test_blockedState Thread.forkOS + , testCase "unblockedState" $ test_unblockedState Thread.forkOS + , testCase "sync exception" $ test_sync_exception Thread.forkOS + , testCase "async exception" $ test_async_exception Thread.forkOS + ] + , testGroup "forkOn 0" $ + [ testCase "wait" $ test_wait $ Thread.forkOn 0 + , testCase "blockedState" $ test_blockedState $ Thread.forkOn 0 + , testCase "unblockedState" $ test_unblockedState $ Thread.forkOn 0 + , testCase "sync exception" $ test_sync_exception $ Thread.forkOn 0 + , testCase "async exception" $ test_async_exception $ Thread.forkOn 0 + ] + , testGroup "forkIOWithUnmask" $ + [ testCase "wait" $ test_wait $ wrapUnmask Thread.forkIOWithUnmask + , testCase "sync exception" $ test_sync_exception $ wrapUnmask Thread.forkIOWithUnmask + , testCase "async exception" $ test_async_exception $ wrapUnmask Thread.forkIOWithUnmask + ] + , testGroup "forkOnWithUnmask 0" $ + [ testCase "wait" $ test_wait $ wrapUnmask $ Thread.forkOnWithUnmask 0 + , testCase "sync exception" $ test_sync_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0 + , testCase "async exception" $ test_async_exception $ wrapUnmask $ Thread.forkOnWithUnmask 0 + ] + ] + , testGroup "ThreadGroup" $ + [ testGroup "forkIO" $ + [ testCase "wait" $ wrapIO test_wait + , testCase "blockedState" $ wrapIO test_blockedState + , testCase "unblockedState" $ wrapIO test_unblockedState + , testCase "sync exception" $ wrapIO test_sync_exception + , testCase "async exception" $ wrapIO test_async_exception + + , testCase "group single wait" $ test_group_single_wait ThreadGroup.forkIO + , testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkIO + ] + , testGroup "forkOS" $ + [ testCase "wait" $ wrapOS test_wait + , testCase "blockedState" $ wrapOS test_blockedState + , testCase "unblockedState" $ wrapOS test_unblockedState + , testCase "sync exception" $ wrapOS test_sync_exception + , testCase "async exception" $ wrapOS test_async_exception + + , testCase "group single wait" $ test_group_single_wait ThreadGroup.forkOS + , testCase "group nrOfRunning" $ test_group_nrOfRunning ThreadGroup.forkOS + ] + , testGroup "forkOn 0" $ + [ testCase "wait" $ wrapOn_0 test_wait + , testCase "blockedState" $ wrapOn_0 test_blockedState + , testCase "unblockedState" $ wrapOn_0 test_unblockedState + , testCase "sync exception" $ wrapOn_0 test_sync_exception + , testCase "async exception" $ wrapOn_0 test_async_exception + + , testCase "group single wait" $ test_group_single_wait $ ThreadGroup.forkOn 0 + , testCase "group nrOfRunning" $ test_group_nrOfRunning $ ThreadGroup.forkOn 0 + ] + , testGroup "forkIOWithUnmask" $ + [ testCase "wait" $ wrapIOWithUnmask test_wait + , testCase "sync exception" $ wrapIOWithUnmask test_sync_exception + , testCase "async exception" $ wrapIOWithUnmask test_async_exception + + , testCase "group single wait" $ test_group_single_wait $ wrapUnmask ∘ ThreadGroup.forkIOWithUnmask + , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask ∘ ThreadGroup.forkIOWithUnmask + ] + , testGroup "forkOnWithUnmask 0" $ + [ testCase "wait" $ wrapOnWithUnmask test_wait + , testCase "sync exception" $ wrapOnWithUnmask test_sync_exception + , testCase "async exception" $ wrapOnWithUnmask test_async_exception + + , testCase "group single wait" $ test_group_single_wait $ wrapUnmask ∘ ThreadGroup.forkOnWithUnmask 0 + , testCase "group nrOfRunning" $ test_group_nrOfRunning $ wrapUnmask ∘ ThreadGroup.forkOnWithUnmask 0 + ] + ] + ] + +-- Exactly 1 moment. Currently equal to 0.005 seconds. +a_moment ∷ Int +a_moment = 5000 + + +-------------------------------------------------------------------------------- +-- General properties +-------------------------------------------------------------------------------- + +type Fork α = IO α → IO (ThreadId, IO (Result α)) + +wrapUnmask ∷ ((β → α) → t) → α → t +wrapUnmask forkWithUnmask = \m -> forkWithUnmask $ const m + +test_wait ∷ Fork () → Assertion +test_wait fork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do + r ← newIORef False + (_, wait) ← fork $ do + threadDelay $ 2 ⋅ a_moment + writeIORef r True + _ ← wait + readIORef r + +test_blockedState ∷ Fork Bool → Assertion +test_blockedState fork = do (_, wait) ← block $ fork $ blocked + wait >>= result >>= assert + +test_unblockedState ∷ Fork Bool → Assertion +test_unblockedState fork = do (_, wait) ← unblock $ fork $ not <$> blocked + wait >>= result >>= assert + +test_sync_exception ∷ Fork () → Assertion +test_sync_exception fork = assert $ do + (_, wait) ← fork $ throwIO MyException + waitForException MyException wait + +waitForException ∷ (Exception e, Eq e) ⇒ e → IO (Result α) → IO Bool +waitForException e wait = wait <$$> either (justEq e ∘ fromException) + (const False) + +test_async_exception ∷ Fork () → Assertion +test_async_exception fork = assert $ do + l ← Lock.newAcquired + (tid, wait) ← fork $ Lock.acquire l + throwTo tid MyException + waitForException MyException wait + +data MyException = MyException deriving (Show, Eq, Typeable) +instance Exception MyException + +test_killThread ∷ Fork () → Assertion +test_killThread fork = assert $ do + l ← Lock.newAcquired + (tid, wait) ← fork $ Lock.acquire l + killThread tid + waitForException ThreadKilled wait + + +-------------------------------------------------------------------------------- +-- ThreadGroup +-------------------------------------------------------------------------------- + +wrapIO ∷ (Fork α → IO β) → IO β +wrapIO = wrap ThreadGroup.forkIO + +wrapOS ∷ (Fork α → IO β) → IO β +wrapOS = wrap ThreadGroup.forkOS + +wrapOn_0 ∷ (Fork α → IO β) → IO β +wrapOn_0 = wrap $ ThreadGroup.forkOn 0 + +wrapIOWithUnmask ∷ (Fork α → IO β) → IO β +wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg $ const m + +wrapOnWithUnmask ∷ (Fork α → IO β) → IO β +wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg $ const m + +wrap ∷ (ThreadGroup → Fork α) → (Fork α → IO β) → IO β +wrap doFork test = ThreadGroup.new >>= test ∘ doFork + +test_group_single_wait ∷ (ThreadGroup → Fork ()) → Assertion +test_group_single_wait doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do + tg ← ThreadGroup.new + r ← newIORef False + _ ← doFork tg $ do + threadDelay $ 2 ⋅ a_moment + writeIORef r True + _ ← ThreadGroup.wait tg + readIORef r + +test_group_nrOfRunning ∷ (ThreadGroup → Fork ()) → Assertion +test_group_nrOfRunning doFork = assert $ fmap isJustTrue $ timeout (10 ⋅ a_moment) $ do + tg ← ThreadGroup.new + l ← Lock.newAcquired + replicateM_ n $ doFork tg $ Lock.acquire l + true ← fmap (≡ n) $ (atomically $ ThreadGroup.nrOfRunning tg ∷ IO Int) + Lock.release l + return true + where + -- Don't set this number too big otherwise forkOS might throw an exception + -- indicating that too many OS threads have been created: + n ∷ Int + n = 100 + + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +-- | Check if the given value equals 'Just' 'True'. +isJustTrue ∷ Maybe Bool → Bool +isJustTrue = maybe False id + +-- | Check if the given value in the 'Maybe' equals the given reference value. +justEq ∷ Eq α ⇒ α → Maybe α → Bool +justEq = maybe False ∘ (≡) + +-- | A flipped '<$>'. +(<$$>) ∷ Functor f ⇒ f α → (α → β) → f β +(<$$>) = flip (<$>) diff --git a/threads.cabal b/threads.cabal --- a/threads.cabal +++ b/threads.cabal @@ -1,5 +1,5 @@ name: threads -version: 0.4.0.2 +version: 0.5 cabal-version: >= 1.9.2 build-type: Custom stability: experimental @@ -10,7 +10,7 @@ copyright: 2010–2012 Bas van Dijk & Roel van Dijk license: BSD3 license-file: LICENSE -homepage: https://github.com/basvandijk/threads/ +homepage: https://github.com/basvandijk/threads bug-reports: https://github.com/basvandijk/threads/issues category: Concurrency synopsis: Fork threads and wait for their result @@ -34,7 +34,7 @@ . * Correct handling of asynchronous exceptions. . - * GHC specific functionality like @forkOnIO@ and @forkIOUnmasked@. + * GHC specific functionality like @forkOn@ and @forkIOWithUnmask@. extra-source-files: README.markdown @@ -45,28 +45,26 @@ ------------------------------------------------------------------------------- library - build-depends: base >= 3 && < 4.6 + build-depends: base >= 4.4 && < 4.6 , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1 && < 2.3 + , stm >= 2.1 && < 2.4 exposed-modules: Control.Concurrent.Thread , Control.Concurrent.Thread.Group - other-modules: Mask ghc-options: -Wall ------------------------------------------------------------------------------- test-suite test-threads - type: exitcode-stdio-1.0 - main-is: test.hs - - ghc-options: -Wall -threaded - - build-depends: base >= 3 && < 4.6 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1 && < 2.3 - , concurrent-extra >= 0.5.1 && < 0.8 - , HUnit >= 1.2.2 && < 1.3 - , test-framework >= 0.2.4 && < 0.6 - , test-framework-hunit >= 0.2.4 && < 0.3 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + ghc-options: -Wall -threaded -------------------------------------------------------------------------------- + build-depends: threads + , base >= 4.4 && < 4.6 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , stm >= 2.1 && < 2.4 + , concurrent-extra >= 0.5.1 && < 0.8 + , HUnit >= 1.2.2 && < 1.3 + , test-framework >= 0.2.4 && < 0.6 + , test-framework-hunit >= 0.2.4 && < 0.3