From 2409a753375b6e2acfae8212dfb343cd65675046 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Thu, 30 Aug 2018 17:26:21 +0300 Subject: [PATCH 1/2] Implement roundtrip property for putEvent/getEvent Fixes #42, #41 --- CHANGELOG.md | 5 ++++ ghc-events.cabal | 2 +- src/GHC/RTS/EventParserUtils.hs | 46 +++++++++++++++++++-------------- src/GHC/RTS/EventTypes.hs | 8 +++--- src/GHC/RTS/Events.hs | 2 +- src/GHC/RTS/Events/Binary.hs | 3 ++- src/GHC/RTS/Events/Merge.hs | 4 +-- 7 files changed, 42 insertions(+), 28 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e1b8168..59eda48 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Change Log +## 0.9.0 - unreleased + +* Event parser (`getEvent`) now reads extra unparsed data after events (instead of skipping them as before) and put it in the new `evExtras` field. This field is used to implement round-trip property of `getEvent`/`putEvent`. See [#42](https://github.com/haskell/ghc-events/issues/42) for more details. + * This is a breaking change (a new field `evExtras` added to `Event`) + ## 0.8.0 - 2018-07-11 * Add HeapProfBreakdownClosureType ([#33](https://github.com/haskell/ghc-events/pull/33), [#39](https://github.com/haskell/ghc-events/pull/39)) diff --git a/ghc-events.cabal b/ghc-events.cabal index 26d7094..3e884b2 100644 --- a/ghc-events.cabal +++ b/ghc-events.cabal @@ -1,5 +1,5 @@ name: ghc-events -version: 0.8.0 +version: 0.9.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, diff --git a/src/GHC/RTS/EventParserUtils.hs b/src/GHC/RTS/EventParserUtils.hs index 7f64903..4044597 100644 --- a/src/GHC/RTS/EventParserUtils.hs +++ b/src/GHC/RTS/EventParserUtils.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveFunctor #-} + module GHC.RTS.EventParserUtils ( EventParser(..), EventParsers(..), @@ -7,7 +10,6 @@ module GHC.RTS.EventParserUtils ( getString, mkEventTypeParsers, simpleEvent, - skip, ) where import Control.Monad @@ -20,13 +22,14 @@ import Data.Char import Data.IntMap (IntMap) import qualified Data.IntMap as M import Data.List +import qualified Data.ByteString as B #define EVENTLOG_CONSTANTS_ONLY #include "EventLogFormat.h" import GHC.RTS.EventTypes -newtype EventParsers = EventParsers (Array Int (Get EventInfo)) +newtype EventParsers = EventParsers (Array Int (Get (EventInfo, B.ByteString))) nBytes :: Integral a => a -> Get [Word8] nBytes n = replicateM (fromIntegral n) get @@ -36,9 +39,6 @@ getString len = do bytes <- nBytes len return $ map (chr . fromIntegral) bytes -skip :: Integral a => a -> Get () -skip n = G.skip (fromIntegral n) - -- -- Code to build the event parser table. -- @@ -55,7 +55,7 @@ data EventParser a | VariableSizeParser { vsp_type :: Int, vsp_parser :: Get a - } + } deriving (Functor) getParser :: EventParser a -> Get a getParser (FixedSizeParser _ _ p) = p @@ -101,7 +101,7 @@ simpleEvent t p = FixedSizeParser t 0 (return p) mkEventTypeParsers :: IntMap EventType -> [EventParser EventInfo] - -> Array Int (Get EventInfo) + -> Array Int (Get (EventInfo, B.ByteString)) mkEventTypeParsers etypes event_parsers = accumArray (flip const) undefined (0, max_event_num) [ (num, parser num) | num <- [0..max_event_num] ] @@ -113,13 +113,19 @@ mkEventTypeParsers etypes event_parsers -- 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 + let mb_mb_et_size = size <$> M.lookup num etypes -- Find a parser for the event with the given size. + maybe_parser :: Maybe EventTypeSize -> Maybe (Get (EventInfo, B.ByteString)) 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 + Nothing -> do + p <- getVariableParser possible + -- Variable parsers don't generate + -- extra data as they parse the + -- whole thing always + return (fmap (, mempty) p) + Just et_size -> + getFixedParser et_size possible return $ getParser best_parser in case mb_mb_et_size of -- This event is declared in the log file's header @@ -141,7 +147,7 @@ getVariableParser (x:xs) = case x of -- 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 :: EventTypeSize -> [EventParser a] -> Maybe (EventParser (a, B.ByteString)) getFixedParser size parsers = do parser <- ((filter isFixedSize) `pipe` (filter (\x -> (fsp_size x) <= size)) `pipe` @@ -155,14 +161,14 @@ getFixedParser size parsers = maybe_head [] = Nothing maybe_head (x:_) = Just x -padParser :: EventTypeSize -> (EventParser a) -> (EventParser a) -padParser _ (VariableSizeParser t p) = VariableSizeParser t p +padParser :: EventTypeSize -> (EventParser a) -> (EventParser (a, B.ByteString)) +padParser _ (VariableSizeParser t p) = VariableSizeParser t (fmap (, mempty) p) padParser size (FixedSizeParser t orig_size orig_p) = FixedSizeParser t size p where p = if (size == orig_size) - then orig_p + then fmap (, mempty) orig_p else do d <- orig_p - skip (size - orig_size) - return d + e <- G.getByteString (fromIntegral (size - orig_size)) + return (d, e) makeParserMap :: [EventParser a] -> IntMap [EventParser a] makeParserMap = foldl buildParserMap M.empty @@ -172,10 +178,10 @@ makeParserMap = foldl buildParserMap M.empty addParser p (Just ps) = Just (p:ps) noEventTypeParser :: Int -> Maybe EventTypeSize - -> Get EventInfo + -> Get (EventInfo, B.ByteString) noEventTypeParser num mb_size = do bytes <- case mb_size of Just n -> return n Nothing -> get :: Get Word16 - skip bytes - return UnknownEvent{ ref = fromIntegral num } + e <- G.getByteString (fromIntegral bytes) + return (UnknownEvent{ ref = fromIntegral num }, e) diff --git a/src/GHC/RTS/EventTypes.hs b/src/GHC/RTS/EventTypes.hs index e5a2d04..52e4fb5 100644 --- a/src/GHC/RTS/EventTypes.hs +++ b/src/GHC/RTS/EventTypes.hs @@ -6,6 +6,7 @@ import Data.Bits import Data.Binary import Data.Text (Text) import qualified Data.Vector.Unboxed as VU +import Data.ByteString (ByteString) -- EventType. type EventTypeNum = Word16 @@ -126,9 +127,10 @@ data EventType = data Event = Event { - evTime :: {-# UNPACK #-}!Timestamp, - evSpec :: EventInfo, - evCap :: Maybe Int + evTime :: {-# UNPACK #-}!Timestamp, + evSpec :: EventInfo, + evCap :: Maybe Int, + evExtras :: !ByteString } deriving Show {-# DEPRECATED time "The field is now called evTime" #-} diff --git a/src/GHC/RTS/Events.hs b/src/GHC/RTS/Events.hs index 34e378e..ab38715 100644 --- a/src/GHC/RTS/Events.hs +++ b/src/GHC/RTS/Events.hs @@ -171,7 +171,7 @@ capSplitEvents' evts imap = -- its capability. All events are expected to belong to the same cap. addBlockMarker :: Int -> [Event] -> [Event] addBlockMarker cap evts = - (Event startTime (EventBlock endTime cap sz) (mkCap cap)) : sortedEvts + (Event startTime (EventBlock endTime cap sz) (mkCap cap) mempty) : sortedEvts where sz = fromIntegral . BL.length $ P.runPut $ mapM_ putEvent evts startTime = case sortedEvts of diff --git a/src/GHC/RTS/Events/Binary.hs b/src/GHC/RTS/Events/Binary.hs index 39f707a..b3d460e 100644 --- a/src/GHC/RTS/Events/Binary.hs +++ b/src/GHC/RTS/Events/Binary.hs @@ -101,7 +101,7 @@ getEvent (EventParsers parsers) = do if etRef == EVENT_DATA_END then return Nothing else do !evTime <- get - evSpec <- parsers ! fromIntegral etRef + (evSpec, evExtras) <- parsers ! fromIntegral etRef return $ Just Event { evCap = undefined, .. } -- @@ -957,6 +957,7 @@ putEvent Event {..} = do putType (eventTypeNum evSpec) put evTime putEventSpec evSpec + putByteString evExtras putEventSpec :: EventInfo -> PutM () putEventSpec (Startup caps) = do diff --git a/src/GHC/RTS/Events/Merge.hs b/src/GHC/RTS/Events/Merge.hs index 2b929bc..7d9f614 100644 --- a/src/GHC/RTS/Events/Merge.hs +++ b/src/GHC/RTS/Events/Merge.hs @@ -83,8 +83,8 @@ sh :: Num a => a -> a -> a sh x y = x + y updateSpec :: (EventInfo -> EventInfo) -> Event -> Event -updateSpec f (Event {evTime = t, evSpec = s, evCap = cap}) = - Event {evTime = t, evSpec = f s, evCap = cap} +updateSpec f (Event {evTime = t, evSpec = s, evCap = cap, evExtras = e}) = + Event {evTime = t, evSpec = f s, evCap = cap, evExtras = e} shift :: MaxVars -> [Event] -> [Event] shift (MaxVars mcs mc mt) = map (updateSpec shift') From 81a3c1ca917a203a2d2c703c94c2b428151c3a18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Sat, 8 Sep 2018 14:37:55 +0300 Subject: [PATCH 2/2] Changes for GHC 7.8.4 compatibility (first attempt) --- src/GHC/RTS/EventParserUtils.hs | 8 ++++---- src/GHC/RTS/Events.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/GHC/RTS/EventParserUtils.hs b/src/GHC/RTS/EventParserUtils.hs index 4044597..4f48091 100644 --- a/src/GHC/RTS/EventParserUtils.hs +++ b/src/GHC/RTS/EventParserUtils.hs @@ -113,7 +113,7 @@ mkEventTypeParsers etypes event_parsers -- 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 = size <$> M.lookup num etypes + let mb_mb_et_size = fmap size (M.lookup num etypes) -- Find a parser for the event with the given size. maybe_parser :: Maybe EventTypeSize -> Maybe (Get (EventInfo, B.ByteString)) maybe_parser mb_et_size = do possible <- M.lookup num parser_map @@ -123,7 +123,7 @@ mkEventTypeParsers etypes event_parsers -- Variable parsers don't generate -- extra data as they parse the -- whole thing always - return (fmap (, mempty) p) + return (fmap (, B.empty) p) Just et_size -> getFixedParser et_size possible return $ getParser best_parser @@ -162,10 +162,10 @@ getFixedParser size parsers = maybe_head (x:_) = Just x padParser :: EventTypeSize -> (EventParser a) -> (EventParser (a, B.ByteString)) -padParser _ (VariableSizeParser t p) = VariableSizeParser t (fmap (, mempty) p) +padParser _ (VariableSizeParser t p) = VariableSizeParser t (fmap (, B.empty) p) padParser size (FixedSizeParser t orig_size orig_p) = FixedSizeParser t size p where p = if (size == orig_size) - then fmap (, mempty) orig_p + then fmap (, B.empty) orig_p else do d <- orig_p e <- G.getByteString (fromIntegral (size - orig_size)) return (d, e) diff --git a/src/GHC/RTS/Events.hs b/src/GHC/RTS/Events.hs index ab38715..a7abf48 100644 --- a/src/GHC/RTS/Events.hs +++ b/src/GHC/RTS/Events.hs @@ -171,7 +171,7 @@ capSplitEvents' evts imap = -- its capability. All events are expected to belong to the same cap. addBlockMarker :: Int -> [Event] -> [Event] addBlockMarker cap evts = - (Event startTime (EventBlock endTime cap sz) (mkCap cap) mempty) : sortedEvts + (Event startTime (EventBlock endTime cap sz) (mkCap cap) B.empty) : sortedEvts where sz = fromIntegral . BL.length $ P.runPut $ mapM_ putEvent evts startTime = case sortedEvts of