diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for ghc-stack-profiler-core +## 0.5.0.0 -- 2026-09-15 + +Major revision of the public API. + +- Add a `ProtocolVersion` message to detect protocol incompatibility. +- Change the format of `ThreadId` in the protocol to `Word64`. + This matches the `uint64_t` used by the RTS. +- Change the format of `CapabilityId` in memory to `Word32`. + This matches the `uint32_t` used by the RTS. + ## 0.4.0.0 -- 2026-07-14 Major version number changed to match `ghc-stack-profiler-speedscope`. diff --git a/ghc-stack-profiler-core.cabal b/ghc-stack-profiler-core.cabal --- a/ghc-stack-profiler-core.cabal +++ b/ghc-stack-profiler-core.cabal @@ -1,15 +1,18 @@ cabal-version: 3.8 name: ghc-stack-profiler-core -version: 0.4.0.0 +version: 0.5.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com build-type: Simple -synopsis: Thread sample types and serialisation logic for `ghc-stack-profiler`. +synopsis: + The eventlog protocol used by ghc-stack-profiler + description: - Thread sample types and serialisation logic for `ghc-stack-profiler`. - Defines the interface and serialisation logic to turn an RTS Callstack into a binary message suitable for the eventlog. + The eventlog protocol used by @ghc-stack-profiler@. + For details, see [@ghc-stack-profiler@](https://hackage.haskell.org/package/ghc-stack-profiler). + extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development tested-with: @@ -28,6 +31,7 @@ LambdaCase NamedFieldPuns NoImportQualifiedPost + PatternSynonyms ViewPatterns library @@ -35,14 +39,18 @@ warnings, exts exposed-modules: - GHC.Stack.Profiler.Core.Eventlog - GHC.Stack.Profiler.Core.SourceLocation - GHC.Stack.Profiler.Core.SymbolTable - GHC.Stack.Profiler.Core.ThreadSample - GHC.Stack.Profiler.Core.Util + GHC.Stack.Profiler.Core + GHC.Stack.Profiler.Core.Internal + other-modules: + GHC.Stack.Profiler.Core.Internal.CallStack + GHC.Stack.Profiler.Core.Internal.Dehydrate + GHC.Stack.Profiler.Core.Internal.Eventlog + GHC.Stack.Profiler.Core.Internal.Hydrate + GHC.Stack.Profiler.Core.Internal.Util + build-depends: - base >=4.17 && <4.23, + base >=4.17 && <5, binary >=0.8.9.3 && <0.11, bytestring >=0.11 && <0.13, containers >=0.6.8 && <0.9, @@ -54,7 +62,7 @@ default-language: GHC2021 -test-suite ghc-stack-profiler-core-tests +test-suite ghc-stack-profiler-tests import: warnings, exts type: exitcode-stdio-1.0 hs-source-dirs: test @@ -65,7 +73,9 @@ bytestring, ghc-stack-profiler-core, tasty >=1.5.4 && <1.6, + tasty-hunit, tasty-quickcheck >=0.10 && <0.12, + text >=2 && <2.2, default-language: GHC2021 diff --git a/src/GHC/Stack/Profiler/Core.hs b/src/GHC/Stack/Profiler/Core.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core.hs @@ -0,0 +1,94 @@ +module GHC.Stack.Profiler.Core ( + -- * Eventlog Protocol Messages + CallStack (..), + ThreadId (..), + CapabilityId (..), + StackItem (..), + IpeId (..), + SourceLocation (..), + + -- * Binary Eventlog Protocol Messages + Message (..), + ProtocolVersion (MkProtocolVersion, MyProtocolVersion), + ProtocolVersionMismatch (..), + CallStackChunk (..), + StringDef (..), + SourceLocationDef (..), + CallStackFrame (..), + StringId (..), + SourceLocationId (..), + + -- * Decode + + -- ** Deserialise + deserializeEventlogMessage, + joinCallStackChunks, + + -- ** Hydrate + hydrateEventlogCallStackMessage, + BinaryCallStackDecodeError (..), + + -- *** Symbol Table + SymbolTableReader (..), + IntMapTable, + mkIntMapSymbolTableReader, + emptyIntMapTable, + insertTextMessage, + insertSourceLocationMessage, + MissingKeyError (..), + + -- * Encode + + -- ** Serialise + + -- ** Dehydrate + dehydrateCallStack, + + -- *** Symbol Table + SymbolTableWriter (..), + emptyMapSymbolTableWriter, + MapTable, + getKnownStrings, + getKnownSourceLocations, +) where + +import GHC.Stack.Profiler.Core.Internal.CallStack ( + CallStack (..), + SourceLocation (..), + StackItem (..), + ) +import GHC.Stack.Profiler.Core.Internal.Dehydrate ( + MapTable, + SymbolTableWriter (..), + dehydrateCallStack, + emptyMapSymbolTableWriter, + getKnownSourceLocations, + getKnownStrings, + ) +import GHC.Stack.Profiler.Core.Internal.Eventlog ( + CallStackChunk (..), + CallStackFrame (..), + CapabilityId (..), + IpeId (..), + Message (..), + ProtocolVersion (MkProtocolVersion, MyProtocolVersion), + ProtocolVersionMismatch (..), + SourceLocationDef (..), + SourceLocationId (..), + StringDef (..), + StringId (..), + ThreadId (..), + deserializeEventlogMessage, + joinCallStackChunks, + ) +import GHC.Stack.Profiler.Core.Internal.Hydrate ( + BinaryCallStackDecodeError (..), + IntMapTable, + MissingKeyError (..), + SymbolTableReader (..), + emptyIntMapTable, + hydrateEventlogCallStackMessage, + insertSourceLocationMessage, + insertTextMessage, + mkIntMapSymbolTableReader, + ) diff --git a/src/GHC/Stack/Profiler/Core/Eventlog.hs b/src/GHC/Stack/Profiler/Core/Eventlog.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Core/Eventlog.hs +++ /dev/null @@ -1,298 +0,0 @@ -module GHC.Stack.Profiler.Core.Eventlog ( - -- * Eventlgog Message types - BinaryEventlogMessage (..), - BinaryCallStackMessage (..), - BinaryStringMessage (..), - BinarySourceLocationMessage (..), - BinaryStackItem (..), - CapabilityId (..), - StringId (..), - incrementStringLocationId, - SourceLocationId (..), - incrementSourceLocationId, - IpeId (..), - - -- * Eventlog constants - callStackFinalMessageTag, - callStackPartialMessageTag, - callStackStringMessageTag, - callStackSourceLocationMessageTag, - callStackMessageTags, - callStackSizeLimit, - callStackSizeLimit_, - byteSizeOf, - eventlogBufferSize, - stringLengthLimit, -) where - -import Control.Monad (replicateM) -import Data.Binary -import Data.Coerce (coerce) -import qualified Data.List as List -import Data.Text (Text) -import GHC.Generics - -import GHC.Stack.Profiler.Core.Util - --- ---------------------------------------------------------------------------- --- Eventlog Messages --- ---------------------------------------------------------------------------- - --- | Efficient serialisation format of the GHC RTS callstack. --- --- Message format: --- --- @ --- MESSAGE --- := FF CA (stack: STACK> --- | FF CB (prefix: STACK> --- | FF CC (stringId: 'Word64') (string: CStringLen) --- | FF CD (srcLocId: 'Word64') (row: 'Word32') (col: 'Word32') (functionId: 'Word64') (filename: 'Word64') --- --- STACK --- := (capability: 'Word32') (threadId: 'Word32') (length: 'Int16') (ENTRY)+ --- # check that length < (2^16-8) / 9 --- --- ENTRY --- := 01 (ipe: 'Word64') --- | 02 (stringId: 'Word64') --- | 03 (stringId: 'Word64') (srcLocId: 'Word64') --- --- CStringLen --- := (length: 'Int16') (Char)+ --- # check that length < 2^16-8 --- @ -data BinaryEventlogMessage - = CallStackFinal !BinaryCallStackMessage - | CallStackChunk !BinaryCallStackMessage - | StringDef !BinaryStringMessage - | SourceLocationDef !BinarySourceLocationMessage - deriving (Eq, Ord, Show, Read, Generic) - -data BinaryCallStackMessage = MkBinaryCallStackMessage - { binaryCallThreadId :: !Word64 - , binaryCallCapabilityId :: !CapabilityId - , binaryCallStack :: ![BinaryStackItem] - } - deriving (Eq, Ord, Show, Read, Generic) - -data BinaryStringMessage = MkBinaryStringMessage - { binaryStringMessageId :: !StringId - , binaryStringMessage :: !Text - } - deriving (Eq, Ord, Show, Read, Generic) - -data BinarySourceLocationMessage = MkBinarySourceLocationMessage - { binarySourceLocationMessageId :: {-# UNPACK #-} !SourceLocationId - , binarySourceLocationRow :: {-# UNPACK #-} !Word32 - , binarySourceLocationColumn :: {-# UNPACK #-} !Word32 - , binarySourceLocationFilename :: {-# UNPACK #-} !StringId - } - deriving (Eq, Ord, Show, Read, Generic) - -data BinaryStackItem - = BinaryIpe {-# UNPACK #-} !IpeId - | BinaryMessage - {-# UNPACK #-} !StringId - {-# UNPACK #-} !(Maybe SourceLocationId) - deriving (Eq, Ord, Show, Read, Generic) - --- | Simple newtype for the ID of a capability. -newtype CapabilityId - = MkCapabilityId - { getCapabilityId :: Word64 - } - deriving (Show, Eq, Ord, Read, Generic) - -newtype StringId = MkStringId - { getStringId :: Word64 - } - deriving (Eq, Ord, Show, Read, Generic) - -incrementStringLocationId :: StringId -> StringId -incrementStringLocationId (MkStringId sid) = MkStringId (sid + 1) - -newtype SourceLocationId = MkSourceLocationId - { getSourceLocationId :: Word64 - } - deriving (Eq, Ord, Show, Read, Generic) - -incrementSourceLocationId :: SourceLocationId -> SourceLocationId -incrementSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1) - -newtype IpeId = MkIpeId - { getIpeId :: Word64 - } - deriving (Eq, Ord, Show, Read, Generic) - --- ---------------------------------------------------------------------------- --- Binary instances --- ---------------------------------------------------------------------------- - -callStackFinalMessageTag :: Word16 -callStackFinalMessageTag = 0xFFCA - -callStackPartialMessageTag :: Word16 -callStackPartialMessageTag = 0xFFCB - -callStackStringMessageTag :: Word16 -callStackStringMessageTag = 0xFFCC - -callStackSourceLocationMessageTag :: Word16 -callStackSourceLocationMessageTag = 0xFFCD - -callStackMessageTags :: [Word16] -callStackMessageTags = - [ callStackFinalMessageTag - , callStackPartialMessageTag - , callStackStringMessageTag - , callStackSourceLocationMessageTag - ] - --- | Each message in the eventlog can be at most 2^16 bytes -eventlogBufferSize :: Word64 -eventlogBufferSize = (2 :: Word64) ^ (16 :: Word64) - --- | Size limit of strings that can occur in the eventlog. -stringLengthLimit :: Word16 -stringLengthLimit = - word64ToWord16 $ - eventlogBufferSize - - 2 {- 0xFFCC -} - - 8 {- Word64 of 'StringId' -} - - 2 {- Word16 for the length of the string to serialise -} - --- | The limit of stack items that can go in one eventlog message in bytes. -callStackSizeLimit :: Word16 -callStackSizeLimit = - callStackSizeLimit_ eventlogBufferSize - --- | The limit of stack items that can go in one eventlog message in bytes --- with configurable the eventlog message size. -callStackSizeLimit_ :: Word64 -> Word16 -callStackSizeLimit_ eventlogSize = - word64ToWord16 - ( eventlogSize - - 2 {- 0xFFCA or 0xFFCB -} - - 4 {- Word32 of 'CapabilityId' -} - - 4 {- Word32 of 'ThreadId' -} - - 2 {- Word16 for the length of stack entry -} - ) - --- | Size in bytes of the given 'BinaryStackItem' -byteSizeOf :: BinaryStackItem -> Word16 -byteSizeOf = \case - BinaryIpe{} -> 1 + 8 {- 0x1 + Word64 of 'IpeId' -} - BinaryMessage _ Nothing -> 1 + 8 {- 0x2 + Word64 of 'StringId' -} - BinaryMessage _ (Just _) -> 1 + 8 + 8 {- 0x3 + Word64 of 'StringId' + Word64 of 'SourceLocationId' -} - -instance Binary BinaryEventlogMessage where - put = \case - CallStackFinal msg -> - putWithTag callStackFinalMessageTag msg - CallStackChunk msg -> - putWithTag callStackPartialMessageTag msg - StringDef msg -> - putWithTag callStackStringMessageTag msg - SourceLocationDef msg -> - putWithTag callStackSourceLocationMessageTag msg - where - putWithTag t msg = putWord16 t >> put msg - - get = do - tag <- getWord16 - case tag of - _ - | tag == callStackFinalMessageTag -> - CallStackFinal <$> get - | tag == callStackPartialMessageTag -> - CallStackChunk <$> get - | tag == callStackStringMessageTag -> - StringDef <$> get - | tag == callStackSourceLocationMessageTag -> - SourceLocationDef <$> get - | otherwise -> - fail $ - "BinaryEventlogMessage.get: Unknown tag expected one of " - ++ tags - ++ " but got " - ++ showAsHex tag - where - tags = List.intercalate ", " $ map showAsHex callStackMessageTags - -instance Binary BinaryCallStackMessage where - put msg = do - putWord32 $ word64ToWord32 $ getCapabilityId $ binaryCallCapabilityId msg - putWord32 $ word64ToWord32 $ binaryCallThreadId msg - let - items = binaryCallStack msg - putWord16 $ intToWord16 $ length items - mapM_ put items - - get = do - capId <- getWord32 - tid <- getWord32 - len <- getWord16 - items <- replicateM (word16ToInt len) get - pure - MkBinaryCallStackMessage - { binaryCallThreadId = word32ToWord64 tid - , binaryCallCapabilityId = MkCapabilityId $ word32ToWord64 capId - , binaryCallStack = items - } - -instance Binary BinaryStackItem where - put = \case - BinaryIpe ipeId -> do - putWord8 0x1 - put ipeId - BinaryMessage sid Nothing -> do - putWord8 0x2 - put sid - BinaryMessage sid (Just lid) -> do - putWord8 0x3 - put sid - put lid - - get = do - getWord8 >>= \case - 0x1 -> BinaryIpe <$> get - 0x2 -> BinaryMessage <$> get <*> pure Nothing - 0x3 -> BinaryMessage <$> get <*> (Just <$> get) - n -> fail $ "StackItem: Unexpected tag byte encounter: " <> show n - -instance Binary BinarySourceLocationMessage where - put msg = do - put $ binarySourceLocationMessageId msg - putWord32 (binarySourceLocationRow msg) - putWord32 (binarySourceLocationColumn msg) - put (binarySourceLocationFilename msg) - - get = do - MkBinarySourceLocationMessage - <$> get - <*> getWord32 - <*> getWord32 - <*> get - -instance Binary BinaryStringMessage where - put msg = do - put $ binaryStringMessageId msg - putTextWord16 stringLengthLimit (binaryStringMessage msg) - - get = do - MkBinaryStringMessage - <$> get - <*> getTextWord16 - -instance Binary SourceLocationId where - put = putWord64 . coerce - get = coerce getWord64 - -instance Binary StringId where - put = putWord64 . coerce - get = coerce getWord64 - -instance Binary IpeId where - put = putWord64 . coerce - get = coerce getWord64 diff --git a/src/GHC/Stack/Profiler/Core/Internal.hs b/src/GHC/Stack/Profiler/Core/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_HADDOCK hide #-} + +module GHC.Stack.Profiler.Core.Internal ( + CallStackFrameTag (..), + MessageTag (..), + ShortText (..), + callStackFrameMaxSize, + callStackFrameSize, + callStackFrameTagSize, + callStackMaxLen, + callStackMaxLen', + capabilityIdSize, + ipeIdSize, + messageMaxSize, + messageMinSize, + messageTagSize, + sourceLocationDefSize, + sourceLocationIdSize, + stringDefBodyMaxSize, + stringIdSize, + threadIdSize, + toShortText, + truncateTextToByteLimit, + chunkCallStack, + chunkCallStack_, +) where + +import GHC.Stack.Profiler.Core.Internal.Dehydrate ( + chunkCallStack, + chunkCallStack_, + ) +import GHC.Stack.Profiler.Core.Internal.Eventlog ( + CallStackFrameTag (..), + MessageTag (..), + ShortText (..), + callStackFrameMaxSize, + callStackFrameSize, + callStackFrameTagSize, + callStackMaxLen, + callStackMaxLen', + capabilityIdSize, + ipeIdSize, + messageMaxSize, + messageMinSize, + messageTagSize, + sourceLocationDefSize, + sourceLocationIdSize, + stringDefBodyMaxSize, + stringIdSize, + threadIdSize, + toShortText, + truncateTextToByteLimit, + ) diff --git a/src/GHC/Stack/Profiler/Core/Internal/CallStack.hs b/src/GHC/Stack/Profiler/Core/Internal/CallStack.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal/CallStack.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Stack.Profiler.Core.Internal.CallStack ( + CallStack (..), + StackItem (..), + SourceLocation (..), +) where + +import Data.Text (Text) +import Data.Word (Word32) +import GHC.Generics +import GHC.Stack.Profiler.Core.Internal.Eventlog + +-- ---------------------------------------------------------------------------- +-- Decoded RTS CallStack +-- ---------------------------------------------------------------------------- + +-- | A decoded rts callstack that can be serialised to the EventLog. +data CallStack = MkCallStack + { callThreadId :: !ThreadId + , callCapabilityId :: !CapabilityId + , callStack :: [StackItem] + } + deriving (Eq, Ord, Show, Generic) + +data StackItem + = IpeId !IpeId + | UserAnnotation !String !(Maybe SourceLocation) + deriving (Eq, Ord, Show, Generic) + +-- | A Haskell source location. +data SourceLocation = MkSourceLocation + { line :: !Word32 + , column :: !Word32 + , fileName :: !Text + } + deriving (Eq, Ord, Show, Generic) diff --git a/src/GHC/Stack/Profiler/Core/Internal/Dehydrate.hs b/src/GHC/Stack/Profiler/Core/Internal/Dehydrate.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal/Dehydrate.hs @@ -0,0 +1,299 @@ +module GHC.Stack.Profiler.Core.Internal.Dehydrate where + +import Control.Monad (when) +import Control.Monad.Trans.State.Strict (State, runState) +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Tuple as Tuple +import GHC.Generics +import GHC.Stack.Profiler.Core.Internal.CallStack +import GHC.Stack.Profiler.Core.Internal.Eventlog + +-- | Generic implementation to turn 'CallStack' into '[Message]'. +-- +-- Replaces already encountered text or source location information with unique ids. +-- If new text or source location messages are encountered, they are inserted into +-- the 'SymbolTableWriter'. +-- +-- All new string values and source location messages are before 'CallStackChunk' and +-- 'CallStackFinal' messages. +-- For the result list @r :: ['Message']@, the following holds: +-- +-- * 'StringDef' messages are the first elements in @r@. There might not be any. +-- * 'SourceLocationDef' are after 'StringDef' messages and before any 'CallStackChunk' or +-- 'CallStackFinal' messages. There might not be any such messages. +-- * Then 'CallStackChunk' follow if there are any. +-- * The last message is always a 'CallStackFinal' message and it occurs exactly once in @r@. +dehydrateCallStack :: + forall table. + SymbolTableWriter table -> + CallStack -> + ([Message], SymbolTableWriter table) +dehydrateCallStack msgTbl0 msg = + let + (stackItems, finalState) = + runWithEncodingState + (newEncodingState msgTbl0) + (mapM go (callStack msg)) + + stringDefs = + map StringDef $ stringMessages finalState + + sourceLocDefs = + map SourceLocationDef $ sourceLocMessages finalState + + stackMsgChunks = + chunkCallStack + MkCallStackChunk + { callStackChunkThreadId = callThreadId msg + , callStackChunkCapabilityId = callCapabilityId msg + , callStackChunk = stackItems + } + in + ( stringDefs ++ sourceLocDefs ++ stackMsgChunks + , symbolTableWriter finalState + ) + where + go :: StackItem -> State (EncodingState tbl) CallStackFrame + go = \case + IpeId ipeId -> + pure $ CallStackFrameIpe ipeId + UserAnnotation s mSrcLoc -> do + srcLocId <- case mSrcLoc of + Nothing -> pure Nothing + Just srcLoc -> Just <$> lookupSourceLocationMessage srcLoc + CallStackFrameAnn <$> lookupTextMessage (Text.pack s) <*> pure srcLocId + +-- | Chunk the 'callStackChunk' of the 'CallStackChunk' by the given 'Int'. +-- If there are no items in 'CallStackChunk', then a singleton list is returned containing +-- the original element. +-- +-- Post-condition for the result @r@: +-- +-- * all elements in @init r @ are 'CallStackChunk's +-- * the element returned by @last r@ is a 'CallStackFinal' Message. +-- +-- The resulting 'CallStackChunk' are in reverse order and so are the chunks themselves. +-- +-- This means, for a stack @[1,2,3,4,5,6]@ and an assumed chunk size of 2, +-- we produce @[[6,5],[4,3],[2,1]]@. +chunkCallStack :: CallStackChunk -> [Message] +chunkCallStack = chunkCallStack_ callStackMaxLen + +-- | Same as 'chunkCallStack', but allows to set the chunking size in bytes. +chunkCallStack_ :: Int -> CallStackChunk -> [Message] +chunkCallStack_ chunkLimit msg0 = + let + items = callStackChunk msg0 + chunked = + let + go (!size, curChunk, restChunk) item = + let + !bytes = callStackFrameSize item + in + if (size + bytes) < chunkLimit + then (size + bytes, item : curChunk, restChunk) + else (bytes, [item], curChunk : restChunk) + (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items + in + lastChunk : initChunk + in + mkEventlogMessages chunked + where + mkCallStack chunk = + MkCallStackChunk + { callStackChunkThreadId = callStackChunkThreadId msg0 + , callStackChunkCapabilityId = callStackChunkCapabilityId msg0 + , callStackChunk = chunk + } + + mkEventlogMessages :: [[CallStackFrame]] -> [Message] + mkEventlogMessages [] = + -- If there are no chunks, we simply return the original message + [ CallStackFinal msg0 + ] + mkEventlogMessages [chunk] = + [ CallStackFinal $ mkCallStack chunk + ] + mkEventlogMessages (chunk : chunks) = + CallStackChunk (mkCallStack chunk) : mkEventlogMessages chunks + +-- ---------------------------------------------------------------------------- +-- Helper types and functions to implement the conversion to the binary +-- representation. +-- ---------------------------------------------------------------------------- + +data EncodingState tbl = MkEncodingState + { symbolTableWriter :: !(SymbolTableWriter tbl) + , stringMessages :: ![StringDef] + , sourceLocMessages :: ![SourceLocationDef] + } + deriving (Generic) + +runWithEncodingState :: EncodingState tbl -> State (EncodingState tbl) a -> (a, EncodingState tbl) +runWithEncodingState encodingState encoder = + runState encoder encodingState + +newEncodingState :: SymbolTableWriter tbl -> EncodingState tbl +newEncodingState msgTbl0 = + MkEncodingState + { symbolTableWriter = msgTbl0 + , stringMessages = [] + , sourceLocMessages = [] + } + +setSymbolTableWriter :: tbl -> State.State (EncodingState tbl) () +setSymbolTableWriter tbl = State.modify' (\st -> st{symbolTableWriter = (symbolTableWriter st){writerTable = tbl}}) + +addStringMessage :: StringDef -> State.State (EncodingState tbl) () +addStringMessage msg = State.modify' (\st -> st{stringMessages = msg : stringMessages st}) + +addSourceLocationMessage :: SourceLocationDef -> State.State (EncodingState tbl) () +addSourceLocationMessage msg = State.modify' (\st -> st{sourceLocMessages = msg : sourceLocMessages st}) + +lookupOrInsertTextMessage :: forall tbl. Text -> State (EncodingState tbl) (StringId, Bool) +lookupOrInsertTextMessage s = do + tbl <- State.gets symbolTableWriter + let + (sid, new, tbl1) = lookupOrInsertText tbl (writerTable tbl) s + setSymbolTableWriter tbl1 + pure (sid, new) + +lookupOrInsertSrcLocMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool) +lookupOrInsertSrcLocMessage s = do + tbl <- State.gets symbolTableWriter + let + (sid, new, tbl1) = lookupOrInsertSourceLocation tbl (writerTable tbl) s + setSymbolTableWriter tbl1 + pure (sid, new) + +lookupTextMessage :: forall tbl. Text -> State (EncodingState tbl) StringId +lookupTextMessage s = do + (sid, new) <- lookupOrInsertTextMessage s + when new $ + addStringMessage $ + MkStringDef sid s + pure sid + +lookupSourceLocationMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) SourceLocationId +lookupSourceLocationMessage s = do + (sid, new) <- lookupOrInsertSrcLocMessage s + when new $ do + fileId <- lookupTextMessage $ fileName s + addSourceLocationMessage $ + MkSourceLocationDef + { sourceLocationDefId = sid + , sourceLocationDefRow = line s + , sourceLocationDefColumn = column s + , sourceLocationDefFilename = fileId + } + pure sid + +-- | Implementation agnostic symbol table supposed to be used to deduplicate symbols +-- in 'CallStack'. +-- +-- When transforming 'CallStack' to ['Message'] we replace some +-- symbols with identifiers. +-- In particular arbitrary length symbols, such as 'Text's and 'SourceLocation's. +-- As these symbols are discovered while encoding the callstack, the 'SymbolTableWriter' +-- needs to be extended, which is why we thread the 'tbl' parameter through the +-- lookup or insertion operations. +data SymbolTableWriter tbl = MkSymbolTableWriter + { writerTable :: !tbl + -- ^ Symbol table for symbols we replace with unique identifiers. + , lookupOrInsertText :: tbl -> Text -> (StringId, Bool, tbl) + -- ^ Lookup up the given 'Text' in the 'tbl' Symbol table. + -- If the 'Text' can't be found, we insert it into the table and generate a + -- new 'StringId. + -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise. + , lookupOrInsertSourceLocation :: tbl -> SourceLocation -> (SourceLocationId, Bool, tbl) + -- ^ Lookup up the given 'SourceLocation' in the 'tbl' Symbol table. + -- If the 'SourceLocation' can't be found, we insert it into the table and generate a + -- new 'SourceLocationId. + -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise. + } + deriving (Generic) + +data MapTable = MkMapTable + { stringTable :: !(Map Text StringId) + , srcLocTable :: !(Map SourceLocation SourceLocationId) + , stringUniqueSupply :: {-# UNPACK #-} !StringId + , srcLocUniqueSupply :: {-# UNPACK #-} !SourceLocationId + } + deriving (Show, Eq, Ord, Generic) + +{-# INLINEABLE emptyMapSymbolTableWriter #-} +emptyMapSymbolTableWriter :: SymbolTableWriter MapTable +emptyMapSymbolTableWriter = + MkSymbolTableWriter + { writerTable = + MkMapTable + { stringTable = Map.empty + , srcLocTable = Map.empty + , stringUniqueSupply = MkStringId 0 + , srcLocUniqueSupply = MkSourceLocationId 0 + } + , lookupOrInsertText = alterStringMap + , lookupOrInsertSourceLocation = alterSrcLocTable + } + where + nextSrcLocUnique tbl = + ( srcLocUniqueSupply tbl + , tbl + { srcLocUniqueSupply = + nextSourceLocationId $ srcLocUniqueSupply tbl + } + ) + + nextStringUnique tbl = + ( stringUniqueSupply tbl + , tbl + { stringUniqueSupply = + nextStringId $ stringUniqueSupply tbl + } + ) + + updateEntry tbl0 nextKey Nothing = + let + (sid, tbl) = nextKey tbl0 + in + ((sid, True, tbl), Just sid) + updateEntry tbl _ (Just val) = + ((val, False, tbl), Just val) + + swapAround set ((sid, new, tbl), hm) = + (sid, new, set tbl hm) + + alterStringMap = \tbl str -> + swapAround setStringTable $ + Map.alterF (updateEntry tbl nextStringUnique) str (stringTable tbl) + + alterSrcLocTable = \tbl srcLoc -> + swapAround setSourceLocationTable $ + Map.alterF (updateEntry tbl nextSrcLocUnique) srcLoc (srcLocTable tbl) + +setSourceLocationTable :: MapTable -> Map SourceLocation SourceLocationId -> MapTable +setSourceLocationTable tbl hm = + tbl + { srcLocTable = hm + } + +setStringTable :: MapTable -> Map Text StringId -> MapTable +setStringTable tbl hm = + tbl + { stringTable = hm + } + +getKnownStrings :: MapTable -> [(StringId, Text)] +{-# INLINEABLE getKnownStrings #-} +getKnownStrings table = + List.map Tuple.swap $ Map.assocs (stringTable table) + +getKnownSourceLocations :: MapTable -> [(SourceLocationId, SourceLocation)] +{-# INLINEABLE getKnownSourceLocations #-} +getKnownSourceLocations table = + List.map Tuple.swap $ Map.assocs (srcLocTable table) diff --git a/src/GHC/Stack/Profiler/Core/Internal/Eventlog.hs b/src/GHC/Stack/Profiler/Core/Internal/Eventlog.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal/Eventlog.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.Stack.Profiler.Core.Internal.Eventlog ( + -- * Eventlog Message types + Message (..), + ProtocolVersion (MkProtocolVersion, MyProtocolVersion), + ProtocolVersionMismatch (..), + CallStackChunk (..), + StringDef (..), + SourceLocationDef (..), + CallStackFrame (..), + ThreadId (..), + CapabilityId (..), + StringId (..), + nextStringId, + SourceLocationId (..), + nextSourceLocationId, + IpeId (..), + deserializeEventlogMessage, + joinCallStackChunks, + + -- * Low-level API + MessageTag (..), + messageTagSize, + CallStackFrameTag (..), + ipeIdSize, + stringIdSize, + sourceLocationIdSize, + messageMaxSize, + messageMinSize, + stringDefBodyMaxSize, + sourceLocationDefSize, + ShortText (..), + toShortText, + truncateTextToByteLimit, + callStackFrameTagSize, + callStackMaxLen, + callStackMaxLen', + callStackFrameSize, + callStackFrameMaxSize, + capabilityIdSize, + threadIdSize, +) where + +import Control.Exception (Exception (..), assert, throw) +import Control.Monad (replicateM, when) +import Data.Binary +import Data.Binary.Get (getByteString, runGetOrFail) +import Data.Binary.Put (putByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Foreign as TF +import GHC.Generics +import GHC.Stack.Profiler.Core.Internal.Util +import Text.Printf (printf) + +-- ---------------------------------------------------------------------------- +-- Eventlog Messages +-- ---------------------------------------------------------------------------- + +-- | Efficient serialisation format of the GHC RTS callstack. +-- +-- Message format: +-- +-- @ +-- 'Message' +-- := FF CA (stackFinal: 'CallStackChunk') +-- | FF CB (stackChunk: 'CallStackChunk') +-- | FF CC (stringDef: 'StringDef') +-- | FF CD (sourceLocationDef: 'SourceLocationDef') +-- +-- 'CallStackChunk' +-- := (capabilityId: 'Word32') (threadId: 'Word32') (callStackLen: 'Word16') (callStack: 'CallStackFrame'{callStackLen}) +-- -- NOTE: callStackLen must be smaller than (2^16 - 8) / 9 +-- +-- 'CallStackFrame' +-- := 01 (ipe: 'Word64') +-- | 02 (stringId: 'Word64') +-- | 03 (stringId: 'Word64') (sourceLocationId: 'Word64') +-- +-- 'StringDef' +-- := (stringId: 'Word64') (stringLen: 'Word16') (string: 'Char'{stringLen}) +-- -- NOTE: stringLen must be smaller than 2^16 - 8 +-- +-- 'SourceLocationDef' +-- := (sourceLocationId: 'Word64') (row: 'Word32') (column: 'Word32') (functionId: 'Word64') (filename: 'Word64') +-- @ +data Message + = -- | The version of the protocol. + ProtocolVersion !ProtocolVersion + | -- | A chunk of the call-stack, indicated by the prefix @FF CA@. + -- + -- This variant indicates that no further 'CallStackChunk' or 'CallStackFinal' will follow. + CallStackFinal !CallStackChunk + | -- | A chunk of the call-stack, indicated by the prefix @FF CB@. + -- + -- This variant indicates that another 'CallStackChunk' or 'CallStackFinal' will follow. + CallStackChunk !CallStackChunk + | -- | A string definition, indicated by the prefix @FF CC@. + -- + -- This messages associates the string ID @stringId@ with the string + -- @strLen@, for future use in call-stack messages and source location + -- definitions. + StringDef !StringDef + | -- | A source location definition, indicated by the prefix @FF CD@. + -- + -- This message associates the source location ID @srcLocId@ with the + -- source location specified by @row@, @col@, @functionId@, and + -- @filename@, for future use in call-stack messages. + SourceLocationDef !SourceLocationDef + deriving (Eq, Ord, Show, Read, Generic) + +-- | The version of the protocol implemented by the `Message` type. +newtype ProtocolVersion + = MkProtocolVersion {getProtocolVersion :: Word8} + deriving (Eq, Ord, Show, Read, Generic) + deriving newtype (Binary) + +-- | The version of the protocol implemented by this package. +-- +-- __Note:__ This should always match the super-major version number of the +-- @ghc-stack-profiler-core@ package. If the package version is +-- @A.B.C.D@, the protocol version is @A@. +pattern MyProtocolVersion :: ProtocolVersion +pattern MyProtocolVersion = MkProtocolVersion 0 + +data ProtocolVersionMismatch + = MkProtocolVersionMismatch + { expectProtocolVersion :: !ProtocolVersion + , actualProtocolVersion :: !ProtocolVersion + } + deriving (Eq, Ord, Show, Read, Generic) + +instance Exception ProtocolVersionMismatch where + displayException :: ProtocolVersionMismatch -> String + displayException e = + let + expect = getProtocolVersion (expectProtocolVersion e) + actual = getProtocolVersion (actualProtocolVersion e) + in + concat + [ "The protocol version of the input (" + , show actual + , ") does not match the version implemented by this package (" + , show expect + , ")." + ] + +data CallStackChunk = MkCallStackChunk + { callStackChunkThreadId :: !ThreadId + , callStackChunkCapabilityId :: !CapabilityId + , callStackChunk :: ![CallStackFrame] + } + deriving (Eq, Ord, Show, Read, Generic) + +data StringDef = MkStringDef + { stringDefId :: !StringId + , stringDefBody :: !Text + } + deriving (Eq, Ord, Show, Read, Generic) + +data SourceLocationDef = MkSourceLocationDef + { sourceLocationDefId :: {-# UNPACK #-} !SourceLocationId + , sourceLocationDefRow :: {-# UNPACK #-} !Word32 + , sourceLocationDefColumn :: {-# UNPACK #-} !Word32 + , sourceLocationDefFilename :: {-# UNPACK #-} !StringId + } + deriving (Eq, Ord, Show, Read, Generic) + +data CallStackFrame + = CallStackFrameIpe {-# UNPACK #-} !IpeId + | CallStackFrameAnn {-# UNPACK #-} !StringId {-# UNPACK #-} !(Maybe SourceLocationId) + deriving (Eq, Ord, Show, Read, Generic) + +-- | The ID of a thread. +newtype ThreadId + = MkThreadId + { getThreadId :: Word64 + } + deriving (Show, Eq, Ord, Read, Generic) + deriving newtype (Binary) + +-- | The ID of a capability. +newtype CapabilityId + = MkCapabilityId + { getCapabilityId :: Word32 + } + deriving (Show, Eq, Ord, Read, Generic) + deriving newtype (Binary) + +newtype StringId = MkStringId + { getStringId :: Word64 + } + deriving (Eq, Ord, Show, Read, Generic) + +nextStringId :: StringId -> StringId +nextStringId (MkStringId sid) = MkStringId (sid + 1) + +newtype SourceLocationId = MkSourceLocationId + { getSourceLocationId :: Word64 + } + deriving (Eq, Ord, Show, Read, Generic) + +nextSourceLocationId :: SourceLocationId -> SourceLocationId +nextSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1) + +newtype IpeId = MkIpeId + { getIpeId :: Word64 + } + deriving (Eq, Ord, Show, Read, Generic) + +-- | Deserialise a `Message`. +-- +-- __Warning:__ This function may throw `ProtocolVersionMismatch`. +deserializeEventlogMessage :: LBS.ByteString -> Either String Message +deserializeEventlogMessage msg = case runGetOrFail get msg of + Left (_, _, errMsg) -> Left errMsg + Right (_, _, callStackMessage) -> Right callStackMessage + +-- | Combine all 'CallStackChunk's into a single 'CallStackChunk'. +-- We assume that all 'CallStackChunk' only differ in their 'callStackChunk' values. +-- +-- 'joinCallStackChunks' is the conceptually inverse of 'chunkCallStack'. +joinCallStackChunks :: NonEmpty CallStackChunk -> CallStackChunk +joinCallStackChunks msgs = + MkCallStackChunk + { callStackChunkThreadId = callStackChunkThreadId $ NonEmpty.head msgs + , callStackChunkCapabilityId = callStackChunkCapabilityId $ NonEmpty.head msgs + , callStackChunk = concatMap (reverse . callStackChunk) . reverse $ NonEmpty.toList msgs + } + +------------------------------------------------------------------------------- +-- Binary instances +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Message Tags + +data MessageTag + = ProtocolVersionTag + | CallStackFinalTag + | CallStackChunkTag + | StringDefTag + | SourceLocationDefTag + deriving (Bounded, Enum, Eq, Show) + +messageTagSize :: Int +messageTagSize = 2 + +messageTagToWord16 :: MessageTag -> Word16 +messageTagToWord16 = \case + ProtocolVersionTag -> 0xFFC0 + CallStackFinalTag -> 0xFFCA + CallStackChunkTag -> 0xFFCB + StringDefTag -> 0xFFCC + SourceLocationDefTag -> 0xFFCD + +instance Binary MessageTag where + put :: MessageTag -> Put + put = putWord16 . messageTagToWord16 + + get :: Get MessageTag + get = + getWord16 >>= \case + 0xFFC0 -> pure ProtocolVersionTag + 0xFFCA -> pure CallStackFinalTag + 0xFFCB -> pure CallStackChunkTag + 0xFFCC -> pure StringDefTag + 0xFFCD -> pure SourceLocationDefTag + badTag -> + fail $ + printf + "Found invalid message tag %s. Expected one of %s." + (showAsHex badTag) + (List.intercalate ", " messageTags) + where + messageTags :: [String] + messageTags = [showAsHex (messageTagToWord16 tag) | tag <- [minBound .. maxBound]] + +------------------------------------------------------------------------------- +-- Messages + +-- | __Warning:__ `get` may throw `ProtocolVersionMismatch`. +instance Binary Message where + put :: Message -> Put + put = \case + ProtocolVersion protocolVersion -> do + put ProtocolVersionTag + put protocolVersion + CallStackFinal callStackChunk -> do + put CallStackFinalTag + put callStackChunk + CallStackChunk callStackChunk -> do + put CallStackChunkTag + put callStackChunk + StringDef stringDef -> do + put StringDefTag + put stringDef + SourceLocationDef sourceLocationDef -> do + put SourceLocationDefTag + put sourceLocationDef + + get :: Get Message + get = + get >>= \case + ProtocolVersionTag -> do + protocolVersion <- get + when (protocolVersion /= MyProtocolVersion) $ + throw $ + MkProtocolVersionMismatch MyProtocolVersion protocolVersion + pure $ ProtocolVersion protocolVersion + CallStackFinalTag -> + CallStackFinal <$> get + CallStackChunkTag -> + CallStackChunk <$> get + StringDefTag -> + StringDef <$> get + SourceLocationDefTag -> + SourceLocationDef <$> get + +messageMaxSize :: Int +messageMaxSize = + fromIntegral (maxBound @Word16) + +messageMinSize :: Int +messageMinSize = + messageTagSize + + minimum + [ {- CallStackChunk/CallStackFinal -} + capabilityIdSize + threadIdSize + callStackLenSize + , {- StringDef -} + stringIdSize + stringDefBodyLenSize + , {- SourceLocationDef -} + sourceLocationDefSize + ] + +------------------------------------------------------------------------------- +-- CallStackChunks + +instance Binary CallStackChunk where + put :: CallStackChunk -> Put + put MkCallStackChunk{callStackChunkCapabilityId, callStackChunkThreadId, callStackChunk} = do + put callStackChunkCapabilityId + put callStackChunkThreadId + let + callStackChunkLength = length callStackChunk + putWord16 $ fromIntegral callStackChunkLength + mapM_ put callStackChunk + + get :: Get CallStackChunk + get = do + callStackChunkCapabilityId <- get + callStackChunkThreadId <- get + callStackChunkLength <- fromIntegral <$> getWord16 + callStackChunk <- replicateM callStackChunkLength get + pure MkCallStackChunk{callStackChunkThreadId, callStackChunkCapabilityId, callStackChunk} + +------------------------------------------------------------------------------- +-- CallStackFrameTags + +data CallStackFrameTag + = CallStackFrameIpeTag + | CallStackFrameAnnWithNothingTag + | CallStackFrameAnnWithJustSourceLocationTag + deriving (Bounded, Enum, Eq, Show) + +callStackFrameTagSize :: Int +callStackFrameTagSize = 1 + +callStackFrameTagToWord8 :: CallStackFrameTag -> Word8 +callStackFrameTagToWord8 = \case + CallStackFrameIpeTag -> 0x1 + CallStackFrameAnnWithNothingTag -> 0x2 + CallStackFrameAnnWithJustSourceLocationTag -> 0x3 + +instance Binary CallStackFrameTag where + put :: CallStackFrameTag -> Put + put = putWord8 . callStackFrameTagToWord8 + + get :: Get CallStackFrameTag + get = + getWord8 >>= \case + 0x1 -> pure CallStackFrameIpeTag + 0x2 -> pure CallStackFrameAnnWithNothingTag + 0x3 -> pure CallStackFrameAnnWithJustSourceLocationTag + badTag -> + fail $ + printf + "Found invalid call-stack frame tag %s. Expected one of %s." + (showAsHex badTag) + (List.intercalate ", " callStackFrameTags) + where + callStackFrameTags :: [String] + callStackFrameTags = [showAsHex (callStackFrameTagToWord8 tag) | tag <- [minBound .. maxBound]] + +------------------------------------------------------------------------------- +-- CallStackFrames + +instance Binary IpeId where + put :: IpeId -> Put + put = putWord64 . coerce + + get :: Get IpeId + get = coerce getWord64 + +ipeIdSize :: Int +ipeIdSize = 8 + +instance Binary CallStackFrame where + put :: CallStackFrame -> Put + put = \case + CallStackFrameIpe ipeId -> do + put CallStackFrameIpeTag + put ipeId + CallStackFrameAnn stringId Nothing -> do + put CallStackFrameAnnWithNothingTag + put stringId + CallStackFrameAnn stringId (Just sourceLocationId) -> do + put CallStackFrameAnnWithJustSourceLocationTag + put stringId + put sourceLocationId + + get :: Get CallStackFrame + get = do + get >>= \case + CallStackFrameIpeTag -> + CallStackFrameIpe <$> get + CallStackFrameAnnWithNothingTag -> + CallStackFrameAnn <$> get <*> pure Nothing + CallStackFrameAnnWithJustSourceLocationTag -> + CallStackFrameAnn <$> get <*> (Just <$> get) + +------------------------------------------------------------------------------- +-- StringDefs + +instance Binary StringId where + put :: StringId -> Put + put = putWord64 . coerce + + get :: Get StringId + get = coerce getWord64 + +stringIdSize :: Int +stringIdSize = 8 + +instance Binary StringDef where + put :: StringDef -> Put + put MkStringDef{stringDefId, stringDefBody} = do + put stringDefId + put $ MkUnsafeShortText (truncateTextToByteLimit stringDefBodyMaxSize stringDefBody) + + get :: Get StringDef + get = do + stringDefId <- get + -- NOTE: This allows reading stringDefBody with a lengthWord8 of up to + -- the maxBound of Word16, which is bigger than stringDefBodyMaxSize. + -- This causes a slight mismatch between the size of stringDefBody + -- read by get and written by put, which means that get followed by + -- put is not the identity. However, this would only truncate the + -- stringDefBody if that binary representation was created manually, + -- rather than via put, so this is likely not an issue. + MkUnsafeShortText stringDefBody <- get + pure MkStringDef{stringDefId, stringDefBody} + +stringDefBodyLenSize :: Int +stringDefBodyLenSize = 2 + +stringDefBodyMaxSize :: Int +stringDefBodyMaxSize = + messageMaxSize + - messageTagSize + - stringIdSize + - stringDefBodyLenSize + +------------------------------------------------------------------------------- +-- SourceLocationDefs + +instance Binary SourceLocationId where + put :: SourceLocationId -> Put + put = putWord64 . coerce + + get :: Get SourceLocationId + get = coerce getWord64 + +sourceLocationIdSize :: Int +sourceLocationIdSize = 8 + +instance Binary SourceLocationDef where + put :: SourceLocationDef -> Put + put msg = do + put $ sourceLocationDefId msg + putWord32 (sourceLocationDefRow msg) + putWord32 (sourceLocationDefColumn msg) + put (sourceLocationDefFilename msg) + + get :: Get SourceLocationDef + get = MkSourceLocationDef <$> get <*> getWord32 <*> getWord32 <*> get + +sourceLocationDefSize :: Int +sourceLocationDefSize = + sourceLocationIdSize {- sourceLocationDefId -} + + 4 {- sourceLocationDefRow -} + + 4 {- sourceLocationDefColumn -} + + stringIdSize {- sourceLocationDefFilename -} + +------------------------------------------------------------------------------- +-- Trim Text to a byte-size limit + +-- | A 'Text' whose 'TF.lengthWord8' is at most @'maxBound' :: 'Word16'@ bytes. +newtype ShortText = MkUnsafeShortText Text + deriving (Eq, Show) + +toShortText :: Text -> ShortText +toShortText text = + MkUnsafeShortText (truncateTextToByteLimit maxBoundWord16 text) + where + maxBoundWord16 = fromIntegral (maxBound @Word16) + +instance Binary ShortText where + put :: ShortText -> Put + put (MkUnsafeShortText text) = do + putWord16 (fromIntegral (TF.lengthWord8 text)) + putByteString (TE.encodeUtf8 text) + + get :: Get ShortText + get = do + lengthWord8 <- fromIntegral <$> getWord16 + bytes <- getByteString lengthWord8 + pure $ MkUnsafeShortText (TE.decodeUtf8Lenient bytes) + +-- | @'truncateTextToByteLimit' byteLimit text@ truncates @text@ such that its +-- UTF-8 serialisation fits within @byteLimit@ bytes. +truncateTextToByteLimit :: Int -> Text -> Text +truncateTextToByteLimit byteLimit text + | TF.lengthWord8 text <= byteLimit = text + | TF.lengthWord8 text' <= byteLimit = text' + | otherwise = + -- @'takeWord8' n@ takes the first n bytes and _expands_ to complete the + -- last code point, which means it may return up to n+3 bytes. Hence, if + -- this happens, we drop the final code point. + assert (byteLimit < TF.lengthWord8 text' && TF.lengthWord8 text' <= byteLimit + 3) $ + T.dropEnd 1 text' + where + text' = TF.takeWord8 (fromIntegral byteLimit) text + +------------------------------------------------------------------------------- +-- Size Invariants + +callStackLenSize :: Int +callStackLenSize = 2 + +-- | The maximum number of `CallStackFrame`s in a single `Message`. +callStackMaxLen :: Int +callStackMaxLen = callStackMaxLen' messageMaxSize + +-- | The size of a serialised `CapabilityId`. +capabilityIdSize :: Int +capabilityIdSize = 4 + +-- | The size of a serialised `ThreadId`. +threadIdSize :: Int +threadIdSize = 8 + +-- | The maximum number of `CallStackFrame`s in a single `Message`, +-- with a variable `messageMaxSize`. Used for testing. +callStackMaxLen' :: Int -> Int +callStackMaxLen' messageMaxSize' = + fromIntegral + ( messageMaxSize' + - messageTagSize + - capabilityIdSize + - threadIdSize + - callStackLenSize + ) + +-- | Size in bytes of the given 'CallStackFrame' +callStackFrameSize :: CallStackFrame -> Int +callStackFrameSize = \case + CallStackFrameIpe{} -> + 1 {- CallStackFrameTag -} + + 8 {- IpeId -} + CallStackFrameAnn _ Nothing -> + 1 {- CallStackFrameTag -} + + 8 {- StringId -} + CallStackFrameAnn _ (Just _) -> + 1 {- CallStackFrameTag -} + + 8 {- StringId -} + + 8 {- SourceLocationId -} + +callStackFrameMaxSize :: Int +callStackFrameMaxSize = + 17 {- see case for CallStackFrameAnn in callStackFrameSize -} diff --git a/src/GHC/Stack/Profiler/Core/Internal/Hydrate.hs b/src/GHC/Stack/Profiler/Core/Internal/Hydrate.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal/Hydrate.hs @@ -0,0 +1,154 @@ +module GHC.Stack.Profiler.Core.Internal.Hydrate where + +import Control.Exception +import Data.Either (partitionEithers) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics +import GHC.Stack.Profiler.Core.Internal.CallStack +import GHC.Stack.Profiler.Core.Internal.Eventlog +import GHC.Stack.Profiler.Core.Internal.Util + +data BinaryCallStackDecodeError + = StringIdNotFound StringId + | SourceLocationIdNotFound SourceLocationId + deriving (Show) + +instance Exception BinaryCallStackDecodeError where + displayException = \case + StringIdNotFound sid -> + "Failed to decode a CallStackChunk. Failed to find a String with the key: " ++ show (getStringId sid) + SourceLocationIdNotFound sid -> + "Failed to decode a CallStackChunk. Failed to find a SourceLocation with the key: " ++ show (getSourceLocationId sid) + +-- | Generic implementation to turn 'CallStackChunk' into the much richer +-- 'CallStack'. +hydrateEventlogCallStackMessage :: SymbolTableReader -> CallStackChunk -> (CallStack, [BinaryCallStackDecodeError]) +hydrateEventlogCallStackMessage decodeTable msg = + let + decodeItem :: CallStackFrame -> Either BinaryCallStackDecodeError StackItem + decodeItem = \case + CallStackFrameIpe ipeId -> + Right $ IpeId ipeId + CallStackFrameAnn stringId mSrcLocId -> do + str <- + maybe + (Left $ StringIdNotFound stringId) + (Right . Text.unpack) + (lookupStringId decodeTable stringId) + srcLoc <- case mSrcLocId of + Nothing -> pure Nothing + Just srcLocId -> + maybe + (Left $ SourceLocationIdNotFound srcLocId) + (Right . Just) + (lookupSourceLocationId decodeTable srcLocId) + pure $ UserAnnotation str srcLoc + + itemsOrErrors = map decodeItem (callStackChunk msg) + (errors, items) = partitionEithers itemsOrErrors + in + ( MkCallStack + { callCapabilityId = callStackChunkCapabilityId msg + , callThreadId = callStackChunkThreadId msg + , callStack = items + } + , errors + ) + +-- | Implementation agnostic symbol table reader helping consumers to decode +-- 'Message's into a 'CallStack'. +-- +-- As during deserialisation, we do not discover new Messages, the abstract 'SymbolTableReader' +-- doesn't need to thread the implementation through the lookup operations. +data SymbolTableReader = MkSymbolTableReader + { lookupStringId :: StringId -> Maybe Text + -- ^ Lookup the 'StringId' in the symbol table. + -- This operation throws an exception if the 'StringId' is unknown. + , lookupSourceLocationId :: SourceLocationId -> Maybe SourceLocation + -- ^ Lookup the 'SourceLocationId' in the symbol table. + -- This operation throws an exception if the 'SourceLocationId' is unknown. + } + deriving (Generic) + +data MissingKeyError + = -- | We failed to find the 'StringId' to fully decode the 'SourceLocationId'. + KeyStringIdNotFound SourceLocationId StringId + deriving (Show) + +instance Exception MissingKeyError where + displayException = \case + KeyStringIdNotFound srcLocId stringId -> + "While decoding the Source Location (" + ++ show (getSourceLocationId srcLocId) + ++ "), " + ++ "the String (" + ++ show (getStringId stringId) + ++ ") couldn't be found" + +data IntMapTable = MkIntMapTable + { stringLookupTable :: !(IntMap Text) + , srcLocLookupTable :: !(IntMap SourceLocation) + } + deriving (Eq, Ord, Show, Generic) + +emptyIntMapTable :: IntMapTable +emptyIntMapTable = + MkIntMapTable + { stringLookupTable = IntMap.empty + , srcLocLookupTable = IntMap.empty + } + +mkIntMapSymbolTableReader :: IntMapTable -> SymbolTableReader +mkIntMapSymbolTableReader tbl = + MkSymbolTableReader + { lookupStringId = flip lookupTextMessage tbl + , lookupSourceLocationId = flip lookupSourceLocationMessage tbl + } + +{-# INLINEABLE insertTextMessage #-} +insertTextMessage :: StringDef -> IntMapTable -> IntMapTable +insertTextMessage msg tbl = + tbl + { stringLookupTable = + IntMap.insert + (idToInt $ stringDefId msg) + (stringDefBody msg) + (stringLookupTable tbl) + } + +{-# INLINEABLE insertSourceLocationMessage #-} +insertSourceLocationMessage :: SourceLocationDef -> IntMapTable -> Either MissingKeyError IntMapTable +insertSourceLocationMessage msg tbl = do + let + srcLocId = sourceLocationDefId msg + fileId = sourceLocationDefFilename msg + + fileName <- + maybe (Left $ KeyStringIdNotFound srcLocId fileId) Right $ lookupTextMessage fileId tbl + + pure + tbl + { srcLocLookupTable = + IntMap.insert + (idToInt srcLocId) + (mkSourceLocation fileName) + (srcLocLookupTable tbl) + } + where + mkSourceLocation fileName = + MkSourceLocation + { line = sourceLocationDefRow msg + , column = sourceLocationDefColumn msg + , fileName = fileName + } + +{-# INLINEABLE lookupTextMessage #-} +lookupTextMessage :: StringId -> IntMapTable -> Maybe Text +lookupTextMessage sid tbl = IntMap.lookup (idToInt sid) (stringLookupTable tbl) + +{-# INLINEABLE lookupSourceLocationMessage #-} +lookupSourceLocationMessage :: SourceLocationId -> IntMapTable -> Maybe SourceLocation +lookupSourceLocationMessage sid tbl = IntMap.lookup (idToInt sid) (srcLocLookupTable tbl) diff --git a/src/GHC/Stack/Profiler/Core/Internal/Util.hs b/src/GHC/Stack/Profiler/Core/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Internal/Util.hs @@ -0,0 +1,84 @@ +module GHC.Stack.Profiler.Core.Internal.Util ( + idToInt, + showAsHex, + putWord64, + putWord32, + putWord16, + getWord64, + getWord32, + getWord16, + word64ToWord32, + word32ToWord64, + word64ToWord16, + word32ToInt, + word64ToInt, + intToWord64, + intToWord32, + intToWord16, + word16ToInt, + intToWord8, + word8ToInt, +) where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Coerce (Coercible, coerce) +import qualified Numeric + +idToInt :: (Coercible a Word64) => a -> Int +idToInt = word64ToInt . coerce + +showAsHex :: (Integral a) => a -> String +showAsHex d = "0x" ++ Numeric.showHex d "" + +putWord64 :: Word64 -> Put +putWord64 = putWord64be + +putWord32 :: Word32 -> Put +putWord32 = putWord32be + +putWord16 :: Word16 -> Put +putWord16 = putWord16be + +getWord64 :: Get Word64 +getWord64 = getWord64be + +getWord32 :: Get Word32 +getWord32 = getWord32be + +getWord16 :: Get Word16 +getWord16 = getWord16be + +word64ToWord32 :: Word64 -> Word32 +word64ToWord32 = fromIntegral + +word32ToWord64 :: Word32 -> Word64 +word32ToWord64 = fromIntegral + +word64ToWord16 :: Word64 -> Word16 +word64ToWord16 = fromIntegral + +word32ToInt :: Word32 -> Int +word32ToInt = fromIntegral + +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +intToWord64 :: Int -> Word64 +intToWord64 = fromIntegral + +intToWord32 :: Int -> Word32 +intToWord32 = fromIntegral + +intToWord16 :: Int -> Word16 +intToWord16 = fromIntegral + +word16ToInt :: Word16 -> Int +word16ToInt = fromIntegral + +intToWord8 :: Int -> Word8 +intToWord8 = fromIntegral + +word8ToInt :: Word8 -> Int +word8ToInt = fromIntegral diff --git a/src/GHC/Stack/Profiler/Core/SourceLocation.hs b/src/GHC/Stack/Profiler/Core/SourceLocation.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Core/SourceLocation.hs +++ /dev/null @@ -1,13 +0,0 @@ -module GHC.Stack.Profiler.Core.SourceLocation where - -import Data.Text (Text) -import Data.Word (Word32) -import GHC.Generics (Generic) - --- | A Haskell source location. -data SourceLocation = MkSourceLocation - { line :: !Word32 - , column :: !Word32 - , fileName :: !Text - } - deriving (Eq, Ord, Show, Generic) diff --git a/src/GHC/Stack/Profiler/Core/SymbolTable.hs b/src/GHC/Stack/Profiler/Core/SymbolTable.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Core/SymbolTable.hs +++ /dev/null @@ -1,247 +0,0 @@ -module GHC.Stack.Profiler.Core.SymbolTable ( - -- * Abstract interfaces for transforming 'CallStackMessage's and - - -- 'BinaryEventlogMessage' into each other. - SymbolTableWriter (..), - SymbolTableReader (..), - - -- * A 'Map' implementation for the 'SymbolTableWriter' interface. - MapTable, - emptyMapSymbolTableWriter, - getKnownStrings, - getKnownSourceLocations, - - -- * An 'IntMap' implementation for the 'SymbolTableReader' interface. - IntMapTable, - MissingKeyError (..), - mkIntMapSymbolTableReader, - emptyIntMapTable, - insertSourceLocationMessage, - insertTextMessage, -) where - -import Control.Exception -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import qualified Data.Tuple as Tuple -import GHC.Generics (Generic) -import GHC.Stack.Profiler.Core.Eventlog -import GHC.Stack.Profiler.Core.SourceLocation -import GHC.Stack.Profiler.Core.Util - --- ---------------------------------------------------------------------------- --- Abstract interfaces for writing and reading to the symbol tables for deduplicating --- the symbols for 'Text' and 'SourceLocation'. --- ---------------------------------------------------------------------------- - --- | Implementation agnostic symbol table supposed to be used to deduplicate symbols --- in 'CallStackMessage'. --- --- When transforming 'CallStackMessage' to ['BinaryEventlogMessage'] we replace some --- symbols with identifiers. --- In particular arbitrary length symbols, such as 'Text's and 'SourceLocation's. --- As these symbols are discovered while encoding the callstack, the 'SymbolTableWriter' --- needs to be extended, which is why we thread the 'tbl' parameter through the --- lookup or insertion operations. -data SymbolTableWriter tbl = MkSymbolTableWriter - { writerTable :: !tbl - -- ^ Symbol table for symbols we replace with unique identifiers. - , lookupOrInsertText :: tbl -> Text -> (StringId, Bool, tbl) - -- ^ Lookup up the given 'Text' in the 'tbl' Symbol table. - -- If the 'Text' can't be found, we insert it into the table and generate a - -- new 'StringId. - -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise. - , lookupOrInsertSourceLocation :: tbl -> SourceLocation -> (SourceLocationId, Bool, tbl) - -- ^ Lookup up the given 'SourceLocation' in the 'tbl' Symbol table. - -- If the 'SourceLocation' can't be found, we insert it into the table and generate a - -- new 'SourceLocationId. - -- Returns 'True', if the given 'Text' was inserted and 'False' otherwise. - } - deriving (Generic) - --- | Implementation agnostic symbol table reader helping consumers to decode --- 'BinaryEventlogMessage's into a 'CallStackMessage'. --- --- As during deserialisation, we do not discover new Messages, the abstract 'SymbolTableReader' --- doesn't need to thread the implementation through the lookup operations. -data SymbolTableReader = MkSymbolTableReader - { lookupStringId :: StringId -> Maybe Text - -- ^ Lookup the 'StringId' in the symbol table. - -- This operation throws an exception if the 'StringId' is unknown. - , lookupSourceLocationId :: SourceLocationId -> Maybe SourceLocation - -- ^ Lookup the 'SourceLocationId' in the symbol table. - -- This operation throws an exception if the 'SourceLocationId' is unknown. - } - deriving (Generic) - --- ---------------------------------------------------------------------------- --- Implementation backend for 'SymbolTableWriter' --- ---------------------------------------------------------------------------- - -data MapTable = MkMapTable - { stringTable :: !(Map Text StringId) - , srcLocTable :: !(Map SourceLocation SourceLocationId) - , stringUniqueSupply :: {-# UNPACK #-} !StringId - , srcLocUniqueSupply :: {-# UNPACK #-} !SourceLocationId - } - deriving (Show, Eq, Ord, Generic) - -{-# INLINEABLE emptyMapSymbolTableWriter #-} -emptyMapSymbolTableWriter :: SymbolTableWriter MapTable -emptyMapSymbolTableWriter = - MkSymbolTableWriter - { writerTable = - MkMapTable - { stringTable = Map.empty - , srcLocTable = Map.empty - , stringUniqueSupply = MkStringId 0 - , srcLocUniqueSupply = MkSourceLocationId 0 - } - , lookupOrInsertText = alterStringMap - , lookupOrInsertSourceLocation = alterSrcLocTable - } - where - nextSrcLocUnique tbl = - ( srcLocUniqueSupply tbl - , tbl - { srcLocUniqueSupply = - incrementSourceLocationId $ srcLocUniqueSupply tbl - } - ) - - nextStringUnique tbl = - ( stringUniqueSupply tbl - , tbl - { stringUniqueSupply = - incrementStringLocationId $ stringUniqueSupply tbl - } - ) - - updateEntry tbl0 nextKey Nothing = - let - (sid, tbl) = nextKey tbl0 - in - ((sid, True, tbl), Just sid) - updateEntry tbl _ (Just val) = - ((val, False, tbl), Just val) - - swapAround set ((sid, new, tbl), hm) = - (sid, new, set tbl hm) - - alterStringMap = \tbl str -> - swapAround setStringTable $ - Map.alterF (updateEntry tbl nextStringUnique) str (stringTable tbl) - - alterSrcLocTable = \tbl srcLoc -> - swapAround setSourceLocationTable $ - Map.alterF (updateEntry tbl nextSrcLocUnique) srcLoc (srcLocTable tbl) - -setSourceLocationTable :: MapTable -> Map SourceLocation SourceLocationId -> MapTable -setSourceLocationTable tbl hm = - tbl - { srcLocTable = hm - } - -setStringTable :: MapTable -> Map Text StringId -> MapTable -setStringTable tbl hm = - tbl - { stringTable = hm - } - -getKnownStrings :: MapTable -> [(StringId, Text)] -{-# INLINEABLE getKnownStrings #-} -getKnownStrings table = - List.map Tuple.swap $ Map.assocs (stringTable table) - -getKnownSourceLocations :: MapTable -> [(SourceLocationId, SourceLocation)] -{-# INLINEABLE getKnownSourceLocations #-} -getKnownSourceLocations table = - List.map Tuple.swap $ Map.assocs (srcLocTable table) - --- ---------------------------------------------------------------------------- --- Implementation backend for 'SymbolTableReader' --- ---------------------------------------------------------------------------- - -data MissingKeyError - = -- | We failed to find the 'StringId' to fully decode the 'SourceLocationId'. - KeyStringIdNotFound SourceLocationId StringId - deriving (Show) - -instance Exception MissingKeyError where - displayException = \case - KeyStringIdNotFound srcLocId stringId -> - "While decoding the Source Location (" - ++ show (getSourceLocationId srcLocId) - ++ "), " - ++ "the String (" - ++ show (getStringId stringId) - ++ ") couldn't be found" - -data IntMapTable = MkIntMapTable - { stringLookupTable :: !(IntMap Text) - , srcLocLookupTable :: !(IntMap SourceLocation) - } - deriving (Eq, Ord, Show, Generic) - -emptyIntMapTable :: IntMapTable -emptyIntMapTable = - MkIntMapTable - { stringLookupTable = IntMap.empty - , srcLocLookupTable = IntMap.empty - } - -mkIntMapSymbolTableReader :: IntMapTable -> SymbolTableReader -mkIntMapSymbolTableReader tbl = - MkSymbolTableReader - { lookupStringId = flip lookupTextMessage tbl - , lookupSourceLocationId = flip lookupSourceLocationMessage tbl - } - -{-# INLINEABLE insertTextMessage #-} -insertTextMessage :: BinaryStringMessage -> IntMapTable -> IntMapTable -insertTextMessage msg tbl = - tbl - { stringLookupTable = - IntMap.insert - (idToInt $ binaryStringMessageId msg) - (binaryStringMessage msg) - (stringLookupTable tbl) - } - -{-# INLINEABLE insertSourceLocationMessage #-} -insertSourceLocationMessage :: BinarySourceLocationMessage -> IntMapTable -> Either MissingKeyError IntMapTable -insertSourceLocationMessage msg tbl = do - let - srcLocId = binarySourceLocationMessageId msg - fileId = binarySourceLocationFilename msg - - fileName <- - maybe (Left $ KeyStringIdNotFound srcLocId fileId) Right $ lookupTextMessage fileId tbl - - pure - tbl - { srcLocLookupTable = - IntMap.insert - (idToInt srcLocId) - (mkSourceLocation fileName) - (srcLocLookupTable tbl) - } - where - mkSourceLocation fileName = - MkSourceLocation - { line = binarySourceLocationRow msg - , column = binarySourceLocationColumn msg - , fileName = fileName - } - -{-# INLINEABLE lookupTextMessage #-} -lookupTextMessage :: StringId -> IntMapTable -> Maybe Text -lookupTextMessage sid tbl = IntMap.lookup (idToInt sid) (stringLookupTable tbl) - -{-# INLINEABLE lookupSourceLocationMessage #-} -lookupSourceLocationMessage :: SourceLocationId -> IntMapTable -> Maybe SourceLocation -lookupSourceLocationMessage sid tbl = IntMap.lookup (idToInt sid) (srcLocLookupTable tbl) diff --git a/src/GHC/Stack/Profiler/Core/ThreadSample.hs b/src/GHC/Stack/Profiler/Core/ThreadSample.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Core/ThreadSample.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module GHC.Stack.Profiler.Core.ThreadSample ( - -- * High-level API - ThreadSample (..), - deserializeEventlogMessage, - - -- * Serialisable 'ThreadSample' - CallStackMessage (..), - StackItem (..), - SourceLocation (..), - - -- * Serialisation of 'CallStackMessage' - SymbolTableWriter (..), - SymbolTableReader (..), - dehydrateCallStackMessage, - BinaryCallStackDecodeError (..), - hydrateEventlogCallStackMessage, - catCallStackMessage, - chunkCallStackMessage, - chunkCallStackMessage_, - - -- * Message dehydration helpers - EncodingState, - runWithEncodingState, - newEncodingState, - lookupSourceLocationMessage, - lookupTextMessage, -) where - -import Control.Concurrent -import Control.Exception (Exception (..)) -import Control.Monad (when) -import Control.Monad.Trans.State.Strict (State, runState) -import qualified Control.Monad.Trans.State.Strict as State -import Data.Binary -import Data.Binary.Get -import qualified Data.ByteString.Lazy as LBS -import Data.Either (partitionEithers) -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Generics - -import GHC.Stack.CloneStack (StackSnapshot) -import GHC.Stack.Profiler.Core.Eventlog -import GHC.Stack.Profiler.Core.SourceLocation -import GHC.Stack.Profiler.Core.SymbolTable -import GHC.Stack.Profiler.Core.Util (word16ToInt) - --- ---------------------------------------------------------------------------- --- Thread Sample --- ---------------------------------------------------------------------------- - --- | A 'ThreadSample' is a snapshot of a threads RTS callstack. --- This callstack is a copy of the original callstack, so can be traversed and --- decoded without affecting the running thread. --- --- The 'StackSnapshot' is a boxed value and needs to be garbage collected. --- Note, as long as 'StackSnapshot' is alive, you keep the full callstack --- alive, which might be quite expensive. -data ThreadSample = ThreadSample - { threadSampleId :: !ThreadId - , threadSampleCapability :: !CapabilityId - , threadSampleStackSnapshot :: !StackSnapshot - } - deriving (Generic) - -deserializeEventlogMessage :: LBS.ByteString -> Either String BinaryEventlogMessage -deserializeEventlogMessage msg = case runGetOrFail get msg of - Left (_, _, errMsg) -> Left errMsg - Right (_, _, callStackMessage) -> Right callStackMessage - --- ---------------------------------------------------------------------------- --- Decoded RTS CallStack --- ---------------------------------------------------------------------------- - --- | A decoded rts callstack that can be serialised to the EventLog. -data CallStackMessage = MkCallStackMessage - { callThreadId :: !Word64 - , callCapabilityId :: !CapabilityId - , callStack :: [StackItem] - } - deriving (Eq, Ord, Show, Generic) - -data StackItem - = IpeId !IpeId - | UserAnnotation !String !(Maybe SourceLocation) - deriving (Eq, Ord, Show, Generic) - --- ---------------------------------------------------------------------------- --- Turning a 'CallStackMessage' into '[BinaryEventlogMessage]' --- ---------------------------------------------------------------------------- - --- | Generic implementation to turn 'CallStackMessage' into '[BinaryEventlogMessage]'. --- --- Replaces already encountered text or source location information with unique ids. --- If new text or source location messages are encountered, they are inserted into --- the 'SymbolTableWriter'. --- --- All new string values and source location messages are before 'CallStackChunk' and --- 'CallStackFinal' messages. --- For the result list @r :: ['BinaryEventlogMessage']@, the following holds: --- --- * 'StringDef' messages are the first elements in @r@. There might not be any. --- * 'SourceLocationDef' are after 'StringDef' messages and before any 'CallStackChunk' or --- 'CallStackFinal' messages. There might not be any such messages. --- * Then 'CallStackChunk' follow if there are any. --- * The last message is always a 'CallStackFinal' message and it occurs exactly once in @r@. -dehydrateCallStackMessage :: - forall table. - SymbolTableWriter table -> - CallStackMessage -> - ([BinaryEventlogMessage], SymbolTableWriter table) -dehydrateCallStackMessage msgTbl0 msg = - let - (stackItems, finalState) = - runWithEncodingState - (newEncodingState msgTbl0) - (mapM go (callStack msg)) - - stringDefs = - map StringDef $ stringMessages finalState - - sourceLocDefs = - map SourceLocationDef $ sourceLocMessages finalState - - -- TODO: this needs to be fixed - stackMsgChunks = - chunkCallStackMessage - MkBinaryCallStackMessage - { binaryCallThreadId = callThreadId msg - , binaryCallCapabilityId = callCapabilityId msg - , binaryCallStack = stackItems - } - in - ( stringDefs ++ sourceLocDefs ++ stackMsgChunks - , symbolTableWriter finalState - ) - where - go :: StackItem -> State (EncodingState tbl) BinaryStackItem - go = \case - IpeId ipeId -> - pure $ BinaryIpe ipeId - UserAnnotation s mSrcLoc -> do - srcLocId <- case mSrcLoc of - Nothing -> pure Nothing - Just srcLoc -> Just <$> lookupSourceLocationMessage srcLoc - BinaryMessage <$> lookupTextMessage (Text.pack s) <*> pure srcLocId - -data BinaryCallStackDecodeError - = StringIdNotFound StringId - | SourceLocationIdNotFound SourceLocationId - deriving (Show) - -instance Exception BinaryCallStackDecodeError where - displayException = \case - StringIdNotFound sid -> - "Failed to decode a BinaryCallStackMessage. Failed to find a String with the key: " ++ show (getStringId sid) - SourceLocationIdNotFound sid -> - "Failed to decode a BinaryCallStackMessage. Failed to find a SourceLocation with the key: " ++ show (getSourceLocationId sid) - --- | Generic implementation to turn 'BinaryCallStackMessage' into the much richer --- 'CallStackMessage'. -hydrateEventlogCallStackMessage :: SymbolTableReader -> BinaryCallStackMessage -> (CallStackMessage, [BinaryCallStackDecodeError]) -hydrateEventlogCallStackMessage decodeTable msg = - let - decodeItem :: BinaryStackItem -> Either BinaryCallStackDecodeError StackItem - decodeItem = \case - BinaryIpe ipeId -> - Right $ IpeId ipeId - BinaryMessage stringId mSrcLocId -> do - str <- - maybe - (Left $ StringIdNotFound stringId) - (Right . Text.unpack) - (lookupStringId decodeTable stringId) - srcLoc <- case mSrcLocId of - Nothing -> pure Nothing - Just srcLocId -> - maybe - (Left $ SourceLocationIdNotFound srcLocId) - (Right . Just) - (lookupSourceLocationId decodeTable srcLocId) - pure $ UserAnnotation str srcLoc - - itemsOrErros = map decodeItem (binaryCallStack msg) - (errors, items) = partitionEithers itemsOrErros - in - ( MkCallStackMessage - { callCapabilityId = binaryCallCapabilityId msg - , callThreadId = binaryCallThreadId msg - , callStack = items - } - , errors - ) - --- | Combine all 'BinaryCallStackMessage's into a single 'BinaryCallStackMessage'. --- We assume that all 'BinaryCallStackMessage' only differ in their 'binaryCallStack' values. --- --- 'catCallStackMessage' is the conceptually inverse of 'chunkCallStackMessage'. -catCallStackMessage :: NonEmpty BinaryCallStackMessage -> BinaryCallStackMessage -catCallStackMessage msgs = - MkBinaryCallStackMessage - { binaryCallThreadId = binaryCallThreadId $ NonEmpty.head msgs - , binaryCallCapabilityId = binaryCallCapabilityId $ NonEmpty.head msgs - , binaryCallStack = concatMap (reverse . binaryCallStack) . reverse $ NonEmpty.toList msgs - } - --- | Chunk the 'binaryCallStack' of the 'BinaryCallStackMessage' by the given 'Word16'. --- If there are no items in 'BinaryCallStackMessage', then a singleton list is returned containing --- the original element. --- --- Post-condition for the result @r@: --- --- * all elements in @init r @ are 'CallStackChunk's --- * the element returned by @last r@ is a 'CallStackFinal' BinaryEventlogMessage. --- --- The resulting 'CallStackChunk' are in reverse order and so are the chunks themselves. --- --- This means, for a stack @[1,2,3,4,5,6]@ and an assumed chunk size of 2, --- we produce @[[6,5],[4,3],[2,1]]@. -chunkCallStackMessage :: BinaryCallStackMessage -> [BinaryEventlogMessage] -chunkCallStackMessage = chunkCallStackMessage_ callStackSizeLimit - --- | Same as 'chunkCallStackMessage', but allows to set the chunking size in bytes. -chunkCallStackMessage_ :: Word16 -> BinaryCallStackMessage -> [BinaryEventlogMessage] -chunkCallStackMessage_ chunkLimit16 msg0 = - let - chunkLimitInt = word16ToInt chunkLimit16 - items = binaryCallStack msg0 - chunked = - let - go (!size, curChunk, restChunk) item = - let - !bytes = word16ToInt $ byteSizeOf item - in - if (size + bytes) < chunkLimitInt - then (size + bytes, item : curChunk, restChunk) - else (bytes, [item], curChunk : restChunk) - (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items - in - lastChunk : initChunk - in - mkEventlogMessages chunked - where - mkCallStack chunk = - MkBinaryCallStackMessage - { binaryCallThreadId = binaryCallThreadId msg0 - , binaryCallCapabilityId = binaryCallCapabilityId msg0 - , binaryCallStack = chunk - } - - mkEventlogMessages :: [[BinaryStackItem]] -> [BinaryEventlogMessage] - mkEventlogMessages [] = - -- If there are no chunks, we simply return the original message - [ CallStackFinal msg0 - ] - mkEventlogMessages [chunk] = - [ CallStackFinal $ mkCallStack chunk - ] - mkEventlogMessages (chunk : chunks) = - CallStackChunk (mkCallStack chunk) : mkEventlogMessages chunks - --- ---------------------------------------------------------------------------- --- Helper types and functions to implement the conversion to the binary --- representation. --- ---------------------------------------------------------------------------- - -data EncodingState tbl = MkEncodingState - { symbolTableWriter :: !(SymbolTableWriter tbl) - , stringMessages :: ![BinaryStringMessage] - , sourceLocMessages :: ![BinarySourceLocationMessage] - } - deriving (Generic) - -runWithEncodingState :: EncodingState tbl -> State (EncodingState tbl) a -> (a, EncodingState tbl) -runWithEncodingState encodingState encoder = - runState encoder encodingState - -newEncodingState :: SymbolTableWriter tbl -> EncodingState tbl -newEncodingState msgTbl0 = - MkEncodingState - { symbolTableWriter = msgTbl0 - , stringMessages = [] - , sourceLocMessages = [] - } - -setSymbolTableWriter :: tbl -> State.State (EncodingState tbl) () -setSymbolTableWriter tbl = State.modify' (\st -> st{symbolTableWriter = (symbolTableWriter st){writerTable = tbl}}) - -addStringMessage :: BinaryStringMessage -> State.State (EncodingState tbl) () -addStringMessage msg = State.modify' (\st -> st{stringMessages = msg : stringMessages st}) - -addSourceLocationMessage :: BinarySourceLocationMessage -> State.State (EncodingState tbl) () -addSourceLocationMessage msg = State.modify' (\st -> st{sourceLocMessages = msg : sourceLocMessages st}) - -lookupOrInsertTextMessage :: forall tbl. Text -> State (EncodingState tbl) (StringId, Bool) -lookupOrInsertTextMessage s = do - tbl <- State.gets symbolTableWriter - let - (sid, new, tbl1) = lookupOrInsertText tbl (writerTable tbl) s - setSymbolTableWriter tbl1 - pure (sid, new) - -lookupOrInsertSrcLocMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool) -lookupOrInsertSrcLocMessage s = do - tbl <- State.gets symbolTableWriter - let - (sid, new, tbl1) = lookupOrInsertSourceLocation tbl (writerTable tbl) s - setSymbolTableWriter tbl1 - pure (sid, new) - -lookupTextMessage :: forall tbl. Text -> State (EncodingState tbl) StringId -lookupTextMessage s = do - (sid, new) <- lookupOrInsertTextMessage s - when new $ - addStringMessage $ - MkBinaryStringMessage sid s - pure sid - -lookupSourceLocationMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) SourceLocationId -lookupSourceLocationMessage s = do - (sid, new) <- lookupOrInsertSrcLocMessage s - when new $ do - fileId <- lookupTextMessage $ fileName s - addSourceLocationMessage $ - MkBinarySourceLocationMessage - { binarySourceLocationMessageId = sid - , binarySourceLocationRow = line s - , binarySourceLocationColumn = column s - , binarySourceLocationFilename = fileId - } - pure sid diff --git a/src/GHC/Stack/Profiler/Core/Util.hs b/src/GHC/Stack/Profiler/Core/Util.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Core/Util.hs +++ /dev/null @@ -1,104 +0,0 @@ -module GHC.Stack.Profiler.Core.Util ( - idToInt, - putTextWord16, - getTextWord16, - showAsHex, - putWord64, - putWord32, - putWord16, - getWord64, - getWord32, - getWord16, - word64ToWord32, - word32ToWord64, - word64ToWord16, - word32ToInt, - word64ToInt, - intToWord64, - intToWord32, - intToWord16, - word16ToInt, - intToWord8, - word8ToInt, -) where - -import Control.Monad (replicateM) -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import Data.Coerce (Coercible, coerce) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Numeric - -idToInt :: (Coercible a Word64) => a -> Int -idToInt = word64ToInt . coerce - -putTextWord16 :: Word16 -> Text -> Put -putTextWord16 bound msg = - putWord16 len <> putStringUtf8 (Text.unpack msg) - where - shortName = Text.take (word16ToInt bound) msg - -- this is safe as 'bound' is a 'Word16' itself - -- so the short string can be at most have a length of 'Word16' - len = intToWord16 $ Text.length shortName - -getTextWord16 :: Get Text -getTextWord16 = do - len <- getWord16 - s <- replicateM (word16ToInt len) get - pure $ Text.pack s - -showAsHex :: (Integral a) => a -> String -showAsHex d = "0x" ++ Numeric.showHex d "" - -putWord64 :: Word64 -> Put -putWord64 = putWord64be - -putWord32 :: Word32 -> Put -putWord32 = putWord32be - -putWord16 :: Word16 -> Put -putWord16 = putWord16be - -getWord64 :: Get Word64 -getWord64 = getWord64be - -getWord32 :: Get Word32 -getWord32 = getWord32be - -getWord16 :: Get Word16 -getWord16 = getWord16be - -word64ToWord32 :: Word64 -> Word32 -word64ToWord32 = fromIntegral - -word32ToWord64 :: Word32 -> Word64 -word32ToWord64 = fromIntegral - -word64ToWord16 :: Word64 -> Word16 -word64ToWord16 = fromIntegral - -word32ToInt :: Word32 -> Int -word32ToInt = fromIntegral - -word64ToInt :: Word64 -> Int -word64ToInt = fromIntegral - -intToWord64 :: Int -> Word64 -intToWord64 = fromIntegral - -intToWord32 :: Int -> Word32 -intToWord32 = fromIntegral - -intToWord16 :: Int -> Word16 -intToWord16 = fromIntegral - -word16ToInt :: Word16 -> Int -word16ToInt = fromIntegral - -intToWord8 :: Int -> Word8 -intToWord8 = fromIntegral - -word8ToInt :: Word8 -> Int -word8ToInt = fromIntegral diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,115 +1,276 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main where -import Data.Binary -import Data.Binary.Put -import qualified Data.ByteString.Lazy as LBS +import Data.Binary (Binary, Word16, Word32, decode, encode) +import qualified Data.ByteString.Lazy as BSL import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe -import GHC.Stack.Profiler.Core.Eventlog -import GHC.Stack.Profiler.Core.ThreadSample -import GHC.Stack.Profiler.Core.Util (word32ToWord64) +import Data.Maybe (mapMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Foreign as TF +import GHC.Stack.Profiler.Core +import GHC.Stack.Profiler.Core.Internal import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options (IsOption (..)) import Test.Tasty.QuickCheck +import Text.Printf (printf) main :: IO () -main = defaultMain tests +main = + defaultMain $ + adjustOption increaseDefaultMaxSize $ + testGroup "Tests" $ + [ testGroup "Size" $ + [ test_encodeSize "MessageTag" (Proxy @MessageTag) messageTagSize + , test_encodeSize "CallStackFrameTag" (Proxy @CallStackFrameTag) callStackFrameTagSize + , prop_encodeSizeInv "IpeId" (Proxy @IpeId) (== ipeIdSize) + , prop_encodeSizeInv "ThreadId" (Proxy @ThreadId) (== threadIdSize) + , prop_encodeSizeInv "CapabilityId" (Proxy @CapabilityId) (== capabilityIdSize) + , prop_encodeSizeInv "CallStackFrame" (Proxy @CallStackFrame) (<= callStackFrameMaxSize) + , prop_chunkCallStackSizeInv + , let + gen = + -- Generate a callStack, divide it into chunks, then pick one of the messages. + elements . chunkCallStack =<< arbitrary + in + prop_encodeSizeInv' "CallStackChunk/CallStackFinal" gen show Nothing (<= messageMaxSize) + , prop_encodeSizeInv "StringId" (Proxy @StringId) (== stringIdSize) + , let + gen = + StringDef <$> arbitrary + showFor msg@(StringDef MkStringDef{stringDefId, stringDefBody}) = + printf + "stringDefId == %d && length stringDefBody == %d && %s" + (getStringId stringDefId) + (T.length stringDefBody) + (labelFor msg) + labelFor (StringDef MkStringDef{stringDefBody}) = + if fromIntegral (T.length stringDefBody) > stringDefBodyMaxSize + then "length stringDefBody > stringDefBodyMaxSize" + else "length stringDefBody <= stringDefBodyMaxSize" + in + prop_encodeSizeInv' "StringDef" gen showFor (Just labelFor) (<= messageMaxSize) + , prop_encodeSizeInv "SourceLocationId" (Proxy @SourceLocationId) (== sourceLocationIdSize) + , prop_encodeSizeInv "SourceLocationDef" (Proxy @SourceLocationDef) (== sourceLocationDefSize) + , prop_encodeSizeInv "ShortText" (Proxy @ShortText) (<= maxBoundWord16 + 2) + , prop_truncateTextToByteLimit + ] + , testGroup "Encode/Decode" $ + [ test_encodeDecode "MessageTag" (Proxy @MessageTag) + , test_encodeDecode "CallStackFrameTag" (Proxy @CallStackFrameTag) + , prop_encodeDecode "IpeId" (Proxy @IpeId) + , prop_encodeDecode "ThreadId" (Proxy @ThreadId) + , prop_encodeDecode "CapabilityId" (Proxy @CapabilityId) + , prop_encodeDecode "CallStackFrame" (Proxy @CallStackFrame) + , prop_chunkAndJoinCallStack + , let + to :: CallStackChunk -> [Message] + to = chunkCallStack + from :: [Message] -> CallStackChunk + from = joinCallStackChunks . NonEmpty.fromList . mapMaybe getCallStackFrame + in + prop_encodeDecodeVia' "CallStackChunk/CallStackFinal" arbitrary show Nothing to from + , prop_encodeDecode "StringId" (Proxy @StringId) + , let + -- The roundtrip property only holds if the byte length of stringDefBody + -- is less than stringDefBodyMaxSize, otherwise it's truncated. + gen = do + MkStringDef{stringDefId, stringDefBody} <- arbitrary + let + stringDefBody' = truncateTextToByteLimit stringDefBodyMaxSize stringDefBody + pure $ StringDef MkStringDef{stringDefId, stringDefBody = stringDefBody'} + in + prop_encodeDecode' "StringDef" gen show Nothing + , prop_encodeDecode "SourceLocationId" (Proxy @SourceLocationId) + , prop_encodeDecode "SourceLocationDef" (Proxy @SourceLocationDef) + , prop_encodeDecode "ShortText" (Proxy @ShortText) + ] + ] + where + increaseDefaultMaxSize :: QuickCheckMaxSize -> QuickCheckMaxSize + increaseDefaultMaxSize v@(QuickCheckMaxSize _) = + if v /= defaultValue then v else QuickCheckMaxSize (2 * maxBoundWord16) -tests :: TestTree -tests = - testGroup - "tests" - [ properties +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Tests - Size Invariants + +-- | Test a size invariant on the result of `encode` using `Enum`. +test_encodeSize :: (Binary a, Bounded a, Enum a, Eq a, Show a) => TestName -> Proxy a -> Int -> TestTree +test_encodeSize testName (_pa :: Proxy a) size = + testGroup testName $ + [ testCase (printf "length (encode %s) == %d" (show a) size) $ do + fromIntegral (BSL.length (encode a)) @?= size + | (a :: a) <- [minBound .. maxBound] ] -properties :: TestTree -properties = - testGroup - "property" - [ testProperty "chunkCallStackMessage . catCallStackMessage" $ - withNumTests 500 $ - withMaxSize (fromIntegral callStackSizeLimit * 3) $ - chunkingRoundTrip_prop callStackSizeLimit - , testProperty "chunkCallStackMessage size < chunkCallStackMessage" $ - withNumTests 500 $ do - withMaxSize (fromIntegral callStackSizeLimit * 3) $ - messageChunkSize_prop eventlogBufferSize callStackSizeLimit - , testProperty "chunkCallStackMessage_ n . catCallStackMessage" $ - withNumTests 500 $ - withEventlogSizeGen $ \eventlogSize -> - withMaxSize (fromIntegral eventlogSize * 20) $ - chunkingRoundTrip_prop (callStackSizeLimit_ eventlogSize) - , testProperty "chunkCallStackMessage_ n < size" $ - withNumTests 500 $ do - withEventlogSizeGen $ \eventlogSize -> - withMaxSize (fromIntegral eventlogSize * 5) $ - messageChunkSize_prop eventlogSize (callStackSizeLimit_ eventlogSize) +-- | Test a size invariant on the result of `encode` using QuickCheck. +prop_encodeSizeInv :: (Arbitrary a, Binary a, Eq a, Show a) => TestName -> Proxy a -> (Int -> Bool) -> TestTree +prop_encodeSizeInv testName (_pa :: Proxy a) sizeInv = + testProperty testName $ \(a :: a) -> + sizeInv (fromIntegral (BSL.length (encode a))) + +-- | Variant of `prop_encodeSizeInv` that accepts a custom generator, show function, and label function. +prop_encodeSizeInv' :: (Binary a, Eq a) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> (Int -> Bool) -> TestTree +prop_encodeSizeInv' testName gen showFor maybeLabelFor sizeInv = + testProperty testName $ + forAllShow gen showFor $ \a -> + maybe property (label . ($ a)) maybeLabelFor $ + sizeInv (fromIntegral (BSL.length (encode a))) + +-------------------------------------------------------------------------------- +-- Tests - Encode/Decode Roundtrips + +-- | Test that an `encode`/`decode` roundtrip using a `Binary` instance is the identity using `Enum`. +test_encodeDecode :: (Binary a, Bounded a, Enum a, Eq a, Show a) => TestName -> Proxy a -> TestTree +test_encodeDecode testName (_pa :: Proxy a) = + testGroup testName $ + [ testCase (printf "decode (encode %s) == %s" (show a) (show a)) $ do + decode (encode a) @?= a + | (a :: a) <- [minBound .. maxBound] ] + +-- | Test that an `encode`/`decode` roundtrip using a `Binary` instance is the identity using QuickCheck. +prop_encodeDecode :: (Arbitrary a, Binary a, Eq a, Show a) => TestName -> Proxy a -> TestTree +prop_encodeDecode testName (_pa :: Proxy a) = + testProperty testName $ \(a :: a) -> + decode (encode a) == a + +-- | Variant of `prop_encodeDecode` that accepts a custom generator, show function, and label function. +prop_encodeDecode' :: (Binary a, Eq a) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> TestTree +prop_encodeDecode' testName gen showFor maybeLabelFor = + prop_encodeDecodeVia' testName gen showFor maybeLabelFor id id + +-- | Variant of `prop_encodeDecode` that accepts conversions to/from a type with a `Binary` instance. +prop_encodeDecodeVia :: (Arbitrary a, Eq a, Show a, Binary b) => TestName -> (a -> b) -> (b -> a) -> TestTree +prop_encodeDecodeVia testName to from = + prop_encodeDecodeVia' testName arbitrary show Nothing to from + +-- | Variant of `prop_encodeDecodeVia'` that accepts conversions to/from a type with a `Binary` instance. +prop_encodeDecodeVia' :: (Eq a, Binary b) => TestName -> Gen a -> (a -> String) -> Maybe (a -> String) -> (a -> b) -> (b -> a) -> TestTree +prop_encodeDecodeVia' testName gen showFor maybeLabelFor to from = + testProperty testName $ + forAllShow gen showFor $ \a -> + maybe property (label . ($ a)) maybeLabelFor $ + from (decode (encode (to a))) == a + +-------------------------------------------------------------------------------- +-- Tests - Auxilliary + +-- | Test that `chunkCallStack_` works as advertised. +prop_chunkCallStackSizeInv :: TestTree +prop_chunkCallStackSizeInv = + testProperty "length (encode message) <= messageMaxSize | message <- chunkCallStack callStack" $ \callStack -> + forAll (choose (messageMinSize, 2 * messageMaxSize)) $ \messageMaxSize' -> + conjoin + [ BSL.length (encode message) <= fromIntegral messageMaxSize' + | message <- chunkCallStack_ (callStackMaxLen' messageMaxSize') callStack + ] + +-- | Test that `chunkCallStack_` and `joinCallStackChunks` are inverses. +prop_chunkAndJoinCallStack :: TestTree +prop_chunkAndJoinCallStack = + testProperty "joinCallStackChunks (chunkCallStack_ n callStack) == callStack" $ + \(Positive n) callStack -> + case NonEmpty.nonEmpty (mapMaybe getCallStackFrame (chunkCallStack_ n callStack)) of + Nothing -> True + Just callStackChunks -> joinCallStackChunks callStackChunks == callStack + +-- | Test that `truncateTextToByteLimit` works as advertised. +prop_truncateTextToByteLimit :: TestTree +prop_truncateTextToByteLimit = + testProperty "lengthWord8 (truncateTextToByteLimit byteLimit text) <= byteLimit" $ + \(NonNegative byteLimit) (UnicodeString (T.pack -> text)) -> + label (labelFor byteLimit text) $ + let + text' = truncateTextToByteLimit byteLimit text + in + if TF.lengthWord8 text <= byteLimit + then + -- If the original text fit within the byteLimit, the text should be unchanged. + text == text' + else + -- Otherwise: + and + [ -- 1. The new text length should be within 3 byte of the byteLimit. + byteLimit - 3 <= TF.lengthWord8 text' && TF.lengthWord8 text' <= byteLimit + , -- 2. The new text should be a prefix of the old text. + text' `T.isPrefixOf` text + ] where - chunkingRoundTrip_prop stackSizeLimit message = - let - msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message) - go = \case - CallStackChunk csm -> Just csm - CallStackFinal csm -> Just csm - _ -> Nothing - in - catCallStackMessage (NonEmpty.fromList msgs) === message + labelFor :: Int -> Text -> String + labelFor byteLimit text + | TF.lengthWord8 text <= byteLimit = "lengthWord8 text <= byteLimit" + | otherwise = "lengthWord8 text > byteLimit" - messageChunkSize_prop eventlogSize stackSizeLimit message = - let - msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message) - go = \case - CallStackChunk csm -> Just csm - CallStackFinal csm -> Just csm - _ -> Nothing - in - conjoin $ - map (eventlogMessageSmallerThanStackSizeLimit_prop (fromIntegral eventlogSize)) msgs +-------------------------------------------------------------------------------- +-- Helpers - eventlogMessageSmallerThanStackSizeLimit_prop :: Word -> BinaryCallStackMessage -> Property - eventlogMessageSmallerThanStackSizeLimit_prop eventlogLimit chunk = - let - -- We need either 'CallStackFinal' or 'CallStackChunk' to add the leading '0xFFCA' or '0xFFCB'. - -- This way, the eventlogLimit length is the correct thing to check. - msg = runPut (put $ CallStackFinal chunk) - in - (LBS.length msg <= fromIntegral eventlogLimit) === True +-- | Get the `CallStackChunk` from a `Message`. +getCallStackFrame :: Message -> Maybe CallStackChunk +getCallStackFrame = \case + CallStackFinal callStackChunk -> Just callStackChunk + CallStackChunk callStackChunk -> Just callStackChunk + _otherwise -> Nothing -withEventlogSizeGen :: (Word64 -> Property) -> Property -withEventlogSizeGen k = - -- 29 bytes is minimum possible eventlog size. - -- 12 bytes need to be subtracted for message overhead. - -- The largest stack item is 17 bytes. - forAll (choose (29, 1000)) k +maxBoundWord16 :: Int +maxBoundWord16 = fromIntegral (maxBound @Word16) -instance Arbitrary BinaryCallStackMessage where - arbitrary = - MkBinaryCallStackMessage - <$> (word32ToWord64 <$> arbitrary) - <*> arbitrary - <*> arbitrary +-------------------------------------------------------------------------------- +-- Generators +instance Arbitrary IpeId where + arbitrary :: Gen IpeId + arbitrary = MkIpeId <$> arbitrary + +instance Arbitrary ThreadId where + arbitrary :: Gen ThreadId + arbitrary = MkThreadId . fromIntegral <$> arbitrary @Word32 + instance Arbitrary CapabilityId where - arbitrary = - MkCapabilityId <$> word32ToWord64 <$> arbitrary + arbitrary :: Gen CapabilityId + arbitrary = MkCapabilityId . fromIntegral <$> arbitrary @Word32 -instance Arbitrary BinaryStackItem where +instance Arbitrary CallStackFrame where + arbitrary :: Gen CallStackFrame arbitrary = oneof - [ BinaryIpe <$> arbitrary - , BinaryMessage <$> arbitrary <*> arbitrary + [ CallStackFrameIpe <$> arbitrary + , CallStackFrameAnn <$> arbitrary <*> arbitrary ] -instance Arbitrary IpeId where - arbitrary = - MkIpeId <$> arbitrary +instance Arbitrary CallStackChunk where + arbitrary :: Gen CallStackChunk + arbitrary = MkCallStackChunk <$> arbitrary <*> arbitrary <*> (NonEmpty.toList <$> arbitrary) instance Arbitrary StringId where - arbitrary = - MkStringId <$> arbitrary + arbitrary :: Gen StringId + arbitrary = MkStringId <$> arbitrary +instance Arbitrary StringDef where + arbitrary :: Gen StringDef + arbitrary = MkStringDef <$> arbitrary <*> arbitraryUnicodeText + instance Arbitrary SourceLocationId where - arbitrary = - MkSourceLocationId <$> arbitrary + arbitrary :: Gen SourceLocationId + arbitrary = MkSourceLocationId <$> arbitrary + +instance Arbitrary SourceLocationDef where + arbitrary :: Gen SourceLocationDef + arbitrary = MkSourceLocationDef <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ShortText where + arbitrary :: Gen ShortText + arbitrary = toShortText <$> arbitraryUnicodeText + +arbitraryUnicodeText :: Gen Text +arbitraryUnicodeText = T.pack . getUnicodeString <$> arbitrary