blob: e7a1039768a111ec295604092641fac6da557639 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
{-# LANGUAGE CPP #-}
module DebugUtil where
import Control.Monad
import Data.Time.Clock
import Data.List
import Text.Printf
import GHC.Conc (threadStatus,ThreadStatus(..))
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc (labelThread)
#endif
showReport :: [(String,String)] -> String
showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
showColumns :: [[String]] -> String
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"
threadReport :: Bool -> IO String
threadReport want_ss = do
threads <- threadsInformation
tm <- getCurrentTime
let (ss,ts) = partition (("search" `isPrefixOf`) . lbl . snd)
threads
r <- forM (if want_ss then threads else 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]
return $ unlines [ showColumns r
, (if want_ss then " There are " else " and ")
++ show (length ss) ++ " search threads." ]
|
