Added threadLabel to MonadThread

Not adding `listThreads` as it's not very well specified in `IO`:

> primop ListThreadsOp "listThreads#" GenPrimOp
>    State# RealWorld -> (# State# RealWorld, Array# ThreadId# #)
>    { Returns an array of the threads started by the program. Note that this
>      threads which have finished execution may or may not be present in this
>      list, depending upon whether they have been collected by the garbage collector.

Author: coot

io-classes/CHANGELOG.md

@@ -1,5 +1,11 @@
 # Revsion history of io-classes
 
+### next version
+
+### Breaking changes
+
+* Added `threadLabel` to `MonadThread`
+
 ### 1.7.0.0
 
 ### Breaking changes

io-classes/src/Control/Monad/Class/MonadFork.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,7 +19,7 @@ import Control.Exception (AsyncException (ThreadKilled), Exception,
            SomeException)
 import Control.Monad.Reader (ReaderT (..), lift)
 import Data.Kind (Type)
-import GHC.Conc.Sync qualified as IO (labelThread)
+import GHC.Conc.Sync qualified as IO
 
 
 class (Monad m, Eq   (ThreadId m),
@@ -30,6 +31,11 @@ class (Monad m, Eq   (ThreadId m),
   myThreadId     :: m (ThreadId m)
   labelThread    :: ThreadId m -> String -> m ()
 
+  -- | Requires ghc-9.6.1 or newer.
+  --
+  -- @since 1.8.0.0
+  threadLabel    :: ThreadId m -> m (Maybe String)
+
 -- | Apply the label to the current thread
 labelThisThread :: MonadThread m => String -> m ()
 labelThisThread label = myThreadId >>= \tid -> labelThread tid label
@@ -53,6 +59,11 @@ instance MonadThread IO where
   type ThreadId IO = IO.ThreadId
   myThreadId   = IO.myThreadId
   labelThread  = IO.labelThread
+#if MIN_VERSION_base(4,18,0)
+  threadLabel = IO.threadLabel
+#else
+  threadLabel = \_ -> pure Nothing
+#endif
 
 instance MonadFork IO where
   forkIO           = IO.forkIO
@@ -67,6 +78,7 @@ instance MonadThread m => MonadThread (ReaderT r m) where
   type ThreadId (ReaderT r m) = ThreadId m
   myThreadId      = lift myThreadId
   labelThread t l = lift (labelThread t l)
+  threadLabel     = lift . threadLabel
 
 instance MonadFork m => MonadFork (ReaderT e m) where
   forkIO (ReaderT f)   = ReaderT $ \e -> forkIO (f e)

io-sim/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history of io-sim
 
+## next version
+
+- Support `threadLabel` (`io-classes-1.8`)
+
 ## 1.6.0.0
 
 - Upgraded to `io-classes-1.6.0.0`

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -547,6 +547,13 @@ schedule !thread@Thread{
                            , threadLabel   = Just l }
       schedule thread' simstate
 
+    GetThreadLabel tid' k -> do
+      let tlbl' | tid' == tid = tlbl
+                | otherwise   = tid' `Map.lookup` threads
+                            >>= threadLabel
+          thread' = thread { threadControl = ThreadControl (k tlbl') ctl }
+      schedule thread' simstate
+
     LabelThread tid' l k -> do
       let thread'  = thread { threadControl = ThreadControl k ctl }
           threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -186,9 +186,10 @@ data SimA s a where
                   SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
   Evaluate     :: a -> (a -> SimA s b) -> SimA s b
 
-  Fork         :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
-  GetThreadId  :: (IOSimThreadId -> SimA s b) -> SimA s b
-  LabelThread  :: IOSimThreadId -> String -> SimA s b -> SimA s b
+  Fork           :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
+  GetThreadId    :: (IOSimThreadId -> SimA s b) -> SimA s b
+  LabelThread    :: IOSimThreadId -> String -> SimA s b -> SimA s b
+  GetThreadLabel :: IOSimThreadId -> (Maybe String -> SimA s b) -> SimA s b
 
   Atomically   :: STM  s a -> (a -> SimA s b) -> SimA s b
 
@@ -469,6 +470,7 @@ instance MonadThread (IOSim s) where
   type ThreadId (IOSim s) = IOSimThreadId
   myThreadId       = IOSim $ oneShot $ \k -> GetThreadId k
   labelThread t l  = IOSim $ oneShot $ \k -> LabelThread t l (k ())
+  threadLabel t    = IOSim $ oneShot $ \k -> GetThreadLabel t k
 
 instance MonadFork (IOSim s) where
   forkIO task        = IOSim $ oneShot $ \k -> Fork task k
@@ -815,10 +817,8 @@ ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThread
            tidWidth
            (ppIOSimThreadId seThreadId)
            tLabelWidth
-           threadLabel
+           (fromMaybe "" seThreadLabel)
            (ppSimEventType seType)
-  where
-    threadLabel = fromMaybe "" seThreadLabel
 
 ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThreadId, seStep, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
@@ -827,10 +827,8 @@ ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThr
            tidWidth
            (ppStepId (seThreadId, seStep))
            tLableWidth
-           threadLabel
+           (fromMaybe "" seThreadLabel)
            (ppSimEventType seType)
-  where
-    threadLabel = fromMaybe "" seThreadLabel
 
 ppSimEvent _ _ _ (SimRacesFound controls) =
     "RacesFound "++show controls

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -703,6 +703,13 @@ schedule thread@Thread{
                            , threadLabel   = Just l }
       schedule thread' simstate
 
+    GetThreadLabel tid' k -> do
+      let tlbl' | tid' == tid = tlbl
+                | otherwise   = tid' `Map.lookup` threads
+                            >>= threadLabel
+          thread' = thread { threadControl = ThreadControl (k tlbl') ctl }
+      schedule thread' simstate
+
     LabelThread tid' l k -> do
       let thread'  = thread { threadControl = ThreadControl k ctl }
           threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads