ghc-events 0.4.3.0 → 0.4.4.0

raw patch · 13 files changed

+547/−58 lines, 13 filesdep ~basedep ~binarydep ~mtlbinary-addedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, binary, mtl

API changes (from Hackage documentation)

Files

• GHC/RTS/EventLogFormat.h +39/−9
• GHC/RTS/EventParserUtils.hs +4/−3
• GHC/RTS/EventTypes.hs +126/−2
• GHC/RTS/Events.hs +316/−36
• GHC/RTS/Events/Merge.hs +2/−0
• GhcEvents.hs +3/−0
• ghc-events.cabal +10/−5
• test/782stop.eventlog binary
• test/783stop.eventlog binary
• test/TestVersions.hs +5/−3
• test/mdlLogMPI1.eventlog binary
• test/pre77stop.eventlog binary
• test/stop.hs +42/−0

@@ -3,16 +3,16 @@  * (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+ * - The format is endian-independent: all values are represented in   *    bigendian order.  *  * - The format is extensible:@@ -51,7 +51,7 @@  *       Word8*         -- extra info (for future extensions)  *       EVENT_ET_END  *- * Event :+ * Event :   *       Word16         -- event_type  *       Word64         -- time (nanosecs)  *       [Word16]       -- length of the rest (for variable-sized events only)@@ -162,6 +162,7 @@ #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. */ @@ -169,6 +170,23 @@  * 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. */@@ -178,7 +196,7 @@  * 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        59+#define NUM_GHC_EVENT_TAGS        70   /* DEPRECATED EVENTS: */@@ -193,9 +211,6 @@ /* 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  @@ -238,7 +253,7 @@ /*  * Status values for EVENT_STOP_THREAD  *- * 1-5 are the StgRun return values (from includes/Constants.h):+ * 1-5 are the StgRun return values (from includes/rts/Constants.h):  *  * #define HeapOverflow   1  * #define StackOverflow  2@@ -247,15 +262,24 @@  * #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 @@ -276,6 +300,12 @@ 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 

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module GHC.RTS.EventParserUtils (@@ -16,7 +17,7 @@     ) where  import Control.Monad-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Reader import Data.Array import Data.Binary@@ -35,11 +36,11 @@ import GHC.RTS.EventTypes  -- reader/Get monad that passes around the event types-type GetEvents a = ReaderT EventParsers (ErrorT String Get) a+type GetEvents a = ReaderT EventParsers (ExceptT String Get) a  newtype EventParsers = EventParsers (Array Int (GetEvents EventInfo)) -type GetHeader a = ErrorT String Get a+type GetHeader a = ExceptT String Get a  getH :: Binary a => GetHeader a getH = lift get

@@ -30,6 +30,13 @@   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@@ -69,6 +76,14 @@ 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@@ -260,6 +275,45 @@   | 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 }@@ -315,6 +369,24 @@    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@@ -325,6 +397,7 @@  | ThreadFinished  | ForeignCall  | BlockedOnMVar+ | BlockedOnMVarRead   -- since GHC-7.8, see [Stop status since GHC-7.7]  | BlockedOnBlackHole  | BlockedOnRead  | BlockedOnWrite@@ -339,6 +412,7 @@  | 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@@ -360,11 +434,41 @@  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" -maxThreadStopStatus :: RawThreadStopStatus-maxThreadStopStatus = 18+-- 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@@ -387,3 +491,23 @@                -- 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

@@ -18,9 +18,15 @@        ThreadId,        TaskId,        KernelThreadId(..),+       -- some types for the parallel RTS+       ProcessId,+       MachineId,+       PortId,+       MessageSize,+       MessageTag(..),         -- * Reading and writing event logs-       readEventLogFromFile,+       readEventLogFromFile, getEventLog,        writeEventLogToFile,         -- * Utilities@@ -45,7 +51,7 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as M import Control.Monad.Reader-import Control.Monad.Error+import Control.Monad.Except import qualified Data.ByteString.Lazy as L import Data.Function import Data.List@@ -135,7 +141,7 @@       lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) -                                               (fromIntegral sz_block_event))       eparsers <- ask-      let e_events = runGet (runErrorT $ runReaderT (getEventBlock eparsers) eparsers) lbs+      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@@ -333,30 +339,6 @@       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}@@ -439,6 +421,80 @@    ))  ] +-- 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@@ -464,11 +520,13 @@   (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+      s <- getE :: GetEvents RawThreadStopStatus+      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77                                               then NoStatus-                                              else mkStopStatus stat}+                                              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)@@ -512,6 +570,103 @@    ))  ] +-- 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)@@ -619,7 +774,7 @@       es <- getEventBlock parsers       return (e:es) -getEventLog :: ErrorT String Get EventLog+getEventLog :: ExceptT String Get EventLog getEventLog = do     header <- getHeader     let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]@@ -633,10 +788,31 @@         -- 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-                            else standardParsers ++ ghc7Parsers-                                 ++ mercuryParsers ++ perfParsers+                            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)@@ -644,7 +820,7 @@ readEventLogFromFile :: FilePath -> IO (Either String EventLog) readEventLogFromFile f = do     s <- L.readFile f-    return $ runGet (do v <- runErrorT $ getEventLog+    return $ runGet (do v <- runExceptT getEventLog                         m <- isEmpty                         m `seq` return v)  s @@ -830,6 +1006,38 @@           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 ->@@ -875,6 +1083,7 @@ 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"@@ -1025,6 +1234,18 @@     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@@ -1072,6 +1293,8 @@  -- 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@@ -1083,6 +1306,7 @@             ThreadFinished -> 5             ForeignCall -> 6             BlockedOnMVar -> 7+            BlockedOnMVarRead -> 20 -- since GHC-7.8.3             BlockedOnBlackHole -> 8             BlockedOnBlackHoleOwnedBy _ -> 8             BlockedOnRead -> 9@@ -1299,6 +1523,62 @@     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

@@ -47,6 +47,7 @@ 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@@ -114,3 +115,4 @@     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,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main where  import GHC.RTS.Events@@ -211,7 +212,9 @@         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)) =

@@ -1,5 +1,5 @@ name:             ghc-events-version:          0.4.3.0+version:          0.4.4.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,19 +7,23 @@ 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>,+                  Thomas Horstmeyer <horstmey@mathematik.uni-marburg.de>,                   Duncan Coutts <duncan@well-typed.com>,                   Nicolas Wu <nick@well-typed.com>,+                  Jost Berthold <berthold@diku.dk>                   Mikolaj Konarski <mikolaj@well-typed.com> maintainer:       Simon Marlow <marlowsd@gmail.com>-bug-reports:      http://trac.haskell.org/ThreadScope/+bug-reports:      https://github.com/haskell/ThreadScope/issues build-type:       Simple-tested-with:      GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1, GHC == 7.8.2+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 cabal-version:    >= 1.8 extra-source-files: GHC/RTS/EventLogFormat.h,                     test/*.eventlog+                    test/stop.hs  source-repository head   type: git@@ -27,7 +31,7 @@  library   build-depends:    base       == 4.*,-                    mtl        >= 1.1 && < 3.0,+                    mtl        >= 2.2.1 && < 3.0,                     containers >= 0.2 && < 0.6,                     binary     >= 0.5 && < 0.8,                     bytestring >= 0.9.0,@@ -42,6 +46,7 @@                     GHC.RTS.EventTypes   include-dirs:     GHC/RTS   extensions:	    RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards+  other-extensions: FlexibleContexts, CPP  executable ghc-events   main-is:          GhcEvents.hs

binary file changed (absent → 6724 bytes)

binary file changed (absent → 6762 bytes)

@@ -21,7 +21,9 @@ files = map ("test/"++)     [ "queens-ghc-6.12.1.eventlog"     , "queens-ghc-7.0.2.eventlog"-    , "mandelbrot-mmc-2011-06-14.eventlog" ]+    , "mandelbrot-mmc-2011-06-14.eventlog" +    , "mdlLogMPI1.eventlog"+    , "pre77stop.eventlog", "782stop.eventlog", "783stop.eventlog" ]  -- returns True on success testFile :: FilePath -> IO Bool@@ -37,7 +39,7 @@             let newlog = ppEventLog newlogdata ++ "\n" in                 if oldlog == newlog                     then putStrLn (f ++ ": success") >> return True-                    else do print $ diffLines oldlog newlog+                    else do putStrLn $ diffLines oldlog newlog                             oops "pretty print output does not match"  main = do@@ -61,5 +63,5 @@ 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 +++                            "Original: " ++ o ++ "\n" ++                             "New:      " ++ n

binary file changed (absent → 67530 bytes)

binary file changed (absent → 6512 bytes)

@@ -0,0 +1,42 @@+-- This test program triggers different thread stop encodings in+-- eventlogs, depending on GHC version (black hole, mvar read, mvar)++module Main where++import Control.Concurrent+import Debug.Trace+import GHC.Conc++main = do +  putStrLn "suggest to run with +RTS -lsu-g-p -K80m -k10m -H200m -C1s"++  -- define some time-consuming computation+  let stuff = ack 3 10+  -- create MVars to block on+  v1 <- newMVar "full"+  v2 <- newEmptyMVar+  -- create a thread which blackholes something, and re-fills the MVar+  traceEventIO "forking child thread"+  forkIO (do traceEventIO "child"+             putStrLn ("child thread sez " ++ show stuff)+             traceEventIO "filling full MVar"+             putMVar v1 "filled full var"+             yield+             traceEventIO "filling empty MVar"+             putMVar v2 "filled empty var"+             yield+             traceEventIO "child finished"+         )+  yield+  putStrLn ("and the main thread sez " ++ show stuff)+  traceEventIO "emptying full MVar"+  s1 <- takeMVar v1+  putStrLn ("from MVar: " ++ s1)+  traceEventIO "reading empty MVar"+  s2 <- readMVar v2+  putStrLn ("from MVar: " ++ s2)++ack :: Integer -> Integer -> Integer+ack 0 m = m+1+ack n 0 = ack (n-1) 1+ack n m = ack (n-1) (ack n (m-1))