Control.Concurrent.ThreadUtil replaces #ifdef imports

    * new function, forkLabeled
    * new module Control.Concurrent.ThreadUtil
    * label a few unlabeled threads

5 files changed, 35 insertions, 14 deletions

diff --git a/dht/OnionRouter.hs b/dht/OnionRouter.hs
index 57c8ba35..cb74f6db 100644
--- a/dht/OnionRouter.hs
+++ b/dht/OnionRouter.hs
@@ -3,7 +3,7 @@
 {-# LANGUAGE RankNTypes               #-}
 module OnionRouter where
 
-import Control.Concurrent.Lifted.Instrument
+import Control.Concurrent.ThreadUtil
 import Crypto.Tox
 import Network.Address
 import Network.Kademlia
@@ -471,9 +471,9 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do
                             n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns)))
                                    <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n)
                     sendqs = do
-                        forkIO $ sendq asel aq 0 >>= atomically . writeTVar av . Just
-                        forkIO $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just
-                        forkIO $ sendq csel cq 2 >>= atomically . writeTVar cv . Just
+                        forkLabeled "sendq.asel" $ sendq asel aq 0 >>= atomically . writeTVar av . Just
+                        forkLabeled "sendq.bsel" $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just
+                        forkLabeled "sendq.csel" $ sendq csel cq 2 >>= atomically . writeTVar cv . Just
                         -- This timeout should be unnecessary... But I'm paranoid.
                         -- Note: 10 seconds should be sufficient for typical get-nodes queries.
                         tm <- timeout 30000000 $ atomically $ do -- Wait for all 3 results.
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
index 8cdd1cdc..a09a517d 100644
--- a/dht/Presence/Presence.hs
+++ b/dht/Presence/Presence.hs
@@ -290,7 +290,8 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do
        buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
        forM_ buds $ \bud -> do
             let (_,h,_) = splitJID bud
-            forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
+            forkLabeled "XMPP.buddies.resolvePeer" $ do
+                void $ resolvePeer (manager state $ clientProfile client) h
 
     atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index e98b9a2e..de2dd5d3 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -65,12 +65,7 @@ import Control.Monad.Trans (lift)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Fix (fix)
 import Control.Monad
-#ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
-#else
-import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
-import GHC.Conc                  (labelThread)
-#endif
+import Control.Concurrent.ThreadUtil (forkIO,myThreadId,forkLabeled,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
 import Control.Concurrent.STM
 import Data.List hiding ((\\))
 -- import Control.Concurrent.STM.TChan
@@ -344,7 +339,7 @@ conduitToChan c = do
     chan <- atomically newLockedChan
     clsrs <- atomically $ newTVar (Just [])
     quitvar <- atomically $ newEmptyTMVar
-    forkIO $ do
+    forkLabeled "XMPP.conduitToChan" $ do
         runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ())
         atomically $ writeTVar clsrs Nothing
     return (chan,clsrs,quitvar)
@@ -462,7 +457,7 @@ sendReply donevar stype reply replychan = do
                       , stanzaOrigin = LocalPeer
                       }
     ioWriteChan replychan replyStanza
-    void . liftIO . forkIO $ do
+    void . liftIO . forkLabeled "XMPPServer.sendReply" $ do
         mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply
         liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
         -- liftIO $ wlog "finished reply stanza"
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index 168dd079..31f78bcf 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -71,7 +71,8 @@ library
                      , RecordWildCards
                      , NondecreasingIndentation
   hs-source-dirs:      src, ., Presence
-  exposed-modules:  Network.SocketLike
+  exposed-modules:  Control.Concurrent.ThreadUtil
+                    Network.SocketLike
                     Data.Digest.CRC32C
                     Data.Bits.ByteString
                     Data.TableMethods
diff --git a/dht/src/Control/Concurrent/ThreadUtil.hs b/dht/src/Control/Concurrent/ThreadUtil.hs
new file mode 100644
index 00000000..2888e899
--- /dev/null
+++ b/dht/src/Control/Concurrent/ThreadUtil.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE CPP #-}
+module Control.Concurrent.ThreadUtil
+    (
+#ifdef THREAD_DEBUG
+      module Control.Concurrent.Lifted.Instrument
+#else
+      module Control.Control.Lifted
+    , module GHC.Conc
+#endif
+    ) where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+
+forkLabeled :: String -> IO () -> IO ThreadId
+forkLabeled lbl action = do
+    t <- forkIO action
+    labelThread t lbl
+    return t
+{-# INLINE forkLabeled #-}
+#endif