diff --git a/GHC/RTS/EventLogFormat.h b/GHC/RTS/EventLogFormat.h --- a/GHC/RTS/EventLogFormat.h +++ b/GHC/RTS/EventLogFormat.h @@ -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. */ @@ -260,22 +261,23 @@ * #define ThreadFinished 5 * #define ForeignCall 6 * #define BlockedOnMVar 7 - * #define BlockedOnMVarRead 8 - * NOTE: added in GHC-7.7, earlier versions shift numbers one up - * #define BlockedOnBlackHole 9 - * #define BlockedOnRead 10 - * #define BlockedOnWrite 11 - * #define BlockedOnDelay 12 - * #define BlockedOnSTM 13 - * #define BlockedOnDoProc 14 - * NOTE: unused GUM states 9, 10 (here: 15,16) in rts/Constants.h + * #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 17 - * NOTE: 17 because unused GUM states are ignored in ghc-events lib - * Otherwise it would be 19, following would be 20, 21 - * #define ThreadMigrating 18 - * #define BlockedOnMsgGlobalise 19 + * #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 diff --git a/GHC/RTS/EventParserUtils.hs b/GHC/RTS/EventParserUtils.hs --- a/GHC/RTS/EventParserUtils.hs +++ b/GHC/RTS/EventParserUtils.hs @@ -16,8 +16,13 @@ ) where import Control.Monad -import Control.Monad.Error -import Control.Monad.Reader +import Control.Monad.Trans.Class +#if MIN_VERSION_transformers(0, 4, 1) +import Control.Monad.Trans.Except +#else +import Control.Monad.Trans.Error +#endif +import Control.Monad.Trans.Reader import Data.Array import Data.Binary import Data.Binary.Get hiding (skip) @@ -34,12 +39,19 @@ import GHC.RTS.EventTypes +#if !(MIN_VERSION_transformers(0, 4, 1)) +-- use Error instead of Except for tranformers-0.3.0.0 +throwE = throwError +type ExceptT = ErrorT +#endif + + -- 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 @@ -125,7 +137,7 @@ -- [ (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) + undeclared_etype num = lift (throwE ("undeclared event type: " ++ show num)) parser_map = makeParserMap event_parsers parser num = -- Get the event's size from the header, diff --git a/GHC/RTS/EventTypes.hs b/GHC/RTS/EventTypes.hs --- a/GHC/RTS/EventTypes.hs +++ b/GHC/RTS/EventTypes.hs @@ -369,18 +369,23 @@ deriving Show -{- [Note: Stop status since GHC-7.7] +{- [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.7 encode BlockedOnBlackHole and following -as 8..18, whereas post-7.7 event logs encode them as 9..19. +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 -either post77 or pre77 parsers for the thread-stop event. -The EVENT_USER_MARKER was not present in GHC-7.6.3, so we take its -absense as an indication that pre77 parsers should be used. - -} +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 @@ -407,9 +412,9 @@ | BlockedOnBlackHoleOwnedBy {-# UNPACK #-}!ThreadId deriving (Show) --- GHC pre-7.7 encoding, see [Stop status since GHC-7.7] -mkStopStatus_pre77 :: RawThreadStopStatus -> ThreadStopStatus -mkStopStatus_pre77 n = case n of +-- normal GHC encoding, see [Stop status in GHC-7.8.2] +mkStopStatus :: RawThreadStopStatus -> ThreadStopStatus +mkStopStatus n = case n of 0 -> NoStatus 1 -> HeapOverflow 2 -> StackOverflow @@ -429,11 +434,13 @@ 16 -> BlockedOnMsgThrowTo 17 -> ThreadMigrating 18 -> BlockedOnMsgGlobalise + 19 -> NoStatus -- yeuch... this one does not actually exist in GHC eventlogs + 20 -> BlockedOnMVarRead -- since GHC-7.8.3 _ -> error "mkStat" --- GHC post-7.7 encoding, see [Stop status since GHC-7.7] -mkStopStatus :: RawThreadStopStatus -> ThreadStopStatus -mkStopStatus n = case n of +-- 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 @@ -442,7 +449,7 @@ 5 -> ThreadFinished 6 -> ForeignCall 7 -> BlockedOnMVar - 8 -> BlockedOnMVarRead -- since GHC-7.8 + 8 -> BlockedOnMVarRead -- in GHC-7.8.2 9 -> BlockedOnBlackHole 10 -> BlockedOnRead 11 -> BlockedOnWrite @@ -456,9 +463,11 @@ 19 -> BlockedOnMsgGlobalise _ -> error "mkStat" -maxThreadStopStatus_pre77, maxThreadStopStatus :: RawThreadStopStatus -maxThreadStopStatus_pre77 = 18 -- see [Stop status since GHC-7.7] -maxThreadStopStatus = 19 +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 @@ -489,11 +498,10 @@ | FailPE | RFork | Connect | DataMes | Head | Constr | Part | Terminate | Packet - deriving (Enum, Show) -- with GUM and its variants, add: -- ...| Fetch | Resume | Ack -- ...| Fish | Schedule | Free | Reval | Shark - + deriving (Enum, Show) offset :: RawMsgTag offset = 0x50 diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs --- a/GHC/RTS/Events.hs +++ b/GHC/RTS/Events.hs @@ -1,9 +1,6 @@ {-# LANGUAGE CPP,BangPatterns,PatternGuards #-} {-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-} {- - - Authors: Donnie Jones, Simon Marlow, Paul Bone, Mischa Dieterle, - - Thomas Horstmeyer, Duncan Coutts, Jost Berthold, Mikolaj Konarski - - Events.hs - Parser functions for GHC RTS EventLog framework, parallel version. -} @@ -53,8 +50,13 @@ import Control.Monad import Data.IntMap (IntMap) import qualified Data.IntMap as M -import Control.Monad.Reader -import Control.Monad.Error +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +#if MIN_VERSION_transformers(0, 4, 1) +import Control.Monad.Trans.Except +#else +import Control.Monad.Trans.Error +#endif import qualified Data.ByteString.Lazy as L import Data.Function import Data.List @@ -69,6 +71,13 @@ #define EVENTLOG_CONSTANTS_ONLY #include "EventLogFormat.h" +#if !(MIN_VERSION_transformers(0, 4, 1)) +-- use Error instead of Except for tranformers-0.3.0.0 +type ExceptT = ErrorT +throwE = throwError +runExceptT = runErrorT +#endif + ------------------------------------------------------------------------------ -- Binary instances @@ -84,7 +93,7 @@ lift $ G.skip (fromIntegral etExtraLen) ete <- getH :: GetHeader Marker when (ete /= EVENT_ET_END) $ - throwError ("Event Type end marker not found.") + throwE ("Event Type end marker not found.") return (EventType etNum etDesc etSize) where getEtDesc :: Int -> GetHeader [Char] @@ -94,14 +103,14 @@ getHeader = do hdrb <- getH :: GetHeader Marker when (hdrb /= EVENT_HEADER_BEGIN) $ - throwError "Header begin marker not found" + throwE "Header begin marker not found" hetm <- getH :: GetHeader Marker when (hetm /= EVENT_HET_BEGIN) $ - throwError "Header Event Type begin marker not found" + throwE "Header Event Type begin marker not found" ets <- getEventTypes emark <- getH :: GetHeader Marker when (emark /= EVENT_HEADER_END) $ - throwError "Header end marker not found" + throwE "Header end marker not found" return (Header ets) where getEventTypes :: GetHeader [EventType] @@ -115,7 +124,7 @@ | m == EVENT_HET_END -> return [] | otherwise -> - throwError "Malformed list of Event Types in header" + throwE "Malformed list of Event Types in header" getEvent :: EventParsers -> GetEvents (Maybe Event) getEvent (EventParsers parsers) = do @@ -144,7 +153,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 @@ -424,17 +433,38 @@ )) ] --- special thread stop event parsers for GHC-7 before version 7.7. --- see [Stop status since GHC-7.7] in EventTypes.hs +-- 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 > maxThreadStopStatus_pre77 + return StopThread{thread=t, status = if s > maxThreadStopStatusPre77 then NoStatus - else mkStopStatus_pre77 s} + else mkStopStatus s} -- older version of the event, no block info )), @@ -446,20 +476,22 @@ i <- getE :: GetEvents ThreadId return StopThread{thread = t, status = case () of - _ | s > maxThreadStopStatus_pre77 + _ | s > maxThreadStopStatusPre77 -> NoStatus | s == 8 {- XXX yeuch -} -- pre-7.7: 8==BlockedOnBlackhole -> BlockedOnBlackHoleOwnedBy i | otherwise - -> mkStopStatus_pre77 s} + -> mkStopStatus s} )) ] --- see [Stop status since GHC-7.7] in EventTypes.hs -post77StopParser :: EventParser EventInfo -post77StopParser = - (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do +-- 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 @@ -468,12 +500,12 @@ status = case () of _ | s > maxThreadStopStatus -> NoStatus - | s == 9 {- XXX yeuch -} - -- GHC post-7.7: 9 == BlockedOnBlackHole + | 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, @@ -501,12 +533,12 @@ (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do -- (thread, status) t <- getE s <- getE :: GetEvents RawThreadStopStatus - return StopThread{thread=t, status = if s > maxThreadStopStatus_pre77 + return StopThread{thread=t, status = if s > maxThreadStopStatusPre77 then NoStatus - else mkStopStatus_pre77 s} - -- older version of the event, use pre-77 encoding - -- (actually, it uses only encodings 0 to 5) - -- see [Stop status since GHC-7.7] in EventTypes.hs + 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) @@ -731,7 +763,7 @@ getData :: GetEvents Data getData = do db <- getE :: GetEvents Marker - when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found" + when (db /= EVENT_DATA_BEGIN) $ lift $ throwE "Data begin marker not found" eparsers <- ask let getEvents :: [Event] -> GetEvents Data @@ -754,7 +786,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] @@ -769,17 +801,23 @@ -- make use of threadscope. -} - -- GHC-7.7 changed the thread block status encoding, and - -- therefore requires a different parser for the stop event. - -- (This fix assumes things will remain as they are in GHC). - -- User markers were added in GHC-7.8 so we simply use - -- different parsers if the user marker event is present. + -- 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 = Nothing == M.lookup EVENT_USER_MARKER imap + 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 [post77StopParser] + else if is_ghc782 then [ghc782StopParser] + else [post782StopParser] event_parsers = if is_ghc_6 then standardParsers ++ ghc6Parsers ++ @@ -795,7 +833,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 @@ -1268,11 +1306,8 @@ -- here we assume that ThreadStopStatus fromEnum matches the definitions in -- EventLogFormat.h - --- The function uses the new (post GHC-7.7) encoding. This is wrong --- when writing a log produced by a GHC pre-7.7, as its version event --- is included, yet this is probably tolerable. --- For the whole story see [Stop status since GHC-7.7] in EventTypes.hs +-- 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 @@ -1284,19 +1319,19 @@ ThreadFinished -> 5 ForeignCall -> 6 BlockedOnMVar -> 7 - BlockedOnMVarRead -> 8 -- since GHC-7.7 - BlockedOnBlackHole -> 9 - BlockedOnBlackHoleOwnedBy _ -> 9 - BlockedOnRead -> 10 - BlockedOnWrite -> 11 - BlockedOnDelay -> 12 - BlockedOnSTM -> 13 - BlockedOnDoProc -> 14 - BlockedOnCCall -> 15 - BlockedOnCCall_NoUnblockExc -> 16 - BlockedOnMsgThrowTo -> 17 - ThreadMigrating -> 18 - BlockedOnMsgGlobalise -> 19 + BlockedOnMVarRead -> 20 -- since GHC-7.8.3 + BlockedOnBlackHole -> 8 + BlockedOnBlackHoleOwnedBy _ -> 8 + BlockedOnRead -> 9 + BlockedOnWrite -> 10 + BlockedOnDelay -> 11 + BlockedOnSTM -> 12 + BlockedOnDoProc -> 13 + BlockedOnCCall -> 14 + BlockedOnCCall_NoUnblockExc -> 15 + BlockedOnMsgThrowTo -> 16 + ThreadMigrating -> 17 + BlockedOnMsgGlobalise -> 18 putE $ case s of BlockedOnBlackHoleOwnedBy i -> i _ -> 0 diff --git a/ghc-events-parallel.cabal b/ghc-events-parallel.cabal --- a/ghc-events-parallel.cabal +++ b/ghc-events-parallel.cabal @@ -1,5 +1,5 @@ name: ghc-events-parallel -version: 0.5.0.0 +version: 0.5.0.1 synopsis: Library and tool for parsing .eventlog files from parallel GHC description: Parses .eventlog files emitted by parallel GHC versions (6.12.3 and later). This package can replace the original @@ -22,18 +22,19 @@ maintainer: Eden group bug-reports: eden@mathematik.uni-marburg.de build-type: Simple -tested-with: GHC == 6.12.3, GHC == 7.4.1, GHC == 7.6.1, GHC == 7.6.3, GHC == 7.8.2 +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 cabal-version: >= 1.8 extra-source-files: GHC/RTS/EventLogFormat.h, test/*.eventlog + test/stop.hs --- source-repository head --- type: darcs --- location: james.mathematik.uni-marburg.de:repos/jb/ghc-events-parallel/ +source-repository head + type: git + location: http://github.com:jberthold/ghc-events-parallel.git library build-depends: base == 4.*, - mtl >= 1.1 && < 3.0, + transformers >= 0.3 && < 0.6, containers >= 0.2 && < 0.6, binary >= 0.5 && < 0.8, bytestring >= 0.9.0, @@ -51,11 +52,11 @@ executable ghc-events main-is: GhcEvents.hs - build-depends: base, mtl, containers, binary, bytestring, array + build-depends: base, transformers, containers, binary, bytestring, array extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards test-suite test-versions type: exitcode-stdio-1.0 main-is: test/TestVersions.hs - build-depends: base, mtl, containers, binary, bytestring, array + build-depends: base, transformers, containers, binary, bytestring, array extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards 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 @@ -23,7 +23,7 @@ , "queens-ghc-7.0.2.eventlog" , "mandelbrot-mmc-2011-06-14.eventlog" , "mdlLogMPI1.eventlog" - , "warshall0-trace-7.8.2#8.eventlog" ] + , "pre77stop.eventlog", "782stop.eventlog", "783stop.eventlog" ] -- returns True on success testFile :: FilePath -> IO Bool 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))