Improvements to the top monitors

Ignore-this: 2b5970ea557f40775a8fca0291049e68

darcs-hash:20100211225048-748be-8786f8a07241468ab2fe8e03a9f8cf21a0a483a8.gz

2 files changed, 66 insertions, 73 deletions

diff --git a/Plugins/Monitors.hs b/Plugins/Monitors.hs
index 69ee869..cba7332 100644
--- a/Plugins/Monitors.hs
+++ b/Plugins/Monitors.hs
@@ -85,5 +85,5 @@ instance Exec Monitors where
     start (CoreTemp   a r) = runM a          coreTempConfig runCoreTemp   r
     start (DiskU    s a r) = runM a          diskUConfig   (runDiskU s)   r
     start (DiskIO   s a r) = runM a          diskIOConfig  (runDiskIO s)  r
-    start (TopCpu     a r) = runM a          topCpuConfig   runTopCpu     r
     start (TopMem     a r) = runM a          topMemConfig   runTopMem     r
+    start (TopCpu     a r) = startTopCpu a r
diff --git a/Plugins/Monitors/Top.hs b/Plugins/Monitors/Top.hs
index 0d9c6bd..14ccf1e 100644
--- a/Plugins/Monitors/Top.hs
+++ b/Plugins/Monitors/Top.hs
@@ -14,24 +14,31 @@
 
 {-# LANGUAGE ForeignFunctionInterface #-}
 
-module Plugins.Monitors.Top ( topCpuConfig
-                            , runTopCpu
-                            , topMemConfig
-                            , runTopMem ) where
+module Plugins.Monitors.Top (startTopCpu, topMemConfig, runTopMem) where
 
 import Plugins.Monitors.Common
 
--- import Control.Monad (zipWithM)
-import Control.Exception
+import Control.Exception (SomeException, handle, evaluate)
+import Control.Concurrent
 import System.Directory
 import System.FilePath
-import System.IO
+import System.Posix.Unistd (getSysVar, SysVar(ClockTick))
 import Foreign.C.Types
 import Data.List (sortBy, foldl')
-import Data.Ord (comparing)
+
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as M
 
+
+topMemConfig :: IO MConfig
+topMemConfig = mkMConfig "<both1>" [ k ++ n | n <- map show [1..maxProc]
+                                            , k <- ["name", "rss", "both"]]
+
+topCpuConfig :: IO MConfig
+topCpuConfig = mkMConfig "<both1>" [ k ++ n | n <- map show [1..maxProc]
+                                            , k <- ["name", "cpu", "both"]]
+
+
 foreign import ccall "unistd.h getpagesize"
   c_getpagesize :: CInt
 
@@ -57,36 +64,34 @@ showInfo nm sms mms = do
   both <- showWithColors' (rnm ++ " " ++ sms) mms
   return [nm, mstr, both]
 
-topMemConfig :: IO MConfig
-topMemConfig = mkMConfig
-               "<both1>"
-               [ k ++ n | n <- map show [1::Int .. 5]
-                        , k <- ["name", "rss", "both"]]
+defHandle :: a -> SomeException -> IO a
+defHandle def _ = evaluate $! def
+
+handlePidFile :: a -> ([String] -> IO a) -> FilePath -> IO a
+handlePidFile def action pidf =
+  handle (defHandle def) (fmap words (readFile f) >>= action)
+  where f = "/proc" </> pidf </> "stat"
+
+maxProc :: Int
+maxProc = 5
 
 data Meminfo = MI !String !Int
 
 meminfo :: FilePath -> IO Meminfo
-meminfo pidf =
-  handle noInfo
-         (do s <- readFile $ "/proc" </> pidf </> "stat"
-             let fs = words s
-                 m = pageSize * read (fs !! 23)
-                 n = drop 1 $ init (fs !! 1)
-             evaluate $ MI n m)
-  where noInfo :: SomeException -> IO Meminfo
-        noInfo _ = evaluate $ MI "" 0
+meminfo = handlePidFile (MI "" 0) $ \fs ->
+  let m = pageSize * (read $! (fs !! 23))
+      n = drop 1 $! init (fs !! 1)
+  in evaluate $! MI n m
 
 meminfos :: IO [Meminfo]
 meminfos = do
   fs <- processes
   mapM meminfo fs
 
-sortByMem :: [Meminfo] -> [Meminfo]
-sortByMem ps = sortBy (flip (comparing rss)) ps
-  where rss (MI _ m) = m
-
 topMemProcesses :: Int -> IO [Meminfo]
-topMemProcesses n = fmap (take n . sortByMem) meminfos
+topMemProcesses n = fmap (take n . sbm) meminfos
+  where sbm = sortBy cmp
+        cmp (MI _ x) (MI _ y) = compare y x
 
 showMeminfo :: Meminfo -> Monitor [String]
 showMeminfo (MI nm rss) =
@@ -96,69 +101,57 @@ showMeminfo (MI nm rss) =
 
 runTopMem :: [String] -> Monitor String
 runTopMem _ = do
-  ps <- io $ topMemProcesses 5
+  ps <- io $ topMemProcesses maxProc
   pstr <- mapM showMeminfo ps
   parseTemplate $ concat pstr
 
-topCpuConfig :: IO MConfig
-topCpuConfig = mkMConfig
-            "<both1>"
-            [ k ++ n | n <- map show [1::Int .. 5]
-                     , k <- ["name", "cpu", "both"]]
-
 data Timeinfo = TI !String !Float
 type Times = IntMap Timeinfo
 data TimesVal = TiV !Int !String !Float
 
-cpuTime :: IO Integer
-cpuTime = do
-  h <- openFile "/proc/stat" ReadMode
-  s <- hGetLine h
-  let ts = (map read . tail . words) s
-  hClose h
-  return $! sum $! ts
-
-nullTimesVal :: TimesVal
-nullTimesVal = TiV 0 "" 0
-
 timeinfo :: FilePath -> IO TimesVal
-timeinfo pidf =
-  handle ((\_ -> evaluate nullTimesVal) :: SomeException -> IO TimesVal)
-         (do s <- readFile $ "/proc" </> pidf </> "stat"
-             let fs = words s
-                 pid = read (head fs)
-                 rf = read . (fs!!)
-                 n = drop 1 $ init (fs!!1)
-             evaluate $! TiV pid n (rf 14 + rf 15))
-
-timeinfos :: IO [(Integer, Times)]
+timeinfo = handlePidFile (TiV 0 "" 0) $ \fs ->
+  let pid = read (head fs)
+      rf = read . (fs!!)
+      n = drop 1 $ init (fs!!1)
+  in evaluate $! TiV pid n (rf 13 + rf 14)
+
+timeinfos :: IO Times
 timeinfos = do
   fs <- processes
   tis <- mapM timeinfo $! fs
-  ct <- cpuTime
-  return $! [(ct, foldl' acc M.empty tis)]
+  return $! foldl' acc M.empty tis
   where acc m (TiV p n t) = M.insert p (TI n t) m
 
 combineTimeInfos :: Times -> Times -> Times
 combineTimeInfos t0 t1 = M.intersectionWith timeDiff t1 t0
   where timeDiff (TI n x1) (TI _ x0) = TI n (x1 - x0)
 
-topTimeProcesses :: Int -> IO [Timeinfo]
-topTimeProcesses n = do
-  ((c0, t0):_, (c1, t1):_) <- doActionTwiceWithDelay 1000000 timeinfos
+type TIVar = MVar Times
+
+topTimeProcesses :: Int -> TIVar -> Float -> IO [Timeinfo]
+topTimeProcesses n tivar lapse = do
+  t0 <- readMVar tivar
+  t1 <- timeinfos
+  modifyMVar_ tivar (\_ -> return $! t1)
   let ts = M.elems $ combineTimeInfos t0 t1
-      sts = take n $ sortBy (flip (comparing tm)) (filter nzr ts)
-      nzr = (>0) . tm
-      tm (TI _ t) = t
-      lapse = fromIntegral (c1 - c0)
+      sts = take n $ sortBy cmp ts
+      cmp (TI _ x) (TI _ y) = compare y x
       norm (TI nm t) = TI nm (100 * t / lapse)
-  return $! map norm sts ++ replicate 5 (TI "" 0)
+  return $! map norm sts
 
 showTimeInfo :: Timeinfo -> Monitor [String]
-showTimeInfo (TI n t) = showInfo n (showDigits 2 t) t
-
-runTopCpu :: [String] -> Monitor String
-runTopCpu _ = do
-  ps <- io $ topTimeProcesses 5
-  pstr <- mapM showTimeInfo ps
-  parseTemplate $ concat pstr
+showTimeInfo (TI n t) = showInfo n (showDigits 1 t) t
+
+runTopCpu :: TIVar -> Float -> [String] -> Monitor String
+runTopCpu tivar lapse _ = do
+   ps <- io $ topTimeProcesses maxProc tivar lapse
+   pstr <- mapM showTimeInfo ps
+   parseTemplate $ concat pstr
+
+startTopCpu :: [String] -> Int -> (String -> IO ()) -> IO ()
+startTopCpu a r cb = do
+  t <- getSysVar ClockTick
+  tivar <- newMVar M.empty
+  let lapse = (fromIntegral r * fromIntegral t) / 10
+  runM a topCpuConfig (runTopCpu tivar lapse) r cb