threadcounter.hs

{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import           Data.List          (intercalate, sortOn)
import           Data.Map.Strict    (Map)
import qualified Data.Map.Strict    as Map
import           GHC.RTS.Events
import           System.Environment (getArgs)


main :: IO ()
main = do
  logfile <- head <$> getArgs
  (Right (EventLog h (Data evs))) <- readEventLogFromFile logfile

  let evs' = sortOn (\Event{evTime} -> evTime) . filter (isThreadEvent . evSpec) $ evs
      threadNames = Map.fromList . concatMap tname $ evs'
      counts = tail $ scanl (\o Event{evSpec} -> threadCounter evSpec + o) 0 evs' <> repeat 0

  putStrLn "time,event,threadid,name,total"
  putStrLn $ intercalate "\n" . filter (not.null) .  map (intercalate "," . asCSV threadNames) $ zip evs' counts

    where
      threadCounter CreateThread{}                    = 1
      threadCounter StopThread{status=ThreadFinished} = -1
      threadCounter _                                 = 0

      tname (Event{evSpec=ThreadLabel{..}}) = [(thread, threadlabel)]
      tname _                               = []

      isThreadEvent CreateThread{}                    = True
      isThreadEvent StopThread{status=ThreadFinished} = True
      isThreadEvent ThreadLabel{..}                   = True
      isThreadEvent _                                 = False


      asCSV m (Event{evTime, evSpec=CreateThread{thread}},total) =
        [show evTime, "create", show thread, n m thread, show total]
      asCSV m (Event{evTime, evSpec=StopThread{thread, status=ThreadFinished}},total) =
        [show evTime, "stop", show thread, n m thread, show total]
      asCSV _ _ = []

      n m i = Map.findWithDefault "" i m