ghc-events-0.2: GHC/RTS/Events.hs
{-# LANGUAGE CPP,BangPatterns,PatternGuards #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-
- Author: Donnie Jones, Simon Marlow
- Events.hs
- Parser functions for GHC RTS EventLog framework.
-}
module GHC.RTS.Events (
-- * The event log types
EventLog(..),
EventType(..),
Event(..),
EventTypeSpecificInfo(..),
ThreadStopStatus(..),
Header(..),
Data(..),
Timestamp,
ThreadId,
-- * Reading an event log from a file
readEventLogFromFile,
-- * Utilities
CapEvent(..), sortEvents, groupEvents, sortGroups,
-- * Printing
showEventTypeSpecificInfo, showThreadStopStatus
) where
{- Libraries. -}
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 synonyms. -}
type Filename = String
-- EventType.
type EventTypeNum = Word16
type EventTypeDescLen = Word32
type EventTypeDesc = String
type EventTypeSize = Word16
-- Event.
type EventDescription = String
type Timestamp = Word64
type ThreadId = Word32
type CapNo = Word16
type Marker = Word32
{-
- Data type delcarations to build the GHC RTS data format,
- which is a (header, data) pair.
-
- Header contains EventTypes.
- Data contains Events.
-}
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 -- ^ 'Nothing' indicates variable size
} deriving Show
data Event =
Event {
time :: {-# UNPACK #-}!Timestamp,
spec :: EventTypeSpecificInfo
} deriving Show
data EventTypeSpecificInfo
= Startup { n_caps :: Int
}
| EventBlock { end_time :: Timestamp,
cap :: Int,
block_events :: [Event]
}
| CreateThread { thread :: {-# UNPACK #-}!ThreadId
}
| RunThread { thread :: {-# UNPACK #-}!ThreadId
}
| StopThread { thread :: {-# UNPACK #-}!ThreadId,
status :: ThreadStopStatus
}
| ThreadRunnable { thread :: {-# UNPACK #-}!ThreadId
}
| MigrateThread { thread :: {-# UNPACK #-}!ThreadId,
newCap :: {-# UNPACK #-}!Int
}
| RunSpark { thread :: {-# UNPACK #-}!ThreadId
}
| StealSpark { thread :: {-# UNPACK #-}!ThreadId,
victimCap :: {-# UNPACK #-}!Int
}
| CreateSparkThread { sparkThread :: {-# UNPACK #-}!ThreadId
}
| WakeupThread { thread :: {-# UNPACK #-}!ThreadId,
otherCap :: {-# UNPACK #-}!Int
}
| Shutdown { }
| RequestSeqGC { }
| RequestParGC { }
| StartGC { }
| GCWork { }
| GCIdle { }
| GCDone { }
| EndGC { }
| Message { msg :: String }
| UserMessage { msg :: String }
| UnknownEvent { ref :: {-# UNPACK #-}!EventTypeNum }
deriving Show
--sync with ghc/includes/Constants.h
data ThreadStopStatus
= NoStatus
| HeapOverflow
| StackOverflow
| ThreadYielding
| ThreadBlocked
| ThreadFinished
| ForeignCall
deriving (Enum, Show)
-- reader/Get monad that passes around the event types
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
------------------------------------------------------------------------------
-- Binary instances
getEventType :: GetHeader EventType
getEventType = do
etNum <- getH
size <- getH :: GetHeader EventTypeSize
let etSize = if size == 0xffff then Nothing else Just size
-- 0xffff indicates variable-sized event
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 -- (n_caps)
c <- getE :: GetEvents CapNo
return Startup{ n_caps = fromIntegral c }
EVENT_BLOCK_MARKER -> do -- (size, end_time, cap)
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 -- (thread)
t <- getE
return CreateThread{thread=t}
EVENT_RUN_THREAD -> do -- (thread)
t <- getE
return RunThread{thread=t}
EVENT_STOP_THREAD -> do -- (thread, status)
t <- getE
s <- getE :: GetEvents Word16
return StopThread{thread=t, status= toEnum (fromIntegral s)}
EVENT_THREAD_RUNNABLE -> do -- (thread)
t <- getE
return ThreadRunnable{thread=t}
EVENT_MIGRATE_THREAD -> do -- (thread, newCap)
t <- getE
nc <- getE :: GetEvents CapNo
return MigrateThread{thread=t,newCap=fromIntegral nc}
EVENT_RUN_SPARK -> do -- (thread)
t <- getE
return RunSpark{thread=t}
EVENT_STEAL_SPARK -> do -- (thread, victimCap)
t <- getE
vc <- getE :: GetEvents CapNo
return StealSpark{thread=t,victimCap=fromIntegral vc}
EVENT_CREATE_SPARK_THREAD -> do -- (sparkThread)
st <- getE :: GetEvents ThreadId
return CreateSparkThread{sparkThread=st}
EVENT_SHUTDOWN -> return Shutdown
EVENT_THREAD_WAKEUP -> do -- (thread, other_cap)
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 -- (msg)
num <- getE :: GetEvents Word16
bytes <- replicateM (fromIntegral num) getE
return Message{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }
EVENT_USER_MSG -> do -- (msg)
num <- getE :: GetEvents Word16
bytes <- replicateM (fromIntegral num) getE
return UserMessage{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }
other -> do -- unrecognised event, just skip it
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
-- -----------------------------------------------------------------------------
-- Utilities
-- | An event annotated with the Capability that generated it, if any
data CapEvent
= CapEvent { ce_cap :: Maybe Int,
ce_event :: Event
}
sortEvents :: [Event] -> [CapEvent]
sortEvents = sortGroups . groupEvents
-- | Sort the raw event stream by time, annotating each event with the
-- capability that generated it.
sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]
sortGroups groups = mergesort' (compare `on` (time . ce_event)) $
[ [ CapEvent cap e | e <- es ]
| (cap, es) <- groups ]
-- sorting is made much faster by the way that the event stream is
-- divided into blocks of events.
-- - All events in a block belong to a particular capability
-- - The events in a block are ordered by time
-- - blocks for the same capability appear in time order in the event
-- stream and do not overlap.
--
-- So to sort the events we make one list of events for each
-- capability (basically just concat . filter), and then
-- merge the resulting lists.
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
-- There are two sources of events without a capability: events
-- in the raw stream not inside an EventBlock, and EventBlocks
-- with cap == -1. We have to merge those two streams.
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)
-----------------------------------------------------------------------------
-- Some pretty-printing support
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"