{-# 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)
#if MIN_VERSION_base(4,18,0)
import qualified Data.ByteString.Char8 as C8
import GHC.Conc (labelThread)
#else
import GHC.Base (labelThread#)
#endif
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 =
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask 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 =
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnWithUnmask Int
cap 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 ()
#if MIN_VERSION_base(4,18,0)
labelThreadBs tid =
labelThread tid . C8.unpack
#else
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, () #)
#endif
#elif defined(TESTSUITE)
labelMe !_ = return $! ()
#else
labelMe :: ByteString -> IO ()
labelMe ByteString
_label = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()
#endif