Added thread-debug flag and "threads" command.

1 files changed, 9 insertions, 2 deletions

diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 4852eb38..22d111e2 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -7,6 +7,7 @@
 --
 --   Normally, you don't need to import this module.
 --
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FlexibleContexts       #-}
@@ -41,8 +42,12 @@ module Network.KRPC.Manager
        ) where
 
 import Control.Applicative
-import Control.Concurrent
-import Control.Concurrent.Lifted (fork)
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import GHC.Conc (labelThread)
+import Control.Concurrent.Lifted
+#endif
 import Control.Exception hiding (Handler)
 import qualified Control.Exception.Lifted as E (Handler (..))
 import Control.Exception.Lifted as Lifted (catches, finally)
@@ -432,6 +437,7 @@ dispatchHandler q @ KQuery {..} addr = do
 --
 handleQuery :: MonadKRPC h m => BValue -> KQuery -> SockAddr -> m ()
 handleQuery raw q addr = void $ fork $ do
+  myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery"
   Manager {..} <- getManager
   res <- dispatchHandler q addr
   let resbe = either toBEncode toBEncode res
@@ -481,6 +487,7 @@ listen :: MonadKRPC h m => m ()
 listen = do
   Manager {..} <- getManager
   tid <- fork $ do
+    myThreadId >>= liftIO . flip labelThread "KRPC.listen"
     listener `Lifted.finally`
       liftIO (takeMVar listenerThread)
   liftIO $ putMVar listenerThread tid