From c479c2dd58c12d159c05040a08da6c4c7730c407 Mon Sep 17 00:00:00 2001
From: James Crayne <jim.crayne@gmail.com>
Date: Fri, 18 Oct 2019 10:13:55 +0000
Subject: convert forkIO to forkLabeled (wip)

---
 dht/Connection/Tcp.hs | 28 ++++++++--------------------
 1 file changed, 8 insertions(+), 20 deletions(-)

(limited to 'dht/Connection')

diff --git a/dht/Connection/Tcp.hs b/dht/Connection/Tcp.hs
index fd5d333b..2572eba6 100644
--- a/dht/Connection/Tcp.hs
+++ b/dht/Connection/Tcp.hs
@@ -35,12 +35,7 @@ import qualified Data.Map as Map
 import           Data.Map (Map)
 #endif
 import Data.Monoid ( (<>) )
-#ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument
-#else
-import Control.Concurrent.Lifted
-import GHC.Conc                  (labelThread)
-#endif
+import Control.Concurrent.ThreadUtil
 
 import Control.Concurrent.STM
 -- import Control.Concurrent.STM.TMVar
@@ -268,7 +263,7 @@ server allocate sessionConduits = do
                       , retrymap = retrymap
                       }
     liftIO $ do
-        tid <- forkIO $ fix $ \loop -> do
+        forkLabeled "server" $ fix $ \loop -> do
             instr <- atomically $ takeTMVar cmds
             -- warn $ "instr = " <> bshow instr
             let again = do doit server instr
@@ -276,7 +271,6 @@ server allocate sessionConduits = do
                            loop
             case instr of Quit -> closeAll server
                           _    -> again
-        labelThread tid "server"
         return server
  where
   closeAll server = do
@@ -337,8 +331,7 @@ server allocate sessionConduits = do
                          interruptDelay d
                          when (not b) forkit
     where
-    forkit = void . forkIO $ do
-        myThreadId >>= flip labelThread ( "Connect." ++ show addr )
+    forkit = void . forkLabeled ( "Connect." ++ show addr ) $ do
         proto <- getProtocolNumber "tcp"
         sock <- socket (socketFamily addr) Stream proto
         handle (\e -> do -- let t = ioeGetErrorType e
@@ -358,8 +351,7 @@ server allocate sessionConduits = do
 
   doit server (ConnectWithEndlessRetry addr params interval) = do
     proto <- getProtocolNumber "tcp"
-    void . forkIO $ do
-        myThreadId >>= flip labelThread ("ConnectWithEndlessRetry." ++ show addr)
+    void . forkLabeled ("ConnectWithEndlessRetry." ++ show addr) $ do
         timer <- interruptibleDelay
         (retryVar,action) <- atomically $ do
             map <- readTVar (retrymap server)
@@ -470,8 +462,7 @@ newConnection server sessionConduits params conkey u h inout = do
     kontvar <- atomically newEmptyTMVar
     -- XXX: Why does kontvar store STM (IO ()) instead of just IO () ?
     let _ = kontvar :: TMVar (STM (IO ()))
-    forkIO $ do
-        myThreadId >>= flip labelThread ("connecting...")
+    forkLabeled ("connecting...") $ do
         getkont <- atomically $ takeTMVar kontvar
         kont <- atomically getkont
         kont
@@ -605,8 +596,7 @@ connectionThreads h pinglogic = do
     (donew,outs) <- atomically $ liftM2 (,) newEmptyTMVar newEmptyTMVar
 
     (doner,incomming) <- atomically $ liftM2 (,) newEmptyTMVar newTChan
-    readerThread <- forkIO $ do
-        myThreadId >>= flip labelThread ("readerThread")
+    readerThread <- forkLabeled "readerThread" $ do
         let finished e  = do
                           hClose h
                           -- warn $ "finished read: " <> bshow (fmap ioeGetErrorType e)
@@ -626,8 +616,7 @@ connectionThreads h pinglogic = do
             isEof <- hIsEOF h
             if isEof then finished Nothing else loop
 
-    writerThread <- forkIO . fix $ \loop -> do
-        myThreadId >>= flip labelThread ("writerThread")
+    writerThread <- forkLabeled "writerThread" . fix $ \loop -> do
         let finished = do -- warn $ "finished write"
                           -- hClose h -- quit reader
                           throwTo readerThread (ErrorCall "EOF")
@@ -792,8 +781,7 @@ tcpManager grokKey sv = do
                 Just {} -> return $ return () -- Connection already in progress.
                 Nothing -> do
                     modifyTVar' rmap $ Map.insert k Nothing
-                    return $ void $ forkIO $ do
-                    myThreadId >>= flip labelThread ("resolve."++show k)
+                    return $ void $ forkLabeled ("resolve."++show k) $ do
                     mconkey <- listToMaybe <$> rslv k
                     case mconkey of
                         Nothing     -> atomically $ modifyTVar' rmap $ Map.delete k
-- 
cgit v1.2.3