diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,7 @@ +Donnie Jones +Simon Marlow +Paul Bone , +Duncan Coutts , +Mischa Dieterle , +Thomas Horstmeyer , +Jost Berthold diff --git a/GHC/RTS/EventLogFormat.h b/GHC/RTS/EventLogFormat.h new file mode 100644 --- /dev/null +++ b/GHC/RTS/EventLogFormat.h @@ -0,0 +1,264 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2008-2009 + * + * Event log format + * + * The log format is designed to be extensible: old tools should be + * able to parse (but not necessarily understand all of) new versions + * of the format, and new tools will be able to understand old log + * files. + * + * Each event has a specific format. If you add new events, give them + * new numbers: we never re-use old event numbers. + * + * - The format is endian-independent: all values are represented in + * bigendian order. + * + * - The format is extensible: + * + * - The header describes each event type and its length. Tools + * that don't recognise a particular event type can skip those events. + * + * - There is room for extra information in the event type + * specification, which can be ignored by older tools. + * + * - Events can have extra information added, but existing fields + * cannot be changed. Tools should ignore extra fields at the + * end of the event record. + * + * - Old event type ids are never re-used; just take a new identifier. + * + * + * The format + * ---------- + * + * log : EVENT_HEADER_BEGIN + * EventType* + * EVENT_HEADER_END + * EVENT_DATA_BEGIN + * Event* + * EVENT_DATA_END + * + * EventType : + * EVENT_ET_BEGIN + * Word16 -- unique identifier for this event + * Int16 -- >=0 size of the event in bytes (minus the header) + * -- -1 variable size + * Word32 -- length of the next field in bytes + * Word8* -- string describing the event + * Word32 -- length of the next field in bytes + * Word8* -- extra info (for future extensions) + * EVENT_ET_END + * + * Event : + * Word16 -- event_type + * Word64 -- time (nanosecs) + * [Word16] -- length of the rest (for variable-sized events only) + * ... extra event-specific info ... + * + * + * To add a new event + * ------------------ + * + * - In this file: + * - give it a new number, add a new #define EVENT_XXX below + * - In EventLog.c + * - add it to the EventDesc array + * - emit the event type in initEventLogging() + * - emit the new event in postEvent_() + * - generate the event itself by calling postEvent() somewhere + * - In the Haskell code to parse the event log file: + * - add types and code to read the new event + * + * -------------------------------------------------------------------------- */ + +#ifndef RTS_EVENTLOGFORMAT_H +#define RTS_EVENTLOGFORMAT_H + +/* + * Markers for begin/end of the Header. + */ +#define EVENT_HEADER_BEGIN 0x68647262 /* 'h' 'd' 'r' 'b' */ +#define EVENT_HEADER_END 0x68647265 /* 'h' 'd' 'r' 'e' */ + +#define EVENT_DATA_BEGIN 0x64617462 /* 'd' 'a' 't' 'b' */ +#define EVENT_DATA_END 0xffff + +/* + * Markers for begin/end of the list of Event Types in the Header. + * Header, Event Type, Begin = hetb + * Header, Event Type, End = hete + */ +#define EVENT_HET_BEGIN 0x68657462 /* 'h' 'e' 't' 'b' */ +#define EVENT_HET_END 0x68657465 /* 'h' 'e' 't' 'e' */ + +#define EVENT_ET_BEGIN 0x65746200 /* 'e' 't' 'b' 0 */ +#define EVENT_ET_END 0x65746500 /* 'e' 't' 'e' 0 */ + +/* + * Types of event + */ +#define EVENT_CREATE_THREAD 0 /* (thread) */ +#define EVENT_RUN_THREAD 1 /* (thread) */ +#define EVENT_STOP_THREAD 2 /* (thread, status, blockinfo) */ +#define EVENT_THREAD_RUNNABLE 3 /* (thread) */ +#define EVENT_MIGRATE_THREAD 4 /* (thread, new_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 /* () */ +/* 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) */ +#define EVENT_USER_MSG 19 /* (message ...) */ +#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 EVENT_WALL_CLOCK_TIME 43 /* (capset, unix_epoch_seconds, nanoseconds) */ +#define EVENT_THREAD_LABEL 44 /* (thread, name_string) */ + +/* Range 45 - 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/ + */ + +/* 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) */ + +/* start of parallel trace events */ +#define EVENT_EDEN_START_RECEIVE 60 /* () */ +#define EVENT_EDEN_END_RECEIVE 61 /* () */ +#define EVENT_CREATE_PROCESS 62 /* (process) */ +#define EVENT_KILL_PROCESS 63 /* (process) */ +#define EVENT_ASSIGN_THREAD_TO_PROCESS 64 /* (thread, process) */ +#define EVENT_CREATE_MACHINE 65 /* (machine, startupTime(in 10^-8 seconds after 19xx)) */ +#define EVENT_KILL_MACHINE 66 /* (machine) */ +#define EVENT_SEND_MESSAGE 67 /* (tag, sender_process, sender_thread, receiver_machine, receiver_process, receiver_inport) */ +#define EVENT_RECEIVE_MESSAGE 68 /* (tag, receiver_process, receiver_inport, sender_machine, sender_process, sender_outport, message_size) */ +#define EVENT_SEND_RECEIVE_LOCAL_MESSAGE 69 /* (tag, sender_process, sender_thread, receiver_process, receiver_inport) */ + + +/* 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 70 + +/* 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) */ +#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): + * + * #define HeapOverflow 1 + * #define StackOverflow 2 + * #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 StgWord32 EventThreadID; +typedef StgWord16 EventCapNo; +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 */ + +typedef StgWord32 EventProcessID; +typedef StgWord16 EventMachineID; +typedef EventThreadID EventPortID; + +#endif + +#endif /* RTS_EVENTLOGFORMAT_H */ 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,198 @@ +{-# LANGUAGE CPP #-} +{-# 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,384 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module GHC.RTS.EventTypes where + +import Data.Word (Word8, 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 +type Capset = Word32 + +-- Types for Parallel-RTS Extension +type ProcessId = Word32 +type MachineId = Word16 +type PortId = ThreadId +type MessageSize = Word32 +type RawMsgTag = Word8 + +-- 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 Parallel-RTS event fields +sz_procid, sz_mid, sz_mes, sz_realtime, sz_msgtag :: EventTypeSize +sz_procid = 4 +sz_mid = 2 +sz_mes = 4 +sz_realtime = 8 +sz_msgtag = 1 + +-- 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 + } + | ThreadLabel { thread :: {-# UNPACK #-}!ThreadId, + threadlabel :: String + } + + -- 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 #-}!Capset + , capsetType :: CapsetType + } + | CapsetDelete { capset :: {-# UNPACK #-}!Capset + } + | CapsetAssignCap { capset :: {-# UNPACK #-}!Capset + , cap :: {-# UNPACK #-}!Int + } + | CapsetRemoveCap { capset :: {-# UNPACK #-}!Capset + , cap :: {-# UNPACK #-}!Int + } + + -- program/process info + | RtsIdentifier { capset :: {-# UNPACK #-}!Capset + , rtsident :: String + } + | ProgramArgs { capset :: {-# UNPACK #-}!Capset + , args :: [String] + } + | ProgramEnv { capset :: {-# UNPACK #-}!Capset + , env :: [String] + } + | OsProcessPid { capset :: {-# UNPACK #-}!Capset + , pid :: {-# UNPACK #-}!Word32 + } + | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset + , ppid :: {-# UNPACK #-}!Word32 + } + | WallClockTime { capset :: {-# UNPACK #-}!Capset + , sec :: {-# UNPACK #-}!Word64 + , nsec :: {-# UNPACK #-}!Word32 + } + + -- messages + | Message { msg :: String } + | UserMessage { msg :: String } + + -- Events emitted by a parallel RTS + -- Programme /process info (tools might prefer newer variants above) + | Version { version :: String } + | ProgramInvocation { commandline :: String } + -- startup and shutdown (incl. real start time, not first log entry) + | CreateMachine { machine :: {-# UNPACK #-} !MachineId, + realtime :: {-# UNPACK #-} !Timestamp} + | KillMachine { machine :: {-# UNPACK #-} !MachineId } + -- Haskell processes mgmt (thread groups that share heap and communicate) + | CreateProcess { process :: {-# UNPACK #-} !ProcessId } + | KillProcess { process :: {-# UNPACK #-} !ProcessId } + | AssignThreadToProcess { thread :: {-# UNPACK #-} !ThreadId, + process :: {-# UNPACK #-} !ProcessId + } + -- communication between processes + | EdenStartReceive { } + | EdenEndReceive { } + | SendMessage { mesTag :: !MessageTag, + senderProcess :: {-# UNPACK #-} !ProcessId, + senderThread :: {-# UNPACK #-} !ThreadId, + receiverMachine :: {-# UNPACK #-} !MachineId, + receiverProcess :: {-# UNPACK #-} !ProcessId, + receiverInport :: {-# UNPACK #-} !PortId + } + | ReceiveMessage { mesTag :: !MessageTag, + receiverProcess :: {-# UNPACK #-} !ProcessId, + receiverInport :: {-# UNPACK #-} !PortId, + senderMachine :: {-# UNPACK #-} !MachineId, + senderProcess :: {-# UNPACK #-} !ProcessId, + senderThread :: {-# UNPACK #-} !ThreadId, + messageSize :: {-# UNPACK #-} !MessageSize + } + | SendReceiveLocalMessage { mesTag :: !MessageTag, + senderProcess :: {-# UNPACK #-} !ProcessId, + senderThread :: {-# UNPACK #-} !ThreadId, + receiverProcess :: {-# UNPACK #-} !ProcessId, + receiverInport :: {-# UNPACK #-} !PortId + } + + -- These events have been added for Mercury's benifit but are generally + -- useful. + | InternString { str :: String, sId :: {-# 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. + } deriving Show + +--sync with ghc/parallel/PEOpCodes.h +data MessageTag + = Ready | NewPE | PETIDS | Finish + | FailPE | RFork | Connect | DataMes + | Head | Constr | Part | Terminate + | Packet + -- with GUM and its variants, add: + -- | Fetch | Resume | Ack + -- | Fish | Schedule | Free | Reval | Shark + deriving (Enum, Show) +offset :: RawMsgTag +offset = 0x50 + +-- decoder and encoder +toMsgTag :: RawMsgTag -> MessageTag +toMsgTag = toEnum . fromIntegral . (\n -> n - offset) + +fromMsgTag :: MessageTag -> RawMsgTag +fromMsgTag = (+ offset) . fromIntegral . fromEnum diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events.hs @@ -0,0 +1,1316 @@ +{-# LANGUAGE CPP,BangPatterns,PatternGuards #-} +{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-} +{- + - Authors: Donnie Jones, Simon Marlow, Paul Bone, Mischa Dieterle, + - Thomas Horstmeyer, Duncan Coutts, Jost Berthold + - Events.hs + - Parser functions for GHC RTS EventLog framework, parallel version. + -} + +module GHC.RTS.Events ( + -- * The event log types + EventLog(..), + EventType(..), + Event(..), + EventInfo(..), + ThreadStopStatus(..), + Header(..), + Data(..), + CapsetType(..), + Timestamp, + ThreadId, + -- some types for the parallel RTS + ProcessId, + MachineId, + PortId, + MessageSize, + MessageTag(..), + + -- * Reading and writing event logs + readEventLogFromFile, getEventLog, + 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} + )), + + (FixedSizeParser EVENT_WALL_CLOCK_TIME (sz_capset + 8 + 4) (do -- (capset, unix_epoch_seconds, nanoseconds) + cs <- getE + s <- getE + ns <- getE + return WallClockTime{capset=cs,sec=s,nsec=ns} + )), + + + (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) + sId <- getE :: GetEvents StringId + return (InternString string sId) + )), + + (VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str) + num <- getE :: GetEvents Word16 + tid <- getE + str <- getString (num - sz_tid) + return ThreadLabel{ thread = tid + , threadlabel = str } + )) + ] + +-- 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} + )) + ] + +-- Parsers for parallel events. Parameter is the thread_id size, to create +-- ghc6-parsers (using the wrong size) where necessary. +parRTSParsers :: EventTypeSize -> [EventParser EventInfo] +parRTSParsers sz_tid = [ + (VariableSizeParser EVENT_VERSION (do -- (version) + num <- getE :: GetEvents Word16 + string <- getString num + return Version{ version = string } + )), + + (VariableSizeParser EVENT_PROGRAM_INVOCATION (do -- (cmd. line) + num <- getE :: GetEvents Word16 + string <- getString num + return ProgramInvocation{ commandline = string } + )), + + (simpleEvent EVENT_EDEN_START_RECEIVE EdenStartReceive), + (simpleEvent EVENT_EDEN_END_RECEIVE EdenEndReceive), + + (FixedSizeParser EVENT_CREATE_PROCESS sz_procid + (do p <- getE + return CreateProcess{ process = p }) + ), + + (FixedSizeParser EVENT_KILL_PROCESS sz_procid + (do p <- getE + return KillProcess{ process = p }) + ), + + (FixedSizeParser EVENT_ASSIGN_THREAD_TO_PROCESS (sz_tid + sz_procid) + (do t <- getE + p <- getE + return AssignThreadToProcess { thread = t, process = p }) + ), + + (FixedSizeParser EVENT_CREATE_MACHINE (sz_mid + sz_realtime) + (do m <- getE + t <- getE + return CreateMachine { machine = m, realtime = t }) + ), + + (FixedSizeParser EVENT_KILL_MACHINE sz_mid + (do m <- getE :: GetEvents MachineId + return KillMachine { machine = m }) + ), + + (FixedSizeParser EVENT_SEND_MESSAGE + (sz_msgtag + 2*sz_procid + 2*sz_tid + sz_mid) + (do tag <- getE :: GetEvents RawMsgTag + sP <- getE :: GetEvents ProcessId + sT <- getE :: GetEvents ThreadId + rM <- getE :: GetEvents MachineId + rP <- getE :: GetEvents ProcessId + rIP <- getE :: GetEvents PortId + return SendMessage { mesTag = toMsgTag tag, + senderProcess = sP, + senderThread = sT, + receiverMachine = rM, + receiverProcess = rP, + receiverInport = rIP + }) + ), + + (FixedSizeParser EVENT_RECEIVE_MESSAGE + (sz_msgtag + 2*sz_procid + 2*sz_tid + sz_mid + sz_mes) + (do tag <- getE :: GetEvents Word8 + rP <- getE :: GetEvents ProcessId + rIP <- getE :: GetEvents PortId + sM <- getE :: GetEvents MachineId + sP <- getE :: GetEvents ProcessId + sT <- getE :: GetEvents ThreadId + mS <- getE :: GetEvents MessageSize + return ReceiveMessage { mesTag = toMsgTag tag, + receiverProcess = rP, + receiverInport = rIP, + senderMachine = sM, + senderProcess = sP, + senderThread= sT, + messageSize = mS + }) + ), + + (FixedSizeParser EVENT_SEND_RECEIVE_LOCAL_MESSAGE + (sz_msgtag + 2*sz_procid + 2*sz_tid) + (do tag <- getE :: GetEvents Word8 + sP <- getE :: GetEvents ProcessId + sT <- getE :: GetEvents ThreadId + rP <- getE :: GetEvents ProcessId + rIP <- getE :: GetEvents PortId + return SendReceiveLocalMessage { mesTag = toMsgTag tag, + senderProcess = sP, + senderThread = sT, + receiverProcess = rP, + receiverInport = rIP + }) + )] + +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 ++ + parRTSParsers sz_old_tid + else standardParsers ++ ghc7Parsers ++ + parRTSParsers sz_tid ++ + 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 + ThreadLabel thread label -> + printf "thread %d has label \"%s\"" thread label + 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 + WallClockTime cs sec nsec -> + printf "capset %d: wall clock time %ds %dns (unix epoch)" cs sec nsec + 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 sId -> + printf "Interned string: \"%s\" with id %d" str sId + -- events for the parallel RTS + Version version -> + printf "compiler version is %s" version + ProgramInvocation commandline -> + printf "program invocation: %s" commandline + EdenStartReceive -> + printf "starting to receive" + EdenEndReceive -> + printf "stop receiving" + CreateProcess process -> + printf "creating process %d" process + KillProcess process -> + printf "killing process %d" process + AssignThreadToProcess thread process -> + printf "assigning thread %d to process %d" thread process + CreateMachine machine realtime -> + printf "creating machine %d at %d" machine realtime + KillMachine machine -> + printf "killing machine %d" machine + SendMessage mesTag senderProcess senderThread + receiverMachine receiverProcess receiverInport -> + printf "sending message with tag %s from process %d, thread %d to machine %d, process %d on inport %d" + (show mesTag) senderProcess senderThread receiverMachine receiverProcess receiverInport + ReceiveMessage mesTag receiverProcess receiverInport + senderMachine senderProcess senderThread messageSize -> + printf "receiving message with tag %s at process %d, inport %d from machine %d, process %d, thread %d with size %d" + (show mesTag) receiverProcess receiverInport + senderMachine senderProcess senderThread messageSize + SendReceiveLocalMessage mesTag senderProcess senderThread + receiverProcess receiverInport -> + printf "sending/receiving message with tag %s from process %d, thread %d to process %d on inport %d" + (show mesTag) senderProcess senderThread receiverProcess receiverInport + 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 + +putEStr :: String -> PutEvents () +putEStr = mapM_ 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 + ThreadLabel {} -> EVENT_THREAD_LABEL + 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 + WallClockTime{} -> EVENT_WALL_CLOCK_TIME + UnknownEvent {} -> error "eventTypeNum UnknownEvent" + InternString {} -> EVENT_INTERN_STRING + Version {} -> EVENT_VERSION + ProgramInvocation {} -> EVENT_PROGRAM_INVOCATION + EdenStartReceive {} -> EVENT_EDEN_START_RECEIVE + EdenEndReceive {} -> EVENT_EDEN_END_RECEIVE + CreateProcess {} -> EVENT_CREATE_PROCESS + KillProcess {} -> EVENT_KILL_PROCESS + AssignThreadToProcess {} -> EVENT_ASSIGN_THREAD_TO_PROCESS + CreateMachine {} -> EVENT_CREATE_MACHINE + KillMachine {} -> EVENT_KILL_MACHINE + SendMessage {} -> EVENT_SEND_MESSAGE + ReceiveMessage {} -> EVENT_RECEIVE_MESSAGE + SendReceiveLocalMessage {} -> EVENT_SEND_RECEIVE_LOCAL_MESSAGE + 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 (ThreadLabel t l) = do + putE (fromIntegral (length l) + sz_tid :: Word16) + putE t + putEStr l + +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 + putEStr 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 (WallClockTime cs sec nsec) = do + putE cs + putE sec + putE nsec + +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 (Version s) = do + putE (fromIntegral (length s) :: Word16) + mapM_ putE s + +putEventSpec (ProgramInvocation s) = do + putE (fromIntegral (length s) :: Word16) + mapM_ putE s + +putEventSpec ( EdenStartReceive ) = return () + +putEventSpec ( EdenEndReceive ) = return () + +putEventSpec ( CreateProcess process ) = do + putE process + +putEventSpec ( KillProcess process ) = do + putE process + +putEventSpec ( AssignThreadToProcess thread process ) = do + putE thread + putE process + +putEventSpec ( CreateMachine machine realtime ) = do + putE machine + putE realtime + +putEventSpec ( KillMachine machine ) = do + putE machine + +putEventSpec ( SendMessage mesTag senderProcess senderThread + receiverMachine receiverProcess receiverInport ) = do + putE (fromMsgTag mesTag) + putE senderProcess + putE senderThread + putE receiverMachine + putE receiverProcess + putE receiverInport + +putEventSpec ( ReceiveMessage mesTag receiverProcess receiverInport + senderMachine senderProcess senderThread messageSize ) = do + putE (fromMsgTag mesTag) + putE receiverProcess + putE receiverInport + putE senderMachine + putE senderProcess + putE senderThread + putE messageSize + +putEventSpec ( SendReceiveLocalMessage mesTag senderProcess senderThread + receiverProcess receiverInport ) = do + putE (fromMsgTag mesTag) + putE senderProcess + putE senderThread + putE receiverProcess + putE receiverInport + +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/GHC/RTS/Events/Analysis.hs b/GHC/RTS/Events/Analysis.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events/Analysis.hs @@ -0,0 +1,283 @@ +module GHC.RTS.Events.Analysis + ( Machine (..) + , validate + , validates + , simulate + , Profile (..) + , profile + , profileIndexed + , profileRouted + , extractIndexed + , refineM + , profileM + , indexM + , toList + , toMaybe + , Process (..) + , routeM + ) + where + +import GHC.RTS.Events + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, catMaybes) +import Data.Either (rights) + +-------------------------------------------------------------------------------- +-- | This is based on a simple finite state machine hence the names `delta` +-- for the state transition function. +-- Since states might be more than simple pattern matched constructors, we +-- use `finals :: state -> Bool`, rather than `Set state`, to indicate that +-- the machine is in some final state. Similarly for `alpha`, which +-- indicates the alphabet of inputs to a machine. +-- The function `delta` returns `Maybe` values, where `Nothing` +-- indicates that no valid transition is possible: ie, there has been an +-- error. +data Machine s i = Machine + { initial :: s -- ^ Initial state + , final :: s -> Bool -- ^ Valid final states + , alpha :: i -> Bool -- ^ Valid input alphabet + , delta :: s -> i -> Maybe s -- ^ State transition function + } + +-- | This machine always accepts, never terminates, and always has unit state. +unitMachine :: Machine () i +unitMachine = Machine + { initial = () + , final = const False + , alpha = const True + , delta = (\s i -> Just ()) + } + +-- | The `step` function runs a machine in a state against a single input. +-- The state remains fixed once a final state is encountered. The +-- result is `Left state input` if some `state` failed for an `ìnput`, and +-- `Right state` for a successful state. +step :: Machine s i -> s -> i -> Either (s, i) s +step m s i + | final m s = Right s + | alpha m i = case delta m s i of + Just s' -> Right s' + Nothing -> Left (s, i) + | otherwise = Right s + +-- | The `validate` function takes a machine and a list of inputs. The machine +-- is started from its initial state and run agains the inputs in turn. +-- It returns the state and input on failure, and just the state on success. +validate :: Machine s i -> [i] -> Either (s, i) s +validate m = foldl (>>=) (Right (initial m)) . map (flip (step m)) + +-- | This function is similar to `validate`, but outputs each intermediary +-- state as well. For an incremental version, use `simulate`. +validates :: Machine s i -> [i] -> [Either (s, i) s] +validates m = scanl (>>=) (Right (initial m)) . map (flip (step m)) + +-------------------------------------------------------------------------------- +-- A Process is a list of successful values, followed by an error if one +-- occured. This captures the idea that a computation may produce a list of +-- elements before possibly failing. This gives us an incremental interface +-- to data processed from machine transitions. +data Process e a + = Done + | Fail e + | Prod a (Process e a) + deriving Show + +toList :: Process e a -> [a] +toList (Fail _) = [] +toList Done = [] +toList (Prod a as) = a : toList as + +toMaybe :: Process e a -> Maybe e +toMaybe (Fail e) = Just e +toMaybe Done = Nothing +toMaybe (Prod _ as) = toMaybe as + +-- | A machine can be analysed while it is accepting input in order to extract +-- some information. This function takes a machine and a function that extracts +-- data and produces output. On failure, the machine state and input are +-- produced. Note that when an input is not in the machine's alphabet, +-- then there is no transition, and so no output is produced in response +-- to that input. +analyse :: Machine s i -- ^ The machine used + -> (s -> i -> Maybe o) -- ^ An extraction function that may produce output + -> [i] -- ^ A list of input + -> Process (s, i) o -- ^ A process that produces output +analyse machine extract is = go (initial machine) is + where + -- go :: s -> [i] -> Process (s, i) o + go _ [] = Done + go s (i:is) + | final machine s = Done + | alpha machine i = + case delta machine s i of + Nothing -> Fail (s, i) + Just s' -> + case extract s i of + Nothing -> go s' is + Just o -> Prod o (go s' is) + | otherwise = go s is + +-- | Machines sometimes need to operate on coarser input than they are defined +-- for. This function takes a function that refines input and a machine that +-- works on refined input, and produces a machine that can work on coarse input. +refineM :: (i -> j) -> Machine s j -> Machine s i +refineM refine machine = Machine + { initial = initial machine + , final = final machine + , alpha = alpha machine . refine + , delta = \s -> delta machine s . refine + } + +-------------------------------------------------------------------------------- +-- | This function produces a process that outputs all the states that a +-- machine goes through. +simulate :: Machine s i -> [i] -> Process (s, i) (s, i) +simulate machine = analyse machine (\s i -> delta machine s i >>= \s' -> return (s', i)) + +-------------------------------------------------------------------------------- +-- | A state augmented by Timestamp information is held in `profileState`. +-- When the state changes, `profileMap` stores a map between each state +-- and its cumulative time. +data Profile s = Profile + { profileState :: s -- ^ The current state + , profileTime :: Timestamp -- ^ The entry time of the state + } deriving (Show) + +-- | This function takes a machine and profiles its state. +profileM :: Ord s + => (i -> Timestamp) + -> Machine s i + -> Machine (Profile s) i +profileM timer machine = Machine + { initial = Profile (initial machine) 0 + , final = final machine . profileState + , alpha = alpha machine + , delta = profileMDelta + } + where + profileMDelta (Profile s _) i = do + s' <- delta machine s i + return $ Profile s' (timer i) + +-- | extractProfile returns the state, the time this state was made, +-- and the time spent in this state. +extractProfile :: (i -> Timestamp) -- ^ Extracts current timestamp + -> Profile s -- ^ A profiled state + -> i -- ^ Some input + -> Maybe (s, Timestamp, Timestamp) -- ^ (state, currentTime, elapsedTime) +extractProfile timer p i = Just (profileState p, profileTime p, timer i - profileTime p) + +profile :: (Ord s, Eq s) + => Machine s i -- ^ A machine to profile + -> (i -> Timestamp) -- ^ Converts input to timestamps + -> [i] -- ^ The list of input + -> Process (Profile s, i) (s, Timestamp, Timestamp) +profile machine timer = + analyse (profileM timer machine) + (extractProfile timer) + +profileIndexed :: (Ord k, Ord s, Eq s) + => Machine s i + -> (i -> Maybe k) + -> (i -> Timestamp) + -> [i] + -> Process (Map k (Profile s), i) (k, (s, Timestamp, Timestamp)) +profileIndexed machine index timer = + analyse (indexM index (profileM timer machine)) + (extractIndexed (extractProfile timer) index) + +extractIndexed :: Ord k => (s -> i -> Maybe o) -> (i -> Maybe k) -> (Map k s -> i -> Maybe (k, o)) +extractIndexed extract index m i = do + k <- index i + s <- M.lookup k m + o <- extract s i + return (k, o) + +-- | An indexed machine takes a function that multiplexes the input to a key +-- and then takes a machine description to an indexed machine. +indexM :: Ord k + => (i -> Maybe k) -- ^ An indexing function + -> Machine s i -- ^ A machine to index with + -> Machine (Map k s) i -- ^ The indexed machine +indexM index machine = Machine + { initial = M.empty + , final = indexMFinal + , alpha = indexMAlpha + , delta = indexMDelta + } + where + -- An indexer never reaches a final state: it is always possible that + -- an event comes along that is accepted by a machine that is not + -- yet in in the index. + -- + -- An alternative view is that the indexer is in a final state if all its + -- elements are, but this would not allow the creation of new indexes: + -- indexMFinal m = not (M.null m) && (all (final machine) . M.elems $ m) + indexMFinal = const False + + -- The alphabet of the indexer is that of its elements. + indexMAlpha = alpha machine + + -- If the index is not yet in the mapping, we start a new machine in its + -- initial state. The indexer fails if indexed state fails. + indexMDelta m i = do + k <- index i + let state = fromMaybe (initial machine) (M.lookup k m) + state' <- delta machine state i + return $ M.insert k state' m + +profileRouted :: (Ord k, Ord s, Eq s, Eq r) + => Machine s i + -> Machine r i + -> (r -> i -> Maybe k) + -> (i -> Timestamp) + -> [i] + -> Process ((Map k (Profile s), r), i) (k, (s, Timestamp, Timestamp)) +profileRouted machine router index timer = + analyse (routeM router index (profileM timer machine)) + (extractRouted (extractProfile timer) index) + +extractRouted :: Ord k => (s -> i -> Maybe o) -> (r -> i -> Maybe k) -> ((Map k s, r) -> i -> Maybe (k, o)) +extractRouted extract index (m, r) i = do + k <- index r i + s <- M.lookup k m + o <- extract s i + return (k, o) + + +-- | A machine can be indexed not only by the inputs, but also by the state +-- of an intermediary routing machine. This is a generalisation of indexM. +routeM :: (Ord k) + => Machine r i + -> (r -> i -> Maybe k) + -> Machine s i + -> Machine (Map k s, r) i +routeM router index machine = Machine + { initial = (M.empty, initial router) + , final = routeMFinal + , alpha = routeMAlpha + , delta = routeMDelta + } + where + -- As with indexers, there is no final state. + routeMFinal = const False + + -- The alphabet is that of the router combined with the machine + routeMAlpha i = alpha router i || alpha machine i + + routeMDelta (m, r) i = do + r' <- if alpha router i + then delta router r i + else return r + m' <- if alpha machine i + then case index r' i of + Just k -> do + s' <- delta machine (fromMaybe (initial machine) (M.lookup k m)) i + return $ M.insert k s' m + Nothing -> return m + else return m + return (m', r') + diff --git a/GHC/RTS/Events/Analysis/Capability.hs b/GHC/RTS/Events/Analysis/Capability.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events/Analysis/Capability.hs @@ -0,0 +1,100 @@ +module GHC.RTS.Events.Analysis.Capability + ( capabilityThreadPoolMachine + , capabilityThreadRunMachine + , capabilityThreadIndexer + ) + where + +import GHC.RTS.Events +import GHC.RTS.Events.Analysis + +import Data.Map (Map) +import qualified Data.Map as M + +-- | This state machine tracks threads residing on capabilities. +-- Each thread can only reside on one capability, but can be migrated between +-- them. +capabilityThreadPoolMachine :: Machine (Map ThreadId Int) CapEvent +capabilityThreadPoolMachine = Machine + { initial = M.empty + , final = const False + , alpha = capabilityThreadPoolMachineAlpha + , delta = capabilityThreadPoolMachineDelta + } + where + capabilityThreadPoolMachineAlpha capEvent = case spec . ce_event $ capEvent of + (CreateThread _) -> True + (StopThread _ _) -> True + (MigrateThread _ _) -> True + _ -> False + + capabilityThreadPoolMachineDelta mapping capEvent = do + capId <- ce_cap capEvent + case spec . ce_event $ capEvent of + (CreateThread threadId) -> insertThread threadId capId mapping + (StopThread threadId ThreadFinished) -> deleteThread threadId mapping + (StopThread _ _) -> Just mapping + (MigrateThread threadId capId') -> deleteThread threadId mapping >>= + insertThread threadId capId' + _ -> Nothing + where + insertThread :: ThreadId -> Int -> Map ThreadId Int -> Maybe (Map ThreadId Int) + insertThread threadId capId m + | threadId `elem` M.keys m = Nothing -- The thread already exists + | otherwise = Just $ M.insert threadId capId m + + deleteThread :: ThreadId -> Map ThreadId Int -> Maybe (Map ThreadId Int) + deleteThread threadId m + | notElem threadId . M.keys $ m = Nothing -- The thread doesn't exist + | otherwise = Just $ M.delete threadId m + +-- | This state machine tracks threads running on capabilities, only one thread +-- may run on a capability at a time. +capabilityThreadRunMachine :: Machine (Map Int ThreadId) CapEvent +capabilityThreadRunMachine = Machine + { initial = M.empty + , final = const False + , alpha = threadRunAlpha + , delta = threadRunDelta + } + where + threadRunAlpha capEvent = case spec . ce_event $ capEvent of + -- TODO: can threads be migrated while they are running? + -- TODO: take into account paused threads + (RunThread _) -> True + (StopThread _ _ ) -> True + _ -> False + + -- The indexer fails if a thread is inserted where one already exists, + -- or if a thread is deleted that doesn't exist. + threadRunDelta mapping e = do + capId <- ce_cap e + case spec . ce_event $ e of + (RunThread threadId) -> runThread capId threadId mapping + (StopThread threadId _ ) -> stopThread threadId mapping + _ -> Just mapping + where + runThread :: Int -> ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId) + runThread capId threadId m + | M.member capId m = Nothing -- A thread is already on this cap + | threadId `elem` M.elems m = Nothing -- This thread is already on a cap + | otherwise = Just $ M.insert capId threadId m + stopThread :: ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId) + stopThread threadId m + | notElem threadId . M.elems $ m = Nothing -- The thread doesn't exist + | otherwise = Just $ M.filter (/= threadId) m + +capabilityThreadIndexer :: Map Int ThreadId -> CapEvent -> Maybe ThreadId +capabilityThreadIndexer m capEvent = case spec . ce_event $ capEvent of + (CreateSparkThread threadId) -> Just threadId + (CreateThread threadId) -> Just threadId + (RunThread threadId) -> Just threadId + (StopThread threadId _) -> Just threadId + (ThreadRunnable threadId) -> Just threadId + (MigrateThread threadId _) -> Just threadId + (WakeupThread threadId capId) -> if Just capId == ce_cap capEvent + then Just threadId + else Nothing + _ -> mThreadId + where + mThreadId = ce_cap capEvent >>= (\capId -> M.lookup capId m) diff --git a/GHC/RTS/Events/Analysis/SparkThread.hs b/GHC/RTS/Events/Analysis/SparkThread.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events/Analysis/SparkThread.hs @@ -0,0 +1,114 @@ +module GHC.RTS.Events.Analysis.SparkThread + ( SparkThreadState (..) + , sparkThreadMachine + , capabilitySparkThreadMachine + , capabilitySparkThreadIndexer + ) + where + +import GHC.RTS.Events +import GHC.RTS.Events.Analysis + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import Debug.Trace + +data SparkThreadState + = SparkThreadInitial + | SparkThreadCreated + | SparkThreadRunning Int + | SparkThreadPaused Int + | SparkThreadFinal + deriving (Eq, Ord, Show) + +sparkThreadMachine :: Machine SparkThreadState EventInfo +sparkThreadMachine = Machine + { initial = SparkThreadInitial + , final = sparkThreadFinal + , alpha = sparkThreadAlpha + , delta = sparkThreadDelta + } + where + sparkThreadFinal SparkThreadFinal = True + sparkThreadFinal _ = False + + -- sparkThreadAlpha (CreateSparkThread _) = True + sparkThreadAlpha (RunThread _) = True + sparkThreadAlpha (StopThread _ _) = True + sparkThreadAlpha SparkRun = True + sparkThreadAlpha (SparkSteal _) = True + sparkThreadAlpha _ = False + + -- SparkThreadInitial + -- sparkThreadDelta SparkThreadInitial (CreateSparkThread _) = Just SparkThreadInitial + sparkThreadDelta SparkThreadInitial (RunThread _) = Just SparkThreadCreated + -- SparkThreadCreated + sparkThreadDelta SparkThreadCreated SparkRun = Just (SparkThreadRunning 0) + sparkThreadDelta SparkThreadCreated (SparkSteal _) = Just (SparkThreadRunning 0) + sparkThreadDelta SparkThreadCreated (StopThread _ ThreadFinished) = Just SparkThreadFinal + -- SparkThreadRunning + sparkThreadDelta (SparkThreadRunning n) (StopThread _ ThreadFinished) = Just SparkThreadFinal + sparkThreadDelta (SparkThreadRunning n) (StopThread _ _) = Just (SparkThreadPaused n) + sparkThreadDelta (SparkThreadRunning n) SparkRun = Just (SparkThreadRunning (n+1)) + sparkThreadDelta (SparkThreadRunning n) (SparkSteal _) = Just (SparkThreadRunning (n+1)) + -- SparkThreadPaused + sparkThreadDelta (SparkThreadPaused n) (RunThread _) = Just (SparkThreadRunning n) + -- Other + sparkThreadDelta _ _ = Nothing + +capabilitySparkThreadMachine :: Machine (Map Int ThreadId, Set ThreadId) CapEvent +capabilitySparkThreadMachine = Machine + { initial = (M.empty, S.empty) + , final = const False + , alpha = capabilitySparkThreadAlpha + , delta = capabilitySparkThreadDelta + } + where + capabilitySparkThreadAlpha capEvent = case spec . ce_event $ capEvent of + (CreateSparkThread _) -> True + (RunThread _) -> True + (StopThread _ _) -> True + _ -> False + capabilitySparkThreadDelta (m, s) e = do + capId <- ce_cap e + case spec . ce_event $ e of + (CreateSparkThread threadId) -> createThread threadId + -- (StopThread threadId ThreadFinished) -> stopThread threadId + (StopThread threadId _) -> pauseThread threadId + (RunThread threadId) -> runThread capId threadId + _ -> Just (m, s) + where + createThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId) + createThread threadId + | S.member threadId s = Nothing -- A spark thread with this Id already created + | otherwise = Just (m, S.insert threadId s) + + runThread :: Int -> ThreadId -> Maybe (Map Int ThreadId, Set ThreadId) + runThread capId threadId + | M.member capId m = Nothing -- A thread is already on this cap + | threadId `elem` M.elems m = Nothing -- This thread is already on a cap + | S.notMember threadId s = Just (m, s) -- Not a spark thread + | otherwise = Just (M.insert capId threadId m, S.insert threadId s) + + stopThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId) + stopThread threadId = Just (M.filter (/= threadId) m, S.delete threadId s) + + pauseThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId) + pauseThread threadId = Just (M.filter (/= threadId) m, s) + +capabilitySparkThreadIndexer :: (Map Int ThreadId, Set ThreadId) -> CapEvent -> Maybe ThreadId +capabilitySparkThreadIndexer (m, s) capEvent = case spec . ce_event $ capEvent of + (CreateThread threadId) -> inSparkThreadPool threadId + (RunThread threadId) -> inSparkThreadPool threadId + (StopThread threadId _) -> inSparkThreadPool threadId + -- (WakeupThread threadId _) -> inSparkThreadPool threadId + _ -> ce_cap capEvent >>= (\capId -> M.lookup capId m) + where + inSparkThreadPool :: ThreadId -> Maybe ThreadId + inSparkThreadPool threadId + | S.member threadId s = Just threadId + | otherwise = Nothing + diff --git a/GHC/RTS/Events/Analysis/Thread.hs b/GHC/RTS/Events/Analysis/Thread.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events/Analysis/Thread.hs @@ -0,0 +1,53 @@ +module GHC.RTS.Events.Analysis.Thread + ( ThreadState (..) + , threadMachine + ) + where + +import GHC.RTS.Events +import GHC.RTS.Events.Analysis + +-------------------------------------------------------------------------------- +-- | This datatype defines the state machine for a single thread. +data ThreadState + = ThreadInitial + | ThreadQueued + | ThreadRunning + | ThreadStopped + | ThreadFinal + deriving (Show, Eq, Ord) + +-- | This state machine tracks the events processed by a thread. +threadMachine :: Machine ThreadState EventInfo +threadMachine = Machine + { initial = ThreadInitial + , final = threadFinal + , alpha = threadAlpha + , delta = threadDelta + } + where + threadFinal ThreadFinal = True + threadFinal _ = False + + threadAlpha (CreateThread _) = True + threadAlpha (RunThread _) = True + threadAlpha (StopThread _ _) = True + threadAlpha (WakeupThread _ _) = True + threadAlpha _ = False + + -- ThreadInitial + threadDelta ThreadInitial (CreateThread _) = Just ThreadQueued + -- ThreadQueued + threadDelta ThreadQueued (RunThread _) = Just ThreadRunning + threadDelta ThreadQueued (WakeupThread _ _) = Just ThreadQueued + -- ThreadRunning + threadDelta ThreadRunning (StopThread _ StackOverflow) = Just ThreadQueued + threadDelta ThreadRunning (StopThread _ HeapOverflow) = Just ThreadQueued + threadDelta ThreadRunning (StopThread _ ForeignCall) = Just ThreadQueued + threadDelta ThreadRunning (StopThread _ ThreadFinished) = Just ThreadFinal + threadDelta ThreadRunning (StopThread _ _) = Just ThreadStopped + -- ThreadStopped + threadDelta ThreadStopped (RunThread _) = Just ThreadRunning + threadDelta ThreadStopped (WakeupThread _ _) = Just ThreadQueued + -- Unknown + threadDelta _ _ = Nothing diff --git a/GHC/RTS/Events/Merge.hs b/GHC/RTS/Events/Merge.hs new file mode 100644 --- /dev/null +++ b/GHC/RTS/Events/Merge.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module GHC.RTS.Events.Merge (mergeEventLogs) where + +import GHC.RTS.Events +import Data.Monoid +import Data.List (foldl') +import Data.Word (Word32, Word16) + +{- +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. +-} + +mergeEventLogs :: EventLog -> EventLog -> EventLog +mergeEventLogs (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2 + = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys +mergeEventLogs _ _ = 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 } +-- TODO introduce parallel RTS process and machine var.s + +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 + -- TODO extend by new shift for Eden events diff --git a/GhcEvents.hs b/GhcEvents.hs new file mode 100644 --- /dev/null +++ b/GhcEvents.hs @@ -0,0 +1,217 @@ +module Main where + +import GHC.RTS.Events +import GHC.RTS.Events.Merge +import GHC.RTS.Events.Analysis +import GHC.RTS.Events.Analysis.SparkThread +import GHC.RTS.Events.Analysis.Thread +import GHC.RTS.Events.Analysis.Capability + +import System.Environment +import Text.Printf +import Data.List +import Data.Either (rights) +import Data.Function +import Data.IntMap (IntMap) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import System.IO +import System.Exit + +main = getArgs >>= command + +command ["--help"] = do + putStr usage + +command ["show", file] = do + log <- readLogOrDie file + putStrLn $ ppEventLog log + +command ["show", "threads", file] = do + eventLog <- readLogOrDie file + let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog + let capEvents = sortEvents . events . dat $ eventLog + let mappings = rights . validates capabilityThreadRunMachine $ capEvents + let indexes = map (uncurry capabilityThreadIndexer) $ zip mappings capEvents + let threadMap = M.fromListWith (++) . reverse $ zip indexes (map return capEvents) + putStrLn "Event Types:" + putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog + putStrLn "Thread Indexed Events:" + putStrLn . showMap + ((++ "\n") . show) + (unlines . map ((" " ++) . ppEvent eventTypeMap)) $ + threadMap + +command ["show", "caps", file] = do + eventLog <- readLogOrDie file + let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog + let capEvents = sortEvents . events . dat $ eventLog + let indexes = map ce_cap capEvents + let capMap = M.fromListWith (++) . reverse $ zip indexes (map return capEvents) + putStrLn "Event Types:" + putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog + putStrLn "Cap Indexed Events:" + putStrLn . showMap + ((++ "\n") . show) + (unlines . map ((" " ++) . ppEvent eventTypeMap)) $ + capMap + +command ["merge", out, file1, file2] = do + log1 <- readLogOrDie file1 + log2 <- readLogOrDie file2 + let m = mergeEventLogs log1 log2 + writeEventLogToFile out m + +command ["validate", "threads", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate (routeM capabilityThreadRunMachine + capabilityThreadIndexer + (refineM (spec . ce_event) threadMachine)) + capEvents + putStrLn $ showValidate (\(m, n) -> + "\nThread States:\n" ++ showIndexed show show m ++ + "\nCap States:\n" ++ showIndexed show show n) + show result + +command ["validate", "threadpool", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate capabilityThreadPoolMachine capEvents + putStrLn $ showValidate show show result + +command ["validate", "threadrun", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate capabilityThreadRunMachine capEvents + putStrLn $ showValidate show show result + +command ["validate", "sparks", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate + (routeM capabilitySparkThreadMachine capabilitySparkThreadIndexer + (refineM (spec . ce_event) sparkThreadMachine)) + capEvents + putStrLn $ showValidate show show result + +command ["simulate", "threads", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate (routeM capabilityThreadRunMachine + capabilityThreadIndexer + (refineM (spec . ce_event) threadMachine)) + capEvents + putStrLn . showProcess $ result + +command ["simulate", "threadpool", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate capabilityThreadPoolMachine capEvents + putStrLn . showProcess $ result + +command ["simulate", "threadrun", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate capabilityThreadRunMachine capEvents + putStrLn . showProcess $ result + +command ["simulate", "sparks", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate + (routeM capabilitySparkThreadMachine + capabilitySparkThreadIndexer + (refineM (spec . ce_event) sparkThreadMachine)) + capEvents + putStrLn . showProcess $ result + +command ["profile", "threads", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = profileRouted + (refineM (spec. ce_event) threadMachine) + capabilityThreadRunMachine + capabilityThreadIndexer + (time . ce_event) + capEvents + putStrLn . showProcess $ result + +command ["profile", "sparks", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = profileRouted + (refineM (spec . ce_event) sparkThreadMachine) + capabilitySparkThreadMachine + capabilitySparkThreadIndexer + (time . ce_event) + capEvents + putStrLn . showProcess $ result + +command _ = putStr usage >> die "Unrecognized command" + +usage = unlines $ map pad strings + where + align = 4 + (maximum . map (length . fst) $ strings) + pad (x, y) = zipWith const (x ++ repeat ' ') (replicate align ()) ++ y + strings = [ ("ghc-events --help:", "Display this help.") + + , ("ghc-events show :", "Pretty print an event log.") + , ("ghc-events show threads :", "Pretty print an event log, ordered by threads.") + , ("ghc-events show caps :", "Pretty print an event log, ordered by capabilities.") + + , ("ghc-events merge :", "Merge two event logs.") + + , ("ghc-events sparks-csv :", "Print spark information in CSV.") + + , ("ghc-events validate threads :", "Validate thread states.") + , ("ghc-events validate threadpool :", "Validate thread pool state.") + , ("ghc-events validate threadrun :", "Validate thread running state.") + , ("ghc-events validate sparks :", "Validate spark thread states.") + + , ("ghc-events simulate threads :", "Simulate thread states.") + , ("ghc-events simulate threadpool :", "Simulate thread pool state.") + , ("ghc-events simulate threadrun :", "Simulate thread running state.") + , ("ghc-events simulate sparks :", "Simulate spark thread states.") + + , ("ghc-events profile threads :", "Profile thread states.") + , ("ghc-events profile sparks :", "Profile spark thread states.") + ] + +readLogOrDie file = do + e <- readEventLogFromFile file + case e of + Left s -> die ("Failed to parse " ++ file ++ ": " ++ s) + Right log -> return log + +die s = do hPutStrLn stderr s; exitWith (ExitFailure 1) + +showValidate :: (s -> String) -> (i -> String) -> Either (s, i) s -> String +showValidate showState showInput (Left (state, input)) = + "Invalid eventlog:" + ++ "\nState:\n" ++ ( showState state ) + ++ "\nInput:\n" ++ ( showInput input ) +showValidate showState _ (Right state) = + "Valid eventlog: " ++ ( showState state ) + +showProcess :: (Show e, Show a) => Process e a -> String +showProcess process = + "Trace:\n" + ++ (unlines . map show . toList) process + ++ "\n" + ++ (maybe "Valid." (("Invalid:\n" ++) . show) . toMaybe) process + +showIndexed :: (k -> String) -> (v -> String) -> Map k v -> String +showIndexed showKey showValue m + | M.null m = "Empty map\n" + | otherwise = "Indexed output:\n" ++ + concatMap (\(k, v) -> "Key: " ++ ( showKey k ) ++ ", Value: " + ++ ( showValue v ) ++ "\n") + (M.toList m) + +showMap :: Ord k => (k -> String) -> (a -> String) -> M.Map k a -> String +showMap showKey showValue m = + concat $ zipWith (++) + (map showKey . M.keys $ m :: [String]) + (map (showValue . (M.!) m) . M.keys $ m :: [String]) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/ghc-events-parallel.cabal b/ghc-events-parallel.cabal new file mode 100644 --- /dev/null +++ b/ghc-events-parallel.cabal @@ -0,0 +1,58 @@ +name: ghc-events-parallel +version: 0.4.0.0 +synopsis: Library and tool for parsing .eventlog files from parallel GHC +description: Parses .eventlog files emitted by parallel GHC versions + (6.12.3 and later). This package can replace the original + ghc-events package and defines a superset of functions + and types. + Includes the ghc-events tool permitting, in particular, + to dump an event log file as text. +category: Development, GHC, Debug, Eden, Profiling, Trace +license: BSD3 +license-file: LICENSE +author: Donnie Jones , + Simon Marlow , + Paul Bone , + Mischa Dieterle , + Thomas Horstmeyer , + Duncan Coutts , + Nicolas Wu , + Jost Berthold +maintainer: Eden group +bug-reports: to maintainer via mail +build-type: Simple +cabal-version: >= 1.8 +extra-source-files: GHC/RTS/EventLogFormat.h, + AUTHORS, + test/*.eventlog + +source-repository head + type: darcs + location: http://james.mathematik.uni-marburg.de:8080/darcs/jb/ghc-events-parallel/ + +library + build-depends: base == 4.*, + mtl >= 1.1 && < 2.1, + containers >= 0.2 && < 0.5, + binary == 0.5.*, + bytestring == 0.9.*, + array >= 0.2 && < 0.5 + exposed-modules: GHC.RTS.Events, + GHC.RTS.Events.Merge + GHC.RTS.Events.Analysis + GHC.RTS.Events.Analysis.Capability + GHC.RTS.Events.Analysis.SparkThread + GHC.RTS.Events.Analysis.Thread + other-modules: GHC.RTS.EventParserUtils, + GHC.RTS.EventTypes + extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + +executable ghc-events + main-is: GhcEvents.hs + build-depends: base, mtl, containers, binary, bytestring, array + extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + +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/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 diff --git a/test/mdlLogMPI1.eventlog b/test/mdlLogMPI1.eventlog new file mode 100644 Binary files /dev/null and b/test/mdlLogMPI1.eventlog differ