ghc-stack-profiler-core 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+382/−232 lines, 7 filesdep ~binary
Dependency ranges changed: binary
Files
- CHANGELOG.md +5/−0
- ghc-stack-profiler-core.cabal +14/−5
- src/GHC/Stack/Profiler/Core/Eventlog.hs +62/−27
- src/GHC/Stack/Profiler/Core/SourceLocation.hs +7/−8
- src/GHC/Stack/Profiler/Core/SymbolTable.hs +154/−96
- src/GHC/Stack/Profiler/Core/ThreadSample.hs +131/−87
- src/GHC/Stack/Profiler/Core/Util.hs +9/−9
CHANGELOG.md view
@@ -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.
ghc-stack-profiler-core.cabal view
@@ -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
src/GHC/Stack/Profiler/Core/Eventlog.hs view
@@ -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 @@ -- := <length: Int16> <Char>+ -- # 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
src/GHC/Stack/Profiler/Core/SourceLocation.hs view
@@ -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)
src/GHC/Stack/Profiler/Core/SymbolTable.hs view
@@ -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)
src/GHC/Stack/Profiler/Core/ThreadSample.hs view
@@ -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
src/GHC/Stack/Profiler/Core/Util.hs view
@@ -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