diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for ghc-stack-profiler-core +## 0.2.0.0 -- 2026-04-10 + +* Add support for eventlog-socket lifecycle hooks [#19](https://github.com/well-typed/ghc-stack-profiler/pull/19) +* Never crash on decoding errors [#12](https://github.com/well-typed/ghc-stack-profiler/pull/12) + ## 0.1.0.0 -- 2025-12-09 * Add types for encoding RTS callstacks to bytes that can be sent to the eventlog. 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,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler-core -version: 0.1.0.0 +version: 0.2.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com @@ -12,7 +12,10 @@ extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development -tested-with: ghc ==9.14 || ==9.12 || ==9.10 +tested-with: + ghc ==9.10.3 + ghc ==9.12.2 + ghc ==9.14.1 common warnings ghc-options: @@ -26,6 +29,7 @@ DuplicateRecordFields LambdaCase NamedFieldPuns + NoImportQualifiedPost ViewPatterns library @@ -40,14 +44,19 @@ GHC.Stack.Profiler.Core.Util build-depends: - base >=4.20 && <4.23, + base >=4.17 && <4.23, binary >=0.8.9.3 && <0.11, - bytestring >=0.11 && <0.13, + bytestring >=0.11 && <0.13, containers >=0.6.8 && <0.9, text >=2 && <2.2, - transformers ^>=0.6.2, + transformers ^>=0.6.1, hs-source-dirs: src default-language: GHC2021 + +source-repository head + type: git + location: https://github.com/well-typed/ghc-stack-profiler.git + subdir: ghc-stack-profiler-core diff --git a/src/GHC/Stack/Profiler/Core/Eventlog.hs b/src/GHC/Stack/Profiler/Core/Eventlog.hs --- a/src/GHC/Stack/Profiler/Core/Eventlog.hs +++ b/src/GHC/Stack/Profiler/Core/Eventlog.hs @@ -1,5 +1,28 @@ -module GHC.Stack.Profiler.Core.Eventlog where +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, + callStackItemLimit, + eventlogBufferSize, + stringLengthLimit, +) where + import Control.Monad (replicateM) import Data.Binary import Data.Coerce (coerce) @@ -37,7 +60,6 @@ -- := + -- # check that length < 2^16-8 -- @ --- data BinaryEventlogMessage = CallStackFinal !BinaryCallStackMessage | CallStackChunk !BinaryCallStackMessage @@ -74,10 +96,10 @@ deriving (Eq, Ord, Show, Generic) -- | Simple newtype for the ID of a capability. -newtype CapabilityId = - MkCapabilityId - { getCapabilityId :: Word64 - } +newtype CapabilityId + = MkCapabilityId + { getCapabilityId :: Word64 + } deriving (Show, Eq, Ord, Generic) newtype StringId = MkStringId @@ -85,11 +107,17 @@ } deriving (Eq, Ord, Show, Generic) +incrementStringLocationId :: StringId -> StringId +incrementStringLocationId (MkStringId sid) = MkStringId (sid + 1) + newtype SourceLocationId = MkSourceLocationId { getSourceLocationId :: Word64 } deriving (Eq, Ord, Show, Generic) +incrementSourceLocationId :: SourceLocationId -> SourceLocationId +incrementSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1) + newtype IpeId = MkIpeId { getIpeId :: Word64 } @@ -125,24 +153,26 @@ -- | Size limit of strings that can occur in the eventlog. stringLengthLimit :: Word16 -stringLengthLimit = word64ToWord16 $ +stringLengthLimit = + word64ToWord16 $ eventlogBufferSize - 2 {- 0xFFCC -} - 8 {- Word64 of 'StringId' -} - 2 {- Word16 for the length of the string to serialise -} callStackItemLimit :: Word16 -callStackItemLimit = word64ToWord16 +callStackItemLimit = + word64ToWord16 ( eventlogBufferSize - - 2 {- 0xFFCA or 0xFFCB -} - - 4 {- Word32 of 'CapabilityId' -} - - 4 {- Word32 of 'ThreadId' -} - - 2 {- Word16 for the length of stack entry -} + - 2 {- 0xFFCA or 0xFFCB -} + - 4 {- Word32 of 'CapabilityId' -} + - 4 {- Word32 of 'ThreadId' -} + - 2 {- Word16 for the length of stack entry -} ) `div` 9 {- Each 'BinaryStackItem' has at most 9 bytes -} instance Binary BinaryEventlogMessage where - put = \ case + put = \case CallStackFinal msg -> putWithTag callStackFinalMessageTag msg CallStackChunk msg -> @@ -151,8 +181,8 @@ putWithTag callStackStringMessageTag msg SourceLocationDef msg -> putWithTag callStackSourceLocationMessageTag msg - where - putWithTag t msg = putWord16 t >> put msg + where + putWithTag t msg = putWord16 t >> put msg get = do tag <- getWord16 @@ -167,16 +197,20 @@ | 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 + 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 + let + items = binaryCallStack msg putWord16 $ intToWord16 $ length items mapM_ put items @@ -185,14 +219,15 @@ tid <- getWord32 len <- getWord16 items <- replicateM (word16ToInt len) get - pure MkBinaryCallStackMessage - { binaryCallThreadId = word32ToWord64 tid - , binaryCallCapabilityId = MkCapabilityId $ word32ToWord64 capId - , binaryCallStack = items - } + pure + MkBinaryCallStackMessage + { binaryCallThreadId = word32ToWord64 tid + , binaryCallCapabilityId = MkCapabilityId $ word32ToWord64 capId + , binaryCallStack = items + } instance Binary BinaryStackItem where - put = \ case + put = \case BinaryIpe ipeId -> do putWord8 1 put ipeId @@ -204,7 +239,7 @@ put lid get = do - getWord8 >>= \ case + getWord8 >>= \case 1 -> BinaryIpe <$> get 2 -> BinaryString <$> get 3 -> BinarySourceLocation <$> get diff --git a/src/GHC/Stack/Profiler/Core/SourceLocation.hs b/src/GHC/Stack/Profiler/Core/SourceLocation.hs --- a/src/GHC/Stack/Profiler/Core/SourceLocation.hs +++ b/src/GHC/Stack/Profiler/Core/SourceLocation.hs @@ -1,15 +1,14 @@ module GHC.Stack.Profiler.Core.SourceLocation where -import Data.Word (Word32) import Data.Text (Text) +import Data.Word (Word32) import GHC.Generics (Generic) -- | A Haskell source location. -data SourceLocation = - MkSourceLocation - { line :: !Word32 - , column :: !Word32 - , functionName :: !Text - , fileName :: !Text - } +data SourceLocation = MkSourceLocation + { line :: !Word32 + , column :: !Word32 + , functionName :: !Text + , 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 --- a/src/GHC/Stack/Profiler/Core/SymbolTable.hs +++ b/src/GHC/Stack/Profiler/Core/SymbolTable.hs @@ -1,31 +1,37 @@ module GHC.Stack.Profiler.Core.SymbolTable ( -- * Abstract interfaces for transforming 'CallStackMessage's and + -- 'BinaryEventlogMessage' into each other. - SymbolTableWriter(..), - SymbolTableReader(..), + 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 Data.Text (Text) -import Data.Word (Word64) +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 -import GHC.Stack (HasCallStack) -- ---------------------------------------------------------------------------- -- Abstract interfaces for writing and reading to the symbol tables for deduplicating @@ -35,27 +41,26 @@ -- | Implementation agnostic symbol table supposed to be used to deduplicate symbols -- in 'CallStackMessage'. -- --- When transforming 'CallStackMessage' to '[BinaryEventlogMessage]' we replace some +-- 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. - } +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 @@ -63,15 +68,14 @@ -- -- 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 -> Text - -- ^ Lookup the 'StringId' in the symbol table. - -- This operation throws an exception if the 'StringId' is unknown. - , lookupSourceLocationId :: SourceLocationId -> SourceLocation - -- ^ Lookup the 'SourceLocationId' in the symbol table. - -- This operation throws an exception if the 'SourceLocationId' is unknown. - } +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) -- ---------------------------------------------------------------------------- @@ -81,66 +85,114 @@ data MapTable = MkMapTable { stringTable :: !(Map Text StringId) , srcLocTable :: !(Map SourceLocation SourceLocationId) - , uniqueSupply :: !Word64 - } deriving (Show, Eq, Ord, Generic) + , stringUniqueSupply :: {-# UNPACK #-} !StringId + , srcLocUniqueSupply :: {-# UNPACK #-} !SourceLocationId + } + deriving (Show, Eq, Ord, Generic) -{-# INLINABLE emptyMapSymbolTableWriter #-} +{-# INLINEABLE emptyMapSymbolTableWriter #-} emptyMapSymbolTableWriter :: SymbolTableWriter MapTable -emptyMapSymbolTableWriter = MkSymbolTableWriter - { writerTable = - MkMapTable - { stringTable = Map.empty - , srcLocTable = Map.empty - , uniqueSupply = 0 +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 } - , lookupOrInsertText = alterStringMap - , lookupOrInsertSourceLocation = alterSrcLocTable - } - - where - nextUnique tbl = (uniqueSupply tbl, tbl { uniqueSupply = uniqueSupply tbl + 1 }) + ) - updateEntry tbl0 mkKey Nothing = - let - (uniq, tbl) = nextUnique tbl0 - sid = mkKey uniq - in - ((sid, True, tbl), Just sid) + nextStringUnique tbl = + ( stringUniqueSupply tbl + , tbl + { stringUniqueSupply = + incrementStringLocationId $ stringUniqueSupply tbl + } + ) - updateEntry tbl _ (Just val) = - ((val, False, tbl), Just val) + 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) + swapAround set ((sid, new, tbl), hm) = + (sid, new, set tbl hm) - alterStringMap = \ tbl str -> - swapAround setStringTable $ - Map.alterF (updateEntry tbl MkStringId) str (stringTable tbl) + alterStringMap = \tbl str -> + swapAround setStringTable $ + Map.alterF (updateEntry tbl nextStringUnique) str (stringTable tbl) - alterSrcLocTable = \ tbl srcLoc -> - swapAround setSourceLocationTable $ - Map.alterF (updateEntry tbl MkSourceLocationId) srcLoc (srcLocTable 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 } +setSourceLocationTable tbl hm = + tbl + { srcLocTable = hm + } setStringTable :: MapTable -> Map Text StringId -> MapTable -setStringTable tbl hm = tbl { stringTable = hm } +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) + } + deriving (Eq, Ord, Show, Generic) emptyIntMapTable :: IntMapTable -emptyIntMapTable = MkIntMapTable - { stringLookupTable = IntMap.empty - , srcLocLookupTable = IntMap.empty - } +emptyIntMapTable = + MkIntMapTable + { stringLookupTable = IntMap.empty + , srcLocLookupTable = IntMap.empty + } mkIntMapSymbolTableReader :: IntMapTable -> SymbolTableReader mkIntMapSymbolTableReader tbl = @@ -149,7 +201,7 @@ , lookupSourceLocationId = flip lookupSourceLocationMessage tbl } -{-# INLINABLE insertTextMessage #-} +{-# INLINEABLE insertTextMessage #-} insertTextMessage :: BinaryStringMessage -> IntMapTable -> IntMapTable insertTextMessage msg tbl = tbl @@ -160,34 +212,40 @@ (stringLookupTable tbl) } -{-# INLINABLE insertSourceLocationMessage #-} -insertSourceLocationMessage :: BinarySourceLocationMessage -> IntMapTable -> IntMapTable -insertSourceLocationMessage msg tbl = - tbl - { srcLocLookupTable = - IntMap.insert - (idToInt $ binarySourceLocationMessageId msg) - sourceLocation - (srcLocLookupTable tbl) - } - where - sourceLocation = MkSourceLocation +{-# INLINEABLE insertSourceLocationMessage #-} +insertSourceLocationMessage :: BinarySourceLocationMessage -> IntMapTable -> Either MissingKeyError IntMapTable +insertSourceLocationMessage msg tbl = do + let + srcLocId = binarySourceLocationMessageId msg + funcId = binarySourceLocationFunctionId msg + fileId = binarySourceLocationFilename msg + + funcName <- + maybe (Left $ KeyStringIdNotFound srcLocId funcId) Right $ lookupTextMessage funcId tbl + fileName <- + maybe (Left $ KeyStringIdNotFound srcLocId fileId) Right $ lookupTextMessage fileId tbl + + pure + tbl + { srcLocLookupTable = + IntMap.insert + (idToInt srcLocId) + (mkSourceLocation funcName fileName) + (srcLocLookupTable tbl) + } + where + mkSourceLocation funcName fileName = + MkSourceLocation { line = binarySourceLocationRow msg , column = binarySourceLocationColumn msg - , functionName = lookupTextMessage (binarySourceLocationFunctionId msg) tbl - , fileName = lookupTextMessage (binarySourceLocationFilename msg) tbl + , functionName = funcName + , fileName = fileName } -{-# INLINABLE lookupTextMessage #-} -lookupTextMessage :: StringId -> IntMapTable -> Text -lookupTextMessage sid tbl = stringLookupTable tbl `unsafeIntMapLookup` idToInt sid - -{-# INLINABLE lookupSourceLocationMessage #-} -lookupSourceLocationMessage :: SourceLocationId -> IntMapTable -> SourceLocation -lookupSourceLocationMessage sid tbl = srcLocLookupTable tbl `unsafeIntMapLookup` idToInt sid +{-# INLINEABLE lookupTextMessage #-} +lookupTextMessage :: StringId -> IntMapTable -> Maybe Text +lookupTextMessage sid tbl = IntMap.lookup (idToInt sid) (stringLookupTable tbl) -unsafeIntMapLookup :: HasCallStack => IntMap a -> Int -> a -unsafeIntMapLookup tbl k = case IntMap.lookup k tbl of - Just v -> v - Nothing -> - error $ "Failed to find key: " ++ showAsHex k +{-# 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 --- a/src/GHC/Stack/Profiler/Core/ThreadSample.hs +++ b/src/GHC/Stack/Profiler/Core/ThreadSample.hs @@ -1,39 +1,52 @@ {-# LANGUAGE OverloadedStrings #-} module GHC.Stack.Profiler.Core.ThreadSample ( - ThreadSample(..), + -- * High-level API + ThreadSample (..), deserializeEventlogMessage, - CallStackMessage(..), - StackItem(..), - SourceLocation(..), + -- * Serialisable 'ThreadSample' + CallStackMessage (..), + StackItem (..), + SourceLocation (..), - SymbolTableWriter(..), - SymbolTableReader(..), + -- * Serialisation of 'CallStackMessage' + SymbolTableWriter (..), + SymbolTableReader (..), dehydrateCallStackMessage, + BinaryCallStackDecodeError (..), hydrateEventlogCallStackMessage, catCallStackMessage, 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.List.NonEmpty (NonEmpty(..)) +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 Data.Either (partitionEithers) import GHC.Stack.CloneStack (StackSnapshot) import GHC.Stack.Profiler.Core.Eventlog -import GHC.Stack.Profiler.Core.Util import GHC.Stack.Profiler.Core.SourceLocation import GHC.Stack.Profiler.Core.SymbolTable +import GHC.Stack.Profiler.Core.Util (chunksOf, word16ToInt) -- ---------------------------------------------------------------------------- -- Thread Sample @@ -46,12 +59,11 @@ -- 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 - } +data ThreadSample = ThreadSample + { threadSampleId :: !ThreadId + , threadSampleCapability :: !CapabilityId + , threadSampleStackSnapshot :: !StackSnapshot + } deriving (Generic) deserializeEventlogMessage :: LBS.ByteString -> Either String BinaryEventlogMessage @@ -64,13 +76,11 @@ -- ---------------------------------------------------------------------------- -- | A decoded rts callstack that can be serialised to the EventLog. --- -data CallStackMessage = - MkCallStackMessage - { callThreadId :: !Word64 - , callCapabilityId :: !CapabilityId - , callStack :: [StackItem] - } +data CallStackMessage = MkCallStackMessage + { callThreadId :: !Word64 + , callCapabilityId :: !CapabilityId + , callStack :: [StackItem] + } deriving (Eq, Ord, Show, Generic) data StackItem @@ -98,15 +108,17 @@ -- '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. +dehydrateCallStackMessage :: + forall table. SymbolTableWriter table -> CallStackMessage -> ([BinaryEventlogMessage], SymbolTableWriter table) dehydrateCallStackMessage msgTbl0 msg = let (stackItems, finalState) = - runState (mapM go (callStack msg)) initEncodingState + runWithEncodingState + (newEncodingState msgTbl0) + (mapM go (callStack msg)) stringDefs = map StringDef $ stringMessages finalState @@ -115,49 +127,68 @@ map SourceLocationDef $ sourceLocMessages finalState stackMsgChunks = - chunkCallStackMessage callStackItemLimit $ MkBinaryCallStackMessage - { binaryCallThreadId = callThreadId msg - , binaryCallCapabilityId = callCapabilityId msg - , binaryCallStack = stackItems - } + chunkCallStackMessage callStackItemLimit $ + 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 + UserMessage s -> + BinaryString <$> lookupTextMessage (Text.pack s) + SourceLocation srcLoc -> + BinarySourceLocation <$> lookupSourceLocationMessage srcLoc - where - initEncodingState = MkEncodingState - { symbolTableWriter = msgTbl0 - , stringMessages = [] - , sourceLocMessages = [] - } +data BinaryCallStackDecodeError + = StringIdNotFound StringId + | SourceLocationIdNotFound SourceLocationId + deriving (Show) - go :: StackItem -> State (EncodingState tbl) BinaryStackItem - go = \ case - IpeId ipeId -> - pure $ BinaryIpe ipeId - UserMessage s -> - BinaryString <$> lookupTextMessage (Text.pack s) - SourceLocation srcLoc -> - BinarySourceLocation <$> lookupSourceLocationMessage srcLoc +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 +hydrateEventlogCallStackMessage :: SymbolTableReader -> BinaryCallStackMessage -> (CallStackMessage, [BinaryCallStackDecodeError]) hydrateEventlogCallStackMessage decodeTable msg = let - decodeItem = \ case - BinaryIpe ipeId -> IpeId ipeId - BinaryString stringId -> UserMessage $ Text.unpack $ lookupStringId decodeTable stringId - BinarySourceLocation srcLocId -> SourceLocation $ lookupSourceLocationId decodeTable srcLocId + decodeItem :: BinaryStackItem -> Either BinaryCallStackDecodeError StackItem + decodeItem = \case + BinaryIpe ipeId -> + Right $ IpeId ipeId + BinaryString stringId -> + maybe + (Left $ StringIdNotFound stringId) + (Right . UserMessage . Text.unpack) + (lookupStringId decodeTable stringId) + BinarySourceLocation srcLocId -> + maybe + (Left $ SourceLocationIdNotFound srcLocId) + (Right . SourceLocation) + (lookupSourceLocationId decodeTable srcLocId) - items = map decodeItem (binaryCallStack msg) + itemsOrErros = map decodeItem (binaryCallStack msg) + (errors, items) = partitionEithers itemsOrErros in - MkCallStackMessage - { callCapabilityId = binaryCallCapabilityId msg - , callThreadId = binaryCallThreadId msg - , callStack = items - } + ( 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. @@ -186,48 +217,59 @@ chunked = chunksOf (word16ToInt chunkSize) items in go chunked - - where - mkCallStack chunk = MkBinaryCallStackMessage + where + mkCallStack chunk = + MkBinaryCallStackMessage { binaryCallThreadId = binaryCallThreadId msg0 , binaryCallCapabilityId = binaryCallCapabilityId msg0 , binaryCallStack = chunk } - go :: [[BinaryStackItem]] -> [BinaryEventlogMessage] - go [] = - -- If there are no chunks, we simply return the original message - [ CallStackFinal msg0 - ] - go [chunk] = - [ CallStackFinal $ mkCallStack chunk - ] - go (chunk:chunks) = - CallStackChunk (mkCallStack chunk) : go chunks + go :: [[BinaryStackItem]] -> [BinaryEventlogMessage] + go [] = + -- If there are no chunks, we simply return the original message + [ CallStackFinal msg0 + ] + go [chunk] = + [ CallStackFinal $ mkCallStack chunk + ] + go (chunk : chunks) = + CallStackChunk (mkCallStack chunk) : go chunks -- ---------------------------------------------------------------------------- -- Helper types and functions to implement the conversion to the binary -- representation. -- ---------------------------------------------------------------------------- -data EncodingState tbl = +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 :: SymbolTableWriter tbl - , stringMessages :: [BinaryStringMessage] - , sourceLocMessages :: [BinarySourceLocationMessage] + { symbolTableWriter = msgTbl0 + , stringMessages = [] + , sourceLocMessages = [] } - deriving (Generic) setSymbolTableWriter :: tbl -> State.State (EncodingState tbl) () -setSymbolTableWriter tbl = State.modify' (\ st -> st { symbolTableWriter = (symbolTableWriter st) { writerTable = 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 }) +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 }) +addSourceLocationMessage msg = State.modify' (\st -> st{sourceLocMessages = msg : sourceLocMessages st}) -lookupOrInsertTextMessage :: forall tbl . Text -> State (EncodingState tbl) (StringId, Bool) +lookupOrInsertTextMessage :: forall tbl. Text -> State (EncodingState tbl) (StringId, Bool) lookupOrInsertTextMessage s = do tbl <- State.gets symbolTableWriter let @@ -235,7 +277,7 @@ setSymbolTableWriter tbl1 pure (sid, new) -lookupOrInsertSrcLocMessage :: forall tbl . SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool) +lookupOrInsertSrcLocMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) (SourceLocationId, Bool) lookupOrInsertSrcLocMessage s = do tbl <- State.gets symbolTableWriter let @@ -243,24 +285,26 @@ setSymbolTableWriter tbl1 pure (sid, new) -lookupTextMessage :: forall tbl . Text -> State (EncodingState tbl) StringId +lookupTextMessage :: forall tbl. Text -> State (EncodingState tbl) StringId lookupTextMessage s = do (sid, new) <- lookupOrInsertTextMessage s when new $ - addStringMessage $ MkBinaryStringMessage sid s + addStringMessage $ + MkBinaryStringMessage sid s pure sid -lookupSourceLocationMessage :: forall tbl . SourceLocation -> State (EncodingState tbl) SourceLocationId +lookupSourceLocationMessage :: forall tbl. SourceLocation -> State (EncodingState tbl) SourceLocationId lookupSourceLocationMessage s = do (sid, new) <- lookupOrInsertSrcLocMessage s when new $ do nameId <- lookupTextMessage $ functionName s fileId <- lookupTextMessage $ fileName s - addSourceLocationMessage $ MkBinarySourceLocationMessage - { binarySourceLocationMessageId = sid - , binarySourceLocationRow = line s - , binarySourceLocationColumn = column s - , binarySourceLocationFunctionId = nameId - , binarySourceLocationFilename = fileId - } + addSourceLocationMessage $ + MkBinarySourceLocationMessage + { binarySourceLocationMessageId = sid + , binarySourceLocationRow = line s + , binarySourceLocationColumn = column s + , binarySourceLocationFunctionId = nameId + , binarySourceLocationFilename = fileId + } pure sid diff --git a/src/GHC/Stack/Profiler/Core/Util.hs b/src/GHC/Stack/Profiler/Core/Util.hs --- a/src/GHC/Stack/Profiler/Core/Util.hs +++ b/src/GHC/Stack/Profiler/Core/Util.hs @@ -2,24 +2,24 @@ import Control.Monad (replicateM) import Data.Binary -import Data.Binary.Put import Data.Binary.Get -import Data.Coerce (coerce, Coercible) +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 :: (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 + 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 @@ -27,7 +27,7 @@ s <- replicateM (word16ToInt len) get pure $ Text.pack s -showAsHex :: Integral a => a -> String +showAsHex :: (Integral a) => a -> String showAsHex d = "0x" ++ Numeric.showHex d "" putWord64 :: Word64 -> Put