ghc-events-parallel (empty) → 0.4.0.0
raw patch · 16 files changed
+3112/−0 lines, 16 filesdep +arraydep +basedep +binarysetup-changedbinary-added
Dependencies added: array, base, binary, bytestring, containers, mtl
Files
- AUTHORS +7/−0
- GHC/RTS/EventLogFormat.h +264/−0
- GHC/RTS/EventParserUtils.hs +198/−0
- GHC/RTS/EventTypes.hs +384/−0
- GHC/RTS/Events.hs +1316/−0
- GHC/RTS/Events/Analysis.hs +283/−0
- GHC/RTS/Events/Analysis/Capability.hs +100/−0
- GHC/RTS/Events/Analysis/SparkThread.hs +114/−0
- GHC/RTS/Events/Analysis/Thread.hs +53/−0
- GHC/RTS/Events/Merge.hs +83/−0
- GhcEvents.hs +217/−0
- LICENSE +31/−0
- Setup.lhs +4/−0
- ghc-events-parallel.cabal +58/−0
- test/mandelbrot-mmc-2011-06-14.eventlog binary
- test/mdlLogMPI1.eventlog binary
+ AUTHORS view
@@ -0,0 +1,7 @@+Donnie Jones <donnie@darthik.com>+Simon Marlow <marlowsd@gmail.com>+Paul Bone <pbone@csse.unimelb.edu.au>,+Duncan Coutts <duncan@well-typed.com>,+Mischa Dieterle <dieterle@mathematik.uni-marburg.de>,+Thomas Horstmeyer <horstmey@mathematik.uni-marburg.de>,+Jost Berthold <berthold@diku.dk>
+ GHC/RTS/EventLogFormat.h view
@@ -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 */
+ GHC/RTS/EventParserUtils.hs view
@@ -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 }
+ GHC/RTS/EventTypes.hs view
@@ -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
+ GHC/RTS/Events.hs view
@@ -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')
+ GHC/RTS/Events/Analysis.hs view
@@ -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')+
+ GHC/RTS/Events/Analysis/Capability.hs view
@@ -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)
+ GHC/RTS/Events/Analysis/SparkThread.hs view
@@ -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+
+ GHC/RTS/Events/Analysis/Thread.hs view
@@ -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
+ GHC/RTS/Events/Merge.hs view
@@ -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
+ GhcEvents.hs view
@@ -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 <file>:", "Pretty print an event log.")+ , ("ghc-events show threads <file>:", "Pretty print an event log, ordered by threads.")+ , ("ghc-events show caps <file>:", "Pretty print an event log, ordered by capabilities.")++ , ("ghc-events merge <out> <in1> <in2>:", "Merge two event logs.")++ , ("ghc-events sparks-csv <file>:", "Print spark information in CSV.")++ , ("ghc-events validate threads <file>:", "Validate thread states.")+ , ("ghc-events validate threadpool <file>:", "Validate thread pool state.")+ , ("ghc-events validate threadrun <file>:", "Validate thread running state.")+ , ("ghc-events validate sparks <file>:", "Validate spark thread states.")++ , ("ghc-events simulate threads <file>:", "Simulate thread states.")+ , ("ghc-events simulate threadpool <file>:", "Simulate thread pool state.")+ , ("ghc-events simulate threadrun <file>:", "Simulate thread running state.")+ , ("ghc-events simulate sparks <file>:", "Simulate spark thread states.")++ , ("ghc-events profile threads <file>:", "Profile thread states.")+ , ("ghc-events profile sparks <file>:", "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])
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ ghc-events-parallel.cabal view
@@ -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 <donnie@darthik.com>, + Simon Marlow <marlowsd@gmail.com>,+ Paul Bone <pbone@csse.unimelb.edu.au>,+ Mischa Dieterle <dieterle@mathematik.uni-marburg.de>,+ Thomas Horstmeyer <horstmey@mathematik.uni-marburg.de>,+ Duncan Coutts <duncan@well-typed.com>,+ Nicolas Wu <nick@well-typed.com>,+ Jost Berthold <berthold@diku.dk>+maintainer: Eden group <eden@mathematik.uni-marburg.de>+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
+ test/mandelbrot-mmc-2011-06-14.eventlog view
binary file changed (absent → 104182 bytes)
+ test/mdlLogMPI1.eventlog view
binary file changed (absent → 67530 bytes)