threads-0.5.1.4/0000755000000000000000000000000012726505665011515 5ustar0000000000000000threads-0.5.1.4/README.markdown0000644000000000000000000000232412726505665014217 0ustar0000000000000000[![Hackage](https://img.shields.io/hackage/v/threads.svg)](https://hackage.haskell.org/package/threads) [![Build Status](https://travis-ci.org/basvandijk/threads.svg)](https://travis-ci.org/basvandijk/threads) 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 [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.1.4/LICENSE0000644000000000000000000000302212726505665012517 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.1.4/Setup.hs0000644000000000000000000000303412726505665013151 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.1.4/threads.cabal0000644000000000000000000000522612726505665014140 0ustar0000000000000000name: threads version: 0.5.1.4 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 tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.2, GHC==8.0.1 source-repository head Type: git Location: git://github.com/basvandijk/threads.git ------------------------------------------------------------------------------- library build-depends: base >= 4.4 && < 4.10 , 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.10 , stm >= 2.1 && < 2.5 , concurrent-extra >= 0.5.1 && < 0.8 , HUnit >= 1.2.2 && < 1.4 , test-framework >= 0.2.4 && < 0.9 , test-framework-hunit >= 0.2.4 && < 0.4 threads-0.5.1.4/test/0000755000000000000000000000000012726505665012474 5ustar0000000000000000threads-0.5.1.4/test/test.hs0000644000000000000000000002427512726505665014021 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, ImpredicativeTypes #-} 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 ) import Prelude ( (*) ) -- 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 a = IO a -> IO (ThreadId, IO (Result a)) wrapUnmask :: ((b -> a) -> t) -> a -> 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 a) -> 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 a -> IO b) -> IO b wrapIO = wrap ThreadGroup.forkIO wrapOS :: (Fork a -> IO b) -> IO b wrapOS = wrap ThreadGroup.forkOS wrapOn_0 :: (Fork a -> IO b) -> IO b wrapOn_0 = wrap $ ThreadGroup.forkOn 0 wrapIOWithUnmask :: (Fork a -> IO b) -> IO b wrapIOWithUnmask = wrap $ \tg m -> ThreadGroup.forkIOWithUnmask tg $ const m wrapOnWithUnmask :: (Fork a -> IO b) -> IO b wrapOnWithUnmask = wrap $ \tg m -> ThreadGroup.forkOnWithUnmask 0 tg $ const m wrap :: (ThreadGroup -> Fork a) -> (Fork a -> IO b) -> IO b 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 a => a -> Maybe a -> Bool justEq = maybe False . (==) -- | A flipped '<$>'. (<&>) :: (Functor f) => f a -> (a -> b) -> f b (<&>) = flip (<$>) threads-0.5.1.4/Control/0000755000000000000000000000000012726505665013135 5ustar0000000000000000threads-0.5.1.4/Control/Concurrent/0000755000000000000000000000000012726505665015257 5ustar0000000000000000threads-0.5.1.4/Control/Concurrent/Thread.hs0000644000000000000000000001244512726505665017030 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude, RankNTypes, ImpredicativeTypes #-} #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 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 a -> IO (ThreadId, IO (Result a)) 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 a -> IO (ThreadId, IO (Result a)) 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 a -> IO (ThreadId, IO (Result a)) 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 :: ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 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 -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- fork :: (IO () -> IO ThreadId) -> (IO a -> IO (ThreadId, IO (Result a))) fork doFork = \a -> do res <- newEmptyMVar tid <- mask $ \restore -> doFork $ try (restore a) >>= putMVar res return (tid, readMVar res) forkWithUnmask :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId) -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 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 a = Either SomeException a -- | Retrieve the actual value from the result. -- -- When the result is 'SomeException' the exception is thrown. result :: Result a -> IO a result = either throwIO return threads-0.5.1.4/Control/Concurrent/Raw.hs0000644000000000000000000000140212726505665016341 0ustar0000000000000000{-# LANGUAGE 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.1.4/Control/Concurrent/Thread/0000755000000000000000000000000012726505665016466 5ustar0000000000000000threads-0.5.1.4/Control/Concurrent/Thread/Group.hs0000644000000000000000000001641412726505665020124 0ustar0000000000000000{-# LANGUAGE CPP , DeriveDataTypeable , NoImplicitPrelude , ImpredicativeTypes , 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 , waitN -- * 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.Ord ( (>=) ) import Data.Int ( Int ) import Data.Typeable ( Typeable ) import Prelude ( ($!), (+), subtract ) import System.IO ( IO ) -- 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 greater than 0. * 'waitN' blocks as long as the counter is greater or equal to the specified number. -} 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 -- | Block until all threads in the group have terminated. -- -- Note that: @wait = 'waitN' 1@. wait :: ThreadGroup -> IO () wait = waitN 1 -- | Block until there are fewer than @N@ running threads in the group. waitN :: Int -> ThreadGroup -> IO () waitN i tg = atomically $ nrOfRunning tg >>= \n -> when (n >= i) retry -------------------------------------------------------------------------------- -- * Forking threads -------------------------------------------------------------------------------- -- | Same as @Control.Concurrent.Thread.'Thread.forkIO'@ but additionaly adds -- the thread to the group. forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) forkIO = fork rawForkIO -- | Same as @Control.Concurrent.Thread.'Thread.forkOS'@ but additionaly adds -- the thread to the group. forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) forkOS = fork Control.Concurrent.forkOS -- | Same as @Control.Concurrent.Thread.'Thread.forkOn'@ but -- additionaly adds the thread to the group. forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) forkOn = fork . rawForkOn -- | Same as @Control.Concurrent.Thread.'Thread.forkIOWithUnmask'@ but -- additionaly adds the thread to the group. forkIOWithUnmask :: ThreadGroup -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) forkIOWithUnmask = forkWithUnmask Control.Concurrent.forkIOWithUnmask -- | Like @Control.Concurrent.Thread.'Thread.forkOnWithUnmask'@ but -- additionaly adds the thread to the group. forkOnWithUnmask :: Int -> ThreadGroup -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) forkOnWithUnmask = forkWithUnmask . Control.Concurrent.forkOnWithUnmask -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- fork :: (IO () -> IO ThreadId) -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)) 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 :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId) -> ThreadGroup -> ((forall b. IO b -> IO b) -> IO a) -> IO (ThreadId, IO (Result a)) 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 a -> (a -> a) -> STM () modifyTVar tv f = readTVar tv >>= writeTVar tv .! f -- | Strict function composition (.!) :: (b -> c) -> (a -> b) -> (a -> c) f .! g = \x -> f $! g x