1 files changed, 34 insertions, 0 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index c3c0ed15..05a3de26 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -26,6 +26,8 @@ import Text.Printf
 import Text.Read
 import Control.Monad.Reader.Class
 import System.Posix.Process (getProcessID)
+import GHC.Stats
+import System.Mem
 
 import Data.Torrent (InfoHash)
 import Network.BitTorrent.Address
@@ -187,6 +189,38 @@ clientSession st signalQuit sock n h = do
                     tm <- getCurrentTime
                     let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts
                     hPutClient h $ showReport r
+        ("mem", s) -> cmd $ return $ do
+                    case s of
+                        "gc" -> do hPutClient h "Performing garbage collection..."
+                                   performMajorGC
+                        "" -> do
+                            is_enabled <- getGCStatsEnabled
+                            if is_enabled
+                             then do
+                                GCStats{..} <- getGCStats
+                                let r = [ ("bytesAllocated", show bytesAllocated)
+                                        , ("numGcs", show numGcs)
+                                        , ("maxBytesUsed", show maxBytesUsed)
+                                        , ("numByteUsageSamples", show numByteUsageSamples)
+                                        , ("cumulativeBytesUsed", show cumulativeBytesUsed)
+                                        , ("bytesCopied", show bytesCopied)
+                                        , ("currentBytesUsed", show currentBytesUsed)
+                                        , ("currentBytesSlop", show currentBytesSlop)
+                                        , ("maxBytesSlop", show maxBytesSlop)
+                                        , ("peakMegabytesAllocated", show peakMegabytesAllocated)
+                                        , ("mutatorCpuSeconds", show mutatorCpuSeconds)
+                                        , ("mutatorWallSeconds", show mutatorWallSeconds)
+                                        , ("gcCpuSeconds", show gcCpuSeconds)
+                                        , ("gcWallSeconds", show gcWallSeconds)
+                                        , ("cpuSeconds", show cpuSeconds)
+                                        , ("wallSeconds", show wallSeconds)
+                                        , ("parTotBytesCopied", show parTotBytesCopied)
+                                        , ("parMaxBytesCopied", show parMaxBytesCopied)
+                                        ]
+                                hPutClient h $ showReport r
+                            else hPutClient h "Run with +RTS -T to obtain live memory-usage information."
+                        _ -> hPutClient h "error."
+
 #endif
         ("closest", s) -> cmd $ do
                         let (ns,hs) = second (dropWhile isSpace) $ break isSpace s