Added thread-debug flag and "threads" command.

2 files changed, 15 insertions, 2 deletions

diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 73b3d492..47d17622 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -9,6 +9,7 @@
 --   Normally, you don't need to import this module, use
 --   "Network.BitTorrent.DHT" instead.
 --
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -49,7 +50,12 @@ module Network.BitTorrent.DHT.Query
        , (<@>)
        ) where
 
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument hiding (yield)
+#else
+import GHC.Conc (labelThread)
 import Control.Concurrent.Lifted hiding (yield)
+#endif
 import Control.Exception.Lifted hiding (Handler)
 import Control.Monad.Reader
 import Control.Monad.Logger
@@ -227,6 +233,7 @@ refreshNodes nid = do
 --   routing table.
 insertNode :: forall ip. Address ip => NodeInfo ip -> Maybe ReflectedIP -> DHT ip ThreadId
 insertNode info witnessed_ip0 = fork $ do
+  -- myThreadId >>= liftIO . flip labelThread "DHT.insertNode"
   var <- asks routingInfo
   tm <- getTimestamp
   let showTable = do
@@ -286,8 +293,10 @@ insertNode info witnessed_ip0 = fork $ do
                            return ps
   ps <- join $ liftIO $ atomically $ atomicInsert arrival0 witnessed_ip0
   showTable
-  _ <- fork $ forM_ ps $ \(CheckPing ns)-> do
-    forM_ ns $ \n -> do
+  _ <- fork $ do
+    myThreadId >>= liftIO . flip labelThread "DHT.insertNode.pingResults"
+    forM_ ps $ \(CheckPing ns)-> do
+      forM_ ns $ \n -> do
         (b,mip) <- probeNode (nodeAddr n)
         let alive = PingResult n b
         $(logDebugS) "insertNode" $ T.pack ("PingResult "++show (nodeId n,b))
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index 8dc3f7ac..bad783a5 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -72,7 +72,11 @@ module Network.BitTorrent.DHT.Session
 import Prelude hiding (ioError)
 
 import Control.Concurrent.STM
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Async.Lifted.Instrument
+#else
 import Control.Concurrent.Async.Lifted
+#endif
 import Control.Exception.Lifted hiding (Handler)
 import Control.Monad.Base
 import Control.Monad.Logger