{-# LANGUAGE CPP #-}
module SlaveThread
(
fork,
forkWithUnmask,
forkFinally,
forkFinallyWithUnmask,
SlaveThreadCrashed(..)
)
where
import SlaveThread.Prelude
import SlaveThread.Util.LowLevelForking
import qualified DeferredFolds.UnfoldlM as UnfoldlM
import qualified StmContainers.Multimap as Multimap
import qualified Control.Foldl as Foldl
import qualified Focus
{-# NOINLINE slaveRegistry #-}
slaveRegistry :: Multimap.Multimap ThreadId ThreadId
slaveRegistry :: Multimap ThreadId ThreadId
slaveRegistry =
forall a. IO a -> a
unsafePerformIO forall key value. IO (Multimap key value)
Multimap.newIO
{-# INLINABLE fork #-}
fork :: IO a -> IO ThreadId
fork :: forall a. IO a -> IO ThreadId
fork =
forall a b. IO a -> IO b -> IO ThreadId
forkFinally forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINABLE forkWithUnmask #-}
forkWithUnmask :: ((forall x. IO x -> IO x) -> IO a) -> IO ThreadId
forkWithUnmask :: forall a. ((forall x. IO x -> IO x) -> IO a) -> IO ThreadId
forkWithUnmask =
forall a b.
IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId
forkFinallyWithUnmask forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINABLE forkFinally #-}
forkFinally :: IO a -> IO b -> IO ThreadId
forkFinally :: forall a b. IO a -> IO b -> IO ThreadId
forkFinally IO a
finalizer IO b
computation =
forall a b.
IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId
forkFinallyWithUnmask IO a
finalizer (\forall x. IO x -> IO x
unmask -> forall x. IO x -> IO x
unmask IO b
computation)
{-# INLINABLE forkFinallyWithUnmask #-}
forkFinallyWithUnmask :: IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId
forkFinallyWithUnmask :: forall a b.
IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId
forkFinallyWithUnmask IO a
finalizer (forall x. IO x -> IO x) -> IO b
computation =
forall b. ((forall x. IO x -> IO x) -> IO b) -> IO b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall x. IO x -> IO x
unmask -> do
ThreadId
masterThread <- IO ThreadId
myThreadId
ThreadId
slaveThread <- IO () -> IO ThreadId
forkIOWithoutHandler forall a b. (a -> b) -> a -> b
$ do
ThreadId
slaveThread <- IO ThreadId
myThreadId
Maybe SomeException
computationExceptions <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((forall x. IO x -> IO x) -> IO b
computation forall x. IO x -> IO x
unmask forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a. Alternative f => f a
empty) (forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
[SomeException]
slavesDyingExceptions <- let
loop :: [SomeException] -> IO [SomeException]
loop ![SomeException]
exceptions =
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(forall x. IO x -> IO x
unmask forall a b. (a -> b) -> a -> b
$ do
ThreadId -> IO ()
killSlaves ThreadId
slaveThread
ThreadId -> IO ()
waitForSlavesToDie ThreadId
slaveThread
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeException]
exceptions)
(\ !SomeException
exception -> [SomeException] -> IO [SomeException]
loop (SomeException
exception forall a. a -> [a] -> [a]
: [SomeException]
exceptions))
in [SomeException] -> IO [SomeException]
loop []
Maybe SomeException
finalizerExceptions <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (IO a
finalizer forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a. Alternative f => f a
empty) (forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
let
handler :: SomeException -> IO ()
handler SomeException
e = do
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just AsyncException
ThreadKilled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe AsyncException
_ -> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
masterThread (ThreadId -> SomeException -> SlaveThreadCrashed
SlaveThreadCrashed ThreadId
slaveThread SomeException
e)
in do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ @Maybe Maybe SomeException
computationExceptions SomeException -> IO ()
handler
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeException]
slavesDyingExceptions SomeException -> IO ()
handler
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ @Maybe Maybe SomeException
finalizerExceptions SomeException -> IO ()
handler
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Maybe ()
result <- forall key value result.
(Eq key, Hashable key, Eq value, Hashable value) =>
Focus () STM result
-> value -> key -> Multimap key value -> STM result
Multimap.focus forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookupAndDelete ThreadId
slaveThread ThreadId
masterThread Multimap ThreadId ThreadId
slaveRegistry
case Maybe ()
result of
Just ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ()
_ -> forall a. STM a
retry
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall key value.
(Eq key, Hashable key, Eq value, Hashable value) =>
value -> key -> Multimap key value -> STM ()
Multimap.insert ThreadId
slaveThread ThreadId
masterThread Multimap ThreadId ThreadId
slaveRegistry
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
slaveThread
killSlaves :: ThreadId -> IO ()
killSlaves :: ThreadId -> IO ()
killSlaves ThreadId
thread = do
#if MIN_VERSION_stm_containers(1,2,0)
[ThreadId]
threads <- forall a. STM a -> IO a
atomically (forall (m :: * -> *) input output.
Monad m =>
FoldM m input output -> UnfoldlM m input -> m output
UnfoldlM.foldM (forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
Foldl.generalize forall a. Fold a [a]
Foldl.revList) (forall key value.
(Eq key, Hashable key) =>
key -> Multimap key value -> UnfoldlM STM value
Multimap.unfoldlMByKey ThreadId
thread Multimap ThreadId ThreadId
slaveRegistry))
#else
threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaveRegistry))
#endif
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ThreadId -> IO ()
killThread [ThreadId]
threads
waitForSlavesToDie :: ThreadId -> IO ()
waitForSlavesToDie :: ThreadId -> IO ()
waitForSlavesToDie ThreadId
thread =
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_stm_containers(1,2,0)
Bool
null <- forall (m :: * -> *) input. Monad m => UnfoldlM m input -> m Bool
UnfoldlM.null forall a b. (a -> b) -> a -> b
$ forall key value.
(Eq key, Hashable key) =>
key -> Multimap key value -> UnfoldlM STM value
Multimap.unfoldlMByKey ThreadId
thread Multimap ThreadId ThreadId
slaveRegistry
#else
null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaveRegistry
#endif
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
null forall a. STM a
retry
data SlaveThreadCrashed
= SlaveThreadCrashed !ThreadId !SomeException
deriving (Int -> SlaveThreadCrashed -> ShowS
[SlaveThreadCrashed] -> ShowS
SlaveThreadCrashed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlaveThreadCrashed] -> ShowS
$cshowList :: [SlaveThreadCrashed] -> ShowS
show :: SlaveThreadCrashed -> String
$cshow :: SlaveThreadCrashed -> String
showsPrec :: Int -> SlaveThreadCrashed -> ShowS
$cshowsPrec :: Int -> SlaveThreadCrashed -> ShowS
Show)
instance Exception SlaveThreadCrashed where
toException :: SlaveThreadCrashed -> SomeException
toException = forall e. Exception e => e -> SomeException
asyncExceptionToException
fromException :: SomeException -> Maybe SlaveThreadCrashed
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException