1 {-# LANGUAGE BangPatterns  #-}
    2 {-# LANGUAGE CPP           #-}
    3 {-# LANGUAGE MagicHash     #-}
    4 {-# LANGUAGE RankNTypes    #-}
    5 {-# LANGUAGE UnboxedTuples #-}
    6 
    7 -- | Handy functions that should really be merged into Control.Concurrent
    8 -- itself.
    9 module Control.Concurrent.Extended
   10     ( forkIOLabeledWithUnmaskBs
   11     , forkOnLabeledWithUnmaskBs
   12     ) where
   13 
   14 ------------------------------------------------------------------------------
   15 import           Control.Exception      (mask_)
   16 import qualified Data.ByteString        as B
   17 import           GHC.Conc.Sync          (ThreadId (..))
   18 
   19 #ifdef LABEL_THREADS
   20 import           Control.Concurrent     (forkIOWithUnmask, forkOnWithUnmask,
   21                                          myThreadId)
   22 import           GHC.Base               (labelThread#)
   23 import           Foreign.C.String       (CString)
   24 import           GHC.IO                 (IO (..))
   25 import           GHC.Ptr                (Ptr (..))
   26 #else
   27 import           Control.Concurrent     (forkIOWithUnmask, forkOnWithUnmask)
   28 #endif
   29 
   30 ------------------------------------------------------------------------------
   31 -- | Sparks off a new thread using 'forkIOWithUnmask' to run the given IO
   32 -- computation, but first labels the thread with the given label (using
   33 -- 'labelThreadBs').
   34 --
   35 -- The implementation makes sure that asynchronous exceptions are masked until
   36 -- the given computation is executed. This ensures the thread will always be
   37 -- labeled which guarantees you can always easily find it in the GHC event log.
   38 --
   39 -- Like 'forkIOWithUnmask', the given computation is given a function to unmask
   40 -- asynchronous exceptions. See the documentation of that function for the
   41 -- motivation.
   42 --
   43 -- Returns the 'ThreadId' of the newly created thread.
   44 forkIOLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label
   45                           -> ((forall a. IO a -> IO a) -> IO ())
   46                           -> IO ThreadId
   47 forkIOLabeledWithUnmaskBs label m =
   48     mask_ $ forkIOWithUnmask $ \unmask -> do
   49       !_ <- labelMe label
   50       m unmask
   51 
   52 
   53 ------------------------------------------------------------------------------
   54 -- | Like 'forkIOLabeledWithUnmaskBs', but lets you specify on which capability
   55 -- (think CPU) the thread should run.
   56 forkOnLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label
   57                           -> Int          -- ^ Capability
   58                           -> ((forall a. IO a -> IO a) -> IO ())
   59                           -> IO ThreadId
   60 forkOnLabeledWithUnmaskBs label cap m =
   61     mask_ $ forkOnWithUnmask cap $ \unmask -> do
   62       !_ <- labelMe label
   63       m unmask
   64 
   65 
   66 ------------------------------------------------------------------------------
   67 -- | Label the current thread.
   68 {-# INLINE labelMe #-}
   69 labelMe :: B.ByteString -> IO ()
   70 #if defined(LABEL_THREADS)
   71 labelMe label = do
   72     tid <- myThreadId
   73     labelThreadBs tid label
   74 
   75 
   76 ------------------------------------------------------------------------------
   77 -- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' instead of a
   78 -- 'String'.
   79 labelThreadBs :: ThreadId -> B.ByteString -> IO ()
   80 labelThreadBs tid bs = B.useAsCString bs $ labelThreadCString tid
   81 
   82 
   83 ------------------------------------------------------------------------------
   84 -- | Like 'labelThread' but uses a 'CString' instead of a 'String'
   85 labelThreadCString :: ThreadId -> CString -> IO ()
   86 labelThreadCString (ThreadId t) (Ptr p) =
   87     IO $ \s -> case labelThread# t p s of
   88                  s1 -> (# s1, () #)
   89 #elif defined(TESTSUITE)
   90 labelMe !_ = return $! ()
   91 #else
   92 labelMe _label = return $! ()
   93 #endif
   94