diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Change Log +## 0.13.0 - 2020-04-04 + +* Fix broken UTF-8 decoding ([#55](https://github.com/haskell/ghc-events/pull/55)) + * This is a breaking change. Most of the String fields in EventInfo have been replaced with Texts. +* Support GHC 8.10.1 + ## 0.12.0 - 2019-12-02 * Add support for EVENT_USER_BINARY_MSG ([#54](https://github.com/haskell/ghc-events/pull/54)) 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.12.0 +version: 0.13.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, @@ -26,7 +26,8 @@ GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 - GHC == 8.8.1 + GHC == 8.8.3 + GHC == 8.10.1 cabal-version: >= 1.8 extra-source-files: include/EventLogFormat.h test/queens-ghc-6.12.1.eventlog @@ -65,6 +66,8 @@ test/time-prof.eventlog.reference test/trace-binary-event.eventlog test/trace-binary-event.eventlog.reference + test/unicode.eventlog + test/unicode.eventlog.reference test/Utils.hs test/stop.hs README.md @@ -75,7 +78,7 @@ location: git@github.com:haskell/ghc-events.git library - build-depends: base >= 4.7 && < 4.14, + build-depends: base >= 4.7 && < 4.15, containers >= 0.5 && < 0.7, binary >= 0.7 && < 0.11, bytestring >= 0.10.4, diff --git a/src/GHC/RTS/EventParserUtils.hs b/src/GHC/RTS/EventParserUtils.hs --- a/src/GHC/RTS/EventParserUtils.hs +++ b/src/GHC/RTS/EventParserUtils.hs @@ -5,21 +5,26 @@ EventParsers(..), getString, + getText, + getTextNul, mkEventTypeParsers, simpleEvent, skip, ) where -import Control.Monad import Data.Array import Data.Binary import Data.Binary.Get () -import qualified Data.Binary.Get as G import Data.Binary.Put () -import Data.Char import Data.IntMap (IntMap) -import qualified Data.IntMap as M import Data.List +import Data.Text (Text) +import qualified Data.Binary.Get as G +import qualified Data.ByteString.Char8 as B8 +import qualified Data.IntMap as M +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE #define EVENTLOG_CONSTANTS_ONLY #include "EventLogFormat.h" @@ -28,13 +33,29 @@ newtype EventParsers = EventParsers (Array Int (Get EventInfo)) -nBytes :: Integral a => a -> Get [Word8] -nBytes n = replicateM (fromIntegral n) get - getString :: Integral a => a -> Get String getString len = do - bytes <- nBytes len - return $ map (chr . fromIntegral) bytes + bytes <- G.getByteString $ fromIntegral len + return $! B8.unpack bytes + +-- | Decode a given length of bytes as a 'Text' +getText + :: Integral a + => a -- ^ Number of bytes to decode + -> Get Text +getText len = do + bytes <- G.getByteString $ fromIntegral len + case TE.decodeUtf8' bytes of + Left err -> fail $ show err + Right text -> return text + +-- | Decode a null-terminated string as a 'Text' +getTextNul :: Get Text +getTextNul = do + chunks <- G.getLazyByteStringNul + case TLE.decodeUtf8' chunks of + Left err -> fail $ show err + Right text -> return $ TL.toStrict text skip :: Integral a => a -> Get () skip n = G.skip (fromIntegral n) diff --git a/src/GHC/RTS/EventTypes.hs b/src/GHC/RTS/EventTypes.hs --- a/src/GHC/RTS/EventTypes.hs +++ b/src/GHC/RTS/EventTypes.hs @@ -11,10 +11,9 @@ -- EventType. type EventTypeNum = Word16 type EventTypeDescLen = Word32 -type EventTypeDesc = String +type EventTypeDesc = Text type EventTypeSize = Word16 -- Event. -type EventDescription = String type Timestamp = Word64 type ThreadId = Word32 type CapNo = Word16 @@ -173,7 +172,7 @@ otherCap :: {-# UNPACK #-}!Int } | ThreadLabel { thread :: {-# UNPACK #-}!ThreadId, - threadlabel :: String + threadlabel :: !Text } -- par sparks @@ -265,13 +264,13 @@ -- program/process info | RtsIdentifier { capset :: {-# UNPACK #-}!Capset - , rtsident :: String + , rtsident :: !Text } | ProgramArgs { capset :: {-# UNPACK #-}!Capset - , args :: [String] + , args :: [Text] } | ProgramEnv { capset :: {-# UNPACK #-}!Capset - , env :: [String] + , env :: [Text] } | OsProcessPid { capset :: {-# UNPACK #-}!Capset , pid :: {-# UNPACK #-}!PID @@ -285,9 +284,9 @@ } -- messages - | Message { msg :: String } - | UserMessage { msg :: String } - | UserMarker { markername :: String } + | Message { msg :: !Text } + | UserMessage { msg :: !Text } + | UserMarker { markername :: !Text } -- Events emitted by a parallel RTS -- Program /process info (tools might prefer newer variants above) @@ -371,7 +370,7 @@ -- perf events | PerfName { perfNum :: {-# UNPACK #-}!PerfEventTypeNum - , name :: String + , name :: !Text } | PerfCounter { perfNum :: {-# UNPACK #-}!PerfEventTypeNum , tid :: {-# UNPACK #-}!KernelThreadId diff --git a/src/GHC/RTS/Events.hs b/src/GHC/RTS/Events.hs --- a/src/GHC/RTS/Events.hs +++ b/src/GHC/RTS/Events.hs @@ -268,7 +268,7 @@ <> " on cap " <> TB.decimal otherCap ThreadLabel thread label -> "thread " <> TB.decimal thread - <> " has label \"" <> TB.fromString label <> "\"" + <> " has label \"" <> TB.fromText label <> "\"" RequestSeqGC -> "requesting sequential GC" RequestParGC -> @@ -320,11 +320,11 @@ CapEnable{cap} -> "enabled cap " <> TB.decimal cap Message msg -> - TB.fromString msg + TB.fromText msg UserMessage msg -> - TB.fromString msg + TB.fromText msg UserMarker markername -> - "marker: " <> TB.fromString markername + "marker: " <> TB.fromText markername CapsetCreate cs ct -> "created capset " <> TB.decimal cs <> " of type " <> TB.fromString (show ct) @@ -344,7 +344,7 @@ <> TB.decimal nsec <> "ns (unix epoch)" RtsIdentifier cs i -> "capset " <> TB.decimal cs - <> ": RTS version \"" <> TB.fromString i <> "\"" + <> ": RTS version \"" <> TB.fromText i <> "\"" ProgramArgs cs args -> "capset " <> TB.decimal cs <> ": args: " <> TB.fromString (show args) @@ -434,7 +434,7 @@ "About to call the program entry point" PerfName{perfNum, name} -> "perf event " <> TB.decimal perfNum - <> " named \"" <> TB.fromString name <> "\"" + <> " named \"" <> TB.fromText name <> "\"" PerfCounter{perfNum, tid, period} -> "perf event counter " <> TB.decimal perfNum <> " incremented by " <> TB.decimal (period + 1) @@ -571,7 +571,7 @@ buildEventType :: EventType -> TB.Builder buildEventType (EventType num dsc msz) = TB.decimal num <> ": " - <> TB.fromString dsc <> " (size " + <> TB.fromText dsc <> " (size " <> maybe "variable" TB.decimal msz <> ")" -- | Pretty prints an 'Event', with clean handling for 'UnknownEvent' @@ -585,7 +585,7 @@ <> maybe "" (\c -> "cap " <> TB.decimal c <> ": ") evCap <> case evSpec of UnknownEvent{ ref=ref } -> - maybe "" (TB.fromString . desc) $ IM.lookup (fromIntegral ref) imap + maybe "" (TB.fromText . desc) $ IM.lookup (fromIntegral ref) imap _ -> buildEventInfo evSpec buildEvent' :: Event -> TB.Builder diff --git a/src/GHC/RTS/Events/Binary.hs b/src/GHC/RTS/Events/Binary.hs --- a/src/GHC/RTS/Events/Binary.hs +++ b/src/GHC/RTS/Events/Binary.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Binary ( -- * Readers getHeader @@ -29,6 +30,7 @@ ) where import Control.Exception (assert) import Control.Monad +import Data.List (intersperse) import Data.Maybe import Prelude hiding (gcd, rem, id) @@ -39,8 +41,6 @@ import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Vector.Unboxed as VU import GHC.RTS.EventTypes @@ -56,16 +56,13 @@ let etSize = if size == 0xffff then Nothing else Just size -- 0xffff indicates variable-sized event etDescLen <- get :: Get EventTypeDescLen - etDesc <- getEtDesc (fromIntegral etDescLen) + etDesc <- getText etDescLen etExtraLen <- get :: Get Word32 G.skip (fromIntegral etExtraLen) ete <- get :: Get Marker when (ete /= EVENT_ET_END) $ fail "Event Type end marker not found." return (EventType etNum etDesc etSize) - where - getEtDesc :: Int -> Get [Char] - getEtDesc s = replicateM s (get :: Get Char) getHeader :: Get Header getHeader = do @@ -270,37 +267,39 @@ (VariableSizeParser EVENT_LOG_MSG (do -- (msg) num <- get :: Get Word16 - string <- getString num + string <- getText num return Message{ msg = string } )), (VariableSizeParser EVENT_USER_MSG (do -- (msg) num <- get :: Get Word16 - string <- getString num + string <- getText num return UserMessage{ msg = string } )), (VariableSizeParser EVENT_USER_MARKER (do -- (markername) num <- get :: Get Word16 - string <- getString num + string <- getText num return UserMarker{ markername = string } )), (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg]) num <- get :: Get Word16 cs <- get - string <- getString (num - sz_capset) - return ProgramArgs{ capset = cs - , args = splitNull string } + string <- getText (num - sz_capset) + return ProgramArgs + { capset = cs + , args = T.splitOn "\0" $ T.dropWhileEnd (== '\0') string } )), (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg]) num <- get :: Get Word16 cs <- get - string <- getString (num - sz_capset) - return ProgramEnv{ capset = cs - , env = splitNull string } + string <- getText (num - sz_capset) + return ProgramEnv + { capset = cs + , env = T.splitOn "\0" $ T.dropWhileEnd (== '\0') string } )), (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str) num <- get :: Get Word16 cs <- get - string <- getString (num - sz_capset) + string <- getText (num - sz_capset) return RtsIdentifier{ capset = cs , rtsident = string } )), @@ -315,7 +314,7 @@ (VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str) num <- get :: Get Word16 tid <- get - str <- getString (num - sz_tid) + str <- getText (num - sz_tid) return ThreadLabel{ thread = tid , threadlabel = str } )) @@ -727,7 +726,7 @@ (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name) num <- get :: Get Word16 perfNum <- get - name <- getString (num - sz_perf_num) + name <- getText (num - sz_perf_num) return PerfName{perfNum, name} )), @@ -752,13 +751,13 @@ heapProfId <- get heapProfSamplingPeriod <- get heapProfBreakdown <- get - heapProfModuleFilter <- getText - heapProfClosureDescrFilter <- getText - heapProfTypeDescrFilter <- getText - heapProfCostCentreFilter <- getText - heapProfCostCentreStackFilter <- getText - heapProfRetainerFilter <- getText - heapProfBiographyFilter <- getText + heapProfModuleFilter <- getTextNul + heapProfClosureDescrFilter <- getTextNul + heapProfTypeDescrFilter <- getTextNul + heapProfCostCentreFilter <- getTextNul + heapProfCostCentreStackFilter <- getTextNul + heapProfRetainerFilter <- getTextNul + heapProfBiographyFilter <- getTextNul assert (fromIntegral payloadLen == sum [ 1 -- heapProfId @@ -777,9 +776,9 @@ , VariableSizeParser EVENT_HEAP_PROF_COST_CENTRE $ do payloadLen <- get :: Get Word16 heapProfCostCentreId <- get - heapProfLabel <- getText - heapProfModule <- getText - heapProfSrcLoc <- getText + heapProfLabel <- getTextNul + heapProfModule <- getTextNul + heapProfSrcLoc <- getTextNul heapProfFlags <- get assert (fromIntegral payloadLen == sum @@ -820,7 +819,7 @@ payloadLen <- get :: Get Word16 heapProfId <- get heapProfResidency <- get - heapProfLabel <- getText + heapProfLabel <- getTextNul assert (fromIntegral payloadLen == sum [ 1 -- heapProfId @@ -879,9 +878,6 @@ putMarker :: Word32 -> PutM () putMarker = putE -putEStr :: String -> PutM () -putEStr = mapM_ putE - putEventLog :: EventLog -> PutM () putEventLog (EventLog hdr es) = do putHeader hdr @@ -899,8 +895,8 @@ putMarker EVENT_ET_BEGIN putType n putE $ fromMaybe 0xffff msz - putE (fromIntegral $ length d :: EventTypeDescLen) - mapM_ put d + putE (fromIntegral $ T.length d :: EventTypeDescLen) + putE d -- the event type header allows for extra data, which we don't use: putE (0 :: Word32) putMarker EVENT_ET_END @@ -1111,9 +1107,9 @@ putCap c putEventSpec (ThreadLabel t l) = do - putE (fromIntegral (length l) + sz_tid :: Word16) + putE (fromIntegral (T.length l) + sz_tid :: Word16) putE t - putEStr l + putE l putEventSpec Shutdown = return () @@ -1220,21 +1216,21 @@ putCap cp putEventSpec (RtsIdentifier cs rts) = do - putE (fromIntegral (length rts) + sz_capset :: Word16) + putE (fromIntegral (T.length rts) + sz_capset :: Word16) putE cs - putEStr rts + putE rts putEventSpec (ProgramArgs cs as) = do - let as' = unsep as - putE (fromIntegral (length as') + sz_capset :: Word16) + let sz_args = sum $ map ((+ 1) {- for \0 -} . T.length) as + putE (fromIntegral sz_args + sz_capset :: Word16) putE cs - mapM_ putE as' + mapM_ putE (intersperse "\0" as) putEventSpec (ProgramEnv cs es) = do - let es' = unsep es - putE (fromIntegral (length es') + sz_capset :: Word16) + let sz_env = sum $ map ((+ 1) {- for \0 -} . T.length) es + putE (fromIntegral sz_env + sz_capset :: Word16) putE cs - mapM_ putE es' + mapM_ putE $ intersperse "\0" es putEventSpec (OsProcessPid cs pid) = do putE cs @@ -1250,16 +1246,16 @@ putE nsec putEventSpec (Message s) = do - putE (fromIntegral (length s) :: Word16) - mapM_ putE s + putE (fromIntegral (T.length s) :: Word16) + putE s putEventSpec (UserMessage s) = do - putE (fromIntegral (length s) :: Word16) - mapM_ putE s + putE (fromIntegral (T.length s) :: Word16) + putE s putEventSpec (UserMarker s) = do - putE (fromIntegral (length s) :: Word16) - mapM_ putE s + putE (fromIntegral (T.length s) :: Word16) + putE s putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent" @@ -1363,9 +1359,9 @@ putEventSpec MerCallingMain = return () putEventSpec PerfName{..} = do - putE (fromIntegral (length name) + sz_perf_num :: Word16) + putE (fromIntegral (T.length name) + sz_perf_num :: Word16) putE perfNum - mapM_ putE name + putE name putEventSpec PerfCounter{..} = do putE perfNum @@ -1431,21 +1427,3 @@ putEventSpec UserBinaryMessage {..} = do putE (fromIntegral (B.length payload) :: Word16) putByteString payload - --- [] == [] --- [x] == x\0 --- [x, y, z] == x\0y\0 -unsep :: [String] -> String -unsep = concatMap (++"\0") -- not the most efficient, but should be ok - -splitNull :: String -> [String] -splitNull [] = [] -splitNull xs = case span (/= '\0') xs of - (x, xs') -> x : splitNull (drop 1 xs') - -getText :: Get T.Text -getText = do - chunks <- G.getLazyByteStringNul - case TLE.decodeUtf8' chunks of - Left err -> fail $ show err - Right text -> return $ TL.toStrict text diff --git a/test/TestVersions.hs b/test/TestVersions.hs --- a/test/TestVersions.hs +++ b/test/TestVersions.hs @@ -17,10 +17,8 @@ import System.Exit (exitFailure) import GHC.RTS.Events -import GHC.RTS.Events.Incremental import Utils (files, diffLines) - testFile :: FilePath -> IO Bool testFile f = do e <- readEventLogFromFile f @@ -35,6 +33,7 @@ else do putStrLn $ diffLines oldlog newlog oops "pretty print output does not match" +main :: IO () main = do successes <- mapM testFile files if and successes diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -17,10 +17,12 @@ , "biographical-samples.eventlog" , "time-prof.eventlog" , "trace-binary-event.eventlog" + , "unicode.eventlog" ] -- Code to help print the differences between a working test and a failing test. +diffLines :: String -> String -> String diffLines o n = diff 1 (lines o) (lines n) diff :: Int -> [String] -> [String] -> String diff --git a/test/unicode.eventlog b/test/unicode.eventlog new file mode 100644 Binary files /dev/null and b/test/unicode.eventlog differ diff --git a/test/unicode.eventlog.reference b/test/unicode.eventlog.reference new file mode 100644 --- /dev/null +++ b/test/unicode.eventlog.reference @@ -0,0 +1,103 @@ +Event Types: +0: Create thread (size 4) +1: Run thread (size 4) +2: Stop thread (size 10) +3: Thread runnable (size 4) +4: Migrate thread (size 6) +8: Wakeup thread (size 6) +9: Starting GC (size 0) +10: Finished GC (size 0) +11: Request sequential GC (size 0) +12: Request parallel GC (size 0) +15: Create spark thread (size 4) +16: Log message (size variable) +18: Block marker (size 14) +19: User message (size variable) +20: GC idle (size 0) +21: GC working (size 0) +22: GC done (size 0) +25: Create capability set (size 6) +26: Delete capability set (size 4) +27: Add capability to capability set (size 6) +28: Remove capability from capability set (size 6) +29: RTS name and version (size variable) +30: Program arguments (size variable) +31: Program environment variables (size variable) +32: Process ID (size 8) +33: Parent process ID (size 8) +34: Spark counters (size 56) +35: Spark create (size 0) +36: Spark dud (size 0) +37: Spark overflow (size 0) +38: Spark run (size 0) +39: Spark steal (size 2) +40: Spark fizzle (size 0) +41: Spark GC (size 0) +43: Wall clock time (size 16) +44: Thread label (size variable) +45: Create capability (size 2) +46: Delete capability (size 2) +47: Disable capability (size 2) +48: Enable capability (size 2) +49: Total heap mem ever allocated (size 12) +50: Current heap size (size 12) +51: Current heap live data (size 12) +52: Heap static parameters (size 38) +53: GC statistics (size 58) +54: Synchronise stop-the-world GC (size 0) +55: Task create (size 18) +56: Task migrate (size 12) +57: Task delete (size 8) +58: User marker (size variable) +59: Empty event for bug #9003 (size 0) +160: Start of heap profile (size variable) +161: Cost center definition (size variable) +162: Start of heap profile sample (size 8) +163: Heap profile cost-centre sample (size variable) +164: Heap profile string sample (size variable) +181: User binary message (size variable) + +Events: +199023: created capset 0 of type CapsetOsProcess +199124: created capset 1 of type CapsetClockDomain +199641: created cap 0 +199705: assigned cap 0 to capset 0 +199757: assigned cap 0 to capset 1 +205412: capset 1: wall clock time 1576909771s 759746000ns (unix epoch) +205582: capset 0: pid 85701 +211303: capset 0: parent pid 89650 +215676: capset 0: RTS version "GHC-8.8.1 rts_l" +218893: capset 0: args: ["./unicode","+RTS","-lu"] +3684143: heap stats for heap capset 0: generations 2, 0 bytes max heap size, 1048576 bytes alloc area size, 1048576 bytes mblock size, 4096 bytes block size +3790819: task 0x7fdd0ee00460 created on cap 0 with OS kernel thread 4628350 +3791820: cap 0: creating thread 1 +3801611: cap 0: running thread 1 +3851573: cap 0: こんにちは +3852417: cap 0: stopping thread 1 (thread finished) +3853023: task 0x7fdd0ee00460 deleted +3854106: task 0x7fdd0ee00460 created on cap 0 with OS kernel thread 4628350 +3854259: cap 0: creating thread 2 +3854458: cap 0: running thread 2 +3979871: cap 0: stopping thread 2 (thread finished) +3980191: task 0x7fdd0ee00460 deleted +3983762: cap 0: starting GC +3988279: cap 0: GC working +4151142: cap 0: GC idle +4151260: cap 0: GC done +4152813: cap 0: GC idle +4152861: cap 0: GC done +4153142: cap 0: GC idle +4153184: cap 0: GC done +4155396: cap 0: allocated on heap capset 0: 42872 total bytes till now +4156194: cap 0: finished GC +4156678: cap 0: all caps stopped for GC +4156798: cap 0: GC stats for heap capset 0: generation 1, 3216 bytes copied, 21256 bytes slop, 950272 bytes fragmentation, 1 par threads, 0 bytes max par copied, 3216 bytes total par copied, 0 bytes balanced par copied +4157147: cap 0: live data in heap capset 0: 36088 bytes +4157226: cap 0: size of heap capset 0: 2097152 bytes +14563387: cap 0: allocated on heap capset 0: 42872 total bytes till now +14566187: removed cap 0 from capset 0 +14566352: removed cap 0 from capset 1 +14566478: deleted cap 0 +14566778: deleted capset 0 +14566855: deleted capset 1 +