module GHC.RTS.Events (
EventLog(..),
EventType(..),
Event(..),
EventTypeSpecificInfo(..),
ThreadStopStatus(..),
Header(..),
Data(..),
Timestamp,
ThreadId,
readEventLogFromFile,
CapEvent(..), sortEvents, groupEvents, sortGroups,
showEventTypeSpecificInfo, showThreadStopStatus
) where
import Data.Word (Word16, Word32, Word64)
import Data.Binary
import Data.Binary.Get
import Control.Monad
import Data.IntMap (IntMap)
import qualified Data.IntMap as M
import Control.Monad.Reader
import Control.Monad.Error
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Function
import Data.List
import Data.Either
import Text.Printf
#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"
type Filename = String
type EventTypeNum = Word16
type EventTypeDescLen = Word32
type EventTypeDesc = String
type EventTypeSize = Word16
type EventDescription = String
type Timestamp = Word64
type ThreadId = Word32
type CapNo = Word16
type Marker = Word32
data EventLog =
EventLog {
header :: Header,
dat :: Data
} deriving Show
newtype Header = Header {
eventTypes :: [EventType]
} deriving Show
data Data = Data {
events :: [Event]
} deriving Show
data EventType =
EventType {
num :: EventTypeNum,
desc :: EventTypeDesc,
size :: Maybe EventTypeSize
} deriving Show
data Event =
Event {
time :: !Timestamp,
spec :: EventTypeSpecificInfo
} deriving Show
data EventTypeSpecificInfo
= Startup { n_caps :: Int
}
| EventBlock { end_time :: Timestamp,
cap :: Int,
block_events :: [Event]
}
| CreateThread { thread :: !ThreadId
}
| RunThread { thread :: !ThreadId
}
| StopThread { thread :: !ThreadId,
status :: ThreadStopStatus
}
| ThreadRunnable { thread :: !ThreadId
}
| MigrateThread { thread :: !ThreadId,
newCap :: !Int
}
| RunSpark { thread :: !ThreadId
}
| StealSpark { thread :: !ThreadId,
victimCap :: !Int
}
| CreateSparkThread { sparkThread :: !ThreadId
}
| WakeupThread { thread :: !ThreadId,
otherCap :: !Int
}
| Shutdown { }
| RequestSeqGC { }
| RequestParGC { }
| StartGC { }
| GCWork { }
| GCIdle { }
| GCDone { }
| EndGC { }
| Message { msg :: String }
| UserMessage { msg :: String }
| UnknownEvent { ref :: !EventTypeNum }
deriving Show
data ThreadStopStatus
= NoStatus
| HeapOverflow
| StackOverflow
| ThreadYielding
| ThreadBlocked
| ThreadFinished
| ForeignCall
deriving (Enum, Show)
type GetEvents a = ReaderT (IntMap EventType) (ErrorT String Get) a
type GetHeader a = ErrorT String Get a
getH :: Binary a => GetHeader a
getH = lift get
getE :: Binary a => GetEvents a
getE = lift $ lift get
getEventType :: GetHeader EventType
getEventType = do
etNum <- getH
size <- getH :: GetHeader EventTypeSize
let etSize = if size == 0xffff then Nothing else Just size
etDescLen <- getH :: GetHeader EventTypeDescLen
etDesc <- getEtDesc (fromIntegral etDescLen)
etExtraLen <- getH :: GetHeader Word32
_skip <- replicateM_ (fromIntegral etExtraLen) (lift getWord8)
ete <- getH :: GetHeader Marker
when (ete /= EVENT_ET_END) $
throwError ("Event Type end marker not found.")
return (EventType etNum etDesc etSize)
where
getEtDesc :: Int -> GetHeader [Char]
getEtDesc s = replicateM s (getH :: GetHeader Char)
getHeader :: GetHeader Header
getHeader = do
hdrb <- getH :: GetHeader Marker
when (hdrb /= EVENT_HEADER_BEGIN) $
throwError "Header begin marker not found"
hetm <- getH :: GetHeader Marker
when (hetm /= EVENT_HET_BEGIN) $
throwError "Header Event Type begin marker not found"
ets <- getEventTypes
emark <- getH :: GetHeader Marker
when (emark /= EVENT_HEADER_END) $
throwError "Header end marker not found"
return (Header ets)
where
getEventTypes :: GetHeader [EventType]
getEventTypes = do
m <- getH :: GetHeader Marker
case () of
_ | m == EVENT_ET_BEGIN -> do
et <- getEventType
nextET <- getEventTypes
return (et : nextET)
| m == EVENT_HET_END ->
return []
| otherwise ->
throwError "Malformed list of Event Types in header"
getEvent :: GetEvents (Maybe Event)
getEvent = do
etRef <- getE
if (etRef == EVENT_DATA_END)
then return Nothing
else do !ts <- getE
spec <- getEvSpecInfo etRef
return (Just (Event ts spec))
getEvSpecInfo :: EventTypeNum -> GetEvents EventTypeSpecificInfo
getEvSpecInfo num = case fromIntegral num :: Int of
EVENT_STARTUP -> do
c <- getE :: GetEvents CapNo
return Startup{ n_caps = fromIntegral c }
EVENT_BLOCK_MARKER -> do
block_size <- getE :: GetEvents Word32
end_time <- getE :: GetEvents Timestamp
c <- getE :: GetEvents CapNo
lbs <- lift . lift $ getLazyByteString (fromIntegral block_size 24)
etypemap <- ask
let e_events = runGet (runErrorT $ runReaderT getEventBlock etypemap) lbs
return EventBlock{ end_time=end_time,
cap= fromIntegral c,
block_events=case e_events of
Left s -> error s
Right es -> es }
EVENT_CREATE_THREAD -> do
t <- getE
return CreateThread{thread=t}
EVENT_RUN_THREAD -> do
t <- getE
return RunThread{thread=t}
EVENT_STOP_THREAD -> do
t <- getE
s <- getE :: GetEvents Word16
return StopThread{thread=t, status= toEnum (fromIntegral s)}
EVENT_THREAD_RUNNABLE -> do
t <- getE
return ThreadRunnable{thread=t}
EVENT_MIGRATE_THREAD -> do
t <- getE
nc <- getE :: GetEvents CapNo
return MigrateThread{thread=t,newCap=fromIntegral nc}
EVENT_RUN_SPARK -> do
t <- getE
return RunSpark{thread=t}
EVENT_STEAL_SPARK -> do
t <- getE
vc <- getE :: GetEvents CapNo
return StealSpark{thread=t,victimCap=fromIntegral vc}
EVENT_CREATE_SPARK_THREAD -> do
st <- getE :: GetEvents ThreadId
return CreateSparkThread{sparkThread=st}
EVENT_SHUTDOWN -> return Shutdown
EVENT_THREAD_WAKEUP -> do
t <- getE
oc <- getE :: GetEvents CapNo
return WakeupThread{thread=t,otherCap=fromIntegral oc}
EVENT_REQUEST_SEQ_GC -> return RequestSeqGC
EVENT_REQUEST_PAR_GC -> return RequestParGC
EVENT_GC_START -> return StartGC
EVENT_GC_WORK -> return GCWork
EVENT_GC_IDLE -> return GCIdle
EVENT_GC_DONE -> return GCDone
EVENT_GC_END -> return EndGC
EVENT_LOG_MSG -> do
num <- getE :: GetEvents Word16
bytes <- replicateM (fromIntegral num) getE
return Message{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }
EVENT_USER_MSG -> do
num <- getE :: GetEvents Word16
bytes <- replicateM (fromIntegral num) getE
return UserMessage{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }
other -> do
etypes <- ask
case M.lookup (fromIntegral other) etypes of
Nothing -> throwError ("getEvSpecInfo: undeclared event type: " ++ show other)
Just t -> do
bytes <- case size t of
Just n -> return n
Nothing -> getE :: GetEvents Word16
skip <- lift . lift $ replicateM_ (fromIntegral bytes) getWord8
return UnknownEvent{ ref = num }
getData :: GetEvents Data
getData = do
db <- getE :: GetEvents Marker
when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found"
getEvents []
where
getEvents :: [Event] -> GetEvents Data
getEvents events = do
mb_e <- getEvent
case mb_e of
Nothing -> return (Data (reverse events))
Just e -> getEvents (e:events)
getEventBlock :: GetEvents [Event]
getEventBlock = do
b <- lift . lift $ isEmpty
if b then return [] else do
mb_e <- getEvent
case mb_e of
Nothing -> return []
Just e -> do
es <- getEventBlock
return (e:es)
getEventLog :: ErrorT String Get EventLog
getEventLog = do
header <- getHeader
let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]
dat <- runReaderT getData imap
return (EventLog header dat)
readEventLogFromFile :: FilePath -> IO (Either String EventLog)
readEventLogFromFile f = do
s <- L.readFile f
return $ runGet (do v <- runErrorT $ getEventLog
m <- isEmpty
m `seq` return v) s
data CapEvent
= CapEvent { ce_cap :: Maybe Int,
ce_event :: Event
}
sortEvents :: [Event] -> [CapEvent]
sortEvents = sortGroups . groupEvents
sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]
sortGroups groups = mergesort' (compare `on` (time . ce_event)) $
[ [ CapEvent cap e | e <- es ]
| (cap, es) <- groups ]
groupEvents :: [Event] -> [(Maybe Int, [Event])]
groupEvents es = (Nothing, n_events) :
[ (Just (cap (head blocks)), concatMap block_events blocks)
| blocks <- groups ]
where
(blocks, anon_events) = partitionEithers (map separate es)
where separate e | b@EventBlock{} <- spec e = Left b
| otherwise = Right e
(cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks
where is_cap c = fromIntegral c /= ((1) :: Word16)
groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks
n_events = merge (compare `on` time) anon_events
(concatMap block_events gbl_blocks)
mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
mergesort' _ [] = []
mergesort' _ [xs] = xs
mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)
merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
merge_pairs _ [] = []
merge_pairs _ [xs] = [xs]
merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss
merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
merge _ [] ys = ys
merge _ xs [] = xs
merge cmp (x:xs) (y:ys)
= case x `cmp` y of
GT -> y : merge cmp (x:xs) ys
_ -> x : merge cmp xs (y:ys)
showEventTypeSpecificInfo :: EventTypeSpecificInfo -> String
showEventTypeSpecificInfo spec =
case spec of
Startup n_caps ->
printf "startup: %d capabilities" n_caps
EventBlock end_time cap _block_events ->
printf "event block: cap %d, end time: %d\n" cap end_time
CreateThread thread ->
printf "creating thread %d" thread
RunThread thread ->
printf "running thread %d" thread
StopThread thread status ->
printf "stopping thread %d (%s)" thread (showThreadStopStatus status)
ThreadRunnable thread ->
printf "thread %d is runnable" thread
MigrateThread thread newCap ->
printf "migrating thread %d to cap %d" thread newCap
RunSpark thread ->
printf "running a local spark (thread %d)" thread
StealSpark thread victimCap ->
printf "thread %d stealing a spark from cap %d" thread victimCap
CreateSparkThread sparkThread ->
printf "creating spark thread %d" sparkThread
Shutdown ->
printf "shutting down"
WakeupThread thread otherCap ->
printf "waking up thread %d on cap %d" thread otherCap
RequestSeqGC ->
printf "requesting sequential GC"
RequestParGC ->
printf "requesting parallel GC"
StartGC ->
printf "starting GC"
EndGC ->
printf "finished GC"
GCWork ->
printf "GC working"
GCIdle ->
printf "GC idle"
GCDone ->
printf "GC done"
_ ->
printf "unknown event type"
showThreadStopStatus :: ThreadStopStatus -> String
showThreadStopStatus HeapOverflow = "heap overflow"
showThreadStopStatus StackOverflow = "stack overflow"
showThreadStopStatus ThreadYielding = "thread yielding"
showThreadStopStatus ThreadBlocked = "thread blocked"
showThreadStopStatus ThreadFinished = "thread finished"
showThreadStopStatus ForeignCall = "making a foreign call"