{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
module Control.Concurrent.Extended
( forkIOLabeledWithUnmaskBs
, forkOnLabeledWithUnmaskBs
) where
import Control.Exception (mask_)
import qualified Data.ByteString as B
import GHC.Conc.Sync (ThreadId (..))
#ifdef LABEL_THREADS
import Control.Concurrent (forkIOWithUnmask, forkOnWithUnmask,
myThreadId)
import GHC.Base (labelThread#)
import Foreign.C.String (CString)
import GHC.IO (IO (..))
import GHC.Ptr (Ptr (..))
#else
import Control.Concurrent (forkIOWithUnmask, forkOnWithUnmask)
#endif
forkIOLabeledWithUnmaskBs :: B.ByteString
-> ((forall a. IO a -> IO a) -> IO ())
-> IO ThreadId
forkIOLabeledWithUnmaskBs :: ByteString -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOLabeledWithUnmaskBs ByteString
label (forall a. IO a -> IO a) -> IO ()
m =
IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
!()
_ <- ByteString -> IO ()
labelMe ByteString
label
(forall a. IO a -> IO a) -> IO ()
m forall a. IO a -> IO a
unmask
forkOnLabeledWithUnmaskBs :: B.ByteString
-> Int
-> ((forall a. IO a -> IO a) -> IO ())
-> IO ThreadId
forkOnLabeledWithUnmaskBs :: ByteString
-> Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnLabeledWithUnmaskBs ByteString
label Int
cap (forall a. IO a -> IO a) -> IO ()
m =
IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnWithUnmask Int
cap (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
!()
_ <- ByteString -> IO ()
labelMe ByteString
label
(forall a. IO a -> IO a) -> IO ()
m forall a. IO a -> IO a
unmask
{-# INLINE labelMe #-}
labelMe :: B.ByteString -> IO ()
#if defined(LABEL_THREADS)
labelMe label = do
tid <- myThreadId
labelThreadBs tid label
labelThreadBs :: ThreadId -> B.ByteString -> IO ()
labelThreadBs tid bs = B.useAsCString bs $ labelThreadCString tid
labelThreadCString :: ThreadId -> CString -> IO ()
labelThreadCString (ThreadId t) (Ptr p) =
IO $ \s -> case labelThread# t p s of
s1 -> (# s1, () #)
#elif defined(TESTSUITE)
labelMe !_ = return $! ()
#else
labelMe :: ByteString -> IO ()
labelMe ByteString
_label = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ()
#endif