diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Donnie Jones +Simon Marlow diff --git a/GHC/RTS/EventLogFormat.h b/GHC/RTS/EventLogFormat.h --- a/GHC/RTS/EventLogFormat.h +++ b/GHC/RTS/EventLogFormat.h @@ -101,18 +101,18 @@ */ #define EVENT_CREATE_THREAD 0 /* (thread) */ #define EVENT_RUN_THREAD 1 /* (thread) */ -#define EVENT_STOP_THREAD 2 /* (thread, status) */ +#define EVENT_STOP_THREAD 2 /* (thread, status, blockinfo) */ #define EVENT_THREAD_RUNNABLE 3 /* (thread) */ #define EVENT_MIGRATE_THREAD 4 /* (thread, new_cap) */ -#define EVENT_RUN_SPARK 5 /* (thread) */ -#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ +/* 5, 6 deprecated */ #define EVENT_SHUTDOWN 7 /* () */ #define EVENT_THREAD_WAKEUP 8 /* (thread, other_cap) */ #define EVENT_GC_START 9 /* () */ #define EVENT_GC_END 10 /* () */ #define EVENT_REQUEST_SEQ_GC 11 /* () */ #define EVENT_REQUEST_PAR_GC 12 /* () */ -#define EVENT_CREATE_SPARK_THREAD 15 /* (thread, spark_thread) */ +/* 13, 14 deprecated */ +#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */ #define EVENT_LOG_MSG 16 /* (message ...) */ #define EVENT_STARTUP 17 /* (num_capabilities) */ #define EVENT_BLOCK_MARKER 18 /* (size, end_time, capability) */ @@ -120,15 +120,86 @@ #define EVENT_GC_IDLE 20 /* () */ #define EVENT_GC_WORK 21 /* () */ #define EVENT_GC_DONE 22 /* () */ +/* 23, 24 used by eden */ +#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */ +#define EVENT_CAPSET_DELETE 26 /* (capset) */ +#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */ +#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */ +/* the RTS identifier is in the form of "GHC-version rts_way" */ +#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */ +/* the vectors in these events are null separated strings */ +#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */ +#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */ +#define EVENT_OSPROCESS_PID 32 /* (capset, pid) */ +#define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */ +#define EVENT_SPARK_COUNTERS 34 /* (crt,dud,ovf,cnv,fiz,gcd,rem) */ +#define EVENT_SPARK_CREATE 35 /* () */ +#define EVENT_SPARK_DUD 36 /* () */ +#define EVENT_SPARK_OVERFLOW 37 /* () */ +#define EVENT_SPARK_RUN 38 /* () */ +#define EVENT_SPARK_STEAL 39 /* (victim_cap) */ +#define EVENT_SPARK_FIZZLE 40 /* () */ +#define EVENT_SPARK_GC 41 /* () */ +#define EVENT_INTERN_STRING 42 /* (string, id) */ -#define NUM_EVENT_TAGS 23 -#if 0 /* DEPRECATED EVENTS: */ +/* Range 43 - 59 is available for new GHC and common events */ + +/* Range 60 - 80 is used by eden for parallel tracing + * see http://www.mathematik.uni-marburg.de/~eden/ + */ + +/* Range 100 - 139 is reserved for Mercury, see below. */ + +/* + * The highest event code +1 that ghc itself emits. Note that some event + * ranges higher than this are reserved but not currently emitted by ghc. + * This must match the size of the EventDesc[] array in EventLog.c + */ +#define NUM_GHC_EVENT_TAGS 42 + + +/* DEPRECATED EVENTS: */ +/* These two are deprecated because we don't need to record the thread, it's + implicit. We have to keep these #defines because for tiresome reasons we + still need to parse them, see GHC.RTS.Events.ghc6Parsers for details. */ +#define EVENT_RUN_SPARK 5 /* (thread) */ +#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ +#if 0 +/* ghc changed how it handles sparks so these are no longer applicable */ #define EVENT_CREATE_SPARK 13 /* (cap, thread) */ #define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */ +/* these are used by eden but are replaced by new alternatives for ghc */ +#define EVENT_VERSION 23 /* (version_string) */ +#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */ #endif + /* + * These event types are Mercury specific, Mercury may use up to event number + * 139 + */ +#define EVENT_FIRST_MER_EVENT 100 +#define NUM_MER_EVENTS 14 + +#define EVENT_MER_START_PAR_CONJUNCTION 100 /* (dyn id, static id) */ +#define EVENT_MER_STOP_PAR_CONJUNCTION 101 /* (dyn id) */ +#define EVENT_MER_STOP_PAR_CONJUNCT 102 /* (dyn id) */ +#define EVENT_MER_CREATE_SPARK 103 /* (dyn id, spark id) */ +#define EVENT_MER_FUT_CREATE 104 /* (fut id, memo'd name id) */ +#define EVENT_MER_FUT_WAIT_NOSUSPEND 105 /* (fut id) */ +#define EVENT_MER_FUT_WAIT_SUSPENDED 106 /* (fut id) */ +#define EVENT_MER_FUT_SIGNAL 107 /* (fut id) */ +#define EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT \ + 108 /* () */ +#define EVENT_MER_WORK_STEALING 109 /* () */ +#define EVENT_MER_LOOKING_FOR_LOCAL_SPARK \ + 112 /* () */ +#define EVENT_MER_RELEASE_CONTEXT 110 /* (context id) */ +#define EVENT_MER_ENGINE_SLEEPING 111 /* () */ +#define EVENT_MER_CALLING_MAIN 113 /* () */ + +/* * Status values for EVENT_STOP_THREAD * * 1-5 are the StgRun return values (from includes/Constants.h): @@ -138,16 +209,37 @@ * #define ThreadYielding 3 * #define ThreadBlocked 4 * #define ThreadFinished 5 + * #define ForeignCall 6 + * #define BlockedOnMVar 7 + * #define BlockedOnBlackHole 8 + * #define BlockedOnRead 9 + * #define BlockedOnWrite 10 + * #define BlockedOnDelay 11 + * #define BlockedOnSTM 12 + * #define BlockedOnDoProc 13 + * #define BlockedOnCCall -- not used (see ForeignCall) + * #define BlockedOnCCall_NoUnblockExc -- not used (see ForeignCall) + * #define BlockedOnMsgThrowTo 16 */ #define THREAD_SUSPENDED_FOREIGN_CALL 6 +/* + * Capset type values for EVENT_CAPSET_CREATE + */ +#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */ +#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */ +#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */ + #ifndef EVENTLOG_CONSTANTS_ONLY typedef StgWord16 EventTypeNum; -typedef StgWord64 EventTimestamp; // in nanoseconds -typedef StgWord64 EventThreadID; +typedef StgWord64 EventTimestamp; /* in nanoseconds */ +typedef StgWord32 EventThreadID; typedef StgWord16 EventCapNo; -typedef StgWord16 EventPayloadSize; // variable-size events +typedef StgWord16 EventPayloadSize; /* variable-size events */ +typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */ +typedef StgWord32 EventCapsetID; +typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */ #endif diff --git a/GHC/RTS/EventParserUtils.hs b/GHC/RTS/EventParserUtils.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/EventParserUtils.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE CPP, PatternGuards #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module GHC.RTS.EventParserUtils ( + EventParser(..), + EventParsers(..), + GetEvents, + GetHeader, + + getE, + getH, + getString, + mkEventTypeParsers, + simpleEvent, + skip, + ) where + +import Control.Monad +import Control.Monad.Error +import Control.Monad.Reader +import Data.Array +import Data.Binary +import Data.Binary.Get hiding (skip) +import qualified Data.Binary.Get as G +import Data.Binary.Put +import Data.Char +import Data.Function +import Data.IntMap (IntMap) +import qualified Data.IntMap as M +import Data.List + +#define EVENTLOG_CONSTANTS_ONLY +#include "EventLogFormat.h" + +import GHC.RTS.EventTypes + +-- reader/Get monad that passes around the event types +type GetEvents a = ReaderT EventParsers (ErrorT String Get) a + +newtype EventParsers = EventParsers (Array Int (GetEvents EventInfo)) + +type GetHeader a = ErrorT String Get a + +getH :: Binary a => GetHeader a +getH = lift get + +getE :: Binary a => GetEvents a +getE = lift $ lift get + +nBytes :: Integral a => a -> GetEvents [Word8] +nBytes n = replicateM (fromIntegral n) getE + +getString :: Integral a => a -> GetEvents String +getString len = do + bytes <- nBytes len + return $ map (chr . fromIntegral) bytes + +skip :: Integral a => a -> GetEvents () +skip n = lift $ lift $ G.skip (fromIntegral n) + +-- +-- Code to build the event parser table. +-- + +-- +-- Event parser data. Parsers are either fixed or vairable size. +-- +data EventParser a + = FixedSizeParser { + fsp_type :: Int, + fsp_size :: EventTypeSize, + fsp_parser :: GetEvents a + } + | VariableSizeParser { + vsp_type :: Int, + vsp_parser :: GetEvents a + } + +get_parser (FixedSizeParser _ _ p) = p +get_parser (VariableSizeParser _ p) = p + +get_type (FixedSizeParser t _ _) = t +get_type (VariableSizeParser t _) = t + +isFixedSize (FixedSizeParser {}) = True +isFixedSize (VariableSizeParser {}) = False + +simpleEvent :: Int -> a -> EventParser a +simpleEvent t p = FixedSizeParser t 0 (return p) + +-- Our event log format allows new fields to be added to events over +-- time. This means that our parser must be able to handle: +-- +-- * old versions of an event, with fewer fields than expected, +-- * new versions of an event, with more fields than expected +-- +-- The event log file declares the size for each event type, so we can +-- select the correct parser for the event type based on its size. We +-- do this once after parsing the header: given the EventTypes, we build +-- an array of event parsers indexed by event type. +-- +-- For each event type, we may have multiple parsers for different +-- versions of the event, indexed by size. These are listed in the +-- eventTypeParsers list below. For the given log file we select the +-- parser for the most recent version (largest size less than the size +-- declared in the header). If this is a newer version of the event +-- than we understand, there may be extra bytes that we have to read +-- and discard in the parser for this event type. +-- +-- Summary: +-- if size is smaller that we expect: +-- parse the earier version, or ignore the event +-- if size is just right: +-- parse it +-- if size is too big: +-- parse the bits we understand and discard the rest + +mkEventTypeParsers :: IntMap EventType + -> [EventParser EventInfo] + -> Array Int (GetEvents EventInfo) +mkEventTypeParsers etypes event_parsers + = accumArray (flip const) undefined (0, max_event_num) + [ (num, parser num) | num <- [0..max_event_num] ] + --([ (num, undeclared_etype num) | num <- [0..max_event_num] ] ++ + -- [ (num, parser num etype) | (num, etype) <- M.toList etypes ]) + where + max_event_num = maximum (M.keys etypes) + undeclared_etype num = throwError ("undeclared event type: " ++ show num) + parser_map = makeParserMap event_parsers + parser num = + -- Get the event's size from the header, + -- the first Maybe describes whether the event was declared in the header. + -- the second Maybe selects between variable and fixed size events. + let mb_mb_et_size = do et <- M.lookup num etypes + return $ size et + -- Find a parser for the event with the given size. + maybe_parser mb_et_size = do possible <- M.lookup num parser_map + best_parser <- case mb_et_size of + Nothing -> getVariableParser possible + Just et_size -> getFixedParser et_size possible + return $ get_parser best_parser + in case mb_mb_et_size of + -- This event is declared in the log file's header + Just mb_et_size -> case maybe_parser mb_et_size of + -- And we have a valid parser for it. + Just p -> p + -- But we don't have a valid parser for it. + Nothing -> noEventTypeParser num mb_et_size + -- This event is not declared in the log file's header + Nothing -> undeclared_etype num + +-- Find the first variable length parser. +getVariableParser :: [EventParser a] -> Maybe (EventParser a) +getVariableParser [] = Nothing +getVariableParser (x:xs) = case x of + FixedSizeParser _ _ _ -> getVariableParser xs + VariableSizeParser _ _ -> Just x + +-- Find the best fixed size parser, that is to say, the parser for the largest +-- event that does not exceed the size of the event as declared in the log +-- file's header. +getFixedParser :: EventTypeSize -> [EventParser a] -> Maybe (EventParser a) +getFixedParser size parsers = + do parser <- ((filter isFixedSize) `pipe` + (filter (\x -> (fsp_size x) <= size)) `pipe` + (sortBy descending_size) `pipe` + maybe_head) parsers + return $ padParser size parser + where pipe f g = g . f + descending_size (FixedSizeParser _ s1 _) (FixedSizeParser _ s2 _) = + compare s2 s1 + descending_size _ _ = undefined + maybe_head [] = Nothing + maybe_head (x:xs) = Just x + +padParser :: EventTypeSize -> (EventParser a) -> (EventParser a) +padParser size (VariableSizeParser t p) = VariableSizeParser t p +padParser size (FixedSizeParser t orig_size orig_p) = FixedSizeParser t size p + where p = if (size == orig_size) + then orig_p + else do d <- orig_p + skip (size - orig_size) + return d + +makeParserMap :: [EventParser a] -> IntMap [EventParser a] +makeParserMap = foldl buildParserMap M.empty + where buildParserMap map parser = M.alter (addParser parser) (get_type parser) map + addParser p Nothing = Just [p] + addParser p (Just ps) = Just (p:ps) + +noEventTypeParser :: Int -> Maybe EventTypeSize + -> GetEvents EventInfo +noEventTypeParser num mb_size = do + bytes <- case mb_size of + Just n -> return n + Nothing -> getE :: GetEvents Word16 + skip bytes + return UnknownEvent{ ref = fromIntegral num } + diff --git a/GHC/RTS/EventTypes.hs b/GHC/RTS/EventTypes.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/EventTypes.hs @@ -0,0 +1,303 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module GHC.RTS.EventTypes where + +import Data.Word (Word16, Word32, Word64) + +-- 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 +type BlockSize = Word32 +type RawThreadStopStatus = Word16 +type StringId = Word32 + +-- These types are used by Mercury events. +type ParConjDynId = Word64 +type ParConjStaticId = StringId +type SparkId = Word32 +type FutureId = Word64 + +sz_event_type_num :: EventTypeSize +sz_event_type_num = 2 +sz_cap :: EventTypeSize +sz_cap = 2 +sz_time :: EventTypeSize +sz_time = 8 +sz_tid :: EventTypeSize +sz_tid = 4 +sz_old_tid :: EventTypeSize +sz_old_tid = 8 -- GHC 6.12 was using 8 for ThreadID when declaring the size + -- of events, but was actually using 32 bits for ThreadIDs +sz_capset :: EventTypeSize +sz_capset = 4 +sz_capset_type :: EventTypeSize +sz_capset_type = 2 +sz_block_size :: EventTypeSize +sz_block_size = 4 +sz_block_event :: EventTypeSize +sz_block_event = fromIntegral (sz_event_type_num + sz_time + sz_block_size + + sz_time + sz_cap) +sz_pid :: EventTypeSize +sz_pid = 4 +sz_th_stop_status :: EventTypeSize +sz_th_stop_status = 2 +sz_string_id :: EventTypeSize +sz_string_id = 4 + +-- Sizes for Mercury event fields. +sz_par_conj_dyn_id :: EventTypeSize +sz_par_conj_dyn_id = 8 +sz_par_conj_static_id :: EventTypeSize +sz_par_conj_static_id = sz_string_id +sz_spark_id :: EventTypeSize +sz_spark_id = 4 +sz_future_id :: EventTypeSize +sz_future_id = 8 + +{- + - 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, Eq) + +data Data = Data { + events :: [Event] + } deriving Show + +data EventType = + EventType { + num :: EventTypeNum, + desc :: EventTypeDesc, + size :: Maybe EventTypeSize -- ^ 'Nothing' indicates variable size + } deriving (Show, Eq) + +data Event = + Event { + time :: {-# UNPACK #-}!Timestamp, + spec :: EventInfo + } deriving Show + +data EventInfo + + -- pseudo events + = EventBlock { end_time :: Timestamp, + cap :: Int, + block_events :: [Event] + } + | UnknownEvent { ref :: {-# UNPACK #-}!EventTypeNum } + + -- init and shutdown + | Startup { n_caps :: Int + } + | Shutdown { } + + -- thread scheduling + | 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 + } + | WakeupThread { thread :: {-# UNPACK #-}!ThreadId, + otherCap :: {-# UNPACK #-}!Int + } + + -- par sparks + | CreateSparkThread { sparkThread :: {-# UNPACK #-}!ThreadId + } + | SparkCounters { sparksCreated, sparksDud, sparksOverflowed, + sparksConverted, sparksFizzled, sparksGCd, + sparksRemaining :: {-# UNPACK #-}! Word64 + } + | SparkCreate { } + | SparkDud { } + | SparkOverflow { } + | SparkRun { } + | SparkSteal { victimCap :: {-# UNPACK #-}!Int } + | SparkFizzle { } + | SparkGC { } + + -- garbage collection + | RequestSeqGC { } + | RequestParGC { } + | StartGC { } + | GCWork { } + | GCIdle { } + | GCDone { } + | EndGC { } + + -- capability sets + | CapsetCreate { capset :: {-# UNPACK #-}!Word32 + , capsetType :: CapsetType + } + | CapsetDelete { capset :: {-# UNPACK #-}!Word32 + } + | CapsetAssignCap { capset :: {-# UNPACK #-}!Word32 + , cap :: {-# UNPACK #-}!Int + } + | CapsetRemoveCap { capset :: {-# UNPACK #-}!Word32 + , cap :: {-# UNPACK #-}!Int + } + + -- program/process info + | RtsIdentifier { capset :: {-# UNPACK #-}!Word32 + , rtsident :: String + } + | ProgramArgs { capset :: {-# UNPACK #-}!Word32 + , args :: [String] + } + | ProgramEnv { capset :: {-# UNPACK #-}!Word32 + , env :: [String] + } + | OsProcessPid { capset :: {-# UNPACK #-}!Word32 + , pid :: {-# UNPACK #-}!Word32 + } + | OsProcessParentPid { capset :: {-# UNPACK #-}!Word32 + , ppid :: {-# UNPACK #-}!Word32 + } + + -- messages + | Message { msg :: String } + | UserMessage { msg :: String } + + -- These events have been added for Mercury's benifit but are generally + -- useful. + | InternString { str :: String, id :: {-# UNPACK #-}!StringId } + + -- Mercury specific events. + | MerStartParConjunction { + dyn_id :: {-# UNPACK #-}!ParConjDynId, + static_id :: {-# UNPACK #-}!ParConjStaticId + } + | MerEndParConjunction { + dyn_id :: {-# UNPACK #-}!ParConjDynId + } + | MerEndParConjunct { + dyn_id :: {-# UNPACK #-}!ParConjDynId + } + | MerCreateSpark { + dyn_id :: {-# UNPACK #-}!ParConjDynId, + spark_id :: {-# UNPACK #-}!SparkId + } + | MerFutureCreate { + future_id :: {-# UNPACK #-}!FutureId, + name_id :: {-# UNPACK #-}!StringId + } + | MerFutureWaitNosuspend { + future_id :: {-# UNPACK #-}!FutureId + } + | MerFutureWaitSuspended { + future_id :: {-# UNPACK #-}!FutureId + } + | MerFutureSignal { + future_id :: {-# UNPACK #-}!FutureId + } + | MerLookingForGlobalThread + | MerWorkStealing + | MerLookingForLocalSpark + | MerReleaseThread { + thread_id :: {-# UNPACK #-}!ThreadId + } + | MerCapSleeping + | MerCallingMain + + deriving Show + +--sync with ghc/includes/Constants.h +data ThreadStopStatus + = NoStatus + | HeapOverflow + | StackOverflow + | ThreadYielding + | ThreadBlocked + | ThreadFinished + | ForeignCall + | BlockedOnMVar + | BlockedOnBlackHole + | BlockedOnRead + | BlockedOnWrite + | BlockedOnDelay + | BlockedOnSTM + | BlockedOnDoProc + | BlockedOnCCall + | BlockedOnCCall_NoUnblockExc + | BlockedOnMsgThrowTo + | ThreadMigrating + | BlockedOnMsgGlobalise + | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId + deriving (Show) + +mkStopStatus :: RawThreadStopStatus -> ThreadStopStatus +mkStopStatus n = case n of + 0 -> NoStatus + 1 -> HeapOverflow + 2 -> StackOverflow + 3 -> ThreadYielding + 4 -> ThreadBlocked + 5 -> ThreadFinished + 6 -> ForeignCall + 7 -> BlockedOnMVar + 8 -> BlockedOnBlackHole + 9 -> BlockedOnRead + 10 -> BlockedOnWrite + 11 -> BlockedOnDelay + 12 -> BlockedOnSTM + 13 -> BlockedOnDoProc + 14 -> BlockedOnCCall + 15 -> BlockedOnCCall_NoUnblockExc + 16 -> BlockedOnMsgThrowTo + 17 -> ThreadMigrating + 18 -> BlockedOnMsgGlobalise + _ -> error "mkStat" + +maxThreadStopStatus :: RawThreadStopStatus +maxThreadStopStatus = 18 + +data CapsetType + = CapsetCustom + | CapsetOsProcess + | CapsetClockDomain + | CapsetUnknown + deriving Show + +mkCapsetType :: Word16 -> CapsetType +mkCapsetType n = case n of + 1 -> CapsetCustom + 2 -> CapsetOsProcess + 3 -> CapsetClockDomain + _ -> CapsetUnknown + +-- | An event annotated with the Capability that generated it, if any +data CapEvent + = CapEvent { ce_cap :: Maybe Int, + ce_event :: Event + -- we could UNPACK ce_event, but the Event constructor + -- might be shared, in which case we could end up + -- increasing the space usage. + } + diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs --- a/GHC/RTS/Events.hs +++ b/GHC/RTS/Events.hs @@ -1,477 +1,1076 @@ {-# 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 - -- we could UNPACK ce_event, but the Event constructor - -- might be shared, in which case we could end up - -- increasing the space usage. - } - -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" +{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-} +{- + - Authors: Donnie Jones, Simon Marlow, Paul Bone, Duncan Coutts + - Events.hs + - Parser functions for GHC RTS EventLog framework. + -} + +module GHC.RTS.Events ( + -- * The event log types + EventLog(..), + EventType(..), + Event(..), + EventInfo(..), + ThreadStopStatus(..), + Header(..), + Data(..), + CapsetType(..), + Timestamp, + ThreadId, + + -- * Reading and writing event logs + readEventLogFromFile, + writeEventLogToFile, + + -- * Utilities + CapEvent(..), sortEvents, groupEvents, sortGroups, + buildEventTypeMap, + + -- * Printing + showEventInfo, showThreadStopStatus, + ppEventLog, ppEventType, ppEvent + ) where + +{- Libraries. -} +import Data.Binary +import Data.Binary.Get hiding (skip) +import qualified Data.Binary.Get as G +import Data.Binary.Put +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.Function +import Data.List +import Data.Either +import Data.Maybe +import Text.Printf +import Data.Array + +import GHC.RTS.EventTypes +import GHC.RTS.EventParserUtils + +#define EVENTLOG_CONSTANTS_ONLY +#include "EventLogFormat.h" + +------------------------------------------------------------------------------ +-- 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 + lift $ G.skip (fromIntegral etExtraLen) + 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 :: EventParsers -> GetEvents (Maybe Event) +getEvent (EventParsers parsers) = do + etRef <- getE :: GetEvents EventTypeNum + if (etRef == EVENT_DATA_END) + then return Nothing + else do !ts <- getE + -- trace ("event: " ++ show etRef) $ do + spec <- parsers ! fromIntegral etRef + return (Just (Event ts spec)) + +-- +-- standardEventParsers. +-- +standardParsers :: [EventParser EventInfo] +standardParsers = [ + (FixedSizeParser EVENT_STARTUP sz_cap (do -- (n_caps) + c <- getE :: GetEvents CapNo + return Startup{ n_caps = fromIntegral c } + )), + + (FixedSizeParser EVENT_BLOCK_MARKER (sz_block_size + sz_time + sz_cap) (do -- (size, end_time, cap) + block_size <- getE :: GetEvents BlockSize + end_time <- getE :: GetEvents Timestamp + c <- getE :: GetEvents CapNo + lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) - + (fromIntegral sz_block_event)) + eparsers <- ask + let e_events = runGet (runErrorT $ runReaderT (getEventBlock eparsers) eparsers) lbs + return EventBlock{ end_time=end_time, + cap= fromIntegral c, + block_events=case e_events of + Left s -> error s + Right es -> es } + )), + + (simpleEvent EVENT_SHUTDOWN Shutdown), + + (simpleEvent EVENT_REQUEST_SEQ_GC RequestSeqGC), + + (simpleEvent EVENT_REQUEST_PAR_GC RequestParGC), + + (simpleEvent EVENT_GC_START StartGC), + + (simpleEvent EVENT_GC_WORK GCWork), + + (simpleEvent EVENT_GC_IDLE GCIdle), + + (simpleEvent EVENT_GC_DONE GCDone), + + (simpleEvent EVENT_GC_END EndGC), + + (FixedSizeParser EVENT_CAPSET_CREATE (sz_capset + sz_capset_type) (do -- (capset, capset_type) + cs <- getE + ct <- fmap mkCapsetType getE + return CapsetCreate{capset=cs,capsetType=ct} + )), + + (FixedSizeParser EVENT_CAPSET_DELETE sz_capset (do -- (capset) + cs <- getE + return CapsetDelete{capset=cs} + )), + + (FixedSizeParser EVENT_CAPSET_ASSIGN_CAP (sz_capset + sz_cap) (do -- (capset, cap) + cs <- getE + cp <- getE :: GetEvents CapNo + return CapsetAssignCap{capset=cs,cap=fromIntegral cp} + )), + + (FixedSizeParser EVENT_CAPSET_REMOVE_CAP (sz_capset + sz_cap) (do -- (capset, cap) + cs <- getE + cp <- getE :: GetEvents CapNo + return CapsetRemoveCap{capset=cs,cap=fromIntegral cp} + )), + + (FixedSizeParser EVENT_OSPROCESS_PID (sz_capset + sz_pid) (do -- (capset, pid) + cs <- getE + pd <- getE + return OsProcessPid{capset=cs,pid=pd} + )), + + (FixedSizeParser EVENT_OSPROCESS_PPID (sz_capset + sz_pid) (do -- (capset, ppid) + cs <- getE + pd <- getE + return OsProcessParentPid{capset=cs,ppid=pd} + )), + + (VariableSizeParser EVENT_LOG_MSG (do -- (msg) + num <- getE :: GetEvents Word16 + string <- getString num + return Message{ msg = string } + )), + (VariableSizeParser EVENT_USER_MSG (do -- (msg) + num <- getE :: GetEvents Word16 + string <- getString num + return UserMessage{ msg = string } + )), + (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg]) + num <- getE :: GetEvents Word16 + cs <- getE + string <- getString (num - sz_capset) + return ProgramArgs{ capset = cs + , args = splitNull string } + )), + (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg]) + num <- getE :: GetEvents Word16 + cs <- getE + string <- getString (num - sz_capset) + return ProgramEnv{ capset = cs + , env = splitNull string } + )), + (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str) + num <- getE :: GetEvents Word16 + cs <- getE + string <- getString (num - sz_capset) + return RtsIdentifier{ capset = cs + , rtsident = string } + )), + + (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id) + num <- getE :: GetEvents Word16 + string <- getString (num - sz_string_id) + id <- getE :: GetEvents StringId + return (InternString string id) + )) + ] + +-- Parsers valid for GHC7 but not GHC6. +ghc7Parsers :: [EventParser EventInfo] +ghc7Parsers = [ + (FixedSizeParser EVENT_CREATE_THREAD sz_tid (do -- (thread) + t <- getE + return CreateThread{thread=t} + )), + + (FixedSizeParser EVENT_RUN_THREAD sz_tid (do -- (thread) + t <- getE + return RunThread{thread=t} + )), + + (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do + -- (thread, status) + t <- getE + s <- getE :: GetEvents RawThreadStopStatus + return StopThread{thread=t, status = if s > maxThreadStopStatus + then NoStatus + else mkStopStatus s} + )), + + (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do + -- (thread, status, info) + t <- getE + s <- getE :: GetEvents RawThreadStopStatus + i <- getE :: GetEvents ThreadId + return StopThread{thread = t, + status = case () of + _ | s > maxThreadStopStatus + -> NoStatus + | s == 8 {- XXX yeuch -} + -> BlockedOnBlackHoleOwnedBy i + | otherwise + -> mkStopStatus s} + )), + + (FixedSizeParser EVENT_THREAD_RUNNABLE sz_tid (do -- (thread) + t <- getE + return ThreadRunnable{thread=t} + )), + + (FixedSizeParser EVENT_MIGRATE_THREAD (sz_tid + sz_cap) (do -- (thread, newCap) + t <- getE + nc <- getE :: GetEvents CapNo + return MigrateThread{thread=t,newCap=fromIntegral nc} + )), + + -- Yes, EVENT_RUN/STEAL_SPARK are deprecated, but see the explanation in the + -- 'ghc6Parsers' section below. Since we're parsing them anyway, we might + -- as well convert them to the new SparkRun/SparkSteal events. + (FixedSizeParser EVENT_RUN_SPARK sz_tid (do -- (thread) + _ <- getE :: GetEvents ThreadId + return SparkRun + )), + + (FixedSizeParser EVENT_STEAL_SPARK (sz_tid + sz_cap) (do -- (thread, victimCap) + _ <- getE :: GetEvents ThreadId + vc <- getE :: GetEvents CapNo + return SparkSteal{victimCap=fromIntegral vc} + )), + + (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_tid (do -- (sparkThread) + st <- getE :: GetEvents ThreadId + return CreateSparkThread{sparkThread=st} + )), + + (FixedSizeParser EVENT_SPARK_COUNTERS (7*8) (do -- (crt,dud,ovf,cnv,fiz,gcd,rem) + crt <- getE :: GetEvents Word64 + dud <- getE :: GetEvents Word64 + ovf <- getE :: GetEvents Word64 + cnv <- getE :: GetEvents Word64 + fiz <- getE :: GetEvents Word64 + gcd <- getE :: GetEvents Word64 + rem <- getE :: GetEvents Word64 + return SparkCounters{sparksCreated = crt, sparksDud = dud, + sparksOverflowed = ovf, sparksConverted = cnv, + sparksFizzled = fiz, sparksGCd = gcd, + sparksRemaining = rem} + )), + + (simpleEvent EVENT_SPARK_CREATE SparkCreate), + (simpleEvent EVENT_SPARK_DUD SparkDud), + (simpleEvent EVENT_SPARK_OVERFLOW SparkOverflow), + (simpleEvent EVENT_SPARK_RUN SparkRun), + (FixedSizeParser EVENT_SPARK_STEAL sz_cap (do -- (victimCap) + vc <- getE :: GetEvents CapNo + return SparkSteal{victimCap=fromIntegral vc} + )), + (simpleEvent EVENT_SPARK_FIZZLE SparkFizzle), + (simpleEvent EVENT_SPARK_GC SparkGC), + + (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do -- (thread, other_cap) + t <- getE + oc <- getE :: GetEvents CapNo + return WakeupThread{thread=t,otherCap=fromIntegral oc} + )) + ] + + ----------------------- + -- GHC 6.12 compat: GHC 6.12 reported the wrong sizes for some events, + -- so we have to recognise those wrong sizes here for backwards + -- compatibility. +ghc6Parsers :: [EventParser EventInfo] +ghc6Parsers = [ + (FixedSizeParser EVENT_STARTUP 0 (do + -- BUG in GHC 6.12: the startup event was incorrectly + -- declared as size 0, so we accept it here. + c <- getE :: GetEvents CapNo + return Startup{ n_caps = fromIntegral c } + )), + + (FixedSizeParser EVENT_CREATE_THREAD sz_old_tid (do -- (thread) + t <- getE + return CreateThread{thread=t} + )), + + (FixedSizeParser EVENT_RUN_THREAD sz_old_tid (do -- (thread) + t <- getE + return RunThread{thread=t} + )), + + (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do -- (thread, status) + t <- getE + s <- getE :: GetEvents Word16 + let stat = fromIntegral s + return StopThread{thread=t, status = if stat > maxBound + then NoStatus + else mkStopStatus stat} + )), + + (FixedSizeParser EVENT_THREAD_RUNNABLE sz_old_tid (do -- (thread) + t <- getE + return ThreadRunnable{thread=t} + )), + + (FixedSizeParser EVENT_MIGRATE_THREAD (sz_old_tid + sz_cap) (do -- (thread, newCap) + t <- getE + nc <- getE :: GetEvents CapNo + return MigrateThread{thread=t,newCap=fromIntegral nc} + )), + + -- Note: it is vital that these two (EVENT_RUN/STEAL_SPARK) remain here (at + -- least in the ghc6Parsers section) even though both events are deprecated. + -- The reason is that .eventlog files created by the buggy GHC-6.12 + -- mis-declare the size of these two events. So we have to handle them + -- specially here otherwise we'll get the wrong size, leading to us getting + -- out of sync and eventual parse failure. Since we're parsing them anyway, + -- we might as well convert them to the new SparkRun/SparkSteal events. + (FixedSizeParser EVENT_RUN_SPARK sz_old_tid (do -- (thread) + _ <- getE :: GetEvents ThreadId + return SparkRun + )), + + (FixedSizeParser EVENT_STEAL_SPARK (sz_old_tid + sz_cap) (do -- (thread, victimCap) + _ <- getE :: GetEvents ThreadId + vc <- getE :: GetEvents CapNo + return SparkSteal{victimCap=fromIntegral vc} + )), + + (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_old_tid (do -- (sparkThread) + st <- getE :: GetEvents ThreadId + return CreateSparkThread{sparkThread=st} + )), + + (FixedSizeParser EVENT_THREAD_WAKEUP (sz_old_tid + sz_cap) (do -- (thread, other_cap) + t <- getE + oc <- getE :: GetEvents CapNo + return WakeupThread{thread=t,otherCap=fromIntegral oc} + )) + ] + +mercuryParsers = [ + (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION + (sz_par_conj_dyn_id + sz_par_conj_static_id) + (do dyn_id <- getE + static_id <- getE + return (MerStartParConjunction dyn_id static_id)) + ), + + (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id + (do dyn_id <- getE + return (MerEndParConjunction dyn_id)) + ), + + (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id + (do dyn_id <- getE + return (MerEndParConjunct dyn_id)) + ), + + (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id) + (do dyn_id <- getE + spark_id <- getE + return (MerCreateSpark dyn_id spark_id)) + ), + + (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id) + (do future_id <- getE + name_id <- getE + return (MerFutureCreate future_id name_id)) + ), + + (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id) + (do future_id <- getE + return (MerFutureWaitNosuspend future_id)) + ), + + (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id) + (do future_id <- getE + return (MerFutureWaitSuspended future_id)) + ), + + (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id) + (do future_id <- getE + return (MerFutureSignal future_id)) + ), + + (simpleEvent EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT MerLookingForGlobalThread), + (simpleEvent EVENT_MER_WORK_STEALING MerWorkStealing), + (simpleEvent EVENT_MER_LOOKING_FOR_LOCAL_SPARK MerLookingForLocalSpark), + + (FixedSizeParser EVENT_MER_RELEASE_CONTEXT sz_tid + (do thread_id <- getE + return (MerReleaseThread thread_id)) + ), + + (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping), + (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain) + + ] + +getData :: GetEvents Data +getData = do + db <- getE :: GetEvents Marker + when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found" + eparsers <- ask + let + getEvents :: [Event] -> GetEvents Data + getEvents events = do + mb_e <- getEvent eparsers + case mb_e of + Nothing -> return (Data (reverse events)) + Just e -> getEvents (e:events) + -- in + getEvents [] + +getEventBlock :: EventParsers -> GetEvents [Event] +getEventBlock parsers = do + b <- lift . lift $ isEmpty + if b then return [] else do + mb_e <- getEvent parsers + case mb_e of + Nothing -> return [] + Just e -> do + es <- getEventBlock parsers + return (e:es) + +getEventLog :: ErrorT String Get EventLog +getEventLog = do + header <- getHeader + let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header] + -- This test is complete, no-one has extended this event yet and all future + -- extensions will use newly allocated event IDs. + is_ghc_6 = Just sz_old_tid == do create_et <- M.lookup EVENT_CREATE_THREAD imap + size create_et + {- + -- GHC6 writes an invalid header, we handle it here by using a + -- different set of event parsers. Note that the ghc7 event parsers + -- are standard events, and can be used by other runtime systems that + -- make use of threadscope. + -} + event_parsers = if is_ghc_6 + then standardParsers ++ ghc6Parsers + else standardParsers ++ ghc7Parsers ++ + mercuryParsers + parsers = mkEventTypeParsers imap event_parsers + dat <- runReaderT getData (EventParsers parsers) + 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 + +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. + -- In light of merged logs, global blocks may have overlapping + -- time spans, thus the blocks are mergesorted + n_events = mergesort' (compare `on` time) (anon_events : map 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) + + +buildEventTypeMap :: [EventType] -> IntMap EventType +buildEventTypeMap etypes = M.fromList [ (fromIntegral (num t),t) | t <- etypes ] + +----------------------------------------------------------------------------- +-- Some pretty-printing support + +showEventInfo :: EventInfo -> String +showEventInfo spec = + case spec of + EventBlock end_time cap _block_events -> + printf "event block: cap %d, end time: %d\n" cap end_time + Startup n_caps -> + printf "startup: %d capabilities" n_caps + 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 + CreateSparkThread sparkThread -> + printf "creating spark thread %d" sparkThread + SparkCounters crt dud ovf cnv fiz gcd rem -> + printf "spark stats: %d created, %d converted, %d remaining (%d overflowed, %d dud, %d GC'd, %d fizzled)" crt cnv rem ovf dud gcd fiz + SparkCreate -> + printf "spark created" + SparkDud -> + printf "dud spark discarded" + SparkOverflow -> + printf "overflowed spark discarded" + SparkRun -> + printf "running a local spark" + SparkSteal victimCap -> + printf "stealing a spark from cap %d" victimCap + SparkFizzle -> + printf "spark fizzled" + SparkGC -> + printf "spark GCed" + 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" + Message msg -> + msg + UserMessage msg -> + msg + CapsetCreate cs ct -> + printf "created capset %d of type %s" cs (show ct) + CapsetDelete cs -> + printf "deleted capset %d" cs + CapsetAssignCap cs cp -> + printf "assigned cap %d to capset %d" cp cs + CapsetRemoveCap cs cp -> + printf "removed cap %d from capset %d" cp cs + OsProcessPid cs pid -> + printf "capset %d: pid %d" cs pid + OsProcessParentPid cs ppid -> + printf "capset %d: parent pid %d" cs ppid + RtsIdentifier cs i -> + printf "capset %d: RTS version %s" cs i + ProgramArgs cs args -> + printf "capset %d: args: %s" cs (show args) + ProgramEnv cs env -> + printf "capset %d: env: %s" cs (show env) + UnknownEvent n -> + printf "Unknown event type %d" n + InternString str id -> + printf "Interned string: \"%s\" with id %d" str id + MerStartParConjunction dyn_id static_id -> + printf "Start a parallel conjunction 0x%x, static_id: %d" dyn_id static_id + MerEndParConjunction dyn_id -> + printf "End par conjunction: 0x%x" dyn_id + MerEndParConjunct dyn_id -> + printf "End par conjunct: 0x%x" dyn_id + MerCreateSpark dyn_id spark_id -> + printf "Create spark for conjunction: 0x%x spark: 0x%x" dyn_id spark_id + MerFutureCreate future_id name_id -> + printf "Create future 0x%x named %d" future_id name_id + MerFutureWaitNosuspend future_id -> + printf "Wait didn't suspend for future: 0x%x" future_id + MerFutureWaitSuspended future_id -> + printf "Wait suspended on future: 0x%x" future_id + MerFutureSignal future_id -> + printf "Signaled future 0x%x" future_id + MerLookingForGlobalThread -> + "Looking for global thread to resume" + MerWorkStealing -> + "Trying to steal a spark" + MerLookingForLocalSpark -> + "Looking for a local spark to execute" + MerReleaseThread thread_id -> + printf "Releasing thread %d to the free pool" thread_id + MerCapSleeping -> + "Capability going to sleep" + MerCallingMain -> + "About to call the program entry point" + +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" +showThreadStopStatus BlockedOnMVar = "blocked on an MVar" +showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole" +showThreadStopStatus BlockedOnRead = "blocked on I/O read" +showThreadStopStatus BlockedOnWrite = "blocked on I/O write" +showThreadStopStatus BlockedOnDelay = "blocked on threadDelay" +showThreadStopStatus BlockedOnSTM = "blocked in STM retry" +showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc" +showThreadStopStatus BlockedOnCCall = "blocked in a foreign call" +showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call" +showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo" +showThreadStopStatus ThreadMigrating = "thread migrating" +showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised" +showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) = + "blocked on black hole owned by thread " ++ show target +showThreadStopStatus NoStatus = "No stop thread status" + +ppEventLog :: EventLog -> String +ppEventLog (EventLog (Header ets) (Data es)) = unlines $ concat ( + [ ["Event Types:"] + , map ppEventType ets + , [""] -- newline + , ["Events:"] + , map (ppEvent imap) sorted + , [""] ]) -- extra trailing newline + where + imap = buildEventTypeMap ets + sorted = sortEvents es + +ppEventType :: EventType -> String +ppEventType (EventType num dsc msz) = printf "%4d: %s (size %s)" num dsc + (case msz of Nothing -> "variable"; Just x -> show x) + +ppEvent :: IntMap EventType -> CapEvent -> String +ppEvent imap (CapEvent cap (Event time spec)) = + printf "%9d: " time ++ + (case cap of + Nothing -> "" + Just c -> printf "cap %d: " c) ++ + case spec of + UnknownEvent{ ref=ref } -> + printf (desc (fromJust (M.lookup (fromIntegral ref) imap))) + + other -> showEventInfo spec + +type PutEvents a = PutM a + +putE :: Binary a => a -> PutEvents () +putE = put + +runPutEBS :: PutEvents () -> L.ByteString +runPutEBS = runPut + +writeEventLogToFile f el = L.writeFile f $ runPutEBS $ putEventLog el + +putType :: EventTypeNum -> PutEvents () +putType = putE + +putCap :: Int -> PutEvents () +putCap c = putE (fromIntegral c :: CapNo) + +putMarker :: Word32 -> PutEvents () +putMarker = putE + +putEventLog :: EventLog -> PutEvents () +putEventLog (EventLog hdr es) = do + putHeader hdr + putData es + +putHeader :: Header -> PutEvents () +putHeader (Header ets) = do + putMarker EVENT_HEADER_BEGIN + putMarker EVENT_HET_BEGIN + mapM_ putEventType ets + putMarker EVENT_HET_END + putMarker EVENT_HEADER_END + where + putEventType (EventType n d msz) = do + putMarker EVENT_ET_BEGIN + putType n + putE $ fromMaybe 0xffff msz + putE (fromIntegral $ length d :: EventTypeDescLen) + mapM_ put d + -- the event type header allows for extra data, which we don't use: + putE (0 :: Word32) + putMarker EVENT_ET_END + +putData :: Data -> PutEvents () +putData (Data es) = do + putMarker EVENT_DATA_BEGIN -- Word32 + mapM_ putEvent es + putType EVENT_DATA_END -- Word16 + +eventTypeNum :: EventInfo -> EventTypeNum +eventTypeNum e = case e of + CreateThread {} -> EVENT_CREATE_THREAD + RunThread {} -> EVENT_RUN_THREAD + StopThread {} -> EVENT_STOP_THREAD + ThreadRunnable {} -> EVENT_THREAD_RUNNABLE + MigrateThread {} -> EVENT_MIGRATE_THREAD + Shutdown {} -> EVENT_SHUTDOWN + WakeupThread {} -> EVENT_THREAD_WAKEUP + StartGC {} -> EVENT_GC_START + EndGC {} -> EVENT_GC_END + RequestSeqGC {} -> EVENT_REQUEST_SEQ_GC + RequestParGC {} -> EVENT_REQUEST_PAR_GC + CreateSparkThread {} -> EVENT_CREATE_SPARK_THREAD + SparkCounters {} -> EVENT_SPARK_COUNTERS + SparkCreate {} -> EVENT_SPARK_CREATE + SparkDud {} -> EVENT_SPARK_DUD + SparkOverflow {} -> EVENT_SPARK_OVERFLOW + SparkRun {} -> EVENT_SPARK_RUN + SparkSteal {} -> EVENT_SPARK_STEAL + SparkFizzle {} -> EVENT_SPARK_FIZZLE + SparkGC {} -> EVENT_SPARK_GC + Message {} -> EVENT_LOG_MSG + Startup {} -> EVENT_STARTUP + EventBlock {} -> EVENT_BLOCK_MARKER + UserMessage {} -> EVENT_USER_MSG + GCIdle {} -> EVENT_GC_IDLE + GCWork {} -> EVENT_GC_WORK + GCDone {} -> EVENT_GC_DONE + CapsetCreate {} -> EVENT_CAPSET_CREATE + CapsetDelete {} -> EVENT_CAPSET_DELETE + CapsetAssignCap {} -> EVENT_CAPSET_ASSIGN_CAP + CapsetRemoveCap {} -> EVENT_CAPSET_REMOVE_CAP + RtsIdentifier {} -> EVENT_RTS_IDENTIFIER + ProgramArgs {} -> EVENT_PROGRAM_ARGS + ProgramEnv {} -> EVENT_PROGRAM_ENV + OsProcessPid {} -> EVENT_OSPROCESS_PID + OsProcessParentPid{} -> EVENT_OSPROCESS_PPID + UnknownEvent {} -> error "eventTypeNum UnknownEvent" + InternString {} -> EVENT_INTERN_STRING + MerStartParConjunction {} -> EVENT_MER_START_PAR_CONJUNCTION + MerEndParConjunction _ -> EVENT_MER_STOP_PAR_CONJUNCTION + MerEndParConjunct _ -> EVENT_MER_STOP_PAR_CONJUNCT + MerCreateSpark {} -> EVENT_MER_CREATE_SPARK + MerFutureCreate {} -> EVENT_MER_FUT_CREATE + MerFutureWaitNosuspend _ -> EVENT_MER_FUT_WAIT_NOSUSPEND + MerFutureWaitSuspended _ -> EVENT_MER_FUT_WAIT_SUSPENDED + MerFutureSignal _ -> EVENT_MER_FUT_SIGNAL + MerLookingForGlobalThread -> EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT + MerWorkStealing -> EVENT_MER_WORK_STEALING + MerLookingForLocalSpark -> EVENT_MER_LOOKING_FOR_LOCAL_SPARK + MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT + MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING + MerCallingMain -> EVENT_MER_CALLING_MAIN + +putEvent :: Event -> PutEvents () +putEvent (Event t spec) = do + putType (eventTypeNum spec) + put t + putEventSpec spec + +putEventSpec (Startup caps) = do + putCap (fromIntegral caps) + +putEventSpec (EventBlock end cap es) = do + let block = runPutEBS (mapM_ putEvent es) + put (fromIntegral (L.length block) + 24 :: Word32) + putE end + putE (fromIntegral cap :: CapNo) + putLazyByteString block + +putEventSpec (CreateThread t) = do + putE t + +putEventSpec (RunThread t) = do + putE t + +-- here we assume that ThreadStopStatus fromEnum matches the definitions in +-- EventLogFormat.h +putEventSpec (StopThread t s) = do + putE t + putE $ case s of + NoStatus -> 0 :: Word16 + HeapOverflow -> 1 + StackOverflow -> 2 + ThreadYielding -> 3 + ThreadBlocked -> 4 + ThreadFinished -> 5 + ForeignCall -> 6 + BlockedOnMVar -> 7 + BlockedOnBlackHole -> 8 + BlockedOnBlackHoleOwnedBy _ -> 8 + BlockedOnRead -> 9 + BlockedOnWrite -> 10 + BlockedOnDelay -> 11 + BlockedOnSTM -> 12 + BlockedOnDoProc -> 13 + BlockedOnCCall -> 14 + BlockedOnCCall_NoUnblockExc -> 15 + BlockedOnMsgThrowTo -> 16 + ThreadMigrating -> 17 + BlockedOnMsgGlobalise -> 18 + putE $ case s of + BlockedOnBlackHoleOwnedBy i -> i + _ -> 0 + +putEventSpec (ThreadRunnable t) = do + putE t + +putEventSpec (MigrateThread t c) = do + putE t + putCap c + +putEventSpec (CreateSparkThread t) = do + putE t + +putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do + putE crt + putE dud + putE ovf + putE cnv + putE fiz + putE gcd + putE rem + +putEventSpec SparkCreate = do + return () + +putEventSpec SparkDud = do + return () + +putEventSpec SparkOverflow = do + return () + +putEventSpec SparkRun = do + return () + +putEventSpec (SparkSteal c) = do + putCap c + +putEventSpec SparkFizzle = do + return () + +putEventSpec SparkGC = do + return () + +putEventSpec (WakeupThread t c) = do + putE t + putCap c + +putEventSpec Shutdown = do + return () + +putEventSpec RequestSeqGC = do + return () + +putEventSpec RequestParGC = do + return () + +putEventSpec StartGC = do + return () + +putEventSpec GCWork = do + return () + +putEventSpec GCIdle = do + return () + +putEventSpec GCDone = do + return () + +putEventSpec EndGC = do + return () + +putEventSpec (CapsetCreate cs ct) = do + putE cs + putE $ case ct of + CapsetCustom -> 1 :: Word16 + CapsetOsProcess -> 2 + CapsetClockDomain -> 3 + CapsetUnknown -> 0 + +putEventSpec (CapsetDelete cs) = do + putE cs + +putEventSpec (CapsetAssignCap cs cp) = do + putE cs + putCap cp + +putEventSpec (CapsetRemoveCap cs cp) = do + putE cs + putCap cp + +putEventSpec (RtsIdentifier cs rts) = do + putE (fromIntegral (length rts) + 4 :: Word16) + putE cs + mapM_ putE rts + +putEventSpec (ProgramArgs cs as) = do + let as' = unsep as + putE (fromIntegral (length as') + 4 :: Word16) + putE cs + mapM_ putE as' + +putEventSpec (ProgramEnv cs es) = do + let es' = unsep es + putE (fromIntegral (length es') + 4 :: Word16) + putE cs + mapM_ putE es' + +putEventSpec (OsProcessPid cs pid) = do + putE cs + putE pid + +putEventSpec (OsProcessParentPid cs ppid) = do + putE cs + putE ppid + +putEventSpec (Message s) = do + putE (fromIntegral (length s) :: Word16) + mapM_ putE s + +putEventSpec (UserMessage s) = do + putE (fromIntegral (length s) :: Word16) + mapM_ putE s + +putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent" + +putEventSpec (InternString str id) = do + putE len + mapM_ putE str + putE id + where len = (fromIntegral (length str) :: Word16) + sz_string_id + +putEventSpec (MerStartParConjunction dyn_id static_id) = do + putE dyn_id + putE static_id + +putEventSpec (MerEndParConjunction dyn_id) = do + putE dyn_id + +putEventSpec (MerEndParConjunct dyn_id) = do + putE dyn_id + +putEventSpec (MerCreateSpark dyn_id spark_id) = do + putE dyn_id + putE spark_id + +putEventSpec (MerFutureCreate future_id name_id) = do + putE future_id + putE name_id + +putEventSpec (MerFutureWaitNosuspend future_id) = do + putE future_id + +putEventSpec (MerFutureWaitSuspended future_id) = do + putE future_id + +putEventSpec (MerFutureSignal future_id) = do + putE future_id + +putEventSpec MerLookingForGlobalThread = return () +putEventSpec MerWorkStealing = return () +putEventSpec MerLookingForLocalSpark = return () + +putEventSpec (MerReleaseThread thread_id) = do + putE thread_id + +putEventSpec MerCapSleeping = return () +putEventSpec MerCallingMain = return () + +-- [] == [] +-- [x] == x\0 +-- [x, y, z] == x\0y\0 +unsep :: [String] -> String +unsep = concatMap (++"\0") -- not the most efficient, but should be ok + +splitNull :: String -> [String] +splitNull [] = [] +splitNull xs = case span (/= '\0') xs of + (x, xs') -> x : splitNull (drop 1 xs') + diff --git a/MergeGhcEvents.hs b/MergeGhcEvents.hs new file mode 100644 --- /dev/null +++ b/MergeGhcEvents.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + +import GHC.RTS.Events +import System.Environment +import Data.Monoid +import Data.List (foldl') +import Data.Word (Word32, Word16) + +-- todo, proper error handling +main = do + [out, file1, file2] <- getArgs + Right f1 <- readEventLogFromFile file1 + Right f2 <- readEventLogFromFile file2 + let m = merge f1 f2 + writeEventLogToFile out m + +{- +GHC numbers caps and capsets in sequential order, starting at 0. Threads are +similarly numbered, but start at 1. In order to merge logs 'x' and 'y', we +find the maximum values of each variable type in 'x', then increment each +variable in 'y' that amount. This guarantees that variables in each log don't +clash, and that the meaning of each reference to a thread/cap/capset is +preserved. +-} + +merge :: EventLog -> EventLog -> EventLog +merge (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2 + = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys +merge _ _ = error "can't merge eventlogs with non-matching headers" + +mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] +mergeOn f [] ys = ys +mergeOn f xs [] = xs +mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys) + | otherwise = y : mergeOn f (x:xs) ys + +data MaxVars = MaxVars { mcapset :: !Word32 + , mcap :: !Int + , mthread :: !ThreadId } + +instance Monoid MaxVars where + -- threads start at 1 + mempty = MaxVars 0 0 1 + mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z) + -- avoid space leaks: + mconcat = foldl' mappend mempty + +-- Capabilities are represented as Word16. An event block marked with the +-- capability of 0xffff belongs to no capability +isCap :: Int -> Bool +isCap x = fromIntegral x /= ((-1) :: Word16) + +maxVars :: [Event] -> MaxVars +maxVars = mconcat . map (maxSpec . spec) + where + -- only checking binding sites right now, sufficient? + maxSpec (Startup n) = mempty { mcap = n - 1 } + maxSpec (CreateThread t) = mempty { mthread = t } + maxSpec (CreateSparkThread t) = mempty { mthread = t } + maxSpec (CapsetCreate cs _) = mempty {mcapset = cs } + maxSpec (EventBlock _ _ es) = maxVars es + maxSpec _ = mempty + +sh :: Num a => a -> a -> a +sh x y = x + y + 1 + +shift :: MaxVars -> [Event] -> [Event] +shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s) + where + -- -1 marks a block that isn't attached to a particular capability + shift' (EventBlock et c bs) = EventBlock et (msh c) $ shift mv bs + where msh x = if isCap x then sh mc x else x + shift' (CreateThread t) = CreateThread $ sh mt t + shift' (RunThread t) = RunThread $ sh mt t + shift' (StopThread t s) = StopThread (sh mt t) s + shift' (ThreadRunnable t) = ThreadRunnable $ sh mt t + shift' (MigrateThread t c) = MigrateThread (sh mt t) (sh mc c) + shift' (CreateSparkThread t) = CreateSparkThread (sh mt t) + shift' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c) + shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst + shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs) + shift' (CapsetRemoveCap cs c) = CapsetRemoveCap (sh mcs cs) (sh mc c) + shift' (RtsIdentifier cs rts) = RtsIdentifier (sh mcs cs) rts + shift' (ProgramArgs cs as) = ProgramArgs (sh mcs cs) as + shift' (ProgramEnv cs es) = ProgramEnv (sh mcs cs) es + shift' (OsProcessPid cs pid) = OsProcessPid (sh mcs cs) pid + shift' (OsProcessParentPid cs ppid) = OsProcessParentPid (sh mcs cs) ppid + shift' x = x diff --git a/ShowGhcEvents.hs b/ShowGhcEvents.hs --- a/ShowGhcEvents.hs +++ b/ShowGhcEvents.hs @@ -20,43 +20,6 @@ Left s -> die ("Failed to parse " ++ file ++ ": " ++ s) Right log -> return log - printf "Event Types:\n" - let etypes = Log.eventTypes (Log.header log) - putStrLn (unlines (map ppEventType etypes)) - - let imap = M.fromList [ (fromIntegral (Log.num t),t) | t <- etypes ] - - let pes = Log.events (Log.dat log) - sorted = sortEvents pes - -- the events come out reversed, and we want a stable sort - - printf "Events:\n" - putStrLn $ unlines $ map (ppEvent imap) $ sorted --- putStrLn $ show $ length $ sorted - -unsortEvents :: [Event] -> [(Int,Event)] -unsortEvents es = ess - where - blocks = [ b | b@EventBlock{} <- map spec es ] - ess = [ (cap block, e) | block <- blocks, e <- block_events block ] + putStrLn $ ppEventLog log die s = do hPutStrLn stderr s; exitWith (ExitFailure 1) - -ppEventType :: EventType -> String -ppEventType et = printf "%4d: %s (size %s)" (Log.num et) (Log.desc et) - (case Log.size et of Nothing -> "variable"; Just x -> show x) - -ppEvent :: IntMap EventType -> CapEvent -> String -ppEvent imap (CapEvent cap (Event time spec)) = - printf "%9d: " time ++ - (case cap of - Nothing -> "" - Just c -> printf "cap %d: " c) ++ - case spec of - UnknownEvent{ ref=ref } -> - printf (Log.desc (fromJust (M.lookup (fromIntegral ref) imap))) - - Message msg -> msg - UserMessage msg -> msg - - other -> showEventTypeSpecificInfo spec diff --git a/ghc-events.cabal b/ghc-events.cabal --- a/ghc-events.cabal +++ b/ghc-events.cabal @@ -1,5 +1,5 @@ name: ghc-events -version: 0.2.0.1 +version: 0.3.0.1 synopsis: Library and tool for parsing .eventlog files from GHC description: Parses .eventlog files emitted by GHC 6.12.1 and later. Includes the show-ghc-events tool to dump an event @@ -8,25 +8,43 @@ license: BSD3 license-file: LICENSE author: Donnie Jones , - Simon Marlow + Simon Marlow , + Paul Bone , + Duncan Coutts maintainer: Simon Marlow +bug-reports: http://trac.haskell.org/ThreadScope/ build-type: Simple -tested-with: GHC == 6.10.2, GHC == 6.11.20090221 -cabal-version: >= 1.6 -extra-source-files: GHC/RTS/EventLogFormat.h +tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1 +cabal-version: >= 1.8 +extra-source-files: GHC/RTS/EventLogFormat.h, + AUTHORS, + test/*.eventlog -library { +source-repository head + type: darcs + location: http://code.haskell.org/ghc-events/ + +library build-depends: base == 4.*, - mtl == 1.1.*, - containers >= 0.2 && < 0.4, + mtl >= 1.1 && < 2.1, + containers >= 0.2 && < 0.5, binary == 0.5.*, - bytestring == 0.9.* + bytestring == 0.9.*, + array == 0.3.* exposed-modules: GHC.RTS.Events + other-modules: GHC.RTS.EventParserUtils, + GHC.RTS.EventTypes extensions: CPP -} -executable show-ghc-events { +executable ghc-events-show main-is: ShowGhcEvents.hs -} + build-depends: base, mtl, containers, binary, bytestring, array +executable ghc-events-merge + main-is: MergeGhcEvents.hs + build-depends: base, mtl, containers, binary, bytestring, array +test-suite test-versions + type: exitcode-stdio-1.0 + main-is: test/TestVersions.hs + build-depends: base, mtl, containers, binary, bytestring, array diff --git a/test/TestVersions.hs b/test/TestVersions.hs new file mode 100644 --- /dev/null +++ b/test/TestVersions.hs @@ -0,0 +1,65 @@ +{- +This test parses sample event logs from each major GHC version and compares +the pretty printed output with reference output. + +When tests fail, use a diff tool to compare the output of show-ghc-events with +the reference file. Resolve the differences in either the library code or the +reference file, and 'darcs record' the changes. + +Steps to produce event log and reference output: + $ ghc --make queens.hs -o queens-ghc-$VERSION -threaded -eventlog + $ queens-ghc-$VERSION 8 +RTS -N4 -ls + $ show-ghc-events queens-ghc-$VERSION.eventlog > queens-ghc-$VERSION.eventlog.reference + +Where queens.hs is http://darcs.haskell.org/nofib/parallel/queens/Main.hs +-} + +import GHC.RTS.Events +import System.Exit + +files :: [FilePath] +files = map ("test/"++) + [ "queens-ghc-6.12.1.eventlog" + , "queens-ghc-7.0.2.eventlog" + , "mandelbrot-mmc-2011-06-14.eventlog" ] + +-- returns True on success +testFile :: FilePath -> IO Bool +testFile f = do + e <- readEventLogFromFile f + let oops s = putStrLn (f ++ ": failure" ++ s) >> return False + + case e of + Left m -> oops m + + Right newlogdata -> do + oldlog <- readFile (f ++ ".reference") + let newlog = ppEventLog newlogdata ++ "\n" in + if oldlog == newlog + then putStrLn (f ++ ": success") >> return True + else do print $ diffLines oldlog newlog + oops "pretty print output does not match" + +main = do + successes <- mapM testFile files + if and successes + then return () + else exitFailure + +-- +-- Code to help print the differences between a working test and a failing test. +-- + +diffLines o n = diff 1 (lines o) (lines n) + +diff :: Int -> [String] -> [String] -> String +diff _ [] [] = "Logs match" +diff l [] (n:ns) = "Extra lines in new log at line " ++ show l ++ ":\n" ++ + (unlines (n:ns)) +diff l (o:os) [] = "Missing lines in new log at line " ++ show l ++ ":\n" ++ + (unlines (o:os)) +diff l (o:os) (n:ns) = if (o == n) + then diff (l+1) os ns + else "Different lines at line " ++ show l ++ ":\n" ++ + "Original: " ++ o ++ + "New: " ++ n diff --git a/test/mandelbrot-mmc-2011-06-14.eventlog b/test/mandelbrot-mmc-2011-06-14.eventlog new file mode 100644 Binary files /dev/null and b/test/mandelbrot-mmc-2011-06-14.eventlog differ