Control.Concurrent.ThreadUtil replaces #ifdef imports

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

1 files changed, 3 insertions, 8 deletions

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"