more forkLabeled, and now forkOSLabeled

1 files changed, 6 insertions, 7 deletions

diff --git a/dht/src/Network/QueryResponse/TCP.hs b/dht/src/Network/QueryResponse/TCP.hs
index de6e1eb7..e4831fb2 100644
--- a/dht/src/Network/QueryResponse/TCP.hs
+++ b/dht/src/Network/QueryResponse/TCP.hs
@@ -19,6 +19,7 @@ import Data.Maybe
 import Data.Ord
 import Data.Time.Clock.POSIX
 import Data.Word
+import Data.String (IsString(..))
 import Network.BSD
 import Network.Socket
 import System.Timeout
@@ -68,6 +69,7 @@ killSession :: TCPSession st -> IO ()
 killSession PendingTCPSession       = return ()
 killSession TCPSession{tcpThread=t} = killThread t
 
+showStat :: IsString p => TCPSession st -> p
 showStat r = case r of PendingTCPSession -> "pending."
                        TCPSession {}     -> "established."
 
@@ -105,7 +107,8 @@ acquireConnection mvar tcpcache stream addr bDoCon = do
                 st <- streamHello stream addr h
                 dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr)
                 signal <- newTVarIO False
-                rthread <- forkIO $ do
+                let showAddr a = show (streamAddr stream a)
+                rthread <- forkLabeled ("tcp:"++showAddr addr) $ do
                   atomically (readTVar signal >>= check)
                   fix $ \loop -> do
                     x <- streamDecode st
@@ -127,8 +130,6 @@ acquireConnection mvar tcpcache stream addr bDoCon = do
                             forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do
                                 dput XTCP $ unwords [show i ++ ".", "Still connected:",  show addr, show (now - tm), showStat r]
                             hClose h
-                let showAddr a = show (streamAddr stream a)
-                labelThread rthread ("tcp:"++showAddr addr)
                 let v = TCPSession
                         { tcpHandle = h
                         , tcpState  = st
@@ -142,8 +143,7 @@ acquireConnection mvar tcpcache stream addr bDoCon = do
                     writeTVar (lru tcpcache) c'
                     writeTVar signal True
                     return rs
-                forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkIO $ do
-                    myThreadId >>= flip labelThread ("tcp-close:"++show k)
+                forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkLabeled ("tcp-close:"++show k) $ do
                     dput XTCP $ "TCP dropped: " ++ show k
                     killSession r
                     case r of TCPSession {tcpState=st,tcpHandle=h} -> do
@@ -184,10 +184,9 @@ tcpTransport maxcon stream = do
     return $ (,) tcpcache Transport
         { awaitMessage   = \f -> takeMVar msgvar >>= \x -> f x `catchIOError` (\e -> dput XTCP ("TCP transport stopped. " ++ show e) >> f Nothing)
         , sendMessage    = \addr (bDoCon,y) -> do
-                                t <- forkIO $ do
+                                void . forkLabeled "tcp-send" $ do
                                     msock <- acquireConnection msgvar tcpcache stream addr bDoCon
                                     mapM_ ($ y) msock
                                   `catchIOError` \e -> dput XTCP $ "TCP-send: " ++ show e
-                                labelThread t "tcp-send"
         , closeTransport = closeAll tcpcache stream >> putMVar msgvar Nothing
         }