server library.

3 files changed, 77 insertions, 0 deletions

diff --git a/lifted-concurrent/lifted-concurrent.cabal b/lifted-concurrent/lifted-concurrent.cabal
index bbf254e3..8fe4b6a9 100644
--- a/lifted-concurrent/lifted-concurrent.cabal
+++ b/lifted-concurrent/lifted-concurrent.cabal
@@ -19,6 +19,8 @@ library
   exposed-modules:
           Control.Concurrent.Lifted.Instrument
         , Control.Concurrent.Async.Lifted.Instrument
+        , DebugUtil
+        , Control.Concurrent.ThreadUtil
   other-modules: DebugTag
   other-extensions:    FlexibleContexts
   build-depends:
@@ -32,3 +34,4 @@ library
         , transformers-base
   hs-source-dirs:      src
   default-language:    Haskell2010
+  cpp-options: -DTHREAD_DEBUG
diff --git a/lifted-concurrent/src/Control/Concurrent/ThreadUtil.hs b/lifted-concurrent/src/Control/Concurrent/ThreadUtil.hs
new file mode 100644
index 00000000..a258d933
--- /dev/null
+++ b/lifted-concurrent/src/Control/Concurrent/ThreadUtil.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP #-}
+module Control.Concurrent.ThreadUtil
+    (
+#ifdef THREAD_DEBUG
+      module Control.Concurrent.Lifted.Instrument
+#else
+      module Control.Control.Lifted
+    , module GHC.Conc
+#endif
+    ) where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+
+forkLabeled :: String -> IO () -> IO ThreadId
+forkLabeled lbl action = do
+    t <- forkIO action
+    labelThread t lbl
+    return t
+{-# INLINE forkLabeled #-}
+
+forkOSLabeled :: String -> IO () -> IO ThreadId
+forkOSLabeled lbl action = do
+    t <- forkOS action
+    labelThread t lbl
+    return t
+{-# INLINE forkOSLabeled #-}
+#endif
diff --git a/lifted-concurrent/src/DebugUtil.hs b/lifted-concurrent/src/DebugUtil.hs
new file mode 100644
index 00000000..e73f9061
--- /dev/null
+++ b/lifted-concurrent/src/DebugUtil.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+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 -- ^ False to summarize search threads.
+                -> 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." ]