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