threads-0.5.0.2/0000755000000000000000000000000012117424167011501 5ustar0000000000000000threads-0.5.0.2/Setup.hs0000644000000000000000000000303412117424167013135 0ustar0000000000000000#! /usr/bin/env runhaskell {-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} module Main (main) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- -- from base import System.IO ( IO ) -- from cabal import Distribution.Simple ( defaultMainWithHooks , simpleUserHooks , UserHooks(haddockHook) , Args ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.Program ( userSpecifyArgs ) import Distribution.Simple.Setup ( HaddockFlags ) import Distribution.PackageDescription ( PackageDescription(..) ) ------------------------------------------------------------------------------- -- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. ------------------------------------------------------------------------------- main ∷ IO () main = defaultMainWithHooks hooks where hooks = simpleUserHooks { haddockHook = haddockHook' } -- Define __HADDOCK__ for CPP when running haddock. haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () haddockHook' pkg lbi = haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) where p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) -- The End --------------------------------------------------------------------- threads-0.5.0.2/README.markdown0000644000000000000000000000200112117424167014173 0ustar0000000000000000This package provides functions to fork threads and wait for their result, whether it's an exception or a normal value. Besides waiting for the termination of a single thread this packages also provides functions to wait for a group of threads to terminate. This package is similar to the [threadmanager], [async] and [spawn] packages. The advantages of this package are: * Simpler API. * More efficient in both space and time. * No space-leak when forking a large number of threads. * Correct handling of asynchronous exceptions. * GHC specific functionality like [forkOnIO] and [forkIOUnmasked]. [threadmanager]: http://hackage.haskell.org/package/threadmanager [async]: http://hackage.haskell.org/package/async [spawn]: http://hackage.haskell.org/package/spawn [forkOnIO]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIO [forkIOUnmasked]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/GHC-Conc-Sync.html#v:forkOnIOUnmasked threads-0.5.0.2/LICENSE0000644000000000000000000000302212117424167012503 0ustar0000000000000000Copyright (c) 2010-2012 Bas van Dijk & Roel van Dijk 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. * The names of Bas van Dijk, Roel van Dijk and the names of contributors may NOT be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT OWNER OR 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. threads-0.5.0.2/threads.cabal0000644000000000000000000000524212117424167014122 0ustar0000000000000000name: threads version: 0.5.0.2 cabal-version: >= 1.9.2 build-type: Custom stability: experimental author: Bas van Dijk Roel van Dijk maintainer: Bas van Dijk Roel van Dijk copyright: 2010–2012 Bas van Dijk & Roel van Dijk license: BSD3 license-file: LICENSE homepage: https://github.com/basvandijk/threads bug-reports: https://github.com/basvandijk/threads/issues category: Concurrency synopsis: Fork threads and wait for their result description: This package provides functions to fork threads and wait for their result, whether it's an exception or a normal value. . Besides waiting for the termination of a single thread this packages also provides functions to wait for a group of threads to terminate. . This package is similar to the @threadmanager@, @async@ and @spawn@ packages. The advantages of this package are: . * Simpler API. . * More efficient in both space and time. . * No space-leak when forking a large number of threads. . * Correct handling of asynchronous exceptions. . * GHC specific functionality like @forkOn@ and @forkIOWithUnmask@. extra-source-files: README.markdown source-repository head Type: git Location: git://github.com/basvandijk/threads.git ------------------------------------------------------------------------------- library build-depends: base >= 4.4 && < 4.7 , base-unicode-symbols >= 0.1.1 && < 0.3 , stm >= 2.1 && < 2.5 exposed-modules: Control.Concurrent.Thread , Control.Concurrent.Thread.Group other-modules: Control.Concurrent.Raw ghc-options: -Wall ------------------------------------------------------------------------------- test-suite test-threads type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test.hs ghc-options: -Wall -threaded build-depends: threads , base >= 4.4 && < 4.7 , base-unicode-symbols >= 0.1.1 && < 0.3 , stm >= 2.1 && < 2.5 , concurrent-extra >= 0.5.1 && < 0.8 , HUnit >= 1.2.2 && < 1.3 , test-framework >= 0.2.4 && < 0.9 , test-framework-hunit >= 0.2.4 && < 0.4 threads-0.5.0.2/test/0000755000000000000000000000000012117424167012460 5ustar0000000000000000threads-0.5.0.2/test/test.hs0000644000000000000000000002466012117424167014003 0ustar0000000000000000{-# 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, mask_ , getMaskingState, MaskingState(MaskedInterruptible) ) import Control.Monad ( return, (>>=), replicateM_ ) import Data.Bool ( Bool(False, True) ) 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 "maskingState" $ test_maskingState 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 "maskingState" $ test_maskingState 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 "maskingState" $ test_maskingState $ 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 "maskingState" $ wrapIO test_maskingState , 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 "maskingState" $ wrapOS test_maskingState , 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 "maskingState" $ wrapOn_0 test_maskingState , 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_maskingState ∷ Fork Bool → Assertion test_maskingState fork = do (_, wait) ← mask_ $ fork $ (MaskedInterruptible ==) <$> getMaskingState 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 (<$>) threads-0.5.0.2/Control/0000755000000000000000000000000012117424167013121 5ustar0000000000000000threads-0.5.0.2/Control/Concurrent/0000755000000000000000000000000012117424167015243 5ustar0000000000000000threads-0.5.0.2/Control/Concurrent/Thread.hs0000644000000000000000000001264212117424167017013 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, RankNTypes #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread -- 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 return value. -- -- This module exports equivalently named functions from @Control.Concurrent@ -- (and @GHC.Conc@). Avoid ambiguities by importing this module qualified. May -- we suggest: -- -- @ -- import qualified Control.Concurrent.Thread as Thread ( ... ) -- @ -- -- The following is an example how to use this module: -- -- @ -- -- import qualified Control.Concurrent.Thread as Thread ( 'forkIO', 'result' ) -- -- main = do (tid, wait) <- Thread.'forkIO' $ do x <- someExpensiveComputation -- return x -- doSomethingElse -- x <- Thread.'result' =<< 'wait' -- doSomethingWithResult x -- @ -- -------------------------------------------------------------------------------- module Control.Concurrent.Thread ( -- * Forking threads forkIO , forkOS , forkOn , forkIOWithUnmask , forkOnWithUnmask -- * Results , Result , result ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import qualified Control.Concurrent ( forkOS , forkIOWithUnmask , forkOnWithUnmask ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) import Control.Exception ( SomeException, try, throwIO, mask ) import Control.Monad ( return, (>>=) ) import Data.Either ( Either(..), either ) import Data.Function ( ($) ) import Data.Int ( Int ) import System.IO ( IO ) -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) -- from threads: import Control.Concurrent.Raw ( rawForkIO, rawForkOn ) -------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------- -- | 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 rawForkIO -- | 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 -- | 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 ∘ rawForkOn -- | 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 -- | 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 -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- -- | A result of a thread is either some exception that was thrown in the thread -- 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. result ∷ Result α → IO α result = either throwIO return threads-0.5.0.2/Control/Concurrent/Raw.hs0000644000000000000000000000143212117424167016330 0ustar0000000000000000{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, MagicHash, UnboxedTuples #-} module Control.Concurrent.Raw ( rawForkIO, rawForkOn ) where import Data.Function ( ($) ) import GHC.IO ( IO(IO) ) import GHC.Exts ( Int(I#), fork#, forkOn# ) import GHC.Conc ( ThreadId(ThreadId) ) -- A version of forkIO that does not include the outer exception -- handler: saves a bit of time when we will be installing our own -- exception handler. {-# INLINE rawForkIO #-} rawForkIO ∷ IO () → IO ThreadId rawForkIO action = IO $ \s → case (fork# action s) of (# s1, tid #) → (# s1, ThreadId tid #) {-# INLINE rawForkOn #-} rawForkOn ∷ Int → IO () → IO ThreadId rawForkOn (I# cpu) action = IO $ \s → case (forkOn# cpu action s) of (# s1, tid #) → (# s1, ThreadId tid #) threads-0.5.0.2/Control/Concurrent/Thread/0000755000000000000000000000000012117424167016452 5ustar0000000000000000threads-0.5.0.2/Control/Concurrent/Thread/Group.hs0000644000000000000000000001624512117424167020112 0ustar0000000000000000{-# LANGUAGE CPP , DeriveDataTypeable , NoImplicitPrelude , UnicodeSyntax , RankNTypes #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif -------------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Thread.Group -- Copyright : (c) 2010-2012 Bas van Dijk & Roel van Dijk -- License : BSD3 (see the file LICENSE) -- Maintainer : Bas van Dijk -- , Roel van Dijk -- -- This module extends @Control.Concurrent.Thread@ with the ability to wait for -- a group of threads to terminate. -- -- This module exports equivalently named functions from @Control.Concurrent@, -- (@GHC.Conc@), and @Control.Concurrent.Thread@. Avoid ambiguities by importing -- this module qualified. May we suggest: -- -- @ -- import Control.Concurrent.Thread.Group ( ThreadGroup ) -- import qualified Control.Concurrent.Thread.Group as ThreadGroup ( ... ) -- @ -- -------------------------------------------------------------------------------- module Control.Concurrent.Thread.Group ( ThreadGroup , new , nrOfRunning , wait -- * Forking threads , forkIO , forkOS , forkOn , forkIOWithUnmask , forkOnWithUnmask ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import qualified Control.Concurrent ( forkOS , forkIOWithUnmask , forkOnWithUnmask ) import Control.Concurrent ( ThreadId ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar ) 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 ( ($!), (+), subtract ) import System.IO ( IO ) -- from base-unicode-symbols: import Data.Eq.Unicode ( (≢) ) import Data.Function.Unicode ( (∘) ) -- from stm: import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVar, writeTVar ) import Control.Concurrent.STM ( STM, atomically, retry ) -- from threads: import Control.Concurrent.Thread ( Result ) import Control.Concurrent.Raw ( rawForkIO, rawForkOn ) #ifdef __HADDOCK__ import qualified Control.Concurrent.Thread as Thread ( forkIO , forkOS , forkOn , forkIOWithUnmask , forkOnWithUnmask ) #endif -------------------------------------------------------------------------------- -- * Thread groups -------------------------------------------------------------------------------- {-| A @ThreadGroup@ can be understood as a counter which counts the number of threads that were added to the group minus the ones that have terminated. More formally a @ThreadGroup@ has the following semantics: * 'new' initializes the counter to 0. * Forking a thread increments the counter. * When a forked thread terminates, whether normally or by raising an exception, the counter is decremented. * 'nrOfRunning' yields a transaction that returns the counter. * 'wait' blocks as long as the counter is not 0. -} newtype ThreadGroup = ThreadGroup (TVar Int) deriving (Eq, Typeable) -- | Create an empty group of threads. new ∷ IO ThreadGroup new = fmap ThreadGroup $ newTVarIO 0 {-| Yield a transaction that returns the number of running threads in the group. Note that because this function yields a 'STM' computation, the returned number is guaranteed to be consistent inside the transaction. -} nrOfRunning ∷ ThreadGroup → STM Int nrOfRunning (ThreadGroup numThreadsTV) = readTVar numThreadsTV -- | Convenience function which blocks until all threads, that were added to the -- group have terminated. wait ∷ ThreadGroup → IO () wait tg = atomically $ nrOfRunning tg >>= \n → when (n ≢ 0) retry -------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------- -- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds -- the thread to the group. forkIO ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α)) forkIO = fork rawForkIO -- | Same as @Control.Concurrent.Thread.'Thread.forkOS'@ but additionaly adds -- the thread to the group. forkOS ∷ ThreadGroup → IO α → IO (ThreadId, IO (Result α)) forkOS = fork Control.Concurrent.forkOS -- | 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 ∘ rawForkOn -- | 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 -------------------------------------------------------------------------------- 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 (+ 1) doFork $ do try (restore a) >>= putMVar res 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 -- | Strict function composition (∘!) ∷ (β → γ) → (α → β) → (α → γ) f ∘! g = \x → f $! g x