diff --git a/GHC/RTS/EventLogFormat.h b/GHC/RTS/EventLogFormat.h --- a/GHC/RTS/EventLogFormat.h +++ b/GHC/RTS/EventLogFormat.h @@ -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 diff --git a/GHC/RTS/EventParserUtils.hs b/GHC/RTS/EventParserUtils.hs --- a/GHC/RTS/EventParserUtils.hs +++ b/GHC/RTS/EventParserUtils.hs @@ -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 diff --git a/GHC/RTS/EventTypes.hs b/GHC/RTS/EventTypes.hs --- a/GHC/RTS/EventTypes.hs +++ b/GHC/RTS/EventTypes.hs @@ -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 diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs --- a/GHC/RTS/Events.hs +++ b/GHC/RTS/Events.hs @@ -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 diff --git a/GHC/RTS/Events/Merge.hs b/GHC/RTS/Events/Merge.hs --- a/GHC/RTS/Events/Merge.hs +++ b/GHC/RTS/Events/Merge.hs @@ -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 diff --git a/GhcEvents.hs b/GhcEvents.hs --- a/GhcEvents.hs +++ b/GhcEvents.hs @@ -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)) = diff --git a/ghc-events.cabal b/ghc-events.cabal --- a/ghc-events.cabal +++ b/ghc-events.cabal @@ -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 , +author: Donnie Jones , Simon Marlow , Paul Bone , + Mischa Dieterle , + Thomas Horstmeyer , Duncan Coutts , Nicolas Wu , + Jost Berthold Mikolaj Konarski maintainer: Simon Marlow -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 diff --git a/test/782stop.eventlog b/test/782stop.eventlog new file mode 100644 Binary files /dev/null and b/test/782stop.eventlog differ diff --git a/test/783stop.eventlog b/test/783stop.eventlog new file mode 100644 Binary files /dev/null and b/test/783stop.eventlog differ diff --git a/test/TestVersions.hs b/test/TestVersions.hs --- a/test/TestVersions.hs +++ b/test/TestVersions.hs @@ -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 diff --git a/test/mdlLogMPI1.eventlog b/test/mdlLogMPI1.eventlog new file mode 100644 Binary files /dev/null and b/test/mdlLogMPI1.eventlog differ diff --git a/test/pre77stop.eventlog b/test/pre77stop.eventlog new file mode 100644 Binary files /dev/null and b/test/pre77stop.eventlog differ diff --git a/test/stop.hs b/test/stop.hs new file mode 100644 --- /dev/null +++ b/test/stop.hs @@ -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))