ghc-events 0.2.0.1 → 0.3.0.1

raw patch · 10 files changed

+1864/−535 lines, 10 filesdep +arraydep ~basedep ~binarydep ~bytestringnew-component:exe:ghc-events-mergenew-component:exe:ghc-events-shownew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: array

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

API changes (from Hackage documentation)

Files

• AUTHORS +2/−0
• GHC/RTS/EventLogFormat.h +101/−9
• GHC/RTS/EventParserUtils.hs +199/−0
• GHC/RTS/EventTypes.hs +303/−0
• GHC/RTS/Events.hs +1075/−476
• MergeGhcEvents.hs +88/−0
• ShowGhcEvents.hs +1/−38
• ghc-events.cabal +30/−12
• test/TestVersions.hs +65/−0
• test/mandelbrot-mmc-2011-06-14.eventlog binary

@@ -0,0 +1,2 @@+Donnie Jones <donnie@darthik.com>+Simon Marlow <marlowsd@gmail.com>

@@ -101,18 +101,18 @@  */ #define EVENT_CREATE_THREAD        0 /* (thread)               */ #define EVENT_RUN_THREAD           1 /* (thread)               */-#define EVENT_STOP_THREAD          2 /* (thread, status)       */+#define EVENT_STOP_THREAD          2 /* (thread, status, blockinfo) */ #define EVENT_THREAD_RUNNABLE      3 /* (thread)               */ #define EVENT_MIGRATE_THREAD       4 /* (thread, new_cap)      */-#define EVENT_RUN_SPARK            5 /* (thread)               */-#define EVENT_STEAL_SPARK          6 /* (thread, victim_cap)   */+/* 5, 6 deprecated */ #define EVENT_SHUTDOWN             7 /* ()                     */ #define EVENT_THREAD_WAKEUP        8 /* (thread, other_cap)    */ #define EVENT_GC_START             9 /* ()                     */ #define EVENT_GC_END              10 /* ()                     */ #define EVENT_REQUEST_SEQ_GC      11 /* ()                     */ #define EVENT_REQUEST_PAR_GC      12 /* ()                     */-#define EVENT_CREATE_SPARK_THREAD 15 /* (thread, spark_thread) */+/* 13, 14 deprecated */+#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */ #define EVENT_LOG_MSG             16 /* (message ...)          */ #define EVENT_STARTUP             17 /* (num_capabilities)     */ #define EVENT_BLOCK_MARKER        18 /* (size, end_time, capability) */@@ -120,15 +120,86 @@ #define EVENT_GC_IDLE             20 /* () */ #define EVENT_GC_WORK             21 /* () */ #define EVENT_GC_DONE             22 /* () */+/* 23, 24 used by eden */+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */+#define EVENT_CAPSET_DELETE       26 /* (capset)               */+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */+/* the RTS identifier is in the form of "GHC-version rts_way"  */+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */+/* the vectors in these events are null separated strings             */+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */+#define EVENT_OSPROCESS_PID       32 /* (capset, pid)          */+#define EVENT_OSPROCESS_PPID      33 /* (capset, parent_pid)   */+#define EVENT_SPARK_COUNTERS      34 /* (crt,dud,ovf,cnv,fiz,gcd,rem) */+#define EVENT_SPARK_CREATE        35 /* ()                     */+#define EVENT_SPARK_DUD           36 /* ()                     */+#define EVENT_SPARK_OVERFLOW      37 /* ()                     */+#define EVENT_SPARK_RUN           38 /* ()                     */+#define EVENT_SPARK_STEAL         39 /* (victim_cap)           */+#define EVENT_SPARK_FIZZLE        40 /* ()                     */+#define EVENT_SPARK_GC            41 /* ()                     */+#define EVENT_INTERN_STRING       42 /* (string, id) */ -#define NUM_EVENT_TAGS            23 -#if 0  /* DEPRECATED EVENTS: */+/* Range 43 - 59 is available for new GHC and common events */++/* Range 60 - 80 is used by eden for parallel tracing+ * see http://www.mathematik.uni-marburg.de/~eden/+ */++/* Range 100 - 139 is reserved for Mercury, see below. */++/*+ * The highest event code +1 that ghc itself emits. Note that some event+ * ranges higher than this are reserved but not currently emitted by ghc.+ * This must match the size of the EventDesc[] array in EventLog.c+ */+#define NUM_GHC_EVENT_TAGS        42+++/* DEPRECATED EVENTS: */+/* These two are deprecated because we don't need to record the thread, it's+   implicit. We have to keep these #defines because for tiresome reasons we+   still need to parse them, see GHC.RTS.Events.ghc6Parsers for details. */+#define EVENT_RUN_SPARK            5 /* (thread)               */+#define EVENT_STEAL_SPARK          6 /* (thread, victim_cap)   */+#if 0+/* ghc changed how it handles sparks so these are no longer applicable */ #define EVENT_CREATE_SPARK        13 /* (cap, thread) */ #define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */+/* these are used by eden but are replaced by new alternatives for ghc */+#define EVENT_VERSION             23 /* (version_string) */+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */ #endif + /*+ * These event types are Mercury specific, Mercury may use up to event number+ * 139+ */+#define EVENT_FIRST_MER_EVENT       100+#define NUM_MER_EVENTS               14++#define EVENT_MER_START_PAR_CONJUNCTION 100 /* (dyn id, static id) */+#define EVENT_MER_STOP_PAR_CONJUNCTION  101 /* (dyn id) */+#define EVENT_MER_STOP_PAR_CONJUNCT     102 /* (dyn id) */+#define EVENT_MER_CREATE_SPARK          103 /* (dyn id, spark id) */+#define EVENT_MER_FUT_CREATE            104 /* (fut id, memo'd name id) */+#define EVENT_MER_FUT_WAIT_NOSUSPEND    105 /* (fut id) */+#define EVENT_MER_FUT_WAIT_SUSPENDED    106 /* (fut id) */+#define EVENT_MER_FUT_SIGNAL            107 /* (fut id) */+#define EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT \+                                        108 /* () */+#define EVENT_MER_WORK_STEALING         109 /* () */+#define EVENT_MER_LOOKING_FOR_LOCAL_SPARK \+                                        112 /* () */+#define EVENT_MER_RELEASE_CONTEXT       110 /* (context id) */+#define EVENT_MER_ENGINE_SLEEPING       111 /* () */+#define EVENT_MER_CALLING_MAIN          113 /* () */++/*  * Status values for EVENT_STOP_THREAD  *  * 1-5 are the StgRun return values (from includes/Constants.h):@@ -138,16 +209,37 @@  * #define ThreadYielding 3  * #define ThreadBlocked  4  * #define ThreadFinished 5+ * #define ForeignCall                  6+ * #define BlockedOnMVar                7+ * #define BlockedOnBlackHole           8+ * #define BlockedOnRead                9+ * #define BlockedOnWrite               10+ * #define BlockedOnDelay               11+ * #define BlockedOnSTM                 12+ * #define BlockedOnDoProc              13+ * #define BlockedOnCCall               -- not used (see ForeignCall)+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)+ * #define BlockedOnMsgThrowTo          16  */ #define THREAD_SUSPENDED_FOREIGN_CALL 6 +/*+ * Capset type values for EVENT_CAPSET_CREATE+ */+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */+ #ifndef EVENTLOG_CONSTANTS_ONLY  typedef StgWord16 EventTypeNum;-typedef StgWord64 EventTimestamp; // in nanoseconds-typedef StgWord64 EventThreadID;+typedef StgWord64 EventTimestamp; /* in nanoseconds */+typedef StgWord32 EventThreadID; typedef StgWord16 EventCapNo;-typedef StgWord16 EventPayloadSize; // variable-size events+typedef StgWord16 EventPayloadSize; /* variable-size events */+typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */+typedef StgWord32 EventCapsetID;+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */  #endif 

@@ -0,0 +1,199 @@+{-# LANGUAGE CPP, PatternGuards #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++module GHC.RTS.EventParserUtils (+        EventParser(..),+        EventParsers(..),+        GetEvents,+        GetHeader,++        getE,+        getH,+        getString,+        mkEventTypeParsers,+        simpleEvent,+        skip,+    ) where++import Control.Monad+import Control.Monad.Error+import Control.Monad.Reader+import Data.Array+import Data.Binary+import Data.Binary.Get hiding (skip)+import qualified Data.Binary.Get as G+import Data.Binary.Put+import Data.Char+import Data.Function+import Data.IntMap (IntMap)+import qualified Data.IntMap as M+import Data.List++#define EVENTLOG_CONSTANTS_ONLY+#include "EventLogFormat.h"++import GHC.RTS.EventTypes++-- reader/Get monad that passes around the event types+type GetEvents a = ReaderT EventParsers (ErrorT String Get) a++newtype EventParsers = EventParsers (Array Int (GetEvents EventInfo))++type GetHeader a = ErrorT String Get a++getH :: Binary a => GetHeader a+getH = lift get++getE :: Binary a => GetEvents a+getE = lift $ lift get++nBytes :: Integral a => a -> GetEvents [Word8]+nBytes n = replicateM (fromIntegral n) getE++getString :: Integral a => a -> GetEvents String+getString len = do+    bytes <- nBytes len+    return $ map (chr . fromIntegral) bytes++skip :: Integral a => a -> GetEvents ()+skip n = lift $ lift $ G.skip (fromIntegral n)++--+-- Code to build the event parser table.+--++--+-- Event parser data.  Parsers are either fixed or vairable size.+--+data EventParser a+    = FixedSizeParser {+        fsp_type        :: Int,+        fsp_size        :: EventTypeSize,+        fsp_parser      :: GetEvents a+    }+    | VariableSizeParser {+        vsp_type        :: Int,+        vsp_parser      :: GetEvents a+    }++get_parser (FixedSizeParser _ _ p) = p+get_parser (VariableSizeParser _ p) = p++get_type (FixedSizeParser t _ _) = t+get_type (VariableSizeParser t _) = t++isFixedSize (FixedSizeParser {}) = True+isFixedSize (VariableSizeParser {}) = False++simpleEvent :: Int -> a -> EventParser a+simpleEvent t p = FixedSizeParser t 0 (return p)++-- Our event log format allows new fields to be added to events over+-- time.  This means that our parser must be able to handle:+--+--  * old versions of an event, with fewer fields than expected,+--  * new versions of an event, with more fields than expected+--+-- The event log file declares the size for each event type, so we can+-- select the correct parser for the event type based on its size.  We+-- do this once after parsing the header: given the EventTypes, we build+-- an array of event parsers indexed by event type.+--+-- For each event type, we may have multiple parsers for different+-- versions of the event, indexed by size.  These are listed in the+-- eventTypeParsers list below.  For the given log file we select the+-- parser for the most recent version (largest size less than the size+-- declared in the header).  If this is a newer version of the event+-- than we understand, there may be extra bytes that we have to read+-- and discard in the parser for this event type.+--+-- Summary:+--   if size is smaller that we expect:+--     parse the earier version, or ignore the event+--   if size is just right:+--     parse it+--   if size is too big:+--     parse the bits we understand and discard the rest++mkEventTypeParsers :: IntMap EventType+                   -> [EventParser EventInfo]+                   -> Array Int (GetEvents EventInfo)+mkEventTypeParsers etypes event_parsers+ = accumArray (flip const) undefined (0, max_event_num)+    [ (num, parser num) | num <- [0..max_event_num] ]+    --([ (num, undeclared_etype num) | num <- [0..max_event_num] ] +++    -- [ (num, parser num etype) | (num, etype) <- M.toList etypes ])+  where+    max_event_num = maximum (M.keys etypes)+    undeclared_etype num = throwError ("undeclared event type: " ++ show num)+    parser_map = makeParserMap event_parsers+    parser num =+            -- Get the event's size from the header,+            -- the first Maybe describes whether the event was declared in the header.+            -- the second Maybe selects between variable and fixed size events.+        let mb_mb_et_size = do et <- M.lookup num etypes+                               return $ size et+            -- Find a parser for the event with the given size.+            maybe_parser mb_et_size = do possible <- M.lookup num parser_map+                                         best_parser <- case mb_et_size of+                                            Nothing -> getVariableParser possible+                                            Just et_size -> getFixedParser et_size possible+                                         return $ get_parser best_parser+            in case mb_mb_et_size of+                -- This event is declared in the log file's header+                Just mb_et_size -> case maybe_parser mb_et_size of+                    -- And we have a valid parser for it.+                    Just p -> p+                    -- But we don't have a valid parser for it.+                    Nothing -> noEventTypeParser num mb_et_size+                -- This event is not declared in the log file's header+                Nothing -> undeclared_etype num++-- Find the first variable length parser.+getVariableParser :: [EventParser a] -> Maybe (EventParser a)+getVariableParser [] = Nothing+getVariableParser (x:xs) = case x of+    FixedSizeParser _ _ _ -> getVariableParser xs+    VariableSizeParser _ _ -> Just x++-- Find the best fixed size parser, that is to say, the parser for the largest+-- event that does not exceed the size of the event as declared in the log+-- file's header.+getFixedParser :: EventTypeSize -> [EventParser a] -> Maybe (EventParser a)+getFixedParser size parsers =+        do parser <- ((filter isFixedSize) `pipe`+                      (filter (\x -> (fsp_size x) <= size)) `pipe`+                      (sortBy descending_size) `pipe`+                      maybe_head) parsers+           return $ padParser size parser+    where pipe f g = g . f+          descending_size (FixedSizeParser _ s1 _) (FixedSizeParser _ s2 _) =+            compare s2 s1+          descending_size _ _ = undefined+          maybe_head [] = Nothing+          maybe_head (x:xs) = Just x++padParser :: EventTypeSize -> (EventParser a) -> (EventParser a)+padParser size (VariableSizeParser t p) = VariableSizeParser t p+padParser size (FixedSizeParser t orig_size orig_p) = FixedSizeParser t size p+    where p = if (size == orig_size)+                then orig_p+                else do d <- orig_p+                        skip (size - orig_size)+                        return d++makeParserMap :: [EventParser a] -> IntMap [EventParser a]+makeParserMap = foldl buildParserMap M.empty+    where buildParserMap map parser = M.alter (addParser parser) (get_type parser) map+          addParser p Nothing = Just [p]+          addParser p (Just ps) = Just (p:ps)++noEventTypeParser :: Int -> Maybe EventTypeSize+                  -> GetEvents EventInfo+noEventTypeParser num mb_size = do+  bytes <- case mb_size of+             Just n  -> return n+             Nothing -> getE :: GetEvents Word16+  skip bytes+  return UnknownEvent{ ref = fromIntegral num }+

@@ -0,0 +1,303 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++module GHC.RTS.EventTypes where++import Data.Word (Word16, Word32, Word64)++-- EventType.+type EventTypeNum = Word16+type EventTypeDescLen = Word32+type EventTypeDesc = String+type EventTypeSize = Word16+-- Event.+type EventDescription = String+type Timestamp = Word64+type ThreadId = Word32+type CapNo = Word16+type Marker = Word32+type BlockSize = Word32+type RawThreadStopStatus = Word16+type StringId = Word32++-- These types are used by Mercury events.+type ParConjDynId = Word64+type ParConjStaticId = StringId+type SparkId = Word32+type FutureId = Word64++sz_event_type_num :: EventTypeSize+sz_event_type_num = 2+sz_cap :: EventTypeSize+sz_cap  = 2+sz_time :: EventTypeSize+sz_time = 8+sz_tid :: EventTypeSize+sz_tid  = 4+sz_old_tid :: EventTypeSize+sz_old_tid  = 8 -- GHC 6.12 was using 8 for ThreadID when declaring the size+                -- of events, but was actually using 32 bits for ThreadIDs+sz_capset :: EventTypeSize+sz_capset = 4+sz_capset_type :: EventTypeSize+sz_capset_type = 2+sz_block_size :: EventTypeSize+sz_block_size = 4+sz_block_event :: EventTypeSize+sz_block_event = fromIntegral (sz_event_type_num + sz_time + sz_block_size+    + sz_time + sz_cap)+sz_pid :: EventTypeSize+sz_pid = 4+sz_th_stop_status :: EventTypeSize+sz_th_stop_status = 2+sz_string_id :: EventTypeSize+sz_string_id = 4++-- Sizes for Mercury event fields.+sz_par_conj_dyn_id :: EventTypeSize+sz_par_conj_dyn_id = 8+sz_par_conj_static_id :: EventTypeSize+sz_par_conj_static_id = sz_string_id+sz_spark_id :: EventTypeSize+sz_spark_id = 4+sz_future_id :: EventTypeSize+sz_future_id = 8++{-+ - Data type delcarations to build the GHC RTS data format,+ - which is a (header, data) pair.+ -+ - Header contains EventTypes.+ - Data contains Events.+ -}+data EventLog =+  EventLog {+    header :: Header,+    dat    :: Data+  } deriving Show++newtype Header = Header {+     eventTypes :: [EventType]+  } deriving (Show, Eq)++data Data = Data {+     events :: [Event]+  } deriving Show++data EventType =+  EventType {+    num  :: EventTypeNum,+    desc :: EventTypeDesc,+    size :: Maybe EventTypeSize -- ^ 'Nothing' indicates variable size+  } deriving (Show, Eq)++data Event =+  Event {+    time :: {-# UNPACK #-}!Timestamp,+    spec :: EventInfo+  } deriving Show++data EventInfo++  -- pseudo events+  = EventBlock         { end_time     :: Timestamp,+                         cap          :: Int,+                         block_events :: [Event]+                       }+  | UnknownEvent       { ref  :: {-# UNPACK #-}!EventTypeNum }++  -- init and shutdown+  | Startup            { n_caps :: Int+                       }+  | Shutdown           { }++  -- thread scheduling+  | CreateThread       { thread :: {-# UNPACK #-}!ThreadId+                       }+  | RunThread          { thread :: {-# UNPACK #-}!ThreadId+                       }+  | StopThread         { thread :: {-# UNPACK #-}!ThreadId,+                         status :: ThreadStopStatus+                       }+  | ThreadRunnable     { thread :: {-# UNPACK #-}!ThreadId+                       }+  | MigrateThread      { thread :: {-# UNPACK #-}!ThreadId,+                         newCap :: {-# UNPACK #-}!Int+                       }+  | WakeupThread       { thread :: {-# UNPACK #-}!ThreadId,+                         otherCap :: {-# UNPACK #-}!Int+                       }++  -- par sparks+  | CreateSparkThread  { sparkThread :: {-# UNPACK #-}!ThreadId+                       }+  | SparkCounters      { sparksCreated, sparksDud, sparksOverflowed,+                         sparksConverted, sparksFizzled, sparksGCd,+                         sparksRemaining :: {-# UNPACK #-}! Word64+                       }+  | SparkCreate        { }+  | SparkDud           { }+  | SparkOverflow      { }+  | SparkRun           { }+  | SparkSteal         { victimCap :: {-# UNPACK #-}!Int }+  | SparkFizzle        { }+  | SparkGC            { }++  -- garbage collection+  | RequestSeqGC       { }+  | RequestParGC       { }+  | StartGC            { }+  | GCWork             { }+  | GCIdle             { }+  | GCDone             { }+  | EndGC              { }++  -- capability sets+  | CapsetCreate       { capset     :: {-# UNPACK #-}!Word32+                       , capsetType :: CapsetType+                       }+  | CapsetDelete       { capset :: {-# UNPACK #-}!Word32+                       }+  | CapsetAssignCap    { capset :: {-# UNPACK #-}!Word32+                       , cap    :: {-# UNPACK #-}!Int+                       }+  | CapsetRemoveCap    { capset :: {-# UNPACK #-}!Word32+                       , cap    :: {-# UNPACK #-}!Int+                       }++  -- program/process info+  | RtsIdentifier      { capset :: {-# UNPACK #-}!Word32+                       , rtsident :: String+                       }+  | ProgramArgs        { capset :: {-# UNPACK #-}!Word32+                       , args   :: [String]+                       }+  | ProgramEnv         { capset :: {-# UNPACK #-}!Word32+                       , env    :: [String]+                       }+  | OsProcessPid       { capset :: {-# UNPACK #-}!Word32+                       , pid    :: {-# UNPACK #-}!Word32+                       }+  | OsProcessParentPid { capset :: {-# UNPACK #-}!Word32+                       , ppid   :: {-# UNPACK #-}!Word32+                       }++  -- messages+  | Message            { msg :: String }+  | UserMessage        { msg :: String }++  -- These events have been added for Mercury's benifit but are generally+  -- useful.+  | InternString       { str :: String, id :: {-# UNPACK #-}!StringId }++  -- Mercury specific events.+  | MerStartParConjunction {+        dyn_id      :: {-# UNPACK #-}!ParConjDynId,+        static_id   :: {-# UNPACK #-}!ParConjStaticId+    }+  | MerEndParConjunction {+        dyn_id      :: {-# UNPACK #-}!ParConjDynId+    }+  | MerEndParConjunct {+        dyn_id      :: {-# UNPACK #-}!ParConjDynId+    }+  | MerCreateSpark {+        dyn_id      :: {-# UNPACK #-}!ParConjDynId,+        spark_id    :: {-# UNPACK #-}!SparkId+    }+  | MerFutureCreate {+        future_id   :: {-# UNPACK #-}!FutureId,+        name_id     :: {-# UNPACK #-}!StringId+    }+  | MerFutureWaitNosuspend {+        future_id   :: {-# UNPACK #-}!FutureId+    }+  | MerFutureWaitSuspended {+        future_id   :: {-# UNPACK #-}!FutureId+    }+  | MerFutureSignal {+        future_id   :: {-# UNPACK #-}!FutureId+    }+  | MerLookingForGlobalThread+  | MerWorkStealing+  | MerLookingForLocalSpark+  | MerReleaseThread {+        thread_id   :: {-# UNPACK #-}!ThreadId+    }+  | MerCapSleeping+  | MerCallingMain++  deriving Show++--sync with ghc/includes/Constants.h+data ThreadStopStatus+ = NoStatus+ | HeapOverflow+ | StackOverflow+ | ThreadYielding+ | ThreadBlocked+ | ThreadFinished+ | ForeignCall+ | BlockedOnMVar+ | BlockedOnBlackHole+ | BlockedOnRead+ | BlockedOnWrite+ | BlockedOnDelay+ | BlockedOnSTM+ | BlockedOnDoProc+ | BlockedOnCCall+ | BlockedOnCCall_NoUnblockExc+ | BlockedOnMsgThrowTo+ | ThreadMigrating+ | BlockedOnMsgGlobalise+ | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId+ deriving (Show)++mkStopStatus :: RawThreadStopStatus -> ThreadStopStatus+mkStopStatus n = case n of+ 0  ->  NoStatus+ 1  ->  HeapOverflow+ 2  ->  StackOverflow+ 3  ->  ThreadYielding+ 4  ->  ThreadBlocked+ 5  ->  ThreadFinished+ 6  ->  ForeignCall+ 7  ->  BlockedOnMVar+ 8  ->  BlockedOnBlackHole+ 9  ->  BlockedOnRead+ 10 ->  BlockedOnWrite+ 11 ->  BlockedOnDelay+ 12 ->  BlockedOnSTM+ 13 ->  BlockedOnDoProc+ 14 ->  BlockedOnCCall+ 15 ->  BlockedOnCCall_NoUnblockExc+ 16 ->  BlockedOnMsgThrowTo+ 17 ->  ThreadMigrating+ 18 ->  BlockedOnMsgGlobalise+ _  ->  error "mkStat"++maxThreadStopStatus :: RawThreadStopStatus+maxThreadStopStatus = 18++data CapsetType+ = CapsetCustom+ | CapsetOsProcess+ | CapsetClockDomain+ | CapsetUnknown+ deriving Show++mkCapsetType :: Word16 -> CapsetType+mkCapsetType n = case n of+ 1 -> CapsetCustom+ 2 -> CapsetOsProcess+ 3 -> CapsetClockDomain+ _ -> CapsetUnknown++-- | An event annotated with the Capability that generated it, if any+data CapEvent+  = CapEvent { ce_cap   :: Maybe Int,+               ce_event :: Event+               -- we could UNPACK ce_event, but the Event constructor+               -- might be shared, in which case we could end up+               -- increasing the space usage.+             }+

@@ -1,477 +1,1076 @@ {-# LANGUAGE CPP,BangPatterns,PatternGuards #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-- - Author: Donnie Jones, Simon Marlow- - Events.hs- -   Parser functions for GHC RTS EventLog framework.- -}- -module GHC.RTS.Events (-       -- * The event log types                       -       EventLog(..),-       EventType(..),-       Event(..),-       EventTypeSpecificInfo(..),-       ThreadStopStatus(..),-       Header(..),-       Data(..),-       Timestamp,-       ThreadId,--       -- * Reading an event log from a file-       readEventLogFromFile,--       -- * Utilities-       CapEvent(..), sortEvents, groupEvents, sortGroups,--       -- * Printing-       showEventTypeSpecificInfo, showThreadStopStatus-  ) where--{- Libraries. -}-import Data.Word (Word16, Word32, Word64)-import Data.Binary-import Data.Binary.Get-import Control.Monad-import Data.IntMap (IntMap)-import qualified Data.IntMap as M-import Control.Monad.Reader-import Control.Monad.Error-import qualified Data.ByteString.Lazy as L-import Data.Char-import Data.Function-import Data.List-import Data.Either-import Text.Printf--#define EVENTLOG_CONSTANTS_ONLY-#include "EventLogFormat.h"--{- Type synonyms. -}-type Filename = String---- EventType.-type EventTypeNum = Word16-type EventTypeDescLen = Word32-type EventTypeDesc = String-type EventTypeSize = Word16--- Event.-type EventDescription = String-type Timestamp = Word64-type ThreadId = Word32-type CapNo = Word16-type Marker = Word32--{-- - Data type delcarations to build the GHC RTS data format,- - which is a (header, data) pair.- -- - Header contains EventTypes.- - Data contains Events.- -}-data EventLog =-  EventLog {-    header :: Header,-    dat    :: Data-  } deriving Show--newtype Header = Header {-     eventTypes :: [EventType]-  } deriving Show--data Data = Data {-     events :: [Event]-  } deriving Show--data EventType =-  EventType {-    num  :: EventTypeNum,-    desc :: EventTypeDesc,-    size :: Maybe EventTypeSize -- ^ 'Nothing' indicates variable size-  } deriving Show--data Event = -  Event {-    time :: {-# UNPACK #-}!Timestamp,-    spec :: EventTypeSpecificInfo-  } deriving Show--data EventTypeSpecificInfo-  = Startup            { n_caps :: Int-                       }-  | EventBlock         { end_time     :: Timestamp, -                         cap          :: Int, -                         block_events :: [Event]-                       }-  | CreateThread       { thread :: {-# UNPACK #-}!ThreadId-                       }-  | RunThread          { thread :: {-# UNPACK #-}!ThreadId -                       }-  | StopThread         { thread :: {-# UNPACK #-}!ThreadId,-                         status :: ThreadStopStatus-                       }-  | ThreadRunnable     { thread :: {-# UNPACK #-}!ThreadId-                       }-  | MigrateThread      { thread :: {-# UNPACK #-}!ThreadId,-                         newCap :: {-# UNPACK #-}!Int-                       }-  | RunSpark           { thread :: {-# UNPACK #-}!ThreadId-                       }-  | StealSpark         { thread :: {-# UNPACK #-}!ThreadId,-                         victimCap :: {-# UNPACK #-}!Int-                       }-  | CreateSparkThread  { sparkThread :: {-# UNPACK #-}!ThreadId-                       }-  | WakeupThread       { thread :: {-# UNPACK #-}!ThreadId, -                         otherCap :: {-# UNPACK #-}!Int-                       }-  | Shutdown           { }-  | RequestSeqGC       { }-  | RequestParGC       { }-  | StartGC            { }-  | GCWork             { }-  | GCIdle             { }-  | GCDone             { }-  | EndGC              { }-  | Message            { msg :: String }-  | UserMessage        { msg :: String }-  | UnknownEvent       { ref  :: {-# UNPACK #-}!EventTypeNum }--  deriving Show----sync with ghc/includes/Constants.h-data ThreadStopStatus- = NoStatus- | HeapOverflow- | StackOverflow- | ThreadYielding- | ThreadBlocked- | ThreadFinished- | ForeignCall- deriving (Enum, Show)---- reader/Get monad that passes around the event types-type GetEvents a = ReaderT (IntMap EventType) (ErrorT String Get) a-  -type GetHeader a = ErrorT String Get a--getH :: Binary a => GetHeader a-getH = lift get--getE :: Binary a => GetEvents a-getE = lift $ lift get----------------------------------------------------------------------------------- Binary instances--getEventType :: GetHeader EventType-getEventType = do -           etNum <- getH-           size <- getH :: GetHeader EventTypeSize-           let etSize = if size == 0xffff then Nothing else Just size-           -- 0xffff indicates variable-sized event-           etDescLen <- getH :: GetHeader EventTypeDescLen-           etDesc <- getEtDesc (fromIntegral etDescLen) -           etExtraLen <- getH :: GetHeader Word32-           _skip  <- replicateM_ (fromIntegral etExtraLen) (lift getWord8)-           ete <- getH :: GetHeader Marker-           when (ete /= EVENT_ET_END) $-              throwError ("Event Type end marker not found.")-           return (EventType etNum etDesc etSize)-           where -             getEtDesc :: Int -> GetHeader [Char]-             getEtDesc s = replicateM s (getH :: GetHeader Char)--getHeader :: GetHeader Header-getHeader = do -           hdrb <- getH :: GetHeader Marker-           when (hdrb /= EVENT_HEADER_BEGIN) $-                throwError "Header begin marker not found"-           hetm <- getH :: GetHeader Marker-           when (hetm /= EVENT_HET_BEGIN) $ -                throwError "Header Event Type begin marker not found"-           ets <- getEventTypes-           emark <- getH :: GetHeader Marker-           when (emark /= EVENT_HEADER_END) $-                throwError "Header end marker not found"-           return (Header ets)-     where    -       getEventTypes :: GetHeader [EventType]-       getEventTypes = do-           m <- getH :: GetHeader Marker-           case () of -            _ | m == EVENT_ET_BEGIN -> do-                   et <- getEventType-                   nextET <- getEventTypes-                   return (et : nextET)-              | m == EVENT_HET_END ->-                   return []-              | otherwise ->-                   throwError "Malformed list of Event Types in header"--getEvent :: GetEvents (Maybe Event)-getEvent = do -  etRef <- getE-  if (etRef == EVENT_DATA_END) -     then return Nothing-     else do !ts   <- getE-             spec <- getEvSpecInfo etRef-             return (Just (Event ts spec))-           -getEvSpecInfo :: EventTypeNum -> GetEvents EventTypeSpecificInfo-getEvSpecInfo num = case fromIntegral num :: Int of-- EVENT_STARTUP -> do -- (n_caps)-  c <- getE :: GetEvents CapNo-  return Startup{ n_caps = fromIntegral c }-- EVENT_BLOCK_MARKER -> do -- (size, end_time, cap)-  block_size <- getE :: GetEvents Word32-  end_time <- getE :: GetEvents Timestamp-  c <- getE :: GetEvents CapNo-  lbs <- lift . lift $ getLazyByteString (fromIntegral block_size - 24)-  etypemap <- ask-  let e_events = runGet (runErrorT $ runReaderT getEventBlock etypemap) lbs-  return EventBlock{ end_time=end_time,-                     cap= fromIntegral c, -                     block_events=case e_events of-                                    Left s -> error s-                                    Right es -> es }-- EVENT_CREATE_THREAD -> do  -- (thread)-  t <- getE-  return CreateThread{thread=t}-- EVENT_RUN_THREAD -> do  --  (thread)-  t <- getE-  return RunThread{thread=t}-- EVENT_STOP_THREAD -> do  -- (thread, status)-  t <- getE-  s <- getE :: GetEvents Word16-  return StopThread{thread=t, status= toEnum (fromIntegral s)}-- EVENT_THREAD_RUNNABLE -> do  -- (thread)-  t <- getE-  return ThreadRunnable{thread=t}-- EVENT_MIGRATE_THREAD -> do  --  (thread, newCap)-  t  <- getE-  nc <- getE :: GetEvents CapNo-  return MigrateThread{thread=t,newCap=fromIntegral nc}-- EVENT_RUN_SPARK -> do  -- (thread)-  t <- getE-  return RunSpark{thread=t}-- EVENT_STEAL_SPARK -> do  -- (thread, victimCap)-  t  <- getE-  vc <- getE :: GetEvents CapNo-  return StealSpark{thread=t,victimCap=fromIntegral vc}-- EVENT_CREATE_SPARK_THREAD -> do  -- (sparkThread)-  st <- getE :: GetEvents ThreadId-  return CreateSparkThread{sparkThread=st}-- EVENT_SHUTDOWN -> return Shutdown-- EVENT_THREAD_WAKEUP -> do  -- (thread, other_cap)-  t <- getE-  oc <- getE :: GetEvents CapNo-  return WakeupThread{thread=t,otherCap=fromIntegral oc}-- EVENT_REQUEST_SEQ_GC -> return RequestSeqGC-- EVENT_REQUEST_PAR_GC -> return RequestParGC-- EVENT_GC_START -> return StartGC- EVENT_GC_WORK  -> return GCWork- EVENT_GC_IDLE  -> return GCIdle- EVENT_GC_DONE  -> return GCDone- EVENT_GC_END   -> return EndGC-- EVENT_LOG_MSG -> do -- (msg)-  num <- getE :: GetEvents Word16-  bytes <- replicateM (fromIntegral num) getE -  return Message{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }-- EVENT_USER_MSG -> do -- (msg)-  num <- getE :: GetEvents Word16-  bytes <- replicateM (fromIntegral num) getE -  return UserMessage{ msg = map (chr . fromIntegral) (bytes :: [Word8]) }-- other -> do -- unrecognised event, just skip it-  etypes <- ask-  case M.lookup (fromIntegral other) etypes of-    Nothing -> throwError ("getEvSpecInfo: undeclared event type: " ++ show other)-    Just t  -> do-      bytes <- case size t of-                 Just n  -> return n-                 Nothing -> getE :: GetEvents Word16-      skip  <- lift . lift $ replicateM_ (fromIntegral bytes) getWord8-      return UnknownEvent{ ref = num }---getData :: GetEvents Data-getData = do-   db <- getE :: GetEvents Marker-   when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found"-   getEvents []-   where-              getEvents :: [Event] -> GetEvents Data-              getEvents events = do-                mb_e <- getEvent-                case mb_e of-                  Nothing -> return (Data (reverse events))-                  Just e  -> getEvents (e:events)--getEventBlock :: GetEvents [Event]-getEventBlock = do-  b <- lift . lift $ isEmpty-  if b then return [] else do-  mb_e <- getEvent-  case mb_e of-    Nothing -> return []-    Just e  -> do-      es <- getEventBlock-      return (e:es)--getEventLog :: ErrorT String Get EventLog-getEventLog = do-    header <- getHeader-    let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]-    dat <- runReaderT getData imap-    return (EventLog header dat)--readEventLogFromFile :: FilePath -> IO (Either String EventLog)-readEventLogFromFile f = do-    s <- L.readFile f-    return $ runGet (do v <- runErrorT $ getEventLog-                        m <- isEmpty-                        m `seq` return v)  s---- -------------------------------------------------------------------------------- Utilities---- | An event annotated with the Capability that generated it, if any-data CapEvent -  = CapEvent { ce_cap   :: Maybe Int,-               ce_event :: Event-               -- we could UNPACK ce_event, but the Event constructor-               -- might be shared, in which case we could end up-               -- increasing the space usage.-             }--sortEvents :: [Event] -> [CapEvent]-sortEvents = sortGroups . groupEvents---- | Sort the raw event stream by time, annotating each event with the--- capability that generated it.-sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]-sortGroups groups = mergesort' (compare `on` (time . ce_event)) $-                      [ [ CapEvent cap e | e <- es ] -                      | (cap, es) <- groups ]-     -- sorting is made much faster by the way that the event stream is-     -- divided into blocks of events.  -     --  - All events in a block belong to a particular capability-     --  - The events in a block are ordered by time-     --  - blocks for the same capability appear in time order in the event-     --    stream and do not overlap.-     ---     -- So to sort the events we make one list of events for each-     -- capability (basically just concat . filter), and then-     -- merge the resulting lists.--groupEvents :: [Event] -> [(Maybe Int, [Event])]-groupEvents es = (Nothing, n_events) : -                 [ (Just (cap (head blocks)), concatMap block_events blocks)-                 | blocks <- groups ]-  where-   (blocks, anon_events) = partitionEithers (map separate es)-      where separate e | b@EventBlock{} <- spec e = Left  b-                       | otherwise                = Right e--   (cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks-      where is_cap c = fromIntegral c /= ((-1) :: Word16)--   groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks--     -- There are two sources of events without a capability: events-     -- in the raw stream not inside an EventBlock, and EventBlocks-     -- with cap == -1.  We have to merge those two streams.-   n_events = merge (compare `on` time) anon_events -                 (concatMap block_events gbl_blocks)--mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]-mergesort' _   [] = []-mergesort' _   [xs] = xs-mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)--merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]-merge_pairs _   [] = []-merge_pairs _   [xs] = [xs]-merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss--merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-merge _   [] ys = ys-merge _   xs [] = xs-merge cmp (x:xs) (y:ys)- = case x `cmp` y of-        GT -> y : merge cmp (x:xs)   ys-        _  -> x : merge cmp    xs (y:ys)---------------------------------------------------------------------------------- Some pretty-printing support--showEventTypeSpecificInfo :: EventTypeSpecificInfo -> String-showEventTypeSpecificInfo spec =-      case spec of-        Startup n_caps ->-          printf "startup: %d capabilities" n_caps-        EventBlock end_time cap _block_events ->-          printf "event block: cap %d, end time: %d\n" cap end_time-        CreateThread thread ->-          printf "creating thread %d" thread-        RunThread thread ->-          printf "running thread %d" thread-        StopThread thread status ->-          printf "stopping thread %d (%s)" thread (showThreadStopStatus status)-        ThreadRunnable thread ->-          printf "thread %d is runnable" thread-        MigrateThread thread newCap  ->-          printf "migrating thread %d to cap %d" thread newCap-        RunSpark thread ->-          printf "running a local spark (thread %d)" thread-        StealSpark thread victimCap ->-          printf "thread %d stealing a spark from cap %d" thread victimCap-        CreateSparkThread sparkThread ->-          printf "creating spark thread %d" sparkThread-        Shutdown ->-          printf "shutting down"-        WakeupThread thread otherCap ->-          printf "waking up thread %d on cap %d" thread otherCap-        RequestSeqGC ->-          printf "requesting sequential GC"-        RequestParGC ->-          printf "requesting parallel GC"-        StartGC ->-          printf "starting GC"-        EndGC ->-          printf "finished GC"-        GCWork ->-          printf "GC working"-        GCIdle ->-          printf "GC idle"-        GCDone ->-          printf "GC done"-	_ ->-          printf "unknown event type"---showThreadStopStatus :: ThreadStopStatus -> String-showThreadStopStatus HeapOverflow   = "heap overflow"-showThreadStopStatus StackOverflow  = "stack overflow"-showThreadStopStatus ThreadYielding = "thread yielding"-showThreadStopStatus ThreadBlocked  = "thread blocked"-showThreadStopStatus ThreadFinished = "thread finished"-showThreadStopStatus ForeignCall    = "making a foreign call"+{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-}+{-+ - Authors: Donnie Jones, Simon Marlow, Paul Bone, Duncan Coutts+ - Events.hs+ -   Parser functions for GHC RTS EventLog framework.+ -}+ +module GHC.RTS.Events (+       -- * The event log types                       +       EventLog(..),+       EventType(..),+       Event(..),+       EventInfo(..),+       ThreadStopStatus(..),+       Header(..),+       Data(..),+       CapsetType(..),+       Timestamp,+       ThreadId,++       -- * Reading and writing event logs+       readEventLogFromFile,+       writeEventLogToFile,++       -- * Utilities+       CapEvent(..), sortEvents, groupEvents, sortGroups,+       buildEventTypeMap,++       -- * Printing+       showEventInfo, showThreadStopStatus,+       ppEventLog, ppEventType, ppEvent+  ) where++{- Libraries. -}+import Data.Binary+import Data.Binary.Get hiding (skip)+import qualified Data.Binary.Get as G+import Data.Binary.Put+import Control.Monad+import Data.IntMap (IntMap)+import qualified Data.IntMap as M+import Control.Monad.Reader+import Control.Monad.Error+import qualified Data.ByteString.Lazy as L+import Data.Function+import Data.List+import Data.Either+import Data.Maybe+import Text.Printf+import Data.Array++import GHC.RTS.EventTypes+import GHC.RTS.EventParserUtils++#define EVENTLOG_CONSTANTS_ONLY+#include "EventLogFormat.h"++------------------------------------------------------------------------------+-- Binary instances++getEventType :: GetHeader EventType+getEventType = do +           etNum <- getH+           size <- getH :: GetHeader EventTypeSize+           let etSize = if size == 0xffff then Nothing else Just size+           -- 0xffff indicates variable-sized event+           etDescLen <- getH :: GetHeader EventTypeDescLen+           etDesc <- getEtDesc (fromIntegral etDescLen) +           etExtraLen <- getH :: GetHeader Word32+           lift $ G.skip (fromIntegral etExtraLen)+           ete <- getH :: GetHeader Marker+           when (ete /= EVENT_ET_END) $+              throwError ("Event Type end marker not found.")+           return (EventType etNum etDesc etSize)+           where +             getEtDesc :: Int -> GetHeader [Char]+             getEtDesc s = replicateM s (getH :: GetHeader Char)++getHeader :: GetHeader Header+getHeader = do +           hdrb <- getH :: GetHeader Marker+           when (hdrb /= EVENT_HEADER_BEGIN) $+                throwError "Header begin marker not found"+           hetm <- getH :: GetHeader Marker+           when (hetm /= EVENT_HET_BEGIN) $ +                throwError "Header Event Type begin marker not found"+           ets <- getEventTypes+           emark <- getH :: GetHeader Marker+           when (emark /= EVENT_HEADER_END) $+                throwError "Header end marker not found"+           return (Header ets)+     where    +       getEventTypes :: GetHeader [EventType]+       getEventTypes = do+           m <- getH :: GetHeader Marker+           case () of +            _ | m == EVENT_ET_BEGIN -> do+                   et <- getEventType+                   nextET <- getEventTypes+                   return (et : nextET)+              | m == EVENT_HET_END ->+                   return []+              | otherwise ->+                   throwError "Malformed list of Event Types in header"++getEvent :: EventParsers -> GetEvents (Maybe Event)+getEvent (EventParsers parsers) = do +  etRef <- getE :: GetEvents EventTypeNum+  if (etRef == EVENT_DATA_END) +     then return Nothing+     else do !ts   <- getE+             -- trace ("event: " ++ show etRef) $ do+             spec <- parsers ! fromIntegral etRef+             return (Just (Event ts spec))++--+-- standardEventParsers.+--+standardParsers :: [EventParser EventInfo]+standardParsers = [+ (FixedSizeParser EVENT_STARTUP sz_cap (do -- (n_caps)+      c <- getE :: GetEvents CapNo+      return Startup{ n_caps = fromIntegral c }+   )),++ (FixedSizeParser EVENT_BLOCK_MARKER (sz_block_size + sz_time + sz_cap) (do -- (size, end_time, cap)+      block_size <- getE :: GetEvents BlockSize+      end_time <- getE :: GetEvents Timestamp+      c <- getE :: GetEvents CapNo+      lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) - +                                              (fromIntegral sz_block_event))+      eparsers <- ask+      let e_events = runGet (runErrorT $ runReaderT (getEventBlock eparsers) eparsers) lbs+      return EventBlock{ end_time=end_time,+                         cap= fromIntegral c, +                         block_events=case e_events of+                                        Left s -> error s+                                        Right es -> es }+   )),+ + (simpleEvent EVENT_SHUTDOWN Shutdown),++ (simpleEvent EVENT_REQUEST_SEQ_GC RequestSeqGC),++ (simpleEvent EVENT_REQUEST_PAR_GC RequestParGC),++ (simpleEvent EVENT_GC_START StartGC),++ (simpleEvent EVENT_GC_WORK GCWork),++ (simpleEvent EVENT_GC_IDLE GCIdle),++ (simpleEvent EVENT_GC_DONE GCDone),++ (simpleEvent EVENT_GC_END EndGC),+ + (FixedSizeParser EVENT_CAPSET_CREATE (sz_capset + sz_capset_type) (do -- (capset, capset_type)+      cs <- getE+      ct <- fmap mkCapsetType getE+      return CapsetCreate{capset=cs,capsetType=ct}+   )),+ + (FixedSizeParser EVENT_CAPSET_DELETE sz_capset (do -- (capset)+      cs <- getE+      return CapsetDelete{capset=cs}+   )),+ + (FixedSizeParser EVENT_CAPSET_ASSIGN_CAP (sz_capset + sz_cap) (do -- (capset, cap)+      cs <- getE+      cp <- getE :: GetEvents CapNo+      return CapsetAssignCap{capset=cs,cap=fromIntegral cp}+   )),++ (FixedSizeParser EVENT_CAPSET_REMOVE_CAP (sz_capset + sz_cap) (do -- (capset, cap)+      cs <- getE+      cp <- getE :: GetEvents CapNo+      return CapsetRemoveCap{capset=cs,cap=fromIntegral cp}+   )),++ (FixedSizeParser EVENT_OSPROCESS_PID (sz_capset + sz_pid) (do -- (capset, pid)+      cs <- getE+      pd <- getE+      return OsProcessPid{capset=cs,pid=pd}+   )),++ (FixedSizeParser EVENT_OSPROCESS_PPID (sz_capset + sz_pid) (do -- (capset, ppid)+      cs <- getE+      pd <- getE+      return OsProcessParentPid{capset=cs,ppid=pd}+  )),++ (VariableSizeParser EVENT_LOG_MSG (do -- (msg)+      num <- getE :: GetEvents Word16+      string <- getString num+      return Message{ msg = string }+   )),+ (VariableSizeParser EVENT_USER_MSG (do -- (msg)+      num <- getE :: GetEvents Word16+      string <- getString num+      return UserMessage{ msg = string }+   )),+ (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])+      num <- getE :: GetEvents Word16+      cs <- getE+      string <- getString (num - sz_capset)+      return ProgramArgs{ capset = cs+                        , args = splitNull string }+   )),+ (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg])+      num <- getE :: GetEvents Word16+      cs <- getE+      string <- getString (num - sz_capset)+      return ProgramEnv{ capset = cs+                       , env = splitNull string }+   )),+ (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str)+      num <- getE :: GetEvents Word16+      cs <- getE+      string <- getString (num - sz_capset)+      return RtsIdentifier{ capset = cs+                          , rtsident = string }+   )),++ (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id)+      num <- getE :: GetEvents Word16+      string <- getString (num - sz_string_id)+      id <- getE :: GetEvents StringId+      return (InternString string id)+    ))+ ]++-- Parsers valid for GHC7 but not GHC6.+ghc7Parsers :: [EventParser EventInfo]+ghc7Parsers = [+ (FixedSizeParser EVENT_CREATE_THREAD sz_tid (do  -- (thread)+      t <- getE+      return CreateThread{thread=t}+   )),++ (FixedSizeParser EVENT_RUN_THREAD sz_tid (do  --  (thread)+      t <- getE+      return RunThread{thread=t}+   )),++ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do+      -- (thread, status)+      t <- getE+      s <- getE :: GetEvents RawThreadStopStatus+      return StopThread{thread=t, status = if s > maxThreadStopStatus +                                              then NoStatus+                                              else mkStopStatus s}+   )),++ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do+      -- (thread, status, info)+      t <- getE+      s <- getE :: GetEvents RawThreadStopStatus +      i <- getE :: GetEvents ThreadId+      return StopThread{thread = t,+                        status = case () of+                                  _ | s > maxThreadStopStatus+                                    -> NoStatus+                                    | s == 8 {- XXX yeuch -}+                                    -> BlockedOnBlackHoleOwnedBy i+                                    | otherwise+                                    -> mkStopStatus s}+   )),++ (FixedSizeParser EVENT_THREAD_RUNNABLE sz_tid (do  -- (thread)+      t <- getE+      return ThreadRunnable{thread=t}+   )),++ (FixedSizeParser EVENT_MIGRATE_THREAD (sz_tid + sz_cap) (do  --  (thread, newCap)+      t  <- getE+      nc <- getE :: GetEvents CapNo+      return MigrateThread{thread=t,newCap=fromIntegral nc}+   )),++ -- Yes, EVENT_RUN/STEAL_SPARK are deprecated, but see the explanation in the+ -- 'ghc6Parsers' section below. Since we're parsing them anyway, we might+ -- as well convert them to the new SparkRun/SparkSteal events.+ (FixedSizeParser EVENT_RUN_SPARK sz_tid (do  -- (thread)+      _ <- getE :: GetEvents ThreadId+      return SparkRun+   )),++ (FixedSizeParser EVENT_STEAL_SPARK (sz_tid + sz_cap) (do  -- (thread, victimCap)+      _  <- getE :: GetEvents ThreadId+      vc <- getE :: GetEvents CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),++ (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_tid (do  -- (sparkThread)+      st <- getE :: GetEvents ThreadId+      return CreateSparkThread{sparkThread=st}+   )),++ (FixedSizeParser EVENT_SPARK_COUNTERS (7*8) (do -- (crt,dud,ovf,cnv,fiz,gcd,rem)+      crt <- getE :: GetEvents Word64+      dud <- getE :: GetEvents Word64+      ovf <- getE :: GetEvents Word64+      cnv <- getE :: GetEvents Word64+      fiz <- getE :: GetEvents Word64+      gcd <- getE :: GetEvents Word64+      rem <- getE :: GetEvents Word64+      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,+                           sparksOverflowed = ovf, sparksConverted = cnv,+                           sparksFizzled    = fiz, sparksGCd       = gcd,+                           sparksRemaining  = rem}+   )),++ (simpleEvent EVENT_SPARK_CREATE   SparkCreate),+ (simpleEvent EVENT_SPARK_DUD      SparkDud),+ (simpleEvent EVENT_SPARK_OVERFLOW SparkOverflow),+ (simpleEvent EVENT_SPARK_RUN      SparkRun),+ (FixedSizeParser EVENT_SPARK_STEAL sz_cap (do  -- (victimCap)+      vc <- getE :: GetEvents CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),+ (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),+ (simpleEvent EVENT_SPARK_GC       SparkGC),++ (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do  -- (thread, other_cap)+      t <- getE+      oc <- getE :: GetEvents CapNo+      return WakeupThread{thread=t,otherCap=fromIntegral oc}+   ))+ ]++ -----------------------+ -- GHC 6.12 compat: GHC 6.12 reported the wrong sizes for some events,+ -- so we have to recognise those wrong sizes here for backwards + -- compatibility.+ghc6Parsers :: [EventParser EventInfo]+ghc6Parsers = [+ (FixedSizeParser EVENT_STARTUP 0 (do+      -- BUG in GHC 6.12: the startup event was incorrectly +      -- declared as size 0, so we accept it here.+      c <- getE :: GetEvents CapNo+      return Startup{ n_caps = fromIntegral c }+   )),++ (FixedSizeParser EVENT_CREATE_THREAD sz_old_tid (do  -- (thread)+      t <- getE+      return CreateThread{thread=t}+   )),++ (FixedSizeParser EVENT_RUN_THREAD sz_old_tid (do  --  (thread)+      t <- getE+      return RunThread{thread=t}+   )),++ (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do  -- (thread, status)+      t <- getE+      s <- getE :: GetEvents Word16+      let stat = fromIntegral s+      return StopThread{thread=t, status = if stat > maxBound+                                              then NoStatus+                                              else mkStopStatus stat}+   )),++ (FixedSizeParser EVENT_THREAD_RUNNABLE sz_old_tid (do  -- (thread)+      t <- getE+      return ThreadRunnable{thread=t}+   )),++ (FixedSizeParser EVENT_MIGRATE_THREAD (sz_old_tid + sz_cap) (do  --  (thread, newCap)+      t  <- getE+      nc <- getE :: GetEvents CapNo+      return MigrateThread{thread=t,newCap=fromIntegral nc}+   )),++ -- Note: it is vital that these two (EVENT_RUN/STEAL_SPARK) remain here (at+ -- least in the ghc6Parsers section) even though both events are deprecated.+ -- The reason is that .eventlog files created by the buggy GHC-6.12+ -- mis-declare the size of these two events. So we have to handle them+ -- specially here otherwise we'll get the wrong size, leading to us getting+ -- out of sync and eventual parse failure. Since we're parsing them anyway,+ -- we might as well convert them to the new SparkRun/SparkSteal events.+ (FixedSizeParser EVENT_RUN_SPARK sz_old_tid (do  -- (thread)+      _ <- getE :: GetEvents ThreadId+      return SparkRun+   )),++ (FixedSizeParser EVENT_STEAL_SPARK (sz_old_tid + sz_cap) (do  -- (thread, victimCap)+      _  <- getE :: GetEvents ThreadId+      vc <- getE :: GetEvents CapNo+      return SparkSteal{victimCap=fromIntegral vc}+   )),++ (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_old_tid (do  -- (sparkThread)+      st <- getE :: GetEvents ThreadId+      return CreateSparkThread{sparkThread=st}+   )),++ (FixedSizeParser EVENT_THREAD_WAKEUP (sz_old_tid + sz_cap) (do  -- (thread, other_cap)+      t <- getE+      oc <- getE :: GetEvents CapNo+      return WakeupThread{thread=t,otherCap=fromIntegral oc}+   ))+ ]++mercuryParsers = [+ (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION +    (sz_par_conj_dyn_id + sz_par_conj_static_id)+    (do dyn_id <- getE+        static_id <- getE+        return (MerStartParConjunction dyn_id static_id))+ ),++ (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id+    (do dyn_id <- getE+        return (MerEndParConjunction dyn_id))+ ),++ (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id+    (do dyn_id <- getE+        return (MerEndParConjunct dyn_id))+ ),++ (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id)+    (do dyn_id <- getE+        spark_id <- getE+        return (MerCreateSpark dyn_id spark_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id)+    (do future_id <- getE+        name_id <- getE+        return (MerFutureCreate future_id name_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id)+    (do future_id <- getE+        return (MerFutureWaitNosuspend future_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id)+    (do future_id <- getE+        return (MerFutureWaitSuspended future_id))+ ),++ (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id)+    (do future_id <- getE+        return (MerFutureSignal future_id))+ ),++ (simpleEvent EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT MerLookingForGlobalThread),+ (simpleEvent EVENT_MER_WORK_STEALING MerWorkStealing),+ (simpleEvent EVENT_MER_LOOKING_FOR_LOCAL_SPARK MerLookingForLocalSpark),++ (FixedSizeParser EVENT_MER_RELEASE_CONTEXT sz_tid+    (do thread_id <- getE+        return (MerReleaseThread thread_id))+ ),++ (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping),+ (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)+ + ]++getData :: GetEvents Data+getData = do+   db <- getE :: GetEvents Marker+   when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found"+   eparsers <- ask+   let +       getEvents :: [Event] -> GetEvents Data+       getEvents events = do+         mb_e <- getEvent eparsers+         case mb_e of+           Nothing -> return (Data (reverse events))+           Just e  -> getEvents (e:events)+   -- in+   getEvents []++getEventBlock :: EventParsers -> GetEvents [Event]+getEventBlock parsers = do+  b <- lift . lift $ isEmpty+  if b then return [] else do+  mb_e <- getEvent parsers+  case mb_e of+    Nothing -> return []+    Just e  -> do+      es <- getEventBlock parsers+      return (e:es)++getEventLog :: ErrorT String Get EventLog+getEventLog = do+    header <- getHeader+    let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]+        -- This test is complete, no-one has extended this event yet and all future+        -- extensions will use newly allocated event IDs.+        is_ghc_6 = Just sz_old_tid == do create_et <- M.lookup EVENT_CREATE_THREAD imap+                                         size create_et +        {-+        -- GHC6 writes an invalid header, we handle it here by using a+        -- different set of event parsers.  Note that the ghc7 event parsers+        -- are standard events, and can be used by other runtime systems that+        -- make use of threadscope.+        -}+        event_parsers = if is_ghc_6+                            then standardParsers ++ ghc6Parsers+                            else standardParsers ++ ghc7Parsers +++                                mercuryParsers+        parsers = mkEventTypeParsers imap event_parsers+    dat <- runReaderT getData (EventParsers parsers)+    return (EventLog header dat)++readEventLogFromFile :: FilePath -> IO (Either String EventLog)+readEventLogFromFile f = do+    s <- L.readFile f+    return $ runGet (do v <- runErrorT $ getEventLog+                        m <- isEmpty+                        m `seq` return v)  s++-- -----------------------------------------------------------------------------+-- Utilities++sortEvents :: [Event] -> [CapEvent]+sortEvents = sortGroups . groupEvents++-- | Sort the raw event stream by time, annotating each event with the+-- capability that generated it.+sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]+sortGroups groups = mergesort' (compare `on` (time . ce_event)) $+                      [ [ CapEvent cap e | e <- es ] +                      | (cap, es) <- groups ]+     -- sorting is made much faster by the way that the event stream is+     -- divided into blocks of events.  +     --  - All events in a block belong to a particular capability+     --  - The events in a block are ordered by time+     --  - blocks for the same capability appear in time order in the event+     --    stream and do not overlap.+     --+     -- So to sort the events we make one list of events for each+     -- capability (basically just concat . filter), and then+     -- merge the resulting lists.++groupEvents :: [Event] -> [(Maybe Int, [Event])]+groupEvents es = (Nothing, n_events) : +                 [ (Just (cap (head blocks)), concatMap block_events blocks)+                 | blocks <- groups ]+  where+   (blocks, anon_events) = partitionEithers (map separate es)+      where separate e | b@EventBlock{} <- spec e = Left  b+                       | otherwise                = Right e++   (cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks+      where is_cap c = fromIntegral c /= ((-1) :: Word16)++   groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks++     -- There are two sources of events without a capability: events+     -- in the raw stream not inside an EventBlock, and EventBlocks+     -- with cap == -1.  We have to merge those two streams.+     -- In light of merged logs, global blocks may have overlapping+     -- time spans, thus the blocks are mergesorted+   n_events = mergesort' (compare `on` time) (anon_events : map block_events gbl_blocks)++mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]+mergesort' _   [] = []+mergesort' _   [xs] = xs+mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)++merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]+merge_pairs _   [] = []+merge_pairs _   [xs] = [xs]+merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss++merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+merge _   [] ys = ys+merge _   xs [] = xs+merge cmp (x:xs) (y:ys)+ = case x `cmp` y of+        GT -> y : merge cmp (x:xs)   ys+        _  -> x : merge cmp    xs (y:ys)+++buildEventTypeMap :: [EventType] -> IntMap EventType+buildEventTypeMap etypes = M.fromList [ (fromIntegral (num t),t) | t <- etypes ]++-----------------------------------------------------------------------------+-- Some pretty-printing support++showEventInfo :: EventInfo -> String+showEventInfo spec =+    case spec of+        EventBlock end_time cap _block_events ->+          printf "event block: cap %d, end time: %d\n" cap end_time+        Startup n_caps ->+          printf "startup: %d capabilities" n_caps+        CreateThread thread ->+          printf "creating thread %d" thread+        RunThread thread ->+          printf "running thread %d" thread+        StopThread thread status ->+          printf "stopping thread %d (%s)" thread (showThreadStopStatus status)+        ThreadRunnable thread ->+          printf "thread %d is runnable" thread+        MigrateThread thread newCap  ->+          printf "migrating thread %d to cap %d" thread newCap+        CreateSparkThread sparkThread ->+          printf "creating spark thread %d" sparkThread+        SparkCounters crt dud ovf cnv fiz gcd rem ->+          printf "spark stats: %d created, %d converted, %d remaining (%d overflowed, %d dud, %d GC'd, %d fizzled)" crt cnv rem ovf dud gcd fiz+        SparkCreate ->+          printf "spark created"+        SparkDud ->+          printf "dud spark discarded"+        SparkOverflow ->+          printf "overflowed spark discarded"+        SparkRun ->+          printf "running a local spark"+        SparkSteal victimCap ->+          printf "stealing a spark from cap %d" victimCap+        SparkFizzle ->+          printf "spark fizzled"+        SparkGC ->+          printf "spark GCed"+        Shutdown ->+          printf "shutting down"+        WakeupThread thread otherCap ->+          printf "waking up thread %d on cap %d" thread otherCap+        RequestSeqGC ->+          printf "requesting sequential GC"+        RequestParGC ->+          printf "requesting parallel GC"+        StartGC ->+          printf "starting GC"+        EndGC ->+          printf "finished GC"+        GCWork ->+          printf "GC working"+        GCIdle ->+          printf "GC idle"+        GCDone ->+          printf "GC done"+        Message msg ->+          msg+        UserMessage msg ->+          msg+        CapsetCreate cs ct ->+          printf "created capset %d of type %s" cs (show ct)+        CapsetDelete cs ->+          printf "deleted capset %d" cs+        CapsetAssignCap cs cp ->+          printf "assigned cap %d to capset %d" cp cs+        CapsetRemoveCap cs cp ->+          printf "removed cap %d from capset %d" cp cs+        OsProcessPid cs pid ->+          printf "capset %d: pid %d" cs pid+        OsProcessParentPid cs ppid ->+          printf "capset %d: parent pid %d" cs ppid+        RtsIdentifier cs i ->+          printf "capset %d: RTS version %s" cs i+        ProgramArgs cs args ->+          printf "capset %d: args: %s" cs (show args)+        ProgramEnv cs env ->+          printf "capset %d: env: %s" cs (show env)+        UnknownEvent n ->+          printf "Unknown event type %d" n+        InternString str id ->+          printf "Interned string: \"%s\" with id %d" str id+        MerStartParConjunction dyn_id static_id ->+          printf "Start a parallel conjunction 0x%x, static_id: %d" dyn_id static_id+        MerEndParConjunction dyn_id ->+          printf "End par conjunction: 0x%x" dyn_id+        MerEndParConjunct dyn_id ->+          printf "End par conjunct: 0x%x" dyn_id+        MerCreateSpark dyn_id spark_id ->+          printf "Create spark for conjunction: 0x%x spark: 0x%x" dyn_id spark_id+        MerFutureCreate future_id name_id ->+          printf "Create future 0x%x named %d" future_id name_id+        MerFutureWaitNosuspend future_id ->+          printf "Wait didn't suspend for future: 0x%x" future_id+        MerFutureWaitSuspended future_id ->+          printf "Wait suspended on future: 0x%x" future_id+        MerFutureSignal future_id ->+          printf "Signaled future 0x%x" future_id+        MerLookingForGlobalThread ->+          "Looking for global thread to resume"+        MerWorkStealing ->+          "Trying to steal a spark"+        MerLookingForLocalSpark ->+          "Looking for a local spark to execute"+        MerReleaseThread thread_id ->+          printf "Releasing thread %d to the free pool" thread_id+        MerCapSleeping ->+          "Capability going to sleep"+        MerCallingMain ->+          "About to call the program entry point"++showThreadStopStatus :: ThreadStopStatus -> String+showThreadStopStatus HeapOverflow   = "heap overflow"+showThreadStopStatus StackOverflow  = "stack overflow"+showThreadStopStatus ThreadYielding = "thread yielding"+showThreadStopStatus ThreadBlocked  = "thread blocked"+showThreadStopStatus ThreadFinished = "thread finished"+showThreadStopStatus ForeignCall    = "making a foreign call"+showThreadStopStatus BlockedOnMVar  = "blocked on an MVar"+showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole"+showThreadStopStatus BlockedOnRead = "blocked on I/O read"+showThreadStopStatus BlockedOnWrite = "blocked on I/O write"+showThreadStopStatus BlockedOnDelay = "blocked on threadDelay"+showThreadStopStatus BlockedOnSTM = "blocked in STM retry"+showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc"+showThreadStopStatus BlockedOnCCall = "blocked in a foreign call"+showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call"+showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo"+showThreadStopStatus ThreadMigrating = "thread migrating"+showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised"+showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) =+          "blocked on black hole owned by thread " ++ show target+showThreadStopStatus NoStatus = "No stop thread status"++ppEventLog :: EventLog -> String+ppEventLog (EventLog (Header ets) (Data es)) = unlines $ concat (+    [ ["Event Types:"]+    , map ppEventType ets+    , [""] -- newline+    , ["Events:"]+    , map (ppEvent imap) sorted+    , [""] ]) -- extra trailing newline+ where+    imap = buildEventTypeMap ets+    sorted = sortEvents es++ppEventType :: EventType -> String+ppEventType (EventType num dsc msz) = printf "%4d: %s (size %s)" num dsc+   (case msz of Nothing -> "variable"; Just x -> show x)++ppEvent :: IntMap EventType -> CapEvent -> String+ppEvent imap (CapEvent cap (Event time spec)) =+  printf "%9d: " time +++  (case cap of+    Nothing -> ""+    Just c  -> printf "cap %d: " c) +++  case spec of+    UnknownEvent{ ref=ref } ->+      printf (desc (fromJust (M.lookup (fromIntegral ref) imap)))++    other -> showEventInfo spec++type PutEvents a = PutM a++putE :: Binary a => a -> PutEvents ()+putE = put++runPutEBS :: PutEvents () -> L.ByteString+runPutEBS = runPut++writeEventLogToFile f el = L.writeFile f $ runPutEBS $ putEventLog el++putType :: EventTypeNum -> PutEvents ()+putType = putE++putCap :: Int -> PutEvents ()+putCap c = putE (fromIntegral c :: CapNo)++putMarker :: Word32 -> PutEvents ()+putMarker = putE++putEventLog :: EventLog -> PutEvents ()+putEventLog (EventLog hdr es) = do+    putHeader hdr+    putData es++putHeader :: Header -> PutEvents ()+putHeader (Header ets) = do+    putMarker EVENT_HEADER_BEGIN+    putMarker EVENT_HET_BEGIN+    mapM_ putEventType ets+    putMarker EVENT_HET_END+    putMarker EVENT_HEADER_END+ where+    putEventType (EventType n d msz) = do+        putMarker EVENT_ET_BEGIN+        putType n+        putE $ fromMaybe 0xffff msz+        putE (fromIntegral $ length d :: EventTypeDescLen)+        mapM_ put d+        -- the event type header allows for extra data, which we don't use:+        putE (0 :: Word32)+        putMarker EVENT_ET_END++putData :: Data -> PutEvents ()+putData (Data es) = do+    putMarker EVENT_DATA_BEGIN -- Word32+    mapM_ putEvent es+    putType EVENT_DATA_END -- Word16++eventTypeNum :: EventInfo -> EventTypeNum+eventTypeNum e = case e of+    CreateThread {} -> EVENT_CREATE_THREAD+    RunThread {} -> EVENT_RUN_THREAD+    StopThread {} -> EVENT_STOP_THREAD+    ThreadRunnable {} -> EVENT_THREAD_RUNNABLE+    MigrateThread {} -> EVENT_MIGRATE_THREAD+    Shutdown {} -> EVENT_SHUTDOWN+    WakeupThread {} -> EVENT_THREAD_WAKEUP+    StartGC {} -> EVENT_GC_START+    EndGC {} -> EVENT_GC_END+    RequestSeqGC {} -> EVENT_REQUEST_SEQ_GC+    RequestParGC {} -> EVENT_REQUEST_PAR_GC+    CreateSparkThread {} -> EVENT_CREATE_SPARK_THREAD+    SparkCounters {} -> EVENT_SPARK_COUNTERS+    SparkCreate   {} -> EVENT_SPARK_CREATE+    SparkDud      {} -> EVENT_SPARK_DUD+    SparkOverflow {} -> EVENT_SPARK_OVERFLOW+    SparkRun      {} -> EVENT_SPARK_RUN+    SparkSteal    {} -> EVENT_SPARK_STEAL+    SparkFizzle   {} -> EVENT_SPARK_FIZZLE+    SparkGC       {} -> EVENT_SPARK_GC+    Message {} -> EVENT_LOG_MSG+    Startup {} -> EVENT_STARTUP+    EventBlock {} -> EVENT_BLOCK_MARKER+    UserMessage {} -> EVENT_USER_MSG+    GCIdle {} -> EVENT_GC_IDLE+    GCWork {} -> EVENT_GC_WORK+    GCDone {} -> EVENT_GC_DONE+    CapsetCreate {} -> EVENT_CAPSET_CREATE+    CapsetDelete {} -> EVENT_CAPSET_DELETE+    CapsetAssignCap {} -> EVENT_CAPSET_ASSIGN_CAP+    CapsetRemoveCap {} -> EVENT_CAPSET_REMOVE_CAP+    RtsIdentifier {} -> EVENT_RTS_IDENTIFIER+    ProgramArgs {} -> EVENT_PROGRAM_ARGS+    ProgramEnv {} -> EVENT_PROGRAM_ENV+    OsProcessPid {} -> EVENT_OSPROCESS_PID+    OsProcessParentPid{} -> EVENT_OSPROCESS_PPID+    UnknownEvent {} -> error "eventTypeNum UnknownEvent"+    InternString {} -> EVENT_INTERN_STRING+    MerStartParConjunction {} -> EVENT_MER_START_PAR_CONJUNCTION+    MerEndParConjunction _ -> EVENT_MER_STOP_PAR_CONJUNCTION+    MerEndParConjunct _ -> EVENT_MER_STOP_PAR_CONJUNCT+    MerCreateSpark {} -> EVENT_MER_CREATE_SPARK+    MerFutureCreate {} -> EVENT_MER_FUT_CREATE+    MerFutureWaitNosuspend _ -> EVENT_MER_FUT_WAIT_NOSUSPEND+    MerFutureWaitSuspended _ -> EVENT_MER_FUT_WAIT_SUSPENDED+    MerFutureSignal _ -> EVENT_MER_FUT_SIGNAL+    MerLookingForGlobalThread -> EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT+    MerWorkStealing -> EVENT_MER_WORK_STEALING+    MerLookingForLocalSpark -> EVENT_MER_LOOKING_FOR_LOCAL_SPARK+    MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT+    MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING+    MerCallingMain -> EVENT_MER_CALLING_MAIN++putEvent :: Event -> PutEvents ()+putEvent (Event t spec) = do+    putType (eventTypeNum spec)+    put t+    putEventSpec spec++putEventSpec (Startup caps) = do+    putCap (fromIntegral caps)++putEventSpec (EventBlock end cap es) = do+    let block = runPutEBS (mapM_ putEvent es)+    put (fromIntegral (L.length block) + 24 :: Word32)+    putE end+    putE (fromIntegral cap :: CapNo)+    putLazyByteString block++putEventSpec (CreateThread t) = do+    putE t++putEventSpec (RunThread t) = do+    putE t++-- here we assume that ThreadStopStatus fromEnum matches the definitions in+-- EventLogFormat.h+putEventSpec (StopThread t s) = do+    putE t+    putE $ case s of+            NoStatus -> 0 :: Word16+            HeapOverflow -> 1+            StackOverflow -> 2+            ThreadYielding -> 3+            ThreadBlocked -> 4+            ThreadFinished -> 5+            ForeignCall -> 6+            BlockedOnMVar -> 7+            BlockedOnBlackHole -> 8+            BlockedOnBlackHoleOwnedBy _ -> 8+            BlockedOnRead -> 9+            BlockedOnWrite -> 10+            BlockedOnDelay -> 11+            BlockedOnSTM -> 12+            BlockedOnDoProc -> 13+            BlockedOnCCall -> 14+            BlockedOnCCall_NoUnblockExc -> 15+            BlockedOnMsgThrowTo -> 16+            ThreadMigrating -> 17+            BlockedOnMsgGlobalise -> 18+    putE $ case s of+            BlockedOnBlackHoleOwnedBy i -> i+            _                           -> 0++putEventSpec (ThreadRunnable t) = do+    putE t++putEventSpec (MigrateThread t c) = do+    putE t+    putCap c++putEventSpec (CreateSparkThread t) = do+    putE t++putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do+    putE crt+    putE dud+    putE ovf+    putE cnv+    putE fiz+    putE gcd+    putE rem++putEventSpec SparkCreate = do+    return ()++putEventSpec SparkDud = do+    return ()++putEventSpec SparkOverflow = do+    return ()++putEventSpec SparkRun = do+    return ()++putEventSpec (SparkSteal c) = do+    putCap c++putEventSpec SparkFizzle = do+    return ()++putEventSpec SparkGC = do+    return ()++putEventSpec (WakeupThread t c) = do+    putE t+    putCap c++putEventSpec Shutdown = do+    return ()++putEventSpec RequestSeqGC = do+    return ()++putEventSpec RequestParGC = do+    return ()++putEventSpec StartGC = do+    return ()++putEventSpec GCWork = do+    return ()++putEventSpec GCIdle = do+    return ()++putEventSpec GCDone = do+    return ()++putEventSpec EndGC = do+    return ()++putEventSpec (CapsetCreate cs ct) = do+    putE cs+    putE $ case ct of+            CapsetCustom -> 1 :: Word16+            CapsetOsProcess -> 2+            CapsetClockDomain -> 3+            CapsetUnknown -> 0++putEventSpec (CapsetDelete cs) = do+    putE cs++putEventSpec (CapsetAssignCap cs cp) = do+    putE cs+    putCap cp++putEventSpec (CapsetRemoveCap cs cp) = do+    putE cs+    putCap cp++putEventSpec (RtsIdentifier cs rts) = do+    putE (fromIntegral (length rts) + 4 :: Word16)+    putE cs+    mapM_ putE rts++putEventSpec (ProgramArgs cs as) = do+    let as' = unsep as+    putE (fromIntegral (length as') + 4 :: Word16)+    putE cs+    mapM_ putE as'++putEventSpec (ProgramEnv cs es) = do+    let es' = unsep es+    putE (fromIntegral (length es') + 4 :: Word16)+    putE cs+    mapM_ putE es'++putEventSpec (OsProcessPid cs pid) = do+    putE cs+    putE pid++putEventSpec (OsProcessParentPid cs ppid) = do+    putE cs+    putE ppid++putEventSpec (Message s) = do+    putE (fromIntegral (length s) :: Word16)+    mapM_ putE s++putEventSpec (UserMessage s) = do+    putE (fromIntegral (length s) :: Word16)+    mapM_ putE s++putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"++putEventSpec (InternString str id) = do+    putE len+    mapM_ putE str+    putE id+  where len = (fromIntegral (length str) :: Word16) + sz_string_id++putEventSpec (MerStartParConjunction dyn_id static_id) = do+    putE dyn_id+    putE static_id++putEventSpec (MerEndParConjunction dyn_id) = do+    putE dyn_id++putEventSpec (MerEndParConjunct dyn_id) = do+    putE dyn_id++putEventSpec (MerCreateSpark dyn_id spark_id) = do+    putE dyn_id+    putE spark_id++putEventSpec (MerFutureCreate future_id name_id) = do+    putE future_id+    putE name_id++putEventSpec (MerFutureWaitNosuspend future_id) = do+    putE future_id++putEventSpec (MerFutureWaitSuspended future_id) = do+    putE future_id++putEventSpec (MerFutureSignal future_id) = do+    putE future_id++putEventSpec MerLookingForGlobalThread = return ()+putEventSpec MerWorkStealing = return ()+putEventSpec MerLookingForLocalSpark = return ()++putEventSpec (MerReleaseThread thread_id) = do+    putE thread_id++putEventSpec MerCapSleeping = return ()+putEventSpec MerCallingMain = return ()++-- [] == []+-- [x] == x\0+-- [x, y, z] == x\0y\0+unsep :: [String] -> String+unsep = concatMap (++"\0") -- not the most efficient, but should be ok++splitNull :: String -> [String]+splitNull [] = []+splitNull xs = case span (/= '\0') xs of+                (x, xs') -> x : splitNull (drop 1 xs')+

@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++import GHC.RTS.Events+import System.Environment+import Data.Monoid+import Data.List (foldl')+import Data.Word (Word32, Word16)++-- todo, proper error handling+main = do+    [out, file1, file2] <- getArgs+    Right f1 <- readEventLogFromFile file1+    Right f2 <- readEventLogFromFile file2+    let m = merge f1 f2+    writeEventLogToFile out m++{-+GHC numbers caps and capsets in sequential order, starting at 0.  Threads are+similarly numbered, but start at 1.  In order to merge logs 'x' and 'y', we+find the maximum values of each variable type in 'x', then increment each+variable in 'y' that amount.  This guarantees that variables in each log don't+clash, and that the meaning of each reference to a thread/cap/capset is+preserved.+-}++merge :: EventLog -> EventLog -> EventLog+merge (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2+ = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys+merge _ _ = error "can't merge eventlogs with non-matching headers"++mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]+mergeOn f [] ys = ys+mergeOn f xs [] = xs+mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys)+                        | otherwise  = y : mergeOn f (x:xs) ys++data MaxVars = MaxVars { mcapset :: !Word32+                       , mcap :: !Int+                       , mthread :: !ThreadId }++instance Monoid MaxVars where+    -- threads start at 1+    mempty  = MaxVars 0 0 1+    mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z)+    -- avoid space leaks:+    mconcat = foldl' mappend mempty++-- Capabilities are represented as Word16.  An event block marked with the+-- capability of 0xffff belongs to no capability+isCap :: Int -> Bool+isCap x = fromIntegral x /= ((-1) :: Word16)++maxVars :: [Event] -> MaxVars+maxVars = mconcat . map (maxSpec . spec)+ where+    -- only checking binding sites right now, sufficient?+    maxSpec (Startup n) = mempty { mcap = n - 1 }+    maxSpec (CreateThread t) = mempty { mthread = t }+    maxSpec (CreateSparkThread t) = mempty { mthread = t }+    maxSpec (CapsetCreate cs _) = mempty {mcapset = cs }+    maxSpec (EventBlock _ _ es) = maxVars es+    maxSpec _  = mempty++sh :: Num a => a -> a -> a+sh x y = x + y + 1++shift :: MaxVars -> [Event] -> [Event]+shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s)+ where+    -- -1 marks a block that isn't attached to a particular capability+    shift' (EventBlock et c bs) = EventBlock et (msh c) $ shift mv bs+     where msh x = if isCap x then sh mc x else x+    shift' (CreateThread t) = CreateThread $ sh mt t+    shift' (RunThread t) = RunThread $ sh mt t+    shift' (StopThread t s) = StopThread (sh mt t) s+    shift' (ThreadRunnable t) = ThreadRunnable $ sh mt t+    shift' (MigrateThread t c) = MigrateThread (sh mt t) (sh mc c)+    shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)+    shift' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)+    shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst+    shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)+    shift' (CapsetRemoveCap cs c) = CapsetRemoveCap (sh mcs cs) (sh mc c)+    shift' (RtsIdentifier cs rts) = RtsIdentifier (sh mcs cs) rts+    shift' (ProgramArgs cs as) = ProgramArgs (sh mcs cs) as+    shift' (ProgramEnv cs es) = ProgramEnv (sh mcs cs) es+    shift' (OsProcessPid cs pid) = OsProcessPid (sh mcs cs) pid+    shift' (OsProcessParentPid cs ppid) = OsProcessParentPid (sh mcs cs) ppid+    shift' x = x

@@ -20,43 +20,6 @@                Left  s   -> die ("Failed to parse " ++ file ++ ": " ++ s)                Right log -> return log     -  printf "Event Types:\n"-  let etypes = Log.eventTypes (Log.header log)-  putStrLn (unlines (map ppEventType etypes))--  let imap = M.fromList [ (fromIntegral (Log.num t),t) | t <- etypes ]--  let pes = Log.events (Log.dat log)-      sorted = sortEvents pes-              -- the events come out reversed, and we want a stable sort--  printf "Events:\n"-  putStrLn $ unlines $ map (ppEvent imap) $ sorted---  putStrLn $ show $ length $ sorted--unsortEvents :: [Event] -> [(Int,Event)]-unsortEvents es = ess- where -   blocks = [ b | b@EventBlock{} <- map spec es ]-   ess    = [ (cap block, e) | block <- blocks, e <- block_events block ]+  putStrLn $ ppEventLog log  die s = do hPutStrLn stderr s; exitWith (ExitFailure 1)--ppEventType :: EventType -> String-ppEventType et = printf "%4d: %s (size %s)" (Log.num et) (Log.desc et) -   (case Log.size et of Nothing -> "variable"; Just x -> show x)--ppEvent :: IntMap EventType -> CapEvent -> String-ppEvent imap (CapEvent cap (Event time spec)) =-  printf "%9d: " time ++-  (case cap of-    Nothing -> ""-    Just c  -> printf "cap %d: " c) ++-  case spec of-    UnknownEvent{ ref=ref } ->-      printf (Log.desc (fromJust (M.lookup (fromIntegral ref) imap)))--    Message msg -> msg-    UserMessage msg -> msg--    other -> showEventTypeSpecificInfo spec

@@ -1,5 +1,5 @@ name:             ghc-events-version:          0.2.0.1+version:          0.3.0.1 synopsis:         Library and tool for parsing .eventlog files from GHC description:      Parses .eventlog files emitted by GHC 6.12.1 and later.                   Includes the show-ghc-events tool to dump an event@@ -8,25 +8,43 @@ license:          BSD3 license-file:     LICENSE author:           Donnie Jones <donnie@darthik.com>, -                  Simon Marlow <marlowsd@gmail.com>+                  Simon Marlow <marlowsd@gmail.com>,+                  Paul Bone <pbone@csse.unimelb.edu.au>,+                  Duncan Coutts <duncan@well-typed.com> maintainer:       Simon Marlow <marlowsd@gmail.com>+bug-reports:      http://trac.haskell.org/ThreadScope/ build-type:       Simple-tested-with:      GHC == 6.10.2, GHC == 6.11.20090221-cabal-version:    >= 1.6-extra-source-files: GHC/RTS/EventLogFormat.h+tested-with:      GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1+cabal-version:    >= 1.8+extra-source-files: GHC/RTS/EventLogFormat.h,+                    AUTHORS,+                    test/*.eventlog -library {+source-repository head+  type: darcs+  location: http://code.haskell.org/ghc-events/++library   build-depends:    base       == 4.*,-                    mtl        == 1.1.*,-                    containers >= 0.2 && < 0.4,+                    mtl        >= 1.1 && < 2.1,+                    containers >= 0.2 && < 0.5,                     binary     == 0.5.*,-                    bytestring == 0.9.*+                    bytestring == 0.9.*,+                    array      == 0.3.*   exposed-modules:  GHC.RTS.Events+  other-modules:    GHC.RTS.EventParserUtils,+                    GHC.RTS.EventTypes   extensions:	    CPP-} -executable show-ghc-events {+executable ghc-events-show   main-is:          ShowGhcEvents.hs-}+  build-depends:    base, mtl, containers, binary, bytestring, array +executable ghc-events-merge+  main-is:          MergeGhcEvents.hs+  build-depends:    base, mtl, containers, binary, bytestring, array +test-suite test-versions+  type:             exitcode-stdio-1.0+  main-is:          test/TestVersions.hs+  build-depends:    base, mtl, containers, binary, bytestring, array

@@ -0,0 +1,65 @@+{-+This test parses sample event logs from each major GHC version and compares+the pretty printed output with reference output.++When tests fail, use a diff tool to compare the output of show-ghc-events with+the reference file.  Resolve the differences in either the library code or the+reference file, and 'darcs record' the changes.++Steps to produce event log and reference output:+    $ ghc --make queens.hs -o queens-ghc-$VERSION -threaded -eventlog+    $ queens-ghc-$VERSION 8 +RTS -N4 -ls+    $ show-ghc-events queens-ghc-$VERSION.eventlog > queens-ghc-$VERSION.eventlog.reference++Where queens.hs is http://darcs.haskell.org/nofib/parallel/queens/Main.hs+-}++import GHC.RTS.Events+import System.Exit++files :: [FilePath]+files = map ("test/"++)+    [ "queens-ghc-6.12.1.eventlog"+    , "queens-ghc-7.0.2.eventlog"+    , "mandelbrot-mmc-2011-06-14.eventlog" ]++-- returns True on success+testFile :: FilePath -> IO Bool+testFile f = do+    e <- readEventLogFromFile f+    let oops s = putStrLn (f ++ ": failure" ++ s) >> return False++    case e of+        Left m -> oops m++        Right newlogdata -> do+            oldlog <- readFile (f ++ ".reference")+            let newlog = ppEventLog newlogdata ++ "\n" in+                if oldlog == newlog+                    then putStrLn (f ++ ": success") >> return True+                    else do print $ diffLines oldlog newlog+                            oops "pretty print output does not match"++main = do+    successes <- mapM testFile files+    if and successes+        then return ()+        else exitFailure++--+-- Code to help print the differences between a working test and a failing test.+--++diffLines o n = diff 1 (lines o) (lines n)++diff :: Int -> [String] -> [String] -> String+diff _ [] [] = "Logs match"+diff l [] (n:ns) = "Extra lines in new log at line " ++ show l ++ ":\n" +++    (unlines (n:ns))+diff l (o:os) [] = "Missing lines in new log at line " ++ show l ++ ":\n" +++    (unlines (o:os))+diff l (o:os) (n:ns) = if (o == n)+                        then diff (l+1) os ns+                        else "Different lines at line " ++ show l ++ ":\n" +++                            "Original: " ++ o +++                            "New:      " ++ n

binary file changed (absent → 104182 bytes)