More details in threads listing.

2 files changed, 20 insertions, 13 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 9bb7c5a7..ef225f0c 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -60,10 +60,14 @@ import Network.BitTorrent.DHT.ContactInfo as Peers
 import qualified Data.MinMaxPSQ as MM
 
 showReport :: [(String,String)] -> String
-showReport kvs = do
-    let colwidth = maximum $ map (length . fst) kvs
-    (k,v) <- kvs
-    concat [ printf "  %-*s" (colwidth+1) k, v, "\n" ]
+showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
+
+showColumns rows = do
+    let cols = transpose rows
+        ws = map (maximum . map (succ . length)) cols
+    fs <- rows
+    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
+    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
 
 
 marshalForClient :: String -> String
@@ -282,8 +286,12 @@ clientSession s@Session{..} sock cnum h = do
         ("threads", _) -> cmd0 $ do
                     ts <- threadsInformation
                     tm <- getCurrentTime
-                    let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts
-                    hPutClient h $ showReport r
+                    r <- forM ts $ \(tid,PerThread{..}) -> do
+                        stat <- threadStatus tid
+                        let showStat (ThreadBlocked reason) = show reason
+                            showStat stat                   = show stat
+                        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
+                    hPutClient h $ showColumns r
 #endif
         ("mem", s) -> cmd0 $ do
                     case s of
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index 957b67bb..7ee78c8b 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -45,26 +45,25 @@ fork action = do
     t <- Raw.fork $ do
         tid <- myThreadId
         tm <- liftBase getCurrentTime
-        bracket_ (modifyThreads $ Map.insert tid (PerThread "" tm))
-                 (modifyThreads $ Map.delete tid)
+        bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm))
+                 (modifyThreads $! Map.delete tid)
                  action
     return t
 
 labelThread :: ThreadId -> String -> IO ()
 labelThread tid s = do
     GHC.labelThread tid s
-    modifyThreads $ Map.adjust (\pt -> pt { lbl = s }) tid
+    modifyThreads $! Map.adjust (\pt -> pt { lbl = s }) tid
 {-# INLINE labelThread #-}
 
-threadsInformation :: IO [PerThread]
+threadsInformation :: IO [(ThreadId,PerThread)]
 threadsInformation = do
     m <- threads <$> readMVar globals
-    return $ Map.elems m
+    return $ Map.toList m
 
 
 modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m ()
 modifyThreads f = do
     g <- takeMVar globals
     let f' st = st { threads = f (threads st) }
-        r = f' g
-    putMVar globals r
+    putMVar globals $! f' g