Control.Concurrent.ThreadUtil replaces #ifdef imports

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

2 files changed, 5 insertions, 9 deletions

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"