{-# LANGUAGE CPP
, DeriveDataTypeable
, NoImplicitPrelude
, ImpredicativeTypes
, RankNTypes #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.Thread.Group
( ThreadGroup
, new
, nrOfRunning
, wait
, waitN
, forkIO
, forkOS
, forkOn
, forkIOWithUnmask
, forkOnWithUnmask
) where
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 )
import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVar, writeTVar )
import Control.Concurrent.STM ( STM, atomically, retry )
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
newtype ThreadGroup = ThreadGroup (TVar Int) deriving (ThreadGroup -> ThreadGroup -> Bool
(ThreadGroup -> ThreadGroup -> Bool)
-> (ThreadGroup -> ThreadGroup -> Bool) -> Eq ThreadGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadGroup -> ThreadGroup -> Bool
$c/= :: ThreadGroup -> ThreadGroup -> Bool
== :: ThreadGroup -> ThreadGroup -> Bool
$c== :: ThreadGroup -> ThreadGroup -> Bool
Eq, Typeable)
new :: IO ThreadGroup
new :: IO ThreadGroup
new = (TVar Int -> ThreadGroup) -> IO (TVar Int) -> IO ThreadGroup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TVar Int -> ThreadGroup
ThreadGroup (IO (TVar Int) -> IO ThreadGroup)
-> IO (TVar Int) -> IO ThreadGroup
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
nrOfRunning :: ThreadGroup -> STM Int
nrOfRunning :: ThreadGroup -> STM Int
nrOfRunning (ThreadGroup TVar Int
numThreadsTV) = TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
numThreadsTV
wait :: ThreadGroup -> IO ()
wait :: ThreadGroup -> IO ()
wait = Int -> ThreadGroup -> IO ()
waitN Int
1
waitN :: Int -> ThreadGroup -> IO ()
waitN :: Int -> ThreadGroup -> IO ()
waitN Int
i ThreadGroup
tg = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadGroup -> STM Int
nrOfRunning ThreadGroup
tg STM Int -> (Int -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n -> Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i) STM ()
forall a. STM a
retry
forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkIO :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkIO = (IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forall a.
(IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
rawForkIO
forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkOS :: ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkOS = (IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forall a.
(IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
Control.Concurrent.forkOS
forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkOn :: Int -> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forkOn = (IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
forall a.
(IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
fork ((IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a)))
-> (Int -> IO () -> IO ThreadId)
-> Int
-> ThreadGroup
-> IO a
-> IO (ThreadId, IO (Result a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ThreadId
rawForkOn
forkIOWithUnmask
:: ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkIOWithUnmask :: ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkIOWithUnmask = (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forall a.
(((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
Control.Concurrent.forkIOWithUnmask
forkOnWithUnmask
:: Int
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkOnWithUnmask :: Int
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkOnWithUnmask = (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forall a.
(((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask ((((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a)))
-> (Int -> ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> Int
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
Control.Concurrent.forkOnWithUnmask
fork :: (IO () -> IO ThreadId)
-> ThreadGroup
-> IO a
-> IO (ThreadId, IO (Result a))
fork :: (IO () -> IO ThreadId)
-> ThreadGroup -> IO a -> IO (ThreadId, IO (Result a))
fork IO () -> IO ThreadId
doFork (ThreadGroup TVar Int
numThreadsTV) IO a
a = do
MVar (Result a)
res <- IO (MVar (Result a))
forall a. IO (MVar a)
newEmptyMVar
ThreadId
tid <- ((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId
forall b. ((forall b. IO b -> IO b) -> IO b) -> IO b
mask (((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
numThreadsTV (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
IO () -> IO ThreadId
doFork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
IO a -> IO (Result a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
forall b. IO b -> IO b
restore IO a
a) IO (Result a) -> (Result a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Result a) -> Result a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Result a)
res
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
numThreadsTV (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
(ThreadId, IO (Result a)) -> IO (ThreadId, IO (Result a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
tid, MVar (Result a) -> IO (Result a)
forall a. MVar a -> IO a
readMVar MVar (Result a)
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 :: (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ThreadGroup
-> ((forall b. IO b -> IO b) -> IO a)
-> IO (ThreadId, IO (Result a))
forkWithUnmask ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
doForkWithUnmask = \(ThreadGroup TVar Int
numThreadsTV) (forall b. IO b -> IO b) -> IO a
f -> do
MVar (Result a)
res <- IO (MVar (Result a))
forall a. IO (MVar a)
newEmptyMVar
ThreadId
tid <- ((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId
forall b. ((forall b. IO b -> IO b) -> IO b) -> IO b
mask (((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
numThreadsTV (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
doForkWithUnmask (((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId)
-> ((forall b. IO b -> IO b) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
unmask -> do
IO a -> IO (Result a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
forall b. IO b -> IO b
restore (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall b. IO b -> IO b) -> IO a
f forall b. IO b -> IO b
unmask) IO (Result a) -> (Result a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Result a) -> Result a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Result a)
res
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
numThreadsTV (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
(ThreadId, IO (Result a)) -> IO (ThreadId, IO (Result a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
tid, MVar (Result a) -> IO (Result a)
forall a. MVar a -> IO a
readMVar MVar (Result a)
res)
modifyTVar :: TVar a -> (a -> a) -> STM ()
modifyTVar :: TVar a -> (a -> a) -> STM ()
modifyTVar TVar a
tv a -> a
f = TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
tv STM a -> (a -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
tv (a -> STM ()) -> (a -> a) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.! a -> a
f
(.!) :: (b -> c) -> (a -> b) -> (a -> c)
b -> c
f .! :: (b -> c) -> (a -> b) -> a -> c
.! a -> b
g = \a
x -> b -> c
f (b -> c) -> b -> c
forall a b. (a -> b) -> a -> b
$! a -> b
g a
x