ghc-events 0.4.4.0 → 0.6.0

raw patch · 38 files changed

+11914/−3559 lines, 38 filesdep +ghc-eventsdep −mtldep ~arraydep ~basedep ~binarynew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-events

Dependencies removed: mtl

Dependency ranges changed: array, base, binary, bytestring, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +32/−0
• GHC/RTS/EventLogFormat.h +0/−312
• GHC/RTS/EventParserUtils.hs +0/−199
• GHC/RTS/EventTypes.hs +0/−513
• GHC/RTS/Events.hs +0/−1643
• GHC/RTS/Events/Analysis.hs +0/−282
• GHC/RTS/Events/Analysis/Capability.hs +0/−209
• GHC/RTS/Events/Analysis/SparkThread.hs +0/−114
• GHC/RTS/Events/Analysis/Thread.hs +0/−53
• GHC/RTS/Events/Merge.hs +0/−118
• GhcEvents.hs +73/−72
• README.md +13/−0
• ghc-events.cabal +46/−14
• include/EventLogFormat.h +312/−0
• src/GHC/RTS/EventParserUtils.hs +181/−0
• src/GHC/RTS/EventTypes.hs +528/−0
• src/GHC/RTS/Events.hs +495/−0
• src/GHC/RTS/Events/Analysis.hs +272/−0
• src/GHC/RTS/Events/Analysis/Capability.hs +209/−0
• src/GHC/RTS/Events/Analysis/SparkThread.hs +110/−0
• src/GHC/RTS/Events/Analysis/Thread.hs +53/−0
• src/GHC/RTS/Events/Binary.hs +1228/−0
• src/GHC/RTS/Events/Incremental.hs +205/−0
• src/GHC/RTS/Events/Merge.hs +113/−0
• test/782stop.eventlog.reference +147/−0
• test/783stop.eventlog.reference +148/−0
• test/TestVersions.hs +5/−30
• test/Utils.hs +25/−0
• test/WriteMerge.hs +46/−0
• test/mandelbrot-mmc-2011-06-14.eventlog.reference +5596/−0
• test/mdlLogMPI1.eventlog binary
• test/parallelTest.eventlog binary
• test/parallelTest.eventlog.reference +486/−0
• test/pre77stop.eventlog.reference +139/−0
• test/queens-ghc-6.12.1.eventlog binary
• test/queens-ghc-6.12.1.eventlog.reference +509/−0
• test/queens-ghc-7.0.2.eventlog binary
• test/queens-ghc-7.0.2.eventlog.reference +943/−0

@@ -0,0 +1,32 @@+# Change Log++## Unreleased++## 0.6.0 - 2017-05-31++This contains breaking changes.++* The deprecation notice on `readEventLogFromFile` has been retracted+* The incremental API has been refactored++The details are as follows:++* Update bug tracker URL ([#10](https://github.com/haskell/ghc-events/pull/10))+* New test for Eden events ([#11](https://github.com/haskell/ghc-events/pull/11))+* Relax version bound for binary ([#15](https://github.com/haskell/ghc-events/pull/15))+* Enable Travis CI ([#19](https://github.com/haskell/ghc-events/pull/19))+* Refactor the incremental API which was introduced in 0.5.0.0 ([#22](https://github.com/haskell/ghc-events/pull/22))+* Some speed/memory usage improvements ([#18](https://github.com/haskell/ghc-events/pull/18), [#22](https://github.com/haskell/ghc-events/pull/22))++## 0.5.0.0 - unreleased++* Readme added :)+* Old parser replaced with an incremental implementation+* General overhaul of the codebase+* Partial Haddock coverage++The 0.5.* releases should be able to handle large event logs and logs that have been cut off abruptly, e.g. from executable runs that resulted in crashes.++This release should be *mostly* backwards compatible, however the "old" way of reading event logs, namely the `readEventLogFromFile`  function is now **deprecated**.++**NOTE:** Users parsing large logs may notice that this version of the library is noticably slower than the older versions. The incremental parser is at fault here - previous versions of the libray used a "trick" that would let them essentially skip the first step of the mergesort algorithm since `EventBlock`s were already sorted in time order. The new parser reads the file incrementally and cannot take the advantage of this. Apologies for any inconvenience this may have caused.

@@ -1,312 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 2008-2012- *- * 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, 7 deprecated */-#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 ...)          */-/* EVENT_STARTUP should be deprecated at some point */-#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,gcd,fiz,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) {not used by ghc} */-#define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */-#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */-#define EVENT_CAP_CREATE          45 /* (cap)                  */-#define EVENT_CAP_DELETE          46 /* (cap)                  */-#define EVENT_CAP_DISABLE         47 /* (cap)                  */-#define EVENT_CAP_ENABLE          48 /* (cap)                  */-#define EVENT_HEAP_ALLOCATED      49 /* (heap_capset, alloc_bytes) */-#define EVENT_HEAP_SIZE           50 /* (heap_capset, size_bytes) */-#define EVENT_HEAP_LIVE           51 /* (heap_capset, live_bytes) */-#define EVENT_HEAP_INFO_GHC       52 /* (heap_capset, n_generations,-                                         max_heap_size, alloc_area_size,-                                         mblock_size, block_size) */-#define EVENT_GC_STATS_GHC        53 /* (heap_capset, generation,-                                         copied_bytes, slop_bytes, frag_bytes,-                                         par_n_threads,-                                         par_max_copied, par_tot_copied) */-#define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */-#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */-#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */-#define EVENT_TASK_DELETE         57 /* (taskID)                 */-#define EVENT_USER_MARKER         58 /* (marker_name) */-#define EVENT_HACK_BUG_T9003      59 /* Hack: see trac #9003 */--/* Range 59 - 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. */--/* Range 140 - 159 is reserved for Perf events, 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)   */-/* shutdown replaced by EVENT_CAP_DELETE */-#define EVENT_SHUTDOWN             7 /* ()                     */-#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 /* () */---/*- * These event types are parsed from hardware performance counters logs,- * such as the Linux Performance Counters data available through- * the perf subsystem.- */--#define EVENT_PERF_NAME           140 /* (perf_num, name) */-#define EVENT_PERF_COUNTER        141 /* (perf_num, tid, period) */-#define EVENT_PERF_TRACEPOINT     142 /* (perf_num, tid) */---/*- * Status values for EVENT_STOP_THREAD- *- * 1-5 are the StgRun return values (from includes/rts/Constants.h):- *- * #define HeapOverflow   1- * #define StackOverflow  2- * #define ThreadYielding 3- * #define ThreadBlocked  4- * #define ThreadFinished 5- * #define ForeignCall                  6- * #define BlockedOnMVar                7- * #define BlockedOnMVarRead            20- * NOTE: in GHC-7.8.2, this was 8, and following states shifted one up- * #define BlockedOnBlackHole           8- * #define BlockedOnRead                9- * #define BlockedOnWrite               10- * #define BlockedOnDelay               11- * #define BlockedOnSTM                 12- * #define BlockedOnDoProc              13- * NOTE: unused GUM states 8, 9 (here: 14,15) in rts/Constants.h- * #define BlockedOnCCall               -- not used (see ForeignCall)- * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)- * #define BlockedOnMsgThrowTo          16- * NOTE: 16 because unused GUM states ignored in ghc-events lib- *       Otherwise it would be 18, following would be 19, 20- * TODO: verify the above is what GHC does (16/17 could be 18/19) - * #define ThreadMigrating              17- * #define BlockedOnMsgGlobalise        18 - * NOTE: not present in GHC. Mercury-Event?- */-#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 StgWord64 EventTaskId;         /* for EVENT_TASK_* */-typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */--typedef StgWord32 EventProcessID;-typedef StgWord16 EventMachineID;-typedef EventThreadID EventPortID;--#endif--#endif /* RTS_EVENTLOGFORMAT_H */

@@ -1,199 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# 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.Except-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 (ExceptT String Get) a--newtype EventParsers = EventParsers (Array Int (GetEvents EventInfo))--type GetHeader a = ExceptT 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 }

@@ -1,513 +0,0 @@-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}--module GHC.RTS.EventTypes where--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Binary---- 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-type PerfEventTypeNum = Word32-type TaskId = Word64-type PID = Word32--newtype KernelThreadId = KernelThreadId { kernelThreadId :: Word64 }-  deriving (Eq, Ord, Show)-instance Binary KernelThreadId where-  put (KernelThreadId tid) = put tid-  get = fmap KernelThreadId get---- 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_taskid :: EventTypeSize-sz_taskid = 8-sz_kernel_tid :: EventTypeSize-sz_kernel_tid = 8-sz_th_stop_status :: EventTypeSize-sz_th_stop_status = 2-sz_string_id :: EventTypeSize-sz_string_id = 4-sz_perf_num :: EventTypeSize-sz_perf_num = 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-                       }-  -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6+-  -- no longer generate the event; should be removed at some point-  | 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            { }--  -- tasks-  | TaskCreate         { taskId :: TaskId,-                         cap :: {-# UNPACK #-}!Int,-                         tid :: {-# UNPACK #-}!KernelThreadId-                       }-  | TaskMigrate        { taskId :: TaskId,-                         cap :: {-# UNPACK #-}!Int,-                         new_cap :: {-# UNPACK #-}!Int-                       }-  | TaskDelete         { taskId :: TaskId }--  -- garbage collection-  | RequestSeqGC       { }-  | RequestParGC       { }-  | StartGC            { }-  | GCWork             { }-  | GCIdle             { }-  | GCDone             { }-  | EndGC              { }-  | GlobalSyncGC       { }-  | GCStatsGHC         { heapCapset   :: {-# UNPACK #-}!Capset-                       , gen          :: {-# UNPACK #-}!Int-                       , copied       :: {-# UNPACK #-}!Word64-                       , slop, frag   :: {-# UNPACK #-}!Word64-                       , parNThreads  :: {-# UNPACK #-}!Int-                       , parMaxCopied :: {-# UNPACK #-}!Word64-                       , parTotCopied :: {-# UNPACK #-}!Word64-                       }--  -- heap statistics-  | HeapAllocated      { heapCapset  :: {-# UNPACK #-}!Capset-                       , allocBytes  :: {-# UNPACK #-}!Word64-                       }-  | HeapSize           { heapCapset  :: {-# UNPACK #-}!Capset-                       , sizeBytes   :: {-# UNPACK #-}!Word64-                       }-  | HeapLive           { heapCapset  :: {-# UNPACK #-}!Capset-                       , liveBytes   :: {-# UNPACK #-}!Word64-                       }-  | HeapInfoGHC        { heapCapset    :: {-# UNPACK #-}!Capset-                       , gens          :: {-# UNPACK #-}!Int-                       , maxHeapSize   :: {-# UNPACK #-}!Word64-                       , allocAreaSize :: {-# UNPACK #-}!Word64-                       , mblockSize    :: {-# UNPACK #-}!Word64-                       , blockSize     :: {-# UNPACK #-}!Word64-                       }--  -- adjusting the number of capabilities on the fly-  | CapCreate          { cap :: {-# UNPACK #-}!Int-                       }-  | CapDelete          { cap :: {-# UNPACK #-}!Int-                       }-  | CapDisable         { cap :: {-# UNPACK #-}!Int-                       }-  | CapEnable          { cap :: {-# UNPACK #-}!Int-                       }--  -- 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 #-}!PID-                       }-  | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset-                       , ppid   :: {-# UNPACK #-}!PID-                       }-  | WallClockTime      { capset :: {-# UNPACK #-}!Capset-                       , sec    :: {-# UNPACK #-}!Word64-                       , nsec   :: {-# UNPACK #-}!Word32-                       }--  -- messages-  | Message            { msg :: String }-  | UserMessage        { msg :: String }-  | UserMarker         { markername :: String }--  -- Events emitted by a parallel RTS-   -- Program /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--  -- perf events-  | PerfName           { perfNum :: {-# UNPACK #-}!PerfEventTypeNum-                       , name    :: String-                       }-  | PerfCounter        { perfNum :: {-# UNPACK #-}!PerfEventTypeNum-                       , tid     :: {-# UNPACK #-}!KernelThreadId-                       , period  :: {-# UNPACK #-}!Word64-                       }-  | PerfTracepoint     { perfNum :: {-# UNPACK #-}!PerfEventTypeNum-                       , tid     :: {-# UNPACK #-}!KernelThreadId-                       }--  deriving Show--{- [Note: Stop status in GHC-7.8.2]--In GHC-7.7, a new thread block reason "BlockedOnMVarRead" was-introduced, and placed adjacent to BlockedOnMVar (7). Therefore, event-logs produced by GHC pre-7.8.2 encode BlockedOnBlackHole and following-as 8..18, whereas GHC-7.8.2 event logs encode them as 9..19.-Later, the prior event numbering was restored for GHC-7.8.3.-See GHC bug #9003 for a discussion.--The parsers in Events.hs have to be adapted accordingly, providing-special ghc-7.8.2 parsers for the thread-stop event if GHC-7.8.2-produced the eventlog.-The EVENT_USER_MARKER was not present in GHC-7.6.3, and a new event-EVENT_HACK_BUG_T9003 was added in GHC-7.8.3, so we take presence of-USER_MARKER and absence of HACK_BUG_T9003 as an indication that-ghc-7.8.2 parsers should be used.--}----sync with ghc/includes/Constants.h-data ThreadStopStatus- = NoStatus- | HeapOverflow- | StackOverflow- | ThreadYielding- | ThreadBlocked- | ThreadFinished- | ForeignCall- | BlockedOnMVar- | BlockedOnMVarRead   -- since GHC-7.8, see [Stop status since GHC-7.7]- | BlockedOnBlackHole- | BlockedOnRead- | BlockedOnWrite- | BlockedOnDelay- | BlockedOnSTM- | BlockedOnDoProc- | BlockedOnCCall- | BlockedOnCCall_NoUnblockExc- | BlockedOnMsgThrowTo- | ThreadMigrating- | BlockedOnMsgGlobalise- | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId- deriving (Show)---- normal GHC encoding, see [Stop status in GHC-7.8.2]-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- 19 ->  NoStatus -- yeuch... this one does not actually exist in GHC eventlogs- 20 ->  BlockedOnMVarRead -- since GHC-7.8.3- _  ->  error "mkStat"---- GHC 7.8.2 encoding, see [Stop status in GHC-7.8.2]-mkStopStatus782 :: RawThreadStopStatus -> ThreadStopStatus-mkStopStatus782 n = case n of- 0  ->  NoStatus- 1  ->  HeapOverflow- 2  ->  StackOverflow- 3  ->  ThreadYielding- 4  ->  ThreadBlocked- 5  ->  ThreadFinished- 6  ->  ForeignCall- 7  ->  BlockedOnMVar- 8  ->  BlockedOnMVarRead -- in GHC-7.8.2- 9  ->  BlockedOnBlackHole- 10 ->  BlockedOnRead- 11 ->  BlockedOnWrite- 12 ->  BlockedOnDelay- 13 ->  BlockedOnSTM- 14 ->  BlockedOnDoProc- 15 ->  BlockedOnCCall- 16 ->  BlockedOnCCall_NoUnblockExc- 17 ->  BlockedOnMsgThrowTo- 18 ->  ThreadMigrating- 19 ->  BlockedOnMsgGlobalise- _  ->  error "mkStat"--maxThreadStopStatusPre77, maxThreadStopStatus782, maxThreadStopStatus -    :: RawThreadStopStatus-maxThreadStopStatusPre77  = 18 -- see [Stop status in GHC-7.8.2]-maxThreadStopStatus782    = 19 -- need to distinguish three cases-maxThreadStopStatus = 20--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

@@ -1,1643 +0,0 @@-{-# LANGUAGE CPP,BangPatterns,PatternGuards #-}-{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-}-{-- -   Parser functions for GHC RTS EventLog framework.- -}--module GHC.RTS.Events (-       -- * The event log types-       EventLog(..),-       EventType(..),-       Event(..),-       EventInfo(..),-       ThreadStopStatus(..),-       Header(..),-       Data(..),-       CapsetType(..),-       Timestamp,-       ThreadId,-       TaskId,-       KernelThreadId(..),-       -- 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,--       -- * Perf events-       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,-       sz_perf_num, sz_kernel_tid-  ) 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.Except-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 (runExceptT $ 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 }-   )),-- -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6+- -- no longer generate the event; should be removed at some point- (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),-- (simpleEvent EVENT_GC_GLOBAL_SYNC GlobalSyncGC),-- (FixedSizeParser EVENT_GC_STATS_GHC (sz_capset + 2 + 5*8 + 4) (do  -- (heap_capset, generation, copied_bytes, slop_bytes, frag_bytes, par_n_threads, par_max_copied, par_tot_copied)-      heapCapset   <- getE-      gen          <- getE :: GetEvents Word16-      copied       <- getE :: GetEvents Word64-      slop         <- getE :: GetEvents Word64-      frag         <- getE :: GetEvents Word64-      parNThreads  <- getE :: GetEvents Word32-      parMaxCopied <- getE :: GetEvents Word64-      parTotCopied <- getE :: GetEvents Word64-      return GCStatsGHC{ gen = fromIntegral gen-                       , parNThreads = fromIntegral parNThreads-                       , ..}- )),-- (FixedSizeParser EVENT_HEAP_ALLOCATED (sz_capset + 8) (do  -- (heap_capset, alloc_bytes)-      heapCapset <- getE-      allocBytes <- getE-      return HeapAllocated{..}- )),-- (FixedSizeParser EVENT_HEAP_SIZE (sz_capset + 8) (do  -- (heap_capset, size_bytes)-      heapCapset <- getE-      sizeBytes  <- getE-      return HeapSize{..}- )),-- (FixedSizeParser EVENT_HEAP_LIVE (sz_capset + 8) (do  -- (heap_capset, live_bytes)-      heapCapset <- getE-      liveBytes  <- getE-      return HeapLive{..}- )),-- (FixedSizeParser EVENT_HEAP_INFO_GHC (sz_capset + 2 + 4*8) (do  -- (heap_capset, n_generations, max_heap_size, alloc_area_size, mblock_size, block_size)-      heapCapset    <- getE-      gens          <- getE :: GetEvents Word16-      maxHeapSize   <- getE :: GetEvents Word64-      allocAreaSize <- getE :: GetEvents Word64-      mblockSize    <- getE :: GetEvents Word64-      blockSize     <- getE :: GetEvents Word64-      return HeapInfoGHC{gens = fromIntegral gens, ..}- )),-- (FixedSizeParser EVENT_CAP_CREATE (sz_cap) (do  -- (cap)-      cap <- getE :: GetEvents CapNo-      return CapCreate{cap = fromIntegral cap}- )),-- (FixedSizeParser EVENT_CAP_DELETE (sz_cap) (do  -- (cap)-      cap <- getE :: GetEvents CapNo-      return CapDelete{cap = fromIntegral cap}- )),-- (FixedSizeParser EVENT_CAP_DISABLE (sz_cap) (do  -- (cap)-      cap <- getE :: GetEvents CapNo-      return CapDisable{cap = fromIntegral cap}- )),-- (FixedSizeParser EVENT_CAP_ENABLE (sz_cap) (do  -- (cap)-      cap <- getE :: GetEvents CapNo-      return CapEnable{cap = fromIntegral cap}- )),-- (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_USER_MARKER (do -- (markername)-      num <- getE :: GetEvents Word16-      string <- getString num-      return UserMarker{ markername = 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_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,gcd,fiz,rem)-      crt <- getE :: GetEvents Word64-      dud <- getE :: GetEvents Word64-      ovf <- getE :: GetEvents Word64-      cnv <- getE :: GetEvents Word64-      gcd <- getE :: GetEvents Word64-      fiz <- getE :: GetEvents Word64-      rem <- getE :: GetEvents Word64-      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,-                           sparksOverflowed = ovf, sparksConverted = cnv,-                           -- Warning: order of fiz and gcd reversed!-                           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_TASK_CREATE (sz_taskid + sz_cap + sz_kernel_tid) (do  -- (taskID, cap, tid)-      taskId <- getE :: GetEvents TaskId-      cap    <- getE :: GetEvents CapNo-      tid    <- getE :: GetEvents KernelThreadId-      return TaskCreate{ taskId, cap = fromIntegral cap, tid }-   )),- (FixedSizeParser EVENT_TASK_MIGRATE (sz_taskid + sz_cap*2) (do  -- (taskID, cap, new_cap)-      taskId  <- getE :: GetEvents TaskId-      cap     <- getE :: GetEvents CapNo-      new_cap <- getE :: GetEvents CapNo-      return TaskMigrate{ taskId, cap = fromIntegral cap-                                , new_cap = fromIntegral new_cap-                        }-   )),- (FixedSizeParser EVENT_TASK_DELETE (sz_taskid) (do  -- (taskID)-      taskId <- getE :: GetEvents TaskId-      return TaskDelete{ taskId }-   )),-- (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}-   ))- ]---- special thread stop event parsers for GHC version 7.8.2--- see [Stop status in GHC-7.8.2] in EventTypes.hs-ghc782StopParser :: EventParser EventInfo-ghc782StopParser =- (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 > maxThreadStopStatus782-                                    -> NoStatus-                                    | s == 9 {- XXX yeuch -}-                                      -- GHC-7.8.2: 9 == BlockedOnBlackHole-                                    -> BlockedOnBlackHoleOwnedBy i-                                    | otherwise-                                    -> mkStopStatus782 s}-   ))---- parsers for GHC < 7.8.2. Older versions do not use block info--- (different length).  See [Stop status in GHC-7.8.2] in--- EventTypes.hs-pre77StopParsers :: [EventParser EventInfo]-pre77StopParsers = [- (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 > maxThreadStopStatusPre77-                                              then NoStatus-                                              else mkStopStatus s}-                        -- older version of the event, no block info-   )),-- (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 > maxThreadStopStatusPre77-                                    -> NoStatus-                                    | s == 8 {- XXX yeuch -}-                                      -- pre-7.7: 8==BlockedOnBlackhole-                                    -> BlockedOnBlackHoleOwnedBy i-                                    | otherwise-                                    -> mkStopStatus s}-    ))-  ]---- parsers for GHC >= 7.8.3, always using block info field parser.--- See [Stop status in GHC-7.8.2] in EventTypes.hs-post782StopParser :: EventParser EventInfo-post782StopParser = - (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 -}-                                      -- post-7.8.2: 8==BlockedOnBlackhole-                                    -> BlockedOnBlackHoleOwnedBy i-                                    | otherwise-                                    -> mkStopStatus s}-    ))-- ------------------------ -- 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 RawThreadStopStatus-      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77-                                              then NoStatus-                                              else mkStopStatus s}-                        -- older version of the event uses pre-77 encoding-                        -- (actually, it only uses encodings 0 to 5)-                        -- see [Stop status in GHC-7.8.2] in EventTypes.hs-   )),-- (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)-- ]--perfParsers = [- (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)-      num     <- getE :: GetEvents Word16-      perfNum <- getE-      name    <- getString (num - sz_perf_num)-      return PerfName{perfNum, name}-   )),-- (FixedSizeParser EVENT_PERF_COUNTER (sz_perf_num + sz_kernel_tid + 8) (do -- (perf_num, tid, period)-      perfNum <- getE-      tid     <- getE-      period  <- getE-      return PerfCounter{perfNum, tid, period}-  )),-- (FixedSizeParser EVENT_PERF_TRACEPOINT (sz_perf_num + sz_kernel_tid) (do -- (perf_num, tid)-      perfNum <- getE-      tid     <- getE-      return PerfTracepoint{perfNum, tid}-  ))- ]--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 :: ExceptT 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.-        -}--        -- GHC-7.8.2 uses a different thread block status encoding,-        -- and therefore requires a different parser for the stop-        -- event. Later, in GHC-7.8.3, the old encoding was restored.-        -- GHC-7.8.2 can be recognised by presence and absence of-        -- events in the header:-        --   * User markers were added in GHC-7.8 -        --   * an empty event HACK_BUG_T9003 was added in GHC-7.8.3-        -- This fix breaks software which uses ghc-events and combines-        -- user markers with the older stop status encoding. We don't-        -- know of any such software, though.-        is_pre77  = M.notMember EVENT_USER_MARKER imap-        is_ghc782 = M.member EVENT_USER_MARKER imap &&-                    M.notMember EVENT_HACK_BUG_T9003 imap--        stopParsers = if is_pre77 then pre77StopParsers-                      else if is_ghc782 then [ghc782StopParser]-                           else [post782StopParser]--        event_parsers = if is_ghc_6-                            then standardParsers ++ ghc6Parsers ++-                                parRTSParsers sz_old_tid-                            else standardParsers ++ ghc7Parsers ++-                                stopParsers ++ parRTSParsers sz_tid ++-                                mercuryParsers ++ perfParsers-        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 <- runExceptT 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"-        TaskCreate taskId cap tid ->-          printf "task 0x%x created on cap %d with OS kernel thread %d"-                 taskId cap (kernelThreadId tid)-        TaskMigrate taskId cap new_cap ->-          printf "task 0x%x migrated from cap %d to cap %d"-                 taskId cap new_cap-        TaskDelete taskId ->-          printf "task 0x%x deleted" taskId-        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"-        GlobalSyncGC ->-          printf "all caps stopped for GC"-        GCStatsGHC{..} ->-          printf "GC stats for heap capset %d: generation %d, %d bytes copied, %d bytes slop, %d bytes fragmentation, %d par threads, %d bytes max par copied, %d bytes total par copied" heapCapset gen copied slop frag parNThreads parMaxCopied parTotCopied-        HeapAllocated{..} ->-          printf "allocated on heap capset %d: %d total bytes till now" heapCapset allocBytes-        HeapSize{..} ->-          printf "size of heap capset %d: %d bytes" heapCapset sizeBytes-        HeapLive{..} ->-          printf "live data in heap capset %d: %d bytes" heapCapset liveBytes-        HeapInfoGHC{..} ->-          printf "heap stats for heap capset %d: generations %d, %d bytes max heap size, %d bytes alloc area size, %d bytes mblock size, %d bytes block size" heapCapset gens maxHeapSize allocAreaSize mblockSize blockSize-        CapCreate{cap} ->-          printf "created cap %d" cap-        CapDelete{cap} ->-          printf "deleted cap %d" cap-        CapDisable{cap} ->-          printf "disabled cap %d" cap-        CapEnable{cap} ->-          printf "enabled cap %d" cap-        Message msg ->-          msg-        UserMessage msg ->-          msg-        UserMarker markername ->-          printf "marker: %s" markername-        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"-        PerfName{perfNum, name} ->-          printf "perf event %d named \"%s\"" perfNum name-        PerfCounter{perfNum, tid, period} ->-          printf "perf event counter %d incremented by %d in OS thread %d"-                 perfNum (period + 1) (kernelThreadId tid)-        PerfTracepoint{perfNum, tid} ->-          printf "perf event tracepoint %d reached in OS thread %d"-                 perfNum (kernelThreadId tid)--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 BlockedOnMVarRead = "blocked reading 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-    GlobalSyncGC {} -> EVENT_GC_GLOBAL_SYNC-    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-    TaskCreate  {} -> EVENT_TASK_CREATE-    TaskMigrate {} -> EVENT_TASK_MIGRATE-    TaskDelete  {} -> EVENT_TASK_DELETE-    Message {} -> EVENT_LOG_MSG-    Startup {} -> EVENT_STARTUP-    EventBlock {} -> EVENT_BLOCK_MARKER-    UserMessage {} -> EVENT_USER_MSG-    UserMarker  {} -> EVENT_USER_MARKER-    GCIdle {} -> EVENT_GC_IDLE-    GCWork {} -> EVENT_GC_WORK-    GCDone {} -> EVENT_GC_DONE-    GCStatsGHC{} -> EVENT_GC_STATS_GHC-    HeapAllocated{} -> EVENT_HEAP_ALLOCATED-    HeapSize{} -> EVENT_HEAP_SIZE-    HeapLive{} -> EVENT_HEAP_LIVE-    HeapInfoGHC{} -> EVENT_HEAP_INFO_GHC-    CapCreate{} -> EVENT_CAP_CREATE-    CapDelete{} -> EVENT_CAP_DELETE-    CapDisable{} -> EVENT_CAP_DISABLE-    CapEnable{} -> EVENT_CAP_ENABLE-    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-    PerfName       {} -> nEVENT_PERF_NAME-    PerfCounter    {} -> nEVENT_PERF_COUNTER-    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT--nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum-nEVENT_PERF_NAME = EVENT_PERF_NAME-nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER-nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT--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--- The standard encoding is used here, which is wrong for eventlogs--- produced by GHC-7.8.2 ([Stop status in GHC-7.8.2] in EventTypes.hs-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-            BlockedOnMVarRead -> 20 -- since GHC-7.8.3-            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-    -- Warning: order of fiz and gcd reversed!-    putE gcd-    putE fiz-    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 GlobalSyncGC = do-    return ()--putEventSpec (TaskCreate taskId cap tid) = do-    putE taskId-    putCap cap-    putE tid--putEventSpec (TaskMigrate taskId cap new_cap) = do-    putE taskId-    putCap cap-    putCap new_cap--putEventSpec (TaskDelete taskId) = do-    putE taskId--putEventSpec GCStatsGHC{..} = do-    putE heapCapset-    putE (fromIntegral gen :: Word16)-    putE copied-    putE slop-    putE frag-    putE (fromIntegral parNThreads :: Word32)-    putE parMaxCopied-    putE parTotCopied--putEventSpec HeapAllocated{..} = do-    putE heapCapset-    putE allocBytes--putEventSpec HeapSize{..} = do-    putE heapCapset-    putE sizeBytes--putEventSpec HeapLive{..} = do-    putE heapCapset-    putE liveBytes--putEventSpec HeapInfoGHC{..} = do-    putE heapCapset-    putE (fromIntegral gens :: Word16)-    putE maxHeapSize-    putE allocAreaSize-    putE mblockSize-    putE blockSize--putEventSpec CapCreate{cap} = do-    putCap cap--putEventSpec CapDelete{cap} = do-    putCap cap--putEventSpec CapDisable{cap} = do-    putCap cap--putEventSpec CapEnable{cap} = do-    putCap cap--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) + sz_capset :: Word16)-    putE cs-    putEStr rts--putEventSpec (ProgramArgs cs as) = do-    let as' = unsep as-    putE (fromIntegral (length as') + sz_capset :: Word16)-    putE cs-    mapM_ putE as'--putEventSpec (ProgramEnv cs es) = do-    let es' = unsep es-    putE (fromIntegral (length es') + sz_capset :: 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 (UserMarker 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 ()--putEventSpec PerfName{..} = do-    putE (fromIntegral (length name) + sz_perf_num :: Word16)-    putE perfNum-    mapM_ putE name--putEventSpec PerfCounter{..} = do-    putE perfNum-    putE tid-    putE period--putEventSpec PerfTracepoint{..} = do-    putE perfNum-    putE tid---- [] == []--- [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')

@@ -1,282 +0,0 @@-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 against 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')

@@ -1,209 +0,0 @@-module GHC.RTS.Events.Analysis.Capability-  ( capabilityThreadPoolMachine-  , capabilityThreadRunMachine-  , capabilityThreadIndexer-  , capabilityTaskPoolMachine-  , capabilityTaskOSMachine-  )- 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 `M.member` 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-      | threadId `M.notMember` 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-      | capId `M.member` 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)---- | This state machine tracks Haskell tasks, represented by TaskId,--- residing on capabilities.--- Each Haskell task can only reside on one capability, but can be migrated--- between them.-capabilityTaskPoolMachine :: Machine (Map TaskId Int) CapEvent-capabilityTaskPoolMachine = Machine-  { initial = M.empty-  , final   = const False-  , alpha   = capabilityTaskPoolMachineAlpha-  , delta   = capabilityTaskPoolMachineDelta-  }- where-  capabilityTaskPoolMachineAlpha capEvent = case spec . ce_event $ capEvent of-     TaskCreate{}  -> True-     TaskDelete{}  -> True-     TaskMigrate{} -> True-     _             -> False--  capabilityTaskPoolMachineDelta mapping capEvent = do-    case spec . ce_event $ capEvent of-      TaskCreate {taskId, cap}           -> insertTask taskId cap mapping-      TaskDelete {taskId}                -> deleteTask taskId Nothing mapping-      TaskMigrate {taskId, cap, new_cap} ->-        deleteTask taskId (Just cap) mapping >>=-          insertTask taskId new_cap-      _                                  -> Nothing-   where-    insertTask :: TaskId -> Int -> Map TaskId Int-               -> Maybe (Map TaskId Int)-    insertTask taskId cap m-      | taskId `M.member` m = Nothing  -- The task already exists.-      | otherwise           = Just $ M.insert taskId cap m--    deleteTask :: TaskId -> Maybe Int -> Map TaskId Int-               -> Maybe (Map TaskId Int)-    deleteTask taskId expectedcap m-      | Just oldcap <- M.lookup taskId m-      , maybe True (==oldcap) expectedcap-      = Just $ M.delete taskId m-      | otherwise-      = Nothing  -- The task doesn't exist, or does but with an unexpected cap.---- | This state machine tracks Haskell tasks (represented by the KernelThreadId--- of their OS thread) residing on capabilities and additionally--- tracks the (immutable) assignment of OS thread ids (KernelThreadId)--- to tasks ids (TaskId).--- Each Haskell task can only reside on one capability, but can be migrated--- between them.------ Invariant for the @(Map KernelThreadId Int, Map TaskId KernelThreadId)@ --- type: the second map is an injection (verified by the machine --- in 'insertTaskOS') and the following sets are equal: --- keys of the fist map and values of the second--- (follows from the construction of the maps by the machine).------ The machine verifies as much as 'capabilityTaskPoolMachine' and additionally--- the data invariant, and offers a richer verification profile.-capabilityTaskOSMachine :: Machine (Map KernelThreadId Int,-                                    Map TaskId KernelThreadId)-                                   CapEvent-capabilityTaskOSMachine = Machine-  { initial = (M.empty, M.empty)-  , final   = const False-  , alpha   = capabilityTaskOSMachineAlpha-  , delta   = capabilityTaskOSMachineDelta-  }- where-  capabilityTaskOSMachineAlpha capEvent = case spec . ce_event $ capEvent of-     TaskCreate{}  -> True-     TaskDelete{}  -> True-     TaskMigrate{} -> True-     _             -> False--  capabilityTaskOSMachineDelta mapping capEvent = do-    case spec . ce_event $ capEvent of-      TaskCreate {taskId, cap, tid} -> insertTaskOS taskId cap tid mapping-      TaskDelete {taskId}           -> deleteTaskOS taskId mapping-      TaskMigrate {taskId, new_cap} -> migrateTaskOS taskId new_cap mapping-      _                             -> Nothing-   where-    insertTaskOS :: TaskId -> Int -> KernelThreadId-                 -> (Map KernelThreadId Int, Map TaskId KernelThreadId)-                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)-    insertTaskOS taskId cap tid (m, ma)-      | taskId `M.member` ma = Nothing  -- The task already exists.-      | tid `M.member` m     = Nothing  -- The OS thread already exists.-      | otherwise            = Just (M.insert tid cap m,-                                     M.insert taskId tid ma)--    deleteTaskOS :: TaskId -> (Map KernelThreadId Int,-                               Map TaskId KernelThreadId)-                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)-    deleteTaskOS taskId (m, ma) =-      case M.lookup taskId ma of-        Nothing  -> Nothing  -- The task doesn't exist.-        Just tid -> Just (M.delete tid m,-                          M.delete taskId ma)--    migrateTaskOS :: TaskId -> Int -> (Map KernelThreadId Int,-                                       Map TaskId KernelThreadId)-                  -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)-    migrateTaskOS taskId new_cap (m, ma) =-      case M.lookup taskId ma of-        Nothing -> Nothing  -- The task doesn't exist.-        Just tid -> Just (M.insert tid new_cap m,-                          ma)  -- The assignment is immutable.

@@ -1,114 +0,0 @@-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-

@@ -1,53 +0,0 @@-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

@@ -1,118 +0,0 @@-{-# OPTIONS_GHC -funbox-strict-fields #-}--module GHC.RTS.Events.Merge (mergeEventLogs) where--import GHC.RTS.Events-import Data.Monoid-import Data.List (foldl')-import qualified Data.Map as M-import Data.Word (Word32, Word16)---- TODO: add a merge mode where the events are synchronized using--- the wall clock time event at the start of both eventlogs (for newer GHCs).--- Such merge is not associative so we either need to take many arguments--- or cope with eventlogs with many wall clock time events (assume they--- are products of previous merges). To decide.--{--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 # of occupied numbers for each variable type in 'x',-then increment each variable in 'y' by that amount.-We assume that if a number is occupied, so are all lower numbers.-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)) =-  let headerMap = M.fromList . map (\ et@EventType {num} -> (num, et))-      m1 = headerMap $ eventTypes h1-      m2 = headerMap $ eventTypes h2-      combine et1 et2 | et1 == et2 = et1-      combine _ _ = error "can't merge eventlogs with inconsistent headers"-      m = M.unionWith combine m1 m2-      h = Header $ M.elems m-  in h == h `seq`  -- Detect inconsistency ASAP.-     EventLog h . Data . mergeOn time xs $ shift (maxVars xs) ys--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---- TODO: rename, since these are not maximal values, but numbers of used values-data MaxVars = MaxVars { mcapset :: !Word32-                       , mcap :: !Int-                       , mthread :: !ThreadId }--- TODO introduce parallel RTS process and machine var.s--instance Monoid MaxVars where-    mempty  = MaxVars 0 0 0-    mappend (MaxVars a b c) (MaxVars x y z) =-      MaxVars (max a x) (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)---- For caps we find the maximum value by summing the @Startup@ declarations.--- TODO: it's not trivial to add CapCreate since we don't know--- if created caps are guaranteed to be numbered consecutively or not--- (are they? is it asserted in GHC code somewhere?). We might instead--- just scan all events mentioning a cap and take the maximum,--- but it's a slower and much longer code, requiring constant maintenance.-maxVars :: [Event] -> MaxVars-maxVars = mconcat . map (maxSpec . spec)- where-    -- only checking binding sites right now, sufficient?-    maxSpec (Startup n) = mempty { mcap = n }-    -- Threads start at 1.-    maxSpec (CreateThread t) = mempty { mthread = t }-    maxSpec (CreateSparkThread t) = mempty { mthread = t }-    -- Capsets start at 0.-    maxSpec (CapsetCreate cs _) = mempty {mcapset = cs + 1 }-    maxSpec (EventBlock _ _ es) = maxVars es-    maxSpec _  = mempty--sh :: Num a => a -> a -> a-sh x y = x + y--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' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)-    shift' (ThreadLabel t l) = ThreadLabel (sh mt t) l-    shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)-    shift' (SparkSteal c) = SparkSteal (sh mc c)-    shift' (TaskCreate tk c tid) = TaskCreate tk (sh mc c) tid-    shift' (TaskMigrate tk c1 c2) = TaskMigrate tk (sh mc c1) (sh mc c2)-    shift' (CapCreate c) = CapCreate (sh mc c)  -- TODO: correct?-    shift' (CapDelete c) = CapDelete (sh mc c)  -- TODO: correct?-    shift' (CapDisable c) = CapDisable (sh mc c)-    shift' (CapEnable c) = CapEnable (sh mc c)-    shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst-    shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)-    shift' (CapsetAssignCap cs c) = CapsetAssignCap (sh mcs cs) (sh mc c)-    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' (WallClockTime cs sec nsec) = WallClockTime (sh mcs cs) sec nsec-    shift' x = x-    -- TODO extend by new shift for Eden events

@@ -1,41 +1,42 @@ {-# LANGUAGE CPP #-}+ module Main where  import GHC.RTS.Events+import GHC.RTS.Events.Incremental 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 System.Environment (getArgs) 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 :: IO () main = getArgs >>= command -command ["--help"] = do-    putStr usage+command :: [String] -> IO ()+command ["--help"] = putStr usage +command ["inc", file] = printEventsIncremental False file++command ["inc", "force", file] = printEventsIncremental True file+ command ["show", file] = do-    log <- readLogOrDie file-    putStrLn $ ppEventLog log+    evtLog <- readLogOrDie file+    putStrLn $ ppEventLog evtLog  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)+        evts = sortEvents $ events $ dat eventLog+        mappings  = rights . validates capabilityThreadRunMachine $ evts+        indexes = zipWith capabilityThreadIndexer mappings evts+        threadMap = M.fromListWith (++) . reverse $ zip indexes (map return evts)     putStrLn "Event Types:"     putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog     putStrLn "Thread Indexed Events:"@@ -47,9 +48,9 @@ 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)+    let evts = sortEvents . events . dat $ eventLog+        indexes = map evCap evts+        capMap = M.fromListWith (++) . reverse $ zip indexes (map return evts)     putStrLn "Event Types:"     putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog     putStrLn "Cap Indexed Events:"@@ -66,11 +67,11 @@  command ["validate", "threads", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = validate (routeM capabilityThreadRunMachine                                   capabilityThreadIndexer-                                  (refineM (spec . ce_event) threadMachine))-                          capEvents+                                  (refineM evSpec threadMachine))+                          evts     putStrLn $ showValidate (\(m, n) ->                                "\nThread States:\n" ++ showIndexed show show m ++                                "\nCap States:\n" ++ showIndexed show show n)@@ -78,110 +79,115 @@  command ["validate", "threadpool", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = validate capabilityThreadPoolMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = validate capabilityThreadPoolMachine evts     putStrLn $ showValidate show show result  command ["validate", "threadrun", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = validate capabilityThreadRunMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = validate capabilityThreadRunMachine evts     putStrLn $ showValidate show show result  command ["validate", "taskpool", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = validate capabilityTaskPoolMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = validate capabilityTaskPoolMachine evts     putStrLn $ showValidate show show result  command ["validate", "tasks", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = validate capabilityTaskOSMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = validate capabilityTaskOSMachine evts     putStrLn $ showValidate show show result  command ["validate", "sparks", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = validate                    (routeM capabilitySparkThreadMachine capabilitySparkThreadIndexer-                     (refineM (spec . ce_event) sparkThreadMachine))-                   capEvents+                     (refineM evSpec sparkThreadMachine))+                   evts     putStrLn $ showValidate show show result  command ["simulate", "threads", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = simulate (routeM capabilityThreadRunMachine                                   capabilityThreadIndexer-                                  (refineM (spec . ce_event) threadMachine))-                          capEvents+                                  (refineM evSpec threadMachine))+                          evts     putStrLn . showProcess $ result  command ["simulate", "threadpool", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = simulate capabilityThreadPoolMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = simulate capabilityThreadPoolMachine evts     putStrLn . showProcess $ result  command ["simulate", "threadrun", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = simulate capabilityThreadRunMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = simulate capabilityThreadRunMachine evts     putStrLn . showProcess $ result  command ["simulate", "taskpool", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = simulate capabilityTaskPoolMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = simulate capabilityTaskPoolMachine evts     putStrLn . showProcess $ result  command ["simulate", "tasks", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog-    let result = simulate capabilityTaskOSMachine capEvents+    let evts = sortEvents . events . dat $ eventLog+    let result = simulate capabilityTaskOSMachine evts     putStrLn . showProcess $ result  command ["simulate", "sparks", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = simulate               (routeM capabilitySparkThreadMachine                   capabilitySparkThreadIndexer-                  (refineM (spec . ce_event) sparkThreadMachine))-              capEvents+                  (refineM evSpec sparkThreadMachine)) evts     putStrLn . showProcess $ result  command ["profile", "threads", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = profileRouted-                   (refineM (spec. ce_event) threadMachine)+                   (refineM evSpec threadMachine)                    capabilityThreadRunMachine-                   capabilityThreadIndexer-                   (time . ce_event)-                   capEvents+                   capabilityThreadIndexer evTime evts     putStrLn . showProcess $ result  command ["profile", "sparks", file] = do     eventLog <- readLogOrDie file-    let capEvents = sortEvents . events . dat $ eventLog+    let evts = sortEvents . events . dat $ eventLog     let result = profileRouted-                   (refineM (spec . ce_event) sparkThreadMachine)+                   (refineM evSpec sparkThreadMachine)                    capabilitySparkThreadMachine                    capabilitySparkThreadIndexer-                   (time . ce_event)-                   capEvents+                   evTime evts     putStrLn . showProcess $ result  command _ = putStr usage >> die "Unrecognized command" +readLogOrDie :: FilePath -> IO EventLog+readLogOrDie file = do+    e <- readEventLogFromFile file+    case e of+        Left s    -> die ("Failed to parse " ++ file ++ ": " ++ s)+        Right evtLog -> return evtLog++usage :: String 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 inc <file>:",                 "Pretty print an event log incrementally")+              , ("ghc-events inc force <file>:",           "Pretty print an event log incrementally. Retry on incomplete input (aka 'tail -f').")               , ("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.")@@ -206,23 +212,13 @@               , ("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--#if ! MIN_VERSION_base(4,8,0)-die s = do hPutStrLn stderr s; exitWith (ExitFailure 1)-#endif- 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 )+  ++ "\nState:\n" ++ showState state+  ++ "\nInput:\n" ++ showInput input showValidate showState _ (Right state) =-  "Valid eventlog: " ++ ( showState state )+  "Valid eventlog: " ++ showState state  showProcess :: (Show e, Show a) => Process e a -> String showProcess process =@@ -231,12 +227,12 @@   ++ "\n"   ++ (maybe "Valid." (("Invalid:\n" ++) . show) . toMaybe) process -showIndexed :: (k -> String) -> (v -> String) -> Map k v -> String+showIndexed :: (k -> String) -> (v -> String) -> M.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")+      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@@ -244,3 +240,8 @@   concat $ zipWith (++)     (map showKey . M.keys $ m :: [String])     (map (showValue . (M.!) m) . M.keys $ m :: [String])++#if !MIN_VERSION_base(4,8,0)+die :: String -> IO a+die err = hPutStrLn stderr err >> exitFailure+#endif

@@ -0,0 +1,13 @@+# ghc-events+[![Build Status](https://travis-ci.org/haskell/ghc-events.svg?branch=master)](https://travis-ci.org/haskell/ghc-events)+[![Hackage](https://img.shields.io/hackage/v/ghc-events.svg)](https://hackage.haskell.org/package/ghc-events)+[![Hackage-Deps](https://img.shields.io/hackage-deps/v/ghc-events.svg)](http://packdeps.haskellers.com/feed?needle=ghc-events)++A Haskell library for parsing .eventlog files emitted by the GHC runtime system.+The package also includes an executable, `ghc-events` that can be used to display the contents of .eventlog files++## TODO+* Add example usage/tutorial of the new API to this readme++## Known Issues+* Writing event logs back to file does not work. It is hard to say how long has this been broken or how difficult will it be to fix ([#14](https://github.com/haskell/ghc-events/issues/14))

@@ -1,5 +1,5 @@ name:             ghc-events-version:          0.4.4.0+version:          0.6.0 synopsis:         Library and tool for parsing .eventlog files from GHC description:      Parses .eventlog files emitted by GHC 6.12.1 and later.                   Includes the ghc-events tool permitting, in particular,@@ -7,7 +7,7 @@ category:         Development, GHC, Debug, Profiling, Trace license:          BSD3 license-file:     LICENSE-author:           Donnie Jones <donnie@darthik.com>, +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>,@@ -16,14 +16,32 @@                   Nicolas Wu <nick@well-typed.com>,                   Jost Berthold <berthold@diku.dk>                   Mikolaj Konarski <mikolaj@well-typed.com>+                  Karolis Velicka <karolis.velicka@gmail.com> maintainer:       Simon Marlow <marlowsd@gmail.com>-bug-reports:      https://github.com/haskell/ThreadScope/issues+bug-reports:      https://github.com/haskell/ghc-events/issues build-type:       Simple-tested-with:      GHC == 6.12.3, GHC == 7.4.1, GHC == 7.6.1, GHC == 7.6.3, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.10.1+tested-with:      GHC == 7.6.1, GHC == 7.6.3, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.10.1,+                  GHC == 8.0.2 cabal-version:    >= 1.8-extra-source-files: GHC/RTS/EventLogFormat.h,-                    test/*.eventlog+extra-source-files: include/EventLogFormat.h+                    test/queens-ghc-6.12.1.eventlog+                    test/queens-ghc-6.12.1.eventlog.reference+                    test/queens-ghc-7.0.2.eventlog+                    test/queens-ghc-7.0.2.eventlog.reference+                    test/mandelbrot-mmc-2011-06-14.eventlog+                    test/mandelbrot-mmc-2011-06-14.eventlog.reference+                    test/parallelTest.eventlog+                    test/parallelTest.eventlog.reference+                    test/pre77stop.eventlog+                    test/pre77stop.eventlog.reference+                    test/782stop.eventlog+                    test/782stop.eventlog.reference+                    test/783stop.eventlog+                    test/783stop.eventlog.reference+                    test/Utils.hs                     test/stop.hs+                    README.md+                    CHANGELOG.md  source-repository head   type: git@@ -31,12 +49,12 @@  library   build-depends:    base       == 4.*,-                    mtl        >= 2.2.1 && < 3.0,-                    containers >= 0.2 && < 0.6,-                    binary     >= 0.5 && < 0.8,-                    bytestring >= 0.9.0,+                    containers >= 0.5 && < 0.6,+                    binary     >= 0.7 && < 0.10,+                    bytestring >= 0.10.4,                     array      >= 0.2 && < 0.6   exposed-modules:  GHC.RTS.Events,+                    GHC.RTS.Events.Incremental                     GHC.RTS.Events.Merge                     GHC.RTS.Events.Analysis                     GHC.RTS.Events.Analysis.Capability@@ -44,17 +62,31 @@                     GHC.RTS.Events.Analysis.Thread   other-modules:    GHC.RTS.EventParserUtils,                     GHC.RTS.EventTypes-  include-dirs:     GHC/RTS+                    GHC.RTS.Events.Binary+  hs-source-dirs:   src+  include-dirs:     include   extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards   other-extensions: FlexibleContexts, CPP+  ghc-options:      -Wall  executable ghc-events   main-is:          GhcEvents.hs-  build-depends:    base, mtl, containers, binary, bytestring, array+  build-depends:    ghc-events, base, containers   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+  main-is:          TestVersions.hs+  other-modules:    Utils+  hs-source-dirs:   ., test+  build-depends:    ghc-events, base   extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards++test-suite write-merge+  type:             exitcode-stdio-1.0+  main-is:          WriteMerge.hs+  other-modules:    Utils+  hs-source-dirs:   ., test+  build-depends:    ghc-events, base, bytestring+  extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards+  buildable:        False

@@ -0,0 +1,312 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2008-2012+ *+ * 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, 7 deprecated */+#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 ...)          */+/* EVENT_STARTUP should be deprecated at some point */+#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,gcd,fiz,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) {not used by ghc} */+#define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */+#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */+#define EVENT_CAP_CREATE          45 /* (cap)                  */+#define EVENT_CAP_DELETE          46 /* (cap)                  */+#define EVENT_CAP_DISABLE         47 /* (cap)                  */+#define EVENT_CAP_ENABLE          48 /* (cap)                  */+#define EVENT_HEAP_ALLOCATED      49 /* (heap_capset, alloc_bytes) */+#define EVENT_HEAP_SIZE           50 /* (heap_capset, size_bytes) */+#define EVENT_HEAP_LIVE           51 /* (heap_capset, live_bytes) */+#define EVENT_HEAP_INFO_GHC       52 /* (heap_capset, n_generations,+                                         max_heap_size, alloc_area_size,+                                         mblock_size, block_size) */+#define EVENT_GC_STATS_GHC        53 /* (heap_capset, generation,+                                         copied_bytes, slop_bytes, frag_bytes,+                                         par_n_threads,+                                         par_max_copied, par_tot_copied) */+#define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */+#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */+#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */+#define EVENT_TASK_DELETE         57 /* (taskID)                 */+#define EVENT_USER_MARKER         58 /* (marker_name) */+#define EVENT_HACK_BUG_T9003      59 /* Hack: see trac #9003 */++/* Range 59 - 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. */++/* Range 140 - 159 is reserved for Perf events, 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)   */+/* shutdown replaced by EVENT_CAP_DELETE */+#define EVENT_SHUTDOWN             7 /* ()                     */+#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 /* () */+++/*+ * These event types are parsed from hardware performance counters logs,+ * such as the Linux Performance Counters data available through+ * the perf subsystem.+ */++#define EVENT_PERF_NAME           140 /* (perf_num, name) */+#define EVENT_PERF_COUNTER        141 /* (perf_num, tid, period) */+#define EVENT_PERF_TRACEPOINT     142 /* (perf_num, tid) */+++/*+ * Status values for EVENT_STOP_THREAD+ *+ * 1-5 are the StgRun return values (from includes/rts/Constants.h):+ *+ * #define HeapOverflow   1+ * #define StackOverflow  2+ * #define ThreadYielding 3+ * #define ThreadBlocked  4+ * #define ThreadFinished 5+ * #define ForeignCall                  6+ * #define BlockedOnMVar                7+ * #define BlockedOnMVarRead            20+ * NOTE: in GHC-7.8.2, this was 8, and following states shifted one up+ * #define BlockedOnBlackHole           8+ * #define BlockedOnRead                9+ * #define BlockedOnWrite               10+ * #define BlockedOnDelay               11+ * #define BlockedOnSTM                 12+ * #define BlockedOnDoProc              13+ * NOTE: unused GUM states 8, 9 (here: 14,15) in rts/Constants.h+ * #define BlockedOnCCall               -- not used (see ForeignCall)+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)+ * #define BlockedOnMsgThrowTo          16+ * NOTE: 16 because unused GUM states ignored in ghc-events lib+ *       Otherwise it would be 18, following would be 19, 20+ * TODO: verify the above is what GHC does (16/17 could be 18/19) + * #define ThreadMigrating              17+ * #define BlockedOnMsgGlobalise        18 + * NOTE: not present in GHC. Mercury-Event?+ */+#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 StgWord64 EventTaskId;         /* for EVENT_TASK_* */+typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */++typedef StgWord32 EventProcessID;+typedef StgWord16 EventMachineID;+typedef EventThreadID EventPortID;++#endif++#endif /* RTS_EVENTLOGFORMAT_H */

@@ -0,0 +1,181 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+module GHC.RTS.EventParserUtils (+        EventParser(..),+        EventParsers(..),++        getString,+        mkEventTypeParsers,+        simpleEvent,+        skip,+    ) where++import Control.Monad+import Data.Array+import Data.Binary+import Data.Binary.Get ()+import qualified Data.Binary.Get as G+import Data.Binary.Put ()+import Data.Char+import Data.IntMap (IntMap)+import qualified Data.IntMap as M+import Data.List++#define EVENTLOG_CONSTANTS_ONLY+#include "EventLogFormat.h"++import GHC.RTS.EventTypes++newtype EventParsers = EventParsers (Array Int (Get EventInfo))++nBytes :: Integral a => a -> Get [Word8]+nBytes n = replicateM (fromIntegral n) get++getString :: Integral a => a -> Get String+getString len = do+    bytes <- nBytes len+    return $ map (chr . fromIntegral) bytes++skip :: Integral a => a -> Get ()+skip n = 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      :: Get a+    }+    | VariableSizeParser {+        vsp_type        :: Int,+        vsp_parser      :: Get a+    }++getParser :: EventParser a -> Get a+getParser (FixedSizeParser _ _ p) = p+getParser (VariableSizeParser _ p) = p++getType :: EventParser a -> Int+getType (FixedSizeParser t _ _) = t+getType (VariableSizeParser t _) = t++isFixedSize :: EventParser a -> Bool+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 (Get EventInfo)+mkEventTypeParsers etypes event_parsers+ = accumArray (flip const) undefined (0, max_event_num)+    [ (num, parser num) | num <- [0..max_event_num] ]+  where+    max_event_num = maximum (M.keys etypes)+    undeclared_etype num = fail ("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 $ getParser 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:_) = Just x++padParser :: EventTypeSize -> (EventParser a) -> (EventParser a)+padParser _    (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) (getType parser) map'+          addParser p Nothing = Just [p]+          addParser p (Just ps) = Just (p:ps)++noEventTypeParser :: Int -> Maybe EventTypeSize+                  -> Get EventInfo+noEventTypeParser num mb_size = do+  bytes <- case mb_size of+             Just n  -> return n+             Nothing -> get :: Get Word16+  skip bytes+  return UnknownEvent{ ref = fromIntegral num }

@@ -0,0 +1,528 @@+module GHC.RTS.EventTypes where+import Control.Monad++import Data.Binary++-- 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+type PerfEventTypeNum = Word32+type TaskId = Word64+type PID = Word32++newtype KernelThreadId = KernelThreadId { kernelThreadId :: Word64 }+  deriving (Eq, Ord, Show)+instance Binary KernelThreadId where+  put (KernelThreadId tid) = put tid+  get = fmap KernelThreadId get++-- 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_taskid :: EventTypeSize+sz_taskid = 8+sz_kernel_tid :: EventTypeSize+sz_kernel_tid = 8+sz_th_stop_status :: EventTypeSize+sz_th_stop_status = 2+sz_string_id :: EventTypeSize+sz_string_id = 4+sz_perf_num :: EventTypeSize+sz_perf_num = 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 {+    evTime  :: {-# UNPACK #-}!Timestamp,+    evSpec  :: EventInfo,+    evCap :: Maybe Int+  } deriving Show++{-# DEPRECATED time "The field is now called evTime" #-}+time :: Event -> Timestamp+time = evTime++{-# DEPRECATED spec "The field is now called evSpec" #-}+spec :: Event -> EventInfo+spec = evSpec++data EventInfo++  -- pseudo events+  = EventBlock         { end_time   :: Timestamp,+                         cap        :: Int,+                         block_size :: BlockSize+                       }+  | UnknownEvent       { ref  :: {-# UNPACK #-}!EventTypeNum }++  -- init and shutdown+  | Startup            { n_caps :: Int+                       }+  -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6++  -- no longer generate the event; should be removed at some point+  | 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            { }++  -- tasks+  | TaskCreate         { taskId :: TaskId,+                         cap :: {-# UNPACK #-}!Int,+                         tid :: {-# UNPACK #-}!KernelThreadId+                       }+  | TaskMigrate        { taskId :: TaskId,+                         cap :: {-# UNPACK #-}!Int,+                         new_cap :: {-# UNPACK #-}!Int+                       }+  | TaskDelete         { taskId :: TaskId }++  -- garbage collection+  | RequestSeqGC       { }+  | RequestParGC       { }+  | StartGC            { }+  | GCWork             { }+  | GCIdle             { }+  | GCDone             { }+  | EndGC              { }+  | GlobalSyncGC       { }+  | GCStatsGHC         { heapCapset   :: {-# UNPACK #-}!Capset+                       , gen          :: {-# UNPACK #-}!Int+                       , copied       :: {-# UNPACK #-}!Word64+                       , slop, frag   :: {-# UNPACK #-}!Word64+                       , parNThreads  :: {-# UNPACK #-}!Int+                       , parMaxCopied :: {-# UNPACK #-}!Word64+                       , parTotCopied :: {-# UNPACK #-}!Word64+                       }++  -- heap statistics+  | HeapAllocated      { heapCapset  :: {-# UNPACK #-}!Capset+                       , allocBytes  :: {-# UNPACK #-}!Word64+                       }+  | HeapSize           { heapCapset  :: {-# UNPACK #-}!Capset+                       , sizeBytes   :: {-# UNPACK #-}!Word64+                       }+  | HeapLive           { heapCapset  :: {-# UNPACK #-}!Capset+                       , liveBytes   :: {-# UNPACK #-}!Word64+                       }+  | HeapInfoGHC        { heapCapset    :: {-# UNPACK #-}!Capset+                       , gens          :: {-# UNPACK #-}!Int+                       , maxHeapSize   :: {-# UNPACK #-}!Word64+                       , allocAreaSize :: {-# UNPACK #-}!Word64+                       , mblockSize    :: {-# UNPACK #-}!Word64+                       , blockSize     :: {-# UNPACK #-}!Word64+                       }++  -- adjusting the number of capabilities on the fly+  | CapCreate          { cap :: {-# UNPACK #-}!Int+                       }+  | CapDelete          { cap :: {-# UNPACK #-}!Int+                       }+  | CapDisable         { cap :: {-# UNPACK #-}!Int+                       }+  | CapEnable          { cap :: {-# UNPACK #-}!Int+                       }++  -- 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 #-}!PID+                       }+  | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset+                       , ppid   :: {-# UNPACK #-}!PID+                       }+  | WallClockTime      { capset :: {-# UNPACK #-}!Capset+                       , sec    :: {-# UNPACK #-}!Word64+                       , nsec   :: {-# UNPACK #-}!Word32+                       }++  -- messages+  | Message            { msg :: String }+  | UserMessage        { msg :: String }+  | UserMarker         { markername :: String }++  -- Events emitted by a parallel RTS+   -- Program /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++  -- perf events+  | PerfName           { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , name    :: String+                       }+  | PerfCounter        { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , tid     :: {-# UNPACK #-}!KernelThreadId+                       , period  :: {-# UNPACK #-}!Word64+                       }+  | PerfTracepoint     { perfNum :: {-# UNPACK #-}!PerfEventTypeNum+                       , tid     :: {-# UNPACK #-}!KernelThreadId+                       }++  deriving Show++{- [Note: Stop status in GHC-7.8.2]++In GHC-7.7, a new thread block reason "BlockedOnMVarRead" was+introduced, and placed adjacent to BlockedOnMVar (7). Therefore, event+logs produced by GHC pre-7.8.2 encode BlockedOnBlackHole and following+as 8..18, whereas GHC-7.8.2 event logs encode them as 9..19.+Later, the prior event numbering was restored for GHC-7.8.3.+See GHC bug #9003 for a discussion.++The parsers in Events.hs have to be adapted accordingly, providing+special ghc-7.8.2 parsers for the thread-stop event if GHC-7.8.2+produced the eventlog.+The EVENT_USER_MARKER was not present in GHC-7.6.3, and a new event+EVENT_HACK_BUG_T9003 was added in GHC-7.8.3, so we take presence of+USER_MARKER and absence of HACK_BUG_T9003 as an indication that+ghc-7.8.2 parsers should be used.+-}++--sync with ghc/includes/Constants.h+data ThreadStopStatus+ = NoStatus+ | HeapOverflow+ | StackOverflow+ | ThreadYielding+ | ThreadBlocked+ | ThreadFinished+ | ForeignCall+ | BlockedOnMVar+ | BlockedOnMVarRead   -- since GHC-7.8, see [Stop status since GHC-7.7]+ | BlockedOnBlackHole+ | BlockedOnRead+ | BlockedOnWrite+ | BlockedOnDelay+ | BlockedOnSTM+ | BlockedOnDoProc+ | BlockedOnCCall+ | BlockedOnCCall_NoUnblockExc+ | BlockedOnMsgThrowTo+ | ThreadMigrating+ | BlockedOnMsgGlobalise+ | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId+ deriving (Show)++-- normal GHC encoding, see [Stop status in GHC-7.8.2]+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+ 19 ->  NoStatus -- yeuch... this one does not actually exist in GHC eventlogs+ 20 ->  BlockedOnMVarRead -- since GHC-7.8.3+ _  ->  error "mkStat"++-- GHC 7.8.2 encoding, see [Stop status in GHC-7.8.2]+mkStopStatus782 :: RawThreadStopStatus -> ThreadStopStatus+mkStopStatus782 n = case n of+ 0  ->  NoStatus+ 1  ->  HeapOverflow+ 2  ->  StackOverflow+ 3  ->  ThreadYielding+ 4  ->  ThreadBlocked+ 5  ->  ThreadFinished+ 6  ->  ForeignCall+ 7  ->  BlockedOnMVar+ 8  ->  BlockedOnMVarRead -- in GHC-7.8.2+ 9  ->  BlockedOnBlackHole+ 10 ->  BlockedOnRead+ 11 ->  BlockedOnWrite+ 12 ->  BlockedOnDelay+ 13 ->  BlockedOnSTM+ 14 ->  BlockedOnDoProc+ 15 ->  BlockedOnCCall+ 16 ->  BlockedOnCCall_NoUnblockExc+ 17 ->  BlockedOnMsgThrowTo+ 18 ->  ThreadMigrating+ 19 ->  BlockedOnMsgGlobalise+ _  ->  error "mkStat"++maxThreadStopStatusPre77, maxThreadStopStatus782, maxThreadStopStatus+    :: RawThreadStopStatus+maxThreadStopStatusPre77  = 18 -- see [Stop status in GHC-7.8.2]+maxThreadStopStatus782    = 19 -- need to distinguish three cases+maxThreadStopStatus = 20++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+{-# DEPRECATED CapEvent "CapEvents will be removed soon, now Event has a field evCap" #-}+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++-- Checks if the capability is not -1 (which indicates a global eventblock), so+-- has no associated capability+mkCap :: Int -> Maybe Int+mkCap cap = do+  guard $ fromIntegral cap /= (maxBound :: Word16)+  return cap

@@ -0,0 +1,495 @@+{-# LANGUAGE CPP,BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -fsimpl-tick-factor=150 #-}+{-+ -   Parser functions for GHC RTS EventLog framework.+ -}++module GHC.RTS.Events (+       -- * The event log types+       EventLog(..),+       Header(..),+       Data(..),+       EventType(..),+       Event(..),+       EventInfo(..),+       ThreadStopStatus(..),+       CapsetType(..),+       Timestamp,+       ThreadId,+       TaskId,+       KernelThreadId(..),+       EventTypeNum,+       EventTypeDesc,+       EventTypeSize,+       BlockSize,+       Capset,+       StringId,+       -- some types for the parallel RTS+       ProcessId,+       MachineId,+       PortId,+       MessageSize,+       MessageTag(..),+       ParConjDynId,+       ParConjStaticId,+       SparkId,+       FutureId,+       PerfEventTypeNum,++       -- * Reading and writing event logs+       readEventLogFromFile,+       writeEventLogToFile,++       serialiseEventLog,++       -- * Utilities+       CapEvent(..), sortEvents,+       buildEventTypeMap,++       -- * Printing+       printEventsIncremental,+       showEventInfo, buildEventInfo,+       showThreadStopStatus,+       ppEventLog, ppEventType,+       ppEvent, buildEvent, buildEvent',++       -- * Perf events+       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,+       sz_perf_num, sz_kernel_tid,++       -- * For compatibility with old clients+       -- readEventLogFromFile, TODO+       spec,+       time,+  ) where++{- Libraries. -}+import Control.Applicative+import Control.Concurrent hiding (ThreadId)+import qualified Data.Binary.Put as P+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Foldable (foldMap)+import Data.Function hiding (id)+import Data.List+import Data.Monoid ((<>))+import System.IO+import Prelude hiding (gcd, rem, id)++import GHC.RTS.EventTypes+import GHC.RTS.Events.Binary+import GHC.RTS.Events.Incremental++-- | Read an entire eventlog file. It returns an error message if it+-- encouters an error while decoding.+--+-- Note that it doesn't fail if it consumes all input in the middle of decoding+-- of an event.+readEventLogFromFile :: FilePath -> IO (Either String EventLog)+readEventLogFromFile path = fmap fst . readEventLog <$> BL.readFile path++-- | Read an eventlog file and pretty print it to stdout+printEventsIncremental+  :: Bool -- ^ Follow the file or not+  -> FilePath+  -> IO ()+printEventsIncremental follow path =+  withFile path ReadMode (hPrintEventsIncremental follow)++-- | Read an eventlog from the Handle and pretty print it to stdout+hPrintEventsIncremental+  :: Bool -- ^ Follow the handle or not+  -> Handle+  -> IO ()+hPrintEventsIncremental follow hdl = go decodeEventLog+  where+    go decoder = case decoder of+      Produce event decoder' -> do+        BB.hPutBuilder stdout $ buildEvent' event <> "\n"+        go decoder'+      Consume k -> do+        chunk <- B.hGetSome hdl 4096+        if+          | not (B.null chunk) -> go $ k chunk+          | follow -> threadDelay 1000000 >> go decoder+          | otherwise -> return ()+      Done {} -> return ()+      Error _ err -> fail err+++-- | Writes the 'EventLog' to file. The log is expected to __NOT__ have 'EventBlock'+-- markers/events - the parsers no longer emit them and they are handled behind+-- the scenes.+writeEventLogToFile :: FilePath -> EventLog -> IO ()+writeEventLogToFile fp = BL.writeFile fp . serialiseEventLog+++-- | Serialises an 'EventLog' back to a 'ByteString', usually for writing it+-- back to a file.+serialiseEventLog :: EventLog -> BL.ByteString+serialiseEventLog el@(EventLog _ (Data events)) =+  P.runPut $ putEventLog blockedEl+  where+    eventsMap = capSplitEvents events+    blockedEventsMap = IM.mapWithKey addBlockMarker eventsMap+    blockedEl = el{dat = Data blockedEvents}+    blockedEvents = IM.foldr (++) [] blockedEventsMap++-- Gets the Capability of an event in numeric form+getIntCap :: Event -> Int+getIntCap Event{evCap = cap} =+  case cap of+  Just capNo -> capNo+  Nothing    -> -1++-- Creates an IntMap of the events with capability number as the key.+-- Key -1 indicates global (capless) event+capSplitEvents :: [Event] -> IM.IntMap [Event]+capSplitEvents evts = capSplitEvents' evts IM.empty++capSplitEvents' :: [Event] -> IM.IntMap [Event] -> IM.IntMap [Event]+capSplitEvents' evts imap =+  case evts of+  (x:xs) -> capSplitEvents' xs (IM.insertWith (++) (getIntCap x) [x] imap)+  []     -> imap++-- Adds a block marker to the beginnng of a list of events, annotated with+-- its capability. All events are expected to belong to the same cap.+addBlockMarker :: Int -> [Event] -> [Event]+addBlockMarker cap evts =+  (Event startTime (EventBlock endTime cap sz) (mkCap cap)) : sortedEvts+  where+    sz = fromIntegral . BL.length $ P.runPut $ mapM_ putEvent evts+    startTime = case sortedEvts of+      (x:_) -> evTime x+      [] -> error "Cannot add block marker to an empty list of events"+    sortedEvts = sortEvents evts+    endTime = evTime $ last sortedEvts++-- -----------------------------------------------------------------------------+-- Utilities+sortEvents :: [Event] -> [Event]+sortEvents = sortBy (compare `on` evTime)++buildEventTypeMap :: [EventType] -> IntMap EventType+buildEventTypeMap etypes =+  IM.fromList [ (fromIntegral (num t),t) | t <- etypes ]++-----------------------------------------------------------------------------+-- Some pretty-printing support++showEventInfo :: EventInfo -> String+showEventInfo = BL8.unpack . BB.toLazyByteString . buildEventInfo++buildEventInfo :: EventInfo -> BB.Builder+buildEventInfo spec' =+    case spec' of+        EventBlock end_time cap _block_events ->+          "event block: cap " <> BB.intDec cap+          <> ", end time: " <> BB.word64Dec end_time <> "\n"+        Startup n_caps ->+          "startup: " <> BB.intDec n_caps <> " capabilities"+        CreateThread thread ->+          "creating thread " <> BB.word32Dec thread+        RunThread thread ->+          "running thread " <> BB.word32Dec thread+        StopThread thread status ->+          "stopping thread " <> BB.word32Dec thread+          <> " (" <> BB.stringUtf8 (showThreadStopStatus status) <> ")"+        ThreadRunnable thread ->+          "thread " <> BB.word32Dec thread <> " is runnable"+        MigrateThread thread newCap  ->+          "migrating thread " <> BB.word32Dec thread+          <> " to cap " <> BB.intDec newCap+        CreateSparkThread sparkThread ->+          "creating spark thread " <> BB.word32Dec sparkThread+        SparkCounters crt dud ovf cnv fiz gcd rem ->+          "spark stats: "+          <> BB.word64Dec crt <> " created, "+          <> BB.word64Dec cnv <> " converted, "+          <> BB.word64Dec rem <> " remaining ("+          <> BB.word64Dec ovf <> " overflowed, "+          <> BB.word64Dec dud <> " dud, "+          <> BB.word64Dec gcd <> " GC'd, "+          <> BB.word64Dec fiz <> " fizzled)"+        SparkCreate ->+          "spark created"+        SparkDud ->+          "dud spark discarded"+        SparkOverflow ->+          "overflowed spark discarded"+        SparkRun ->+          "running a local spark"+        SparkSteal victimCap ->+          "stealing a spark from cap " <> BB.intDec victimCap+        SparkFizzle ->+          "spark fizzled"+        SparkGC ->+          "spark GCed"+        TaskCreate taskId cap tid ->+          "task 0x" <> BB.word64Hex taskId+          <> " created on cap " <> BB.intDec cap+          <>" with OS kernel thread " <> BB.word64Dec (kernelThreadId tid)+        TaskMigrate taskId cap new_cap ->+          "task 0x" <> BB.word64Hex taskId+          <> " migrated from cap " <> BB.intDec cap+          <> " to cap " <> BB.intDec new_cap+        TaskDelete taskId ->+          "task 0x" <> BB.word64Hex taskId <> " deleted"+        Shutdown ->+          "shutting down"+        WakeupThread thread otherCap ->+          "waking up thread " <> BB.word32Dec thread+          <> " on cap " <> BB.intDec otherCap+        ThreadLabel thread label ->+          "thread " <> BB.word32Dec thread+          <> " has label \"" <> BB.stringUtf8 label <> "\""+        RequestSeqGC ->+          "requesting sequential GC"+        RequestParGC ->+          "requesting parallel GC"+        StartGC ->+          "starting GC"+        EndGC ->+          "finished GC"+        GCWork ->+          "GC working"+        GCIdle ->+          "GC idle"+        GCDone ->+          "GC done"+        GlobalSyncGC ->+          "all caps stopped for GC"+        GCStatsGHC{..} ->+          "GC stats for heap capset " <> BB.word32Dec heapCapset+          <> ": generation " <> BB.intDec gen <> ", "+          <> BB.word64Dec copied <> " bytes copied, "+          <> BB.word64Dec slop <> " bytes slop, "+          <> BB.word64Dec frag <> " bytes fragmentation, "+          <> BB.intDec parNThreads <> " par threads, "+          <> BB.word64Dec parMaxCopied <> " bytes max par copied, "+          <> BB.word64Dec parTotCopied <> " bytes total par copied"+        HeapAllocated{..} ->+          "allocated on heap capset " <> BB.word32Dec heapCapset+          <> ": " <> BB.word64Dec allocBytes <> " total bytes till now"+        HeapSize{..} ->+          "size of heap capset " <> BB.word32Dec heapCapset+          <> ": " <> BB.word64Dec sizeBytes <> " bytes"+        HeapLive{..} ->+          "live data in heap capset " <> BB.word32Dec heapCapset+          <> ": " <> BB.word64Dec liveBytes <> " bytes"+        HeapInfoGHC{..} ->+          "heap stats for heap capset " <> BB.word32Dec heapCapset+          <> ": generations " <> BB.intDec gens <> ", "+          <> BB.word64Dec maxHeapSize <> " bytes max heap size, "+          <> BB.word64Dec allocAreaSize <> " bytes alloc area size, "+          <> BB.word64Dec mblockSize <> " bytes mblock size, "+          <> BB.word64Dec blockSize <> " bytes block size"+        CapCreate{cap} ->+          "created cap " <> BB.intDec cap+        CapDelete{cap} ->+          "deleted cap " <> BB.intDec cap+        CapDisable{cap} ->+          "disabled cap " <> BB.intDec cap+        CapEnable{cap} ->+          "enabled cap " <> BB.intDec cap+        Message msg ->+          BB.stringUtf8 msg+        UserMessage msg ->+          BB.stringUtf8 msg+        UserMarker markername ->+          "marker: " <> BB.stringUtf8 markername+        CapsetCreate cs ct ->+          "created capset " <> BB.word32Dec cs+          <> " of type " <> BB.stringUtf8 (show ct)+        CapsetDelete cs ->+          "deleted capset " <> BB.word32Dec cs+        CapsetAssignCap cs cp ->+          "assigned cap " <> BB.intDec cp <> " to capset " <> BB.word32Dec cs+        CapsetRemoveCap cs cp ->+          "removed cap " <> BB.intDec cp <> " from capset " <> BB.word32Dec cs+        OsProcessPid cs pid ->+          "capset " <> BB.word32Dec cs <> ": pid " <> BB.word32Dec pid+        OsProcessParentPid cs ppid ->+          "capset " <> BB.word32Dec cs <> ": parent pid " <> BB.word32Dec ppid+        WallClockTime cs sec nsec ->+          "capset " <> BB.word32Dec cs <> ": wall clock time "+          <> BB.word64Dec sec <> "s "+          <> BB.word32Dec nsec <> "ns (unix epoch)"+        RtsIdentifier cs i ->+          "capset " <> BB.word32Dec cs+          <> ": RTS version \"" <> BB.stringUtf8 i <> "\""+        ProgramArgs cs args ->+          "capset " <> BB.word32Dec cs+          <> ": args: " <> BB.stringUtf8 (show args)+        ProgramEnv cs env ->+          "capset " <> BB.word32Dec cs+          <> ": env: " <> BB.stringUtf8 (show env)+        UnknownEvent n ->+          "Unknown event type " <> BB.word16Dec n+        InternString str sId ->+          "Interned string: \"" <> BB.stringUtf8 str+          <> "\" with id " <> BB.word32Dec sId+        -- events for the parallel RTS+        Version version ->+          "compiler version is " <> BB.stringUtf8 version+        ProgramInvocation  commandline ->+          "program invocation: " <> BB.stringUtf8 commandline+        EdenStartReceive ->+          "starting to receive"+        EdenEndReceive ->+          "stop receiving"+        CreateProcess  process ->+          "creating process " <> BB.word32Dec process+        KillProcess process ->+          "killing process " <> BB.word32Dec process+        AssignThreadToProcess thread process ->+          "assigning thread " <> BB.word32Dec thread+          <> " to process " <> BB.word32Dec process+        CreateMachine machine realtime ->+          "creating machine " <> BB.word16Dec machine+          <> " at " <> BB.word64Dec realtime+        KillMachine machine ->+          "killing machine " <> BB.word16Dec machine+        SendMessage mesTag senderProcess senderThread+          receiverMachine receiverProcess receiverInport ->+            "sending message with tag " <> BB.stringUtf8 (show mesTag)+            <> " from process " <> BB.word32Dec senderProcess+            <> ", thread " <> BB.word32Dec senderThread+            <> " to machine " <> BB.word16Dec receiverMachine+            <> ", process " <> BB.word32Dec receiverProcess+            <> " on inport " <> BB.word32Dec receiverInport+        ReceiveMessage mesTag receiverProcess receiverInport+          senderMachine senderProcess senderThread messageSize ->+            "receiving message with tag " <> BB.stringUtf8 (show mesTag)+            <> " at process " <> BB.word32Dec receiverProcess+            <> ", inport " <> BB.word32Dec receiverInport+            <> " from machine " <> BB.word16Dec senderMachine+            <> ", process " <> BB.word32Dec senderProcess+            <> ", thread " <> BB.word32Dec senderThread+            <> " with size " <> BB.word32Dec messageSize+        SendReceiveLocalMessage mesTag senderProcess senderThread+          receiverProcess receiverInport ->+            "sending/receiving message with tag " <> BB.stringUtf8 (show mesTag)+            <> " from process " <> BB.word32Dec senderProcess+            <> ", thread " <> BB.word32Dec senderThread+            <> " to process " <> BB.word32Dec receiverProcess+            <> " on inport " <> BB.word32Dec receiverInport+        MerStartParConjunction dyn_id static_id ->+          "Start a parallel conjunction 0x" <> BB.word64Hex dyn_id+          <> ", static_id: " <> BB.word32Dec static_id+        MerEndParConjunction dyn_id ->+          "End par conjunction: 0x" <> BB.word64Hex dyn_id+        MerEndParConjunct dyn_id ->+          "End par conjunct: 0x" <> BB.word64Hex dyn_id+        MerCreateSpark dyn_id spark_id ->+          "Create spark for conjunction: 0x" <> BB.word64Hex dyn_id+          <> " spark: 0x" <> BB.word32Hex spark_id+        MerFutureCreate future_id name_id ->+          "Create future 0x" <> BB.word64Hex future_id+          <> " named " <> BB.word32Dec name_id+        MerFutureWaitNosuspend future_id ->+          "Wait didn't suspend for future: 0x" <> BB.word64Hex future_id+        MerFutureWaitSuspended future_id ->+          "Wait suspended on future: 0x" <> BB.word64Hex future_id+        MerFutureSignal future_id ->+          "Signaled future 0x" <> BB.word64Hex 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 ->+          "Releasing thread " <> BB.word32Dec thread_id <> " to the free pool"+        MerCapSleeping ->+          "Capability going to sleep"+        MerCallingMain ->+          "About to call the program entry point"+        PerfName{perfNum, name} ->+          "perf event " <> BB.word32Dec perfNum+          <> " named \"" <> BB.stringUtf8 name <> "\""+        PerfCounter{perfNum, tid, period} ->+          "perf event counter " <> BB.word32Dec perfNum+          <> " incremented by " <> BB.word64Dec (period + 1)+          <> " in OS thread " <> BB.word64Dec (kernelThreadId tid)+        PerfTracepoint{perfNum, tid} ->+          "perf event tracepoint " <> BB.word32Dec perfNum+          <> " reached in OS thread " <> BB.word64Dec (kernelThreadId tid)++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 BlockedOnMVarRead = "blocked reading 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 = BL8.unpack . BB.toLazyByteString . buildEventLog++buildEventLog :: EventLog -> BB.Builder+buildEventLog (EventLog (Header ets) (Data es)) =+  "Event Types:\n"+  <> foldMap (\evType -> buildEventType evType <> "\n") ets+  <> "\n"+  <> "Events:\n"+  <> foldMap (\ev -> buildEvent imap ev <> "\n") sorted+  where+    imap = buildEventTypeMap ets+    sorted = sortEvents es++ppEventType :: EventType -> String+ppEventType = BL8.unpack . BB.toLazyByteString . buildEventType++buildEventType :: EventType -> BB.Builder+buildEventType (EventType num dsc msz) =+  BB.word16Dec num <> ": "+  <> BB.stringUtf8 dsc <> " (size "+  <> maybe "variable" BB.word16Dec msz <> ")"++-- | Pretty prints an 'Event', with clean handling for 'UnknownEvent'+ppEvent :: IntMap EventType -> Event -> String+ppEvent imap = BL8.unpack . BB.toLazyByteString . buildEvent imap++buildEvent :: IntMap EventType -> Event -> BB.Builder+buildEvent imap Event {..} =+  BB.word64Dec evTime+  <> ": "+  <> maybe "" (\c -> "cap " <> BB.intDec c <> ": ") evCap+  <> case evSpec of+    UnknownEvent{ ref=ref } ->+      maybe "" (BB.stringUtf8 . desc) $ IM.lookup (fromIntegral ref) imap+    _ -> buildEventInfo evSpec++buildEvent' :: Event -> BB.Builder+buildEvent' Event {..} =+   BB.word64Dec evTime+   <> ": "+   <> maybe "" (\c -> "cap " <> BB.intDec c <> ": ") evCap+   <> case evSpec of+     UnknownEvent{ ref=ref } ->+      "Unknown Event (ref: " <> BB.word16Dec ref <> ")"+     _ -> buildEventInfo evSpec

@@ -0,0 +1,272 @@+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)++--------------------------------------------------------------------------------+-- | 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+  }++-- | 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 against 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 = go (initial machine)+ 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')

@@ -0,0 +1,209 @@+module GHC.RTS.Events.Analysis.Capability+  ( capabilityThreadPoolMachine+  , capabilityThreadRunMachine+  , capabilityThreadIndexer+  , capabilityTaskPoolMachine+  , capabilityTaskOSMachine+  )+ 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) Event+capabilityThreadPoolMachine = Machine+  { initial = M.empty+  , final   = const False+  , alpha   = capabilityThreadPoolMachineAlpha+  , delta   = capabilityThreadPoolMachineDelta+  }+ where+  capabilityThreadPoolMachineAlpha evt = case evSpec evt of+     (CreateThread _)    -> True+     (StopThread _ _)    -> True+     (MigrateThread _ _) -> True+     _                   -> False++  capabilityThreadPoolMachineDelta mapping evt = do+    capId <- evCap evt+    case evSpec evt 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 `M.member` 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+      | threadId `M.notMember` 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) Event+capabilityThreadRunMachine = Machine+  { initial = M.empty+  , final   = const False+  , alpha   = threadRunAlpha+  , delta   = threadRunDelta+  }+ where+  threadRunAlpha event = case evSpec event 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 <- evCap e+    case evSpec $ 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+      | capId `M.member` 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 -> Event -> Maybe ThreadId+capabilityThreadIndexer m evt = case evSpec evt 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 == evCap evt+                                   then Just threadId+                                   else Nothing+  _                             -> mThreadId+ where+  mThreadId = evCap evt >>= (\capId -> M.lookup capId m)++-- | This state machine tracks Haskell tasks, represented by TaskId,+-- residing on capabilities.+-- Each Haskell task can only reside on one capability, but can be migrated+-- between them.+capabilityTaskPoolMachine :: Machine (Map TaskId Int) Event+capabilityTaskPoolMachine = Machine+  { initial = M.empty+  , final   = const False+  , alpha   = capabilityTaskPoolMachineAlpha+  , delta   = capabilityTaskPoolMachineDelta+  }+ where+  capabilityTaskPoolMachineAlpha evt = case evSpec evt of+     TaskCreate{}  -> True+     TaskDelete{}  -> True+     TaskMigrate{} -> True+     _             -> False++  capabilityTaskPoolMachineDelta mapping evt = do+    case evSpec evt of+      TaskCreate {taskId, cap}           -> insertTask taskId cap mapping+      TaskDelete {taskId}                -> deleteTask taskId Nothing mapping+      TaskMigrate {taskId, cap, new_cap} ->+        deleteTask taskId (Just cap) mapping >>=+          insertTask taskId new_cap+      _                                  -> Nothing+   where+    insertTask :: TaskId -> Int -> Map TaskId Int+               -> Maybe (Map TaskId Int)+    insertTask taskId cap m+      | taskId `M.member` m = Nothing  -- The task already exists.+      | otherwise           = Just $ M.insert taskId cap m++    deleteTask :: TaskId -> Maybe Int -> Map TaskId Int+               -> Maybe (Map TaskId Int)+    deleteTask taskId expectedcap m+      | Just oldcap <- M.lookup taskId m+      , maybe True (==oldcap) expectedcap+      = Just $ M.delete taskId m+      | otherwise+      = Nothing  -- The task doesn't exist, or does but with an unexpected cap.++-- | This state machine tracks Haskell tasks (represented by the KernelThreadId+-- of their OS thread) residing on capabilities and additionally+-- tracks the (immutable) assignment of OS thread ids (KernelThreadId)+-- to tasks ids (TaskId).+-- Each Haskell task can only reside on one capability, but can be migrated+-- between them.+--+-- Invariant for the @(Map KernelThreadId Int, Map TaskId KernelThreadId)@ +-- type: the second map is an injection (verified by the machine +-- in 'insertTaskOS') and the following sets are equal: +-- keys of the fist map and values of the second+-- (follows from the construction of the maps by the machine).+--+-- The machine verifies as much as 'capabilityTaskPoolMachine' and additionally+-- the data invariant, and offers a richer verification profile.+capabilityTaskOSMachine :: Machine (Map KernelThreadId Int,+                                    Map TaskId KernelThreadId)+                                   Event+capabilityTaskOSMachine = Machine+  { initial = (M.empty, M.empty)+  , final   = const False+  , alpha   = capabilityTaskOSMachineAlpha+  , delta   = capabilityTaskOSMachineDelta+  }+ where+  capabilityTaskOSMachineAlpha evt = case evSpec evt of+     TaskCreate{}  -> True+     TaskDelete{}  -> True+     TaskMigrate{} -> True+     _             -> False++  capabilityTaskOSMachineDelta mapping evt = do+    case evSpec evt of+      TaskCreate {taskId, cap, tid} -> insertTaskOS taskId cap tid mapping+      TaskDelete {taskId}           -> deleteTaskOS taskId mapping+      TaskMigrate {taskId, new_cap} -> migrateTaskOS taskId new_cap mapping+      _                             -> Nothing+   where+    insertTaskOS :: TaskId -> Int -> KernelThreadId+                 -> (Map KernelThreadId Int, Map TaskId KernelThreadId)+                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    insertTaskOS taskId cap tid (m, ma)+      | taskId `M.member` ma = Nothing  -- The task already exists.+      | tid `M.member` m     = Nothing  -- The OS thread already exists.+      | otherwise            = Just (M.insert tid cap m,+                                     M.insert taskId tid ma)++    deleteTaskOS :: TaskId -> (Map KernelThreadId Int,+                               Map TaskId KernelThreadId)+                 -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    deleteTaskOS taskId (m, ma) =+      case M.lookup taskId ma of+        Nothing  -> Nothing  -- The task doesn't exist.+        Just tid -> Just (M.delete tid m,+                          M.delete taskId ma)++    migrateTaskOS :: TaskId -> Int -> (Map KernelThreadId Int,+                                       Map TaskId KernelThreadId)+                  -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId)+    migrateTaskOS taskId new_cap (m, ma) =+      case M.lookup taskId ma of+        Nothing -> Nothing  -- The task doesn't exist.+        Just tid -> Just (M.insert tid new_cap m,+                          ma)  -- The assignment is immutable.

@@ -0,0 +1,110 @@+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++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 _) (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) Event+capabilitySparkThreadMachine = Machine+  { initial = (M.empty, S.empty)+  , final   = const False+  , alpha   = capabilitySparkThreadAlpha+  , delta   = capabilitySparkThreadDelta+  }+ where+  capabilitySparkThreadAlpha evt = case evSpec evt of+    (CreateSparkThread _)         -> True+    (RunThread _)                 -> True+    (StopThread _ _)              -> True+    _                             -> False+  capabilitySparkThreadDelta (m, s) evt = do+    capId <- evCap evt+    case evSpec evt of+      (CreateSparkThread threadId)         -> createThread 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) -> Event -> Maybe ThreadId+capabilitySparkThreadIndexer (m, s) evt = case evSpec evt of+  (CreateThread threadId)   -> inSparkThreadPool threadId+  (RunThread threadId)      -> inSparkThreadPool threadId+  (StopThread threadId _)   -> inSparkThreadPool threadId+  _                         -> evCap evt >>= (\capId -> M.lookup capId m)+ where+  inSparkThreadPool :: ThreadId -> Maybe ThreadId+  inSparkThreadPool threadId+    | S.member threadId s = Just threadId+    | otherwise           = Nothing+

@@ -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

@@ -0,0 +1,1228 @@+{-# LANGUAGE CPP #-}+module GHC.RTS.Events.Binary+  ( -- * Readers+    getHeader+  , getEvent+  , standardParsers+  , ghc6Parsers+  , ghc7Parsers+  , mercuryParsers+  , perfParsers+  , pre77StopParsers+  , ghc782StopParser+  , post782StopParser+  , parRTSParsers++  -- * Writers+  , putEventLog+  , putHeader+  , putEvent++  -- * Perf events+  , nEVENT_PERF_NAME+  , nEVENT_PERF_COUNTER+  , nEVENT_PERF_TRACEPOINT++  ) where+import Control.Monad+import Data.Maybe+import Prelude hiding (gcd, rem, id)++import Data.Array+import Data.Binary+import Data.Binary.Put+import qualified Data.Binary.Get as G++import GHC.RTS.EventTypes+import GHC.RTS.EventParserUtils++#define EVENTLOG_CONSTANTS_ONLY+#include "EventLogFormat.h"++getEventType :: Get EventType+getEventType = do+           etNum <- get+           size <- get :: Get EventTypeSize+           let etSize = if size == 0xffff then Nothing else Just size+           -- 0xffff indicates variable-sized event+           etDescLen <- get :: Get EventTypeDescLen+           etDesc <- getEtDesc (fromIntegral etDescLen)+           etExtraLen <- get :: Get Word32+           G.skip (fromIntegral etExtraLen)+           ete <- get :: Get Marker+           when (ete /= EVENT_ET_END) $+              fail "Event Type end marker not found."+           return (EventType etNum etDesc etSize)+           where+             getEtDesc :: Int -> Get [Char]+             getEtDesc s = replicateM s (get :: Get Char)++getHeader :: Get Header+getHeader = do+            hdrb <- get :: Get Marker+            when (hdrb /= EVENT_HEADER_BEGIN) $+                 fail "Header begin marker not found"+            hetm <- get :: Get Marker+            when (hetm /= EVENT_HET_BEGIN) $+                 fail "Header Event Type begin marker not found"+            ets <- getEventTypes+            emark <- get :: Get Marker+            when (emark /= EVENT_HEADER_END) $+                 fail "Header end marker not found"+            db <- get :: Get Marker+            when (db /= EVENT_DATA_BEGIN) $+                  fail "My Data begin marker not found"+            return $ Header ets+     where+      getEventTypes :: Get [EventType]+      getEventTypes = do+          m <- get :: Get Marker+          case m of+             EVENT_ET_BEGIN -> do+                  et <- getEventType+                  nextET <- getEventTypes+                  return (et : nextET)+             EVENT_HET_END ->+                  return []+             _ ->+                  fail "Malformed list of Event Types in header"++getEvent :: EventParsers -> Get (Maybe Event)+getEvent (EventParsers parsers) = do+  etRef <- get :: Get EventTypeNum+  if etRef == EVENT_DATA_END+     then return Nothing+     else do !evTime   <- get+             evSpec <- parsers ! fromIntegral etRef+             return $ Just Event { evCap = undefined, .. }++--+-- standardEventParsers.+--+standardParsers :: [EventParser EventInfo]+standardParsers = [+ (FixedSizeParser EVENT_STARTUP sz_cap (do -- (n_caps)+      c <- get :: Get 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 <- get :: Get BlockSize+      end_time <- get :: Get Timestamp+      c <- get :: Get CapNo+      return EventBlock { end_time   = end_time,+                          cap        = fromIntegral c,+                          block_size = ((fromIntegral block_size) -+                                        (fromIntegral sz_block_event))+                        }+   )),++ -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6++ -- no longer generate the event; should be removed at some point+ (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),++ (simpleEvent EVENT_GC_GLOBAL_SYNC GlobalSyncGC),++ (FixedSizeParser EVENT_GC_STATS_GHC (sz_capset + 2 + 5*8 + 4) (do  -- (heap_capset, generation, copied_bytes, slop_bytes, frag_bytes, par_n_threads, par_max_copied, par_tot_copied)+      heapCapset   <- get+      gen          <- get :: Get Word16+      copied       <- get :: Get Word64+      slop         <- get :: Get Word64+      frag         <- get :: Get Word64+      parNThreads  <- get :: Get Word32+      parMaxCopied <- get :: Get Word64+      parTotCopied <- get :: Get Word64+      return GCStatsGHC{ gen = fromIntegral gen+                       , parNThreads = fromIntegral parNThreads+                       , ..}+ )),++ (FixedSizeParser EVENT_HEAP_ALLOCATED (sz_capset + 8) (do  -- (heap_capset, alloc_bytes)+      heapCapset <- get+      allocBytes <- get+      return HeapAllocated{..}+ )),++ (FixedSizeParser EVENT_HEAP_SIZE (sz_capset + 8) (do  -- (heap_capset, size_bytes)+      heapCapset <- get+      sizeBytes  <- get+      return HeapSize{..}+ )),++ (FixedSizeParser EVENT_HEAP_LIVE (sz_capset + 8) (do  -- (heap_capset, live_bytes)+      heapCapset <- get+      liveBytes  <- get+      return HeapLive{..}+ )),++ (FixedSizeParser EVENT_HEAP_INFO_GHC (sz_capset + 2 + 4*8) (do  -- (heap_capset, n_generations, max_heap_size, alloc_area_size, mblock_size, block_size)+      heapCapset    <- get+      gens          <- get :: Get Word16+      maxHeapSize   <- get :: Get Word64+      allocAreaSize <- get :: Get Word64+      mblockSize    <- get :: Get Word64+      blockSize     <- get :: Get Word64+      return HeapInfoGHC{gens = fromIntegral gens, ..}+ )),++ (FixedSizeParser EVENT_CAP_CREATE (sz_cap) (do  -- (cap)+      cap <- get :: Get CapNo+      return CapCreate{cap = fromIntegral cap}+ )),++ (FixedSizeParser EVENT_CAP_DELETE (sz_cap) (do  -- (cap)+      cap <- get :: Get CapNo+      return CapDelete{cap = fromIntegral cap}+ )),++ (FixedSizeParser EVENT_CAP_DISABLE (sz_cap) (do  -- (cap)+      cap <- get :: Get CapNo+      return CapDisable{cap = fromIntegral cap}+ )),++ (FixedSizeParser EVENT_CAP_ENABLE (sz_cap) (do  -- (cap)+      cap <- get :: Get CapNo+      return CapEnable{cap = fromIntegral cap}+ )),++ (FixedSizeParser EVENT_CAPSET_CREATE (sz_capset + sz_capset_type) (do -- (capset, capset_type)+      cs <- get+      ct <- fmap mkCapsetType get+      return CapsetCreate{capset=cs,capsetType=ct}+   )),++ (FixedSizeParser EVENT_CAPSET_DELETE sz_capset (do -- (capset)+      cs <- get+      return CapsetDelete{capset=cs}+   )),++ (FixedSizeParser EVENT_CAPSET_ASSIGN_CAP (sz_capset + sz_cap) (do -- (capset, cap)+      cs <- get+      cp <- get :: Get CapNo+      return CapsetAssignCap{capset=cs,cap=fromIntegral cp}+   )),++ (FixedSizeParser EVENT_CAPSET_REMOVE_CAP (sz_capset + sz_cap) (do -- (capset, cap)+      cs <- get+      cp <- get :: Get CapNo+      return CapsetRemoveCap{capset=cs,cap=fromIntegral cp}+   )),++ (FixedSizeParser EVENT_OSPROCESS_PID (sz_capset + sz_pid) (do -- (capset, pid)+      cs <- get+      pd <- get+      return OsProcessPid{capset=cs,pid=pd}+   )),++ (FixedSizeParser EVENT_OSPROCESS_PPID (sz_capset + sz_pid) (do -- (capset, ppid)+      cs <- get+      pd <- get+      return OsProcessParentPid{capset=cs,ppid=pd}+  )),++ (FixedSizeParser EVENT_WALL_CLOCK_TIME (sz_capset + 8 + 4) (do -- (capset, unix_epoch_seconds, nanoseconds)+      cs <- get+      s  <- get+      ns <- get+      return WallClockTime{capset=cs,sec=s,nsec=ns}+  )),++ (VariableSizeParser EVENT_LOG_MSG (do -- (msg)+      num <- get :: Get Word16+      string <- getString num+      return Message{ msg = string }+   )),+ (VariableSizeParser EVENT_USER_MSG (do -- (msg)+      num <- get :: Get Word16+      string <- getString num+      return UserMessage{ msg = string }+   )),+    (VariableSizeParser EVENT_USER_MARKER (do -- (markername)+      num <- get :: Get Word16+      string <- getString num+      return UserMarker{ markername = string }+   )),+ (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])+      num <- get :: Get Word16+      cs <- get+      string <- getString (num - sz_capset)+      return ProgramArgs{ capset = cs+                        , args = splitNull string }+   )),+ (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg])+      num <- get :: Get Word16+      cs <- get+      string <- getString (num - sz_capset)+      return ProgramEnv{ capset = cs+                       , env = splitNull string }+   )),+ (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str)+      num <- get :: Get Word16+      cs <- get+      string <- getString (num - sz_capset)+      return RtsIdentifier{ capset = cs+                          , rtsident = string }+   )),++ (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id)+      num <- get :: Get Word16+      string <- getString (num - sz_string_id)+      sId <- get :: Get StringId+      return (InternString string sId)+    )),++ (VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str)+      num <- get :: Get Word16+      tid <- get+      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 <- get+      return CreateThread{thread=t}+   )),++ (FixedSizeParser EVENT_RUN_THREAD sz_tid (do  --  (thread)+      t <- get+      return RunThread{thread=t}+   )),++ (FixedSizeParser EVENT_THREAD_RUNNABLE sz_tid (do  -- (thread)+      t <- get+      return ThreadRunnable{thread=t}+   )),++ (FixedSizeParser EVENT_MIGRATE_THREAD (sz_tid + sz_cap) (do  --  (thread, newCap)+      t  <- get+      nc <- get :: Get 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)+      _ <- get :: Get ThreadId+      return SparkRun+   )),++ (FixedSizeParser EVENT_STEAL_SPARK (sz_tid + sz_cap) (do  -- (thread, victimCap)+      _  <- get :: Get ThreadId+      vc <- get :: Get CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),++ (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_tid (do  -- (sparkThread)+      st <- get :: Get ThreadId+      return CreateSparkThread{sparkThread=st}+   )),++ (FixedSizeParser EVENT_SPARK_COUNTERS (7*8) (do -- (crt,dud,ovf,cnv,gcd,fiz,rem)+      crt <- get :: Get Word64+      dud <- get :: Get Word64+      ovf <- get :: Get Word64+      cnv <- get :: Get Word64+      gcd <- get :: Get Word64+      fiz <- get :: Get Word64+      rem <- get :: Get Word64+      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,+                           sparksOverflowed = ovf, sparksConverted = cnv,+                           -- Warning: order of fiz and gcd reversed!+                           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 <- get :: Get CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),+ (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),+ (simpleEvent EVENT_SPARK_GC       SparkGC),++ (FixedSizeParser EVENT_TASK_CREATE (sz_taskid + sz_cap + sz_kernel_tid) (do  -- (taskID, cap, tid)+      taskId <- get :: Get TaskId+      cap    <- get :: Get CapNo+      tid    <- get :: Get KernelThreadId+      return TaskCreate{ taskId, cap = fromIntegral cap, tid }+   )),+ (FixedSizeParser EVENT_TASK_MIGRATE (sz_taskid + sz_cap*2) (do  -- (taskID, cap, new_cap)+      taskId  <- get :: Get TaskId+      cap     <- get :: Get CapNo+      new_cap <- get :: Get CapNo+      return TaskMigrate{ taskId, cap = fromIntegral cap+                                , new_cap = fromIntegral new_cap+                        }+   )),+ (FixedSizeParser EVENT_TASK_DELETE (sz_taskid) (do  -- (taskID)+      taskId <- get :: Get TaskId+      return TaskDelete{ taskId }+   )),++ (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do  -- (thread, other_cap)+      t <- get+      oc <- get :: Get CapNo+      return WakeupThread{thread=t,otherCap=fromIntegral oc}+   ))+ ]++-- special thread stop event parsers for GHC version 7.8.2+-- see [Stop status in GHC-7.8.2] in EventTypes.hs+ghc782StopParser :: EventParser EventInfo+ghc782StopParser =+ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do+      -- (thread, status, info)+      t <- get+      s <- get :: Get RawThreadStopStatus+      i <- get :: Get ThreadId+      return StopThread{thread = t,+                        status = case () of+                                  _ | s > maxThreadStopStatus782+                                    -> NoStatus+                                    | s == 9 {- XXX yeuch -}+                                      -- GHC-7.8.2: 9 == BlockedOnBlackHole+                                    -> BlockedOnBlackHoleOwnedBy i+                                    | otherwise+                                    -> mkStopStatus782 s}+   ))++-- parsers for GHC < 7.8.2. Older versions do not use block info+-- (different length).  See [Stop status in GHC-7.8.2] in+-- EventTypes.hs+pre77StopParsers :: [EventParser EventInfo]+pre77StopParsers = [+ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do+      -- (thread, status)+      t <- get+      s <- get :: Get RawThreadStopStatus+      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77+                                              then NoStatus+                                              else mkStopStatus s}+                        -- older version of the event, no block info+   )),++ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid)+    (do+      -- (thread, status, info)+      t <- get+      s <- get :: Get RawThreadStopStatus+      i <- get :: Get ThreadId+      return StopThread{thread = t,+                        status = case () of+                                  _ | s > maxThreadStopStatusPre77+                                    -> NoStatus+                                    | s == 8 {- XXX yeuch -}+                                      -- pre-7.7: 8==BlockedOnBlackhole+                                    -> BlockedOnBlackHoleOwnedBy i+                                    | otherwise+                                    -> mkStopStatus s}+    ))+  ]++-- parsers for GHC >= 7.8.3, always using block info field parser.+-- See [Stop status in GHC-7.8.2] in EventTypes.hs+post782StopParser :: EventParser EventInfo+post782StopParser =+ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid)+    (do+      -- (thread, status, info)+      t <- get+      s <- get :: Get RawThreadStopStatus+      i <- get :: Get ThreadId+      return StopThread{thread = t,+                        status = case () of+                                  _ | s > maxThreadStopStatus+                                    -> NoStatus+                                    | s == 8 {- XXX yeuch -}+                                      -- post-7.8.2: 8==BlockedOnBlackhole+                                    -> BlockedOnBlackHoleOwnedBy i+                                    | otherwise+                                    -> mkStopStatus s}+    ))++ -----------------------+ -- 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 <- get :: Get CapNo+      return Startup{ n_caps = fromIntegral c }+   )),++ (FixedSizeParser EVENT_CREATE_THREAD sz_old_tid (do  -- (thread)+      t <- get+      return CreateThread{thread=t}+   )),++ (FixedSizeParser EVENT_RUN_THREAD sz_old_tid (do  --  (thread)+      t <- get+      return RunThread{thread=t}+   )),++ (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do  -- (thread, status)+      t <- get+      s <- get :: Get RawThreadStopStatus+      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77+                                              then NoStatus+                                              else mkStopStatus s}+                        -- older version of the event uses pre-77 encoding+                        -- (actually, it only uses encodings 0 to 5)+                        -- see [Stop status in GHC-7.8.2] in EventTypes.hs+   )),++ (FixedSizeParser EVENT_THREAD_RUNNABLE sz_old_tid (do  -- (thread)+      t <- get+      return ThreadRunnable{thread=t}+   )),++ (FixedSizeParser EVENT_MIGRATE_THREAD (sz_old_tid + sz_cap) (do  --  (thread, newCap)+      t  <- get+      nc <- get :: Get 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)+      _ <- get :: Get ThreadId+      return SparkRun+   )),++ (FixedSizeParser EVENT_STEAL_SPARK (sz_old_tid + sz_cap) (do  -- (thread, victimCap)+      _  <- get :: Get ThreadId+      vc <- get :: Get CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),++ (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_old_tid (do  -- (sparkThread)+      st <- get :: Get ThreadId+      return CreateSparkThread{sparkThread=st}+   )),++ (FixedSizeParser EVENT_THREAD_WAKEUP (sz_old_tid + sz_cap) (do  -- (thread, other_cap)+      t <- get+      oc <- get :: Get 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 <- get :: Get Word16+      string <- getString num+      return Version{ version = string }+   )),++ (VariableSizeParser EVENT_PROGRAM_INVOCATION (do -- (cmd. line)+      num <- get :: Get 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 <- get+        return CreateProcess{ process = p })+ ),++ (FixedSizeParser EVENT_KILL_PROCESS sz_procid+    (do p <- get+        return KillProcess{ process = p })+ ),++ (FixedSizeParser EVENT_ASSIGN_THREAD_TO_PROCESS (sz_tid' + sz_procid)+    (do t <- get+        p <- get+        return AssignThreadToProcess { thread = t, process = p })+ ),++ (FixedSizeParser EVENT_CREATE_MACHINE (sz_mid + sz_realtime)+    (do m <- get+        t <- get+        return CreateMachine { machine = m, realtime = t })+ ),++ (FixedSizeParser EVENT_KILL_MACHINE sz_mid+    (do m <- get :: Get MachineId+        return KillMachine { machine = m })+ ),++ (FixedSizeParser EVENT_SEND_MESSAGE+    (sz_msgtag + 2*sz_procid + 2*sz_tid' + sz_mid)+    (do tag <- get :: Get RawMsgTag+        sP  <- get :: Get ProcessId+        sT  <- get :: Get ThreadId+        rM  <- get :: Get MachineId+        rP  <- get :: Get ProcessId+        rIP <- get :: Get 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 <- get :: Get Word8+        rP  <- get :: Get ProcessId+        rIP <- get :: Get PortId+        sM  <- get :: Get MachineId+        sP  <- get :: Get ProcessId+        sT  <- get :: Get ThreadId+        mS  <- get :: Get 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 <- get :: Get Word8+        sP  <- get :: Get ProcessId+        sT  <- get :: Get ThreadId+        rP  <- get :: Get ProcessId+        rIP <- get :: Get PortId+        return SendReceiveLocalMessage { mesTag = toMsgTag tag,+                                         senderProcess = sP,+                                         senderThread = sT,+                                         receiverProcess = rP,+                                         receiverInport = rIP+                                       })+ )]++mercuryParsers :: [EventParser EventInfo]+mercuryParsers = [+ (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION+    (sz_par_conj_dyn_id + sz_par_conj_static_id)+    (do dyn_id <- get+        static_id <- get+        return (MerStartParConjunction dyn_id static_id))+ ),++ (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id+    (do dyn_id <- get+        return (MerEndParConjunction dyn_id))+ ),++ (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id+    (do dyn_id <- get+        return (MerEndParConjunct dyn_id))+ ),++ (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id)+    (do dyn_id <- get+        spark_id <- get+        return (MerCreateSpark dyn_id spark_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id)+    (do future_id <- get+        name_id <- get+        return (MerFutureCreate future_id name_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id)+    (do future_id <- get+        return (MerFutureWaitNosuspend future_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id)+    (do future_id <- get+        return (MerFutureWaitSuspended future_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id)+    (do future_id <- get+        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 <- get+        return (MerReleaseThread thread_id))+ ),++ (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping),+ (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)++ ]++perfParsers :: [EventParser EventInfo]+perfParsers = [+ (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)+      num     <- get :: Get Word16+      perfNum <- get+      name    <- getString (num - sz_perf_num)+      return PerfName{perfNum, name}+   )),++ (FixedSizeParser EVENT_PERF_COUNTER (sz_perf_num + sz_kernel_tid + 8) (do -- (perf_num, tid, period)+      perfNum <- get+      tid     <- get+      period  <- get+      return PerfCounter{perfNum, tid, period}+  )),++ (FixedSizeParser EVENT_PERF_TRACEPOINT (sz_perf_num + sz_kernel_tid) (do -- (perf_num, tid)+      perfNum <- get+      tid     <- get+      return PerfTracepoint{perfNum, tid}+  ))+ ]++-----------------------------------------------------------++putE :: Binary a => a -> PutM ()+putE = put++putType :: EventTypeNum -> PutM ()+putType = putE++putCap :: Int -> PutM ()+putCap c = putE (fromIntegral c :: CapNo)++putMarker :: Word32 -> PutM ()+putMarker = putE++putEStr :: String -> PutM ()+putEStr = mapM_ putE++putEventLog :: EventLog -> PutM ()+putEventLog (EventLog hdr es) = do+    putHeader hdr+    putData es++putHeader :: Header -> PutM ()+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 -> PutM ()+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+    GlobalSyncGC {} -> EVENT_GC_GLOBAL_SYNC+    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+    TaskCreate  {} -> EVENT_TASK_CREATE+    TaskMigrate {} -> EVENT_TASK_MIGRATE+    TaskDelete  {} -> EVENT_TASK_DELETE+    Message {} -> EVENT_LOG_MSG+    Startup {} -> EVENT_STARTUP+    EventBlock {} -> EVENT_BLOCK_MARKER+    UserMessage {} -> EVENT_USER_MSG+    UserMarker  {} -> EVENT_USER_MARKER+    GCIdle {} -> EVENT_GC_IDLE+    GCWork {} -> EVENT_GC_WORK+    GCDone {} -> EVENT_GC_DONE+    GCStatsGHC{} -> EVENT_GC_STATS_GHC+    HeapAllocated{} -> EVENT_HEAP_ALLOCATED+    HeapSize{} -> EVENT_HEAP_SIZE+    HeapLive{} -> EVENT_HEAP_LIVE+    HeapInfoGHC{} -> EVENT_HEAP_INFO_GHC+    CapCreate{} -> EVENT_CAP_CREATE+    CapDelete{} -> EVENT_CAP_DELETE+    CapDisable{} -> EVENT_CAP_DISABLE+    CapEnable{} -> EVENT_CAP_ENABLE+    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+    PerfName       {} -> nEVENT_PERF_NAME+    PerfCounter    {} -> nEVENT_PERF_COUNTER+    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT++nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum+nEVENT_PERF_NAME = EVENT_PERF_NAME+nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER+nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT++putEvent :: Event -> PutM ()+putEvent Event {..} = do+    putType (eventTypeNum evSpec)+    put evTime+    putEventSpec evSpec++putEventSpec :: EventInfo -> PutM ()+putEventSpec (Startup caps) = do+    putCap (fromIntegral caps)++putEventSpec (EventBlock end cap sz) = do+    putE (fromIntegral (sz+24) :: BlockSize)+    putE end+    putE (fromIntegral cap :: CapNo)++putEventSpec (CreateThread t) =+    putE t++putEventSpec (RunThread t) =+    putE t++-- here we assume that ThreadStopStatus fromEnum matches the definitions in+-- EventLogFormat.h+-- The standard encoding is used here, which is wrong for eventlogs+-- produced by GHC-7.8.2 ([Stop status in GHC-7.8.2] in EventTypes.hs+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+            BlockedOnMVarRead -> 20 -- since GHC-7.8.3+            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) =+    putE t++putEventSpec (MigrateThread t c) = do+    putE t+    putCap c++putEventSpec (CreateSparkThread t) =+    putE t++putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do+    putE crt+    putE dud+    putE ovf+    putE cnv+    -- Warning: order of fiz and gcd reversed!+    putE gcd+    putE fiz+    putE rem++putEventSpec SparkCreate =+    return ()++putEventSpec SparkDud =+    return ()++putEventSpec SparkOverflow =+    return ()++putEventSpec SparkRun =+    return ()++putEventSpec (SparkSteal c) =+    putCap c++putEventSpec SparkFizzle =+    return ()++putEventSpec SparkGC =+    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 =+    return ()++putEventSpec RequestSeqGC =+    return ()++putEventSpec RequestParGC =+    return ()++putEventSpec StartGC =+    return ()++putEventSpec GCWork =+    return ()++putEventSpec GCIdle =+    return ()++putEventSpec GCDone =+    return ()++putEventSpec EndGC =+    return ()++putEventSpec GlobalSyncGC =+    return ()++putEventSpec (TaskCreate taskId cap tid) = do+    putE taskId+    putCap cap+    putE tid++putEventSpec (TaskMigrate taskId cap new_cap) = do+    putE taskId+    putCap cap+    putCap new_cap++putEventSpec (TaskDelete taskId) =+    putE taskId++putEventSpec GCStatsGHC{..} = do+    putE heapCapset+    putE (fromIntegral gen :: Word16)+    putE copied+    putE slop+    putE frag+    putE (fromIntegral parNThreads :: Word32)+    putE parMaxCopied+    putE parTotCopied++putEventSpec HeapAllocated{..} = do+    putE heapCapset+    putE allocBytes++putEventSpec HeapSize{..} = do+    putE heapCapset+    putE sizeBytes++putEventSpec HeapLive{..} = do+    putE heapCapset+    putE liveBytes++putEventSpec HeapInfoGHC{..} = do+    putE heapCapset+    putE (fromIntegral gens :: Word16)+    putE maxHeapSize+    putE allocAreaSize+    putE mblockSize+    putE blockSize++putEventSpec CapCreate{cap} =+    putCap cap++putEventSpec CapDelete{cap} =+    putCap cap++putEventSpec CapDisable{cap} =+    putCap cap++putEventSpec CapEnable{cap} =+    putCap cap++putEventSpec (CapsetCreate cs ct) = do+    putE cs+    putE $ case ct of+            CapsetCustom -> 1 :: Word16+            CapsetOsProcess -> 2+            CapsetClockDomain -> 3+            CapsetUnknown -> 0++putEventSpec (CapsetDelete cs) =+    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) + sz_capset :: Word16)+    putE cs+    putEStr rts++putEventSpec (ProgramArgs cs as) = do+    let as' = unsep as+    putE (fromIntegral (length as') + sz_capset :: Word16)+    putE cs+    mapM_ putE as'++putEventSpec (ProgramEnv cs es) = do+    let es' = unsep es+    putE (fromIntegral (length es') + sz_capset :: 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 (UserMarker 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) =+    putE dyn_id++putEventSpec (MerEndParConjunct dyn_id) =+    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) =+    putE future_id++putEventSpec (MerFutureWaitSuspended future_id) =+    putE future_id++putEventSpec (MerFutureSignal future_id) =+    putE future_id++putEventSpec MerLookingForGlobalThread = return ()+putEventSpec MerWorkStealing = return ()+putEventSpec MerLookingForLocalSpark = return ()++putEventSpec (MerReleaseThread thread_id) =+    putE thread_id++putEventSpec MerCapSleeping = return ()+putEventSpec MerCallingMain = return ()++putEventSpec PerfName{..} = do+    putE (fromIntegral (length name) + sz_perf_num :: Word16)+    putE perfNum+    mapM_ putE name++putEventSpec PerfCounter{..} = do+    putE perfNum+    putE tid+    putE period++putEventSpec PerfTracepoint{..} = do+    putE perfNum+    putE tid++-- [] == []+-- [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')

@@ -0,0 +1,205 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+module GHC.RTS.Events.Incremental+  ( -- * Incremental API+    Decoder(..)+  , decodeHeader+  , decodeEvents+  , decodeEventLog++  -- * Lazy API+  , readHeader+  , readEvents+  , readEventLog+  ) where+import Control.Monad+import Data.Either+import Data.Maybe+import Prelude++import qualified Data.Binary.Get as G+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL+import qualified Data.IntMap.Strict as IM++import GHC.RTS.EventParserUtils+import GHC.RTS.EventTypes+import GHC.RTS.Events.Binary++#define EVENTLOG_CONSTANTS_ONLY+#include "EventLogFormat.h"++-- | The unfolding of the decoding process.+data Decoder a+  = Consume (B.ByteString -> Decoder a)+  -- ^ The decoder has consumed all the available input and needs more to+  -- continue.+  | Produce !a (Decoder a)+  -- ^ The decoder has returned a decoded value and the next decoder state to+  -- continue.+  | Done B.ByteString+  -- ^ The decoder has ended with leftover input.+  | Error B.ByteString String+  -- ^ The decoder has encountered an error with lefover input and an error+  -- message.++-- | Push an input chunk to the decoder+pushChunk :: Decoder a -> B.ByteString -> Decoder a+pushChunk decoder chunk = case decoder of+  Consume k -> k chunk+  Produce a decoder' -> Produce a $ decoder' `pushChunk` chunk+  Done leftover -> Done $ leftover `B.append` chunk+  Error leftover err -> Error (leftover `B.append` chunk) err++-- | Decode a header and continue with the provided decoder+withHeader+  :: (Header -> B.ByteString -> Decoder r)+  -- ^ Continuation+  -> Decoder r+withHeader f = go $ G.runGetIncremental getHeader+  where+    go decoder = case decoder of+      G.Done leftover _ header -> f header leftover+      G.Partial k -> Consume $ \chunk -> go $ k $ Just chunk+      G.Fail leftover _ err -> Error leftover err++-- | Decode a header+decodeHeader :: Decoder Header+decodeHeader = withHeader $ \header leftover -> Produce header $ Done leftover++-- | Decode events+decodeEvents :: Header -> Decoder Event+decodeEvents header = go (0 :: Int) Nothing decoder0+  where+    decoder0 = mkEventDecoder header+    go !remaining !blockCap decoder = case decoder of+      G.Done leftover consumed r -> do+        let !decoder' = decoder0 `G.pushChunk` leftover+        case r of+          Just event -> case evSpec event of+            EventBlock {..} ->+              go (fromIntegral block_size) (mkCap cap) decoder'+            _ -> do+              let+                !remaining' = remaining - fromIntegral consumed+                !blockCap' = if remaining' > 0 then blockCap else Nothing+                !event' = event { evCap = blockCap }+              Produce event' $ go remaining' blockCap' decoder'+          Nothing -> go remaining blockCap decoder'+      G.Partial k ->+        Consume $ \chunk -> go remaining blockCap $ k $ Just chunk+      G.Fail leftover _ err ->+        Error leftover err++-- | Decode a header and events+decodeEventLog :: Decoder Event+decodeEventLog = withHeader $ \header leftover ->+  decodeEvents header `pushChunk` leftover++-- | Read a header from a lazy bytestring and return the header and the+-- leftover input for subsequent decoding.+--+-- Note that the input must contain a whole header in one go. If incremental+-- parsing of a header is necessary, use 'decodeHeader' instead.+readHeader :: BL.ByteString -> Either String (Header, BL.ByteString)+readHeader = go $ Left decodeHeader+  where+    go r bytes = case r of+      Left decoder -> case decoder of+        Produce header decoder' -> case decoder' of+          Done leftover -> Right (header, BL.Chunk leftover bytes)+          _ -> fail "readHeader: unexpected decoder"+        Consume k -> case bytes of+          BL.Empty -> fail "readHeader: not enough bytes"+          BL.Chunk chunk chunks -> go (Left $! k chunk) chunks+        Done _ -> fail "readHeader: unexpected termination"+        Error _ err -> fail err+      Right header -> Right (header, bytes)++-- | Read events from a lazy bytestring. It returns an error message if it+-- encouters an error while decoding.+--+-- Note that it doesn't fail if it consumes all input in the middle of decoding+-- of an event.+readEvents :: Header -> BL.ByteString -> ([Event], Maybe String)+readEvents header = f . go (decodeEvents header)+  where+    f :: [Either e a] -> ([a], Maybe e)+    f xs = (rights rs, listToMaybe (lefts ls))+      where+        (rs, ls) = break isLeft xs+#if !MIN_VERSION_base(4, 7, 0)+        isLeft (Left _) = True+        isLeft _ = False+#endif+    go :: Decoder Event -> BL.ByteString -> [Either String Event]+    go decoder bytes = case decoder of+      Produce event decoder' -> Right event : go decoder' bytes+      Consume k -> case bytes of+        BL.Empty -> []+        BL.Chunk chunk chunks -> go (k chunk) chunks+      Done {} -> []+      Error _ err -> [Left err]++-- | Read an entire eventlog from a lazy bytestring. It returns an error message if it+-- encouters an error while decoding.+--+-- Note that it doesn't fail if it consumes all input in the middle of decoding+-- of an event.+readEventLog :: BL.ByteString -> Either String (EventLog, Maybe String)+readEventLog bytes = do+  (header, bytes') <- readHeader bytes+  case readEvents header bytes' of+    (events, err) -> return (EventLog header (Data events), err)++-- | Makes a decoder with all the required parsers when given a Header+mkEventDecoder :: Header -> G.Decoder (Maybe Event)+mkEventDecoder header = G.runGetIncremental $ getEvent parsers+  where+    imap = IM.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 <- IM.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.++    -- GHC-7.8.2 uses a different thread block status encoding,+    -- and therefore requires a different parser for the stop+    -- event. Later, in GHC-7.8.3, the old encoding was restored.+    -- GHC-7.8.2 can be recognised by presence and absence of+    -- events in the header:+    --   * User markers were added in GHC-7.8+    --   * an empty event HACK_BUG_T9003 was added in GHC-7.8.3+    -- This fix breaks software which uses ghc-events and combines+    -- user markers with the older stop status encoding. We don't+    -- know of any such software, though.+    is_pre77 = IM.notMember EVENT_USER_MARKER imap+    is_ghc782 = IM.member EVENT_USER_MARKER imap+      && IM.notMember EVENT_HACK_BUG_T9003 imap++    stopParsers+      | is_pre77 = pre77StopParsers+      | is_ghc782 = [ghc782StopParser]+      | otherwise = [post782StopParser]++    event_parsers+      | is_ghc_6 = concat+        [ standardParsers+        , ghc6Parsers+        , parRTSParsers sz_old_tid+        ]+      | otherwise = concat+        [ standardParsers+        , ghc7Parsers+        , stopParsers+        , parRTSParsers sz_tid+        , mercuryParsers+        , perfParsers+        ]+    parsers = EventParsers $ mkEventTypeParsers imap event_parsers

@@ -0,0 +1,113 @@+module GHC.RTS.Events.Merge (mergeEventLogs) where++import GHC.RTS.Events+import Data.Monoid+import Data.List (foldl')+import qualified Data.Map as M+import Data.Word (Word32)+import Prelude++-- TODO: add a merge mode where the events are synchronized using+-- the wall clock time event at the start of both eventlogs (for newer GHCs).+-- Such merge is not associative so we either need to take many arguments+-- or cope with eventlogs with many wall clock time events (assume they+-- are products of previous merges). To decide.++{-+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 # of occupied numbers for each variable type in 'x',+then increment each variable in 'y' by that amount.+We assume that if a number is occupied, so are all lower numbers.+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)) =+  let headerMap = M.fromList . map (\ et@EventType {num} -> (num, et))+      m1 = headerMap $ eventTypes h1+      m2 = headerMap $ eventTypes h2+      combine et1 et2 | et1 == et2 = et1+      combine _ _ = error "can't merge eventlogs with inconsistent headers"+      m = M.unionWith combine m1 m2+      h = Header $ M.elems m+  in h == h `seq`  -- Detect inconsistency ASAP.+     EventLog h . Data . mergeOn evTime xs $ shift (maxVars xs) ys++mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]+mergeOn _ [] ys = ys+mergeOn _ 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++-- TODO: rename, since these are not maximal values, but numbers of used values+data MaxVars = MaxVars { mcapset :: !Word32+                       , mcap :: !Int+                       , mthread :: !ThreadId }+-- TODO introduce parallel RTS process and machine var.s++instance Monoid MaxVars where+    mempty  = MaxVars 0 0 0+    mappend (MaxVars a b c) (MaxVars x y z) =+      MaxVars (max a x) (b + y) (max c z)+    -- avoid space leaks:+    mconcat = foldl' mappend mempty++-- For caps we find the maximum value by summing the @Startup@ declarations.+-- TODO: it's not trivial to add CapCreate since we don't know+-- if created caps are guaranteed to be numbered consecutively or not+-- (are they? is it asserted in GHC code somewhere?). We might instead+-- just scan all events mentioning a cap and take the maximum,+-- but it's a slower and much longer code, requiring constant maintenance.+maxVars :: [Event] -> MaxVars+maxVars = mconcat . map (maxSpec . evSpec)+ where+    -- only checking binding sites right now, sufficient?+    maxSpec (Startup n) = mempty { mcap = n }+    -- Threads start at 1.+    maxSpec (CreateThread t) = mempty { mthread = t }+    maxSpec (CreateSparkThread t) = mempty { mthread = t }+    -- Capsets start at 0.+    maxSpec (CapsetCreate cs _) = mempty {mcapset = cs + 1 }+    maxSpec _  = mempty++sh :: Num a => a -> a -> a+sh x y = x + y++updateSpec :: (EventInfo -> EventInfo) -> Event -> Event+updateSpec f (Event {evTime = t, evSpec = s, evCap = cap}) =+    Event {evTime = t, evSpec = f s, evCap = cap}++shift :: MaxVars -> [Event] -> [Event]+shift (MaxVars mcs mc mt) = map (updateSpec shift')+ where+    -- -1 marks a block that isn't attached to a particular capability+    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' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)+    shift' (ThreadLabel t l) = ThreadLabel (sh mt t) l+    shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)+    shift' (SparkSteal c) = SparkSteal (sh mc c)+    shift' (TaskCreate tk c tid) = TaskCreate tk (sh mc c) tid+    shift' (TaskMigrate tk c1 c2) = TaskMigrate tk (sh mc c1) (sh mc c2)+    shift' (CapCreate c) = CapCreate (sh mc c)  -- TODO: correct?+    shift' (CapDelete c) = CapDelete (sh mc c)  -- TODO: correct?+    shift' (CapDisable c) = CapDisable (sh mc c)+    shift' (CapEnable c) = CapEnable (sh mc c)+    shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst+    shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)+    shift' (CapsetAssignCap cs c) = CapsetAssignCap (sh mcs cs) (sh mc c)+    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' (WallClockTime cs sec nsec) = WallClockTime (sh mcs cs) sec nsec+    shift' x = x+    -- TODO extend by new shift for Eden events