content: {-# LANGUAGE BangPatterns  #-}
  {-# LANGUAGE CPP           #-}
  {-# LANGUAGE MagicHash     #-}
  {-# LANGUAGE RankNTypes    #-}
  {-# LANGUAGE UnboxedTuples #-}
  
  -- | Handy functions that should really be merged into Control.Concurrent
  -- itself.
  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
  
  ------------------------------------------------------------------------------
  -- | Sparks off a new thread using 'forkIOWithUnmask' to run the given IO
  -- computation, but first labels the thread with the given label (using
  -- 'labelThreadBs').
  --
  -- The implementation makes sure that asynchronous exceptions are masked until
  -- the given computation is executed. This ensures the thread will always be
  -- labeled which guarantees you can always easily find it in the GHC event log.
  --
  -- Like 'forkIOWithUnmask', the given computation is given a function to unmask
  -- asynchronous exceptions. See the documentation of that function for the
  -- motivation.
  --
  -- Returns the 'ThreadId' of the newly created thread.
  forkIOLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label
                            -> ((forall a. IO a -> IO a) -> IO ())
                            -> IO ThreadId
  forkIOLabeledWithUnmaskBs label m =
      mask_ $ forkIOWithUnmask $ \unmask -> do
        !_ <- labelMe label
        m unmask
  
  
  ------------------------------------------------------------------------------
  -- | Like 'forkIOLabeledWithUnmaskBs', but lets you specify on which capability
  -- (think CPU) the thread should run.
  forkOnLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label
                            -> Int          -- ^ Capability
                            -> ((forall a. IO a -> IO a) -> IO ())
                            -> IO ThreadId
  forkOnLabeledWithUnmaskBs label cap m =
      mask_ $ forkOnWithUnmask cap $ \unmask -> do
        !_ <- labelMe label
        m unmask
  
  
  ------------------------------------------------------------------------------
  -- | Label the current thread.
  {-# INLINE labelMe #-}
  labelMe :: B.ByteString -> IO ()
  #if defined(LABEL_THREADS)
  labelMe label = do
      tid <- myThreadId
      labelThreadBs tid label
  
  
  ------------------------------------------------------------------------------
  -- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' instead of a
  -- 'String'.
  labelThreadBs :: ThreadId -> B.ByteString -> IO ()
  #if MIN_VERSION_base(4,18,0)
  labelThreadBs tid =
    -- The 'labelThread#' signature changed: it now requires a UTF-8 encoded
    -- ByteArray#.
    labelThread tid . C8.unpack
  #else
  labelThreadBs tid bs = B.useAsCString bs $ labelThreadCString tid
  
  
  ------------------------------------------------------------------------------
  -- | Like 'labelThread' but uses a 'CString' instead of a 'String'
  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 _label = return $! ()
  #endif
  