Label mux threads

Author: karknu

network-mux/src/Network/Mux.hs

@@ -177,11 +177,11 @@ muxStart tracer (MuxApplication ptcls) bearer = do
 
     muxerJob tq cnt =
       JobPool.Job (mux cnt MuxState { egressQueue   = tq,  Egress.bearer })
-                  MuxerException
+                  MuxerException "muxer"
 
     demuxerJob tbl =
       JobPool.Job (demux DemuxState { dispatchTable = tbl, Ingress.bearer })
-                  DemuxerException
+                  DemuxerException "demuxer"
 
     miniProtocolInitiatorJob = miniProtocolJob selectInitiator ModeInitiator
     miniProtocolResponderJob = miniProtocolJob selectResponder ModeResponder
@@ -216,6 +216,7 @@ muxStart tracer (MuxApplication ptcls) bearer = do
       where
         job run = JobPool.Job (jobAction run)
                               (MiniProtocolException pnum pix pmode)
+                              ((show pix) ++ "." ++ (show pmode))
 
         jobAction run = do
           chan    <- mkChannel

network-mux/src/Network/Mux/JobPool.hs

@@ -28,7 +28,7 @@ data JobPool m a = JobPool {
        completionQueue :: !(TQueue m a)
      }
 
-data Job m a = Job (m a) (SomeException -> a)
+data Job m a = Job (m a) (SomeException -> a) String
 
 withJobPool :: forall m a b.
                (MonadAsync m, MonadThrow m)
@@ -52,12 +52,13 @@ forkJob :: forall m a.
         => JobPool m a
         -> Job     m a
         -> m ()
-forkJob JobPool{jobsVar, completionQueue} (Job action handler) =
+forkJob JobPool{jobsVar, completionQueue} (Job action handler label) =
     mask $ \restore -> do
       jobAsync <- async $ do
+        tid <- myThreadId
+        labelThread tid label
         res <- handleJust notAsyncExceptions (return . handler) $
                  restore action
-        tid <- myThreadId
         atomically $ do
           writeTQueue completionQueue res
           modifyTVar' jobsVar (Map.delete tid)