diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for ghc-stack-profiler-core + +## 0.1.0.0 -- 2025-12-09 + +* Add types for encoding RTS callstacks to bytes that can be sent to the eventlog. +* First version. Released on an unsuspecting world. diff --git a/ghc-stack-profiler-core.cabal b/ghc-stack-profiler-core.cabal new file mode 100644 --- /dev/null +++ b/ghc-stack-profiler-core.cabal @@ -0,0 +1,53 @@ +cabal-version: 3.8 +name: ghc-stack-profiler-core +version: 0.1.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`. +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. + +extra-doc-files: CHANGELOG.md +category: Profiling, Benchmarking, Development +tested-with: ghc ==9.14 || ==9.12 || ==9.10 + +common warnings + ghc-options: + -Wall + -Wunused-packages + +common exts + default-extensions: + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + LambdaCase + NamedFieldPuns + ViewPatterns + +library + import: + 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 + + build-depends: + base >=4.20 && <4.23, + binary >=0.8.9.3 && <0.11, + bytestring >=0.11 && <0.13, + containers >=0.6.8 && <0.9, + text >=2 && <2.2, + transformers ^>=0.6.2, + + hs-source-dirs: + src + + default-language: GHC2021 diff --git a/src/GHC/Stack/Profiler/Core/Eventlog.hs b/src/GHC/Stack/Profiler/Core/Eventlog.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Eventlog.hs @@ -0,0 +1,249 @@ +module GHC.Stack.Profiler.Core.Eventlog 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" +-- | "FF" "CB" +-- | "FF" "CC" +-- | "FF" "CD" +-- +-- STACK +-- := + +-- # check that length < (2^16-8) / 9 +-- +-- ENTRY +-- := "01" +-- | "02" +-- | "03" +-- +-- CStringLen +-- := + +-- # check that length < 2^16-8 +-- @ +-- +data BinaryEventlogMessage + = CallStackFinal !BinaryCallStackMessage + | CallStackChunk !BinaryCallStackMessage + | StringDef !BinaryStringMessage + | SourceLocationDef !BinarySourceLocationMessage + deriving (Eq, Ord, Show, Generic) + +data BinaryCallStackMessage = MkBinaryCallStackMessage + { binaryCallThreadId :: !Word64 + , binaryCallCapabilityId :: !CapabilityId + , binaryCallStack :: ![BinaryStackItem] + } + deriving (Eq, Ord, Show, Generic) + +data BinaryStringMessage = MkBinaryStringMessage + { binaryStringMessageId :: !StringId + , binaryStringMessage :: !Text + } + deriving (Eq, Ord, Show, Generic) + +data BinarySourceLocationMessage = MkBinarySourceLocationMessage + { binarySourceLocationMessageId :: {-# UNPACK #-} !SourceLocationId + , binarySourceLocationRow :: {-# UNPACK #-} !Word32 + , binarySourceLocationColumn :: {-# UNPACK #-} !Word32 + , binarySourceLocationFunctionId :: {-# UNPACK #-} !StringId + , binarySourceLocationFilename :: {-# UNPACK #-} !StringId + } + deriving (Eq, Ord, Show, Generic) + +data BinaryStackItem + = BinaryIpe {-# UNPACK #-} !IpeId + | BinaryString {-# UNPACK #-} !StringId + | BinarySourceLocation {-# UNPACK #-} !SourceLocationId + deriving (Eq, Ord, Show, Generic) + +-- | Simple newtype for the ID of a capability. +newtype CapabilityId = + MkCapabilityId + { getCapabilityId :: Word64 + } + deriving (Show, Eq, Ord, Generic) + +newtype StringId = MkStringId + { getStringId :: Word64 + } + deriving (Eq, Ord, Show, Generic) + +newtype SourceLocationId = MkSourceLocationId + { getSourceLocationId :: Word64 + } + deriving (Eq, Ord, Show, Generic) + +newtype IpeId = MkIpeId + { getIpeId :: Word64 + } + deriving (Eq, Ord, Show, 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 -} + +callStackItemLimit :: Word16 +callStackItemLimit = word64ToWord16 + ( eventlogBufferSize + - 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 + 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 1 + put ipeId + BinaryString sid -> do + putWord8 2 + put sid + BinarySourceLocation lid -> do + putWord8 3 + put lid + + get = do + getWord8 >>= \ case + 1 -> BinaryIpe <$> get + 2 -> BinaryString <$> get + 3 -> BinarySourceLocation <$> 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 (binarySourceLocationFunctionId msg) + put (binarySourceLocationFilename msg) + + get = do + MkBinarySourceLocationMessage + <$> get + <*> getWord32 + <*> getWord32 + <*> get + <*> 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/SourceLocation.hs b/src/GHC/Stack/Profiler/Core/SourceLocation.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/SourceLocation.hs @@ -0,0 +1,15 @@ +module GHC.Stack.Profiler.Core.SourceLocation where + +import Data.Word (Word32) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | A Haskell source location. +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 new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/SymbolTable.hs @@ -0,0 +1,193 @@ +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, + -- * An 'IntMap' implementation for the 'SymbolTableReader' interface. + IntMapTable, + mkIntMapSymbolTableReader, + emptyIntMapTable, + insertSourceLocationMessage, + insertTextMessage, +) where + +import Data.Text (Text) +import Data.Word (Word64) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +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 +-- 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 -> 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. + } + deriving (Generic) + +-- ---------------------------------------------------------------------------- +-- Implementation backend for 'SymbolTableWriter' +-- ---------------------------------------------------------------------------- + +data MapTable = MkMapTable + { stringTable :: !(Map Text StringId) + , srcLocTable :: !(Map SourceLocation SourceLocationId) + , uniqueSupply :: !Word64 + } deriving (Show, Eq, Ord, Generic) + +{-# INLINABLE emptyMapSymbolTableWriter #-} +emptyMapSymbolTableWriter :: SymbolTableWriter MapTable +emptyMapSymbolTableWriter = MkSymbolTableWriter + { writerTable = + MkMapTable + { stringTable = Map.empty + , srcLocTable = Map.empty + , uniqueSupply = 0 + } + , 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) + + 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 MkStringId) str (stringTable tbl) + + alterSrcLocTable = \ tbl srcLoc -> + swapAround setSourceLocationTable $ + Map.alterF (updateEntry tbl MkSourceLocationId) 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 } + +-- ---------------------------------------------------------------------------- +-- Implementation backend for 'SymbolTableReader' +-- ---------------------------------------------------------------------------- + +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 + } + +{-# INLINABLE insertTextMessage #-} +insertTextMessage :: BinaryStringMessage -> IntMapTable -> IntMapTable +insertTextMessage msg tbl = + tbl + { stringLookupTable = + IntMap.insert + (idToInt $ binaryStringMessageId msg) + (binaryStringMessage msg) + (stringLookupTable tbl) + } + +{-# INLINABLE insertSourceLocationMessage #-} +insertSourceLocationMessage :: BinarySourceLocationMessage -> IntMapTable -> IntMapTable +insertSourceLocationMessage msg tbl = + tbl + { srcLocLookupTable = + IntMap.insert + (idToInt $ binarySourceLocationMessageId msg) + sourceLocation + (srcLocLookupTable tbl) + } + where + sourceLocation = MkSourceLocation + { line = binarySourceLocationRow msg + , column = binarySourceLocationColumn msg + , functionName = lookupTextMessage (binarySourceLocationFunctionId msg) tbl + , fileName = lookupTextMessage (binarySourceLocationFilename msg) tbl + } + +{-# 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 + +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 diff --git a/src/GHC/Stack/Profiler/Core/ThreadSample.hs b/src/GHC/Stack/Profiler/Core/ThreadSample.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/ThreadSample.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Stack.Profiler.Core.ThreadSample ( + ThreadSample(..), + deserializeEventlogMessage, + + CallStackMessage(..), + StackItem(..), + SourceLocation(..), + + SymbolTableWriter(..), + SymbolTableReader(..), + dehydrateCallStackMessage, + hydrateEventlogCallStackMessage, + catCallStackMessage, + chunkCallStackMessage, +) where + +import Control.Concurrent +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 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.Util +import GHC.Stack.Profiler.Core.SourceLocation +import GHC.Stack.Profiler.Core.SymbolTable + +-- ---------------------------------------------------------------------------- +-- 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 + | UserMessage !String + | SourceLocation !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) = + runState (mapM go (callStack msg)) initEncodingState + + stringDefs = + map StringDef $ stringMessages finalState + + sourceLocDefs = + map SourceLocationDef $ sourceLocMessages finalState + + stackMsgChunks = + chunkCallStackMessage callStackItemLimit $ MkBinaryCallStackMessage + { binaryCallThreadId = callThreadId msg + , binaryCallCapabilityId = callCapabilityId msg + , binaryCallStack = stackItems + } + in + ( stringDefs ++ sourceLocDefs ++ stackMsgChunks + , symbolTableWriter finalState + ) + + where + initEncodingState = MkEncodingState + { symbolTableWriter = msgTbl0 + , stringMessages = [] + , sourceLocMessages = [] + } + + 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 + +-- | Generic implementation to turn 'BinaryCallStackMessage' into the much richer +-- 'CallStackMessage'. +hydrateEventlogCallStackMessage :: SymbolTableReader -> BinaryCallStackMessage -> CallStackMessage +hydrateEventlogCallStackMessage decodeTable msg = + let + decodeItem = \ case + BinaryIpe ipeId -> IpeId ipeId + BinaryString stringId -> UserMessage $ Text.unpack $ lookupStringId decodeTable stringId + BinarySourceLocation srcLocId -> SourceLocation $ lookupSourceLocationId decodeTable srcLocId + + items = map decodeItem (binaryCallStack msg) + in + MkCallStackMessage + { callCapabilityId = binaryCallCapabilityId msg + , callThreadId = binaryCallThreadId msg + , callStack = items + } + +-- | Combine all 'BinaryCallStackMessage's into a single 'BinaryCallStackMessage'. +-- We assume that all 'BinaryCallStackMessage' only differ in their 'binaryCallStack' values. +-- +-- 'catCallStackMessage' is the inverse of 'chunkCallStackMessage'. +catCallStackMessage :: NonEmpty BinaryCallStackMessage -> BinaryCallStackMessage +catCallStackMessage msgs = + MkBinaryCallStackMessage + { binaryCallThreadId = binaryCallThreadId $ NonEmpty.head msgs + , binaryCallCapabilityId = binaryCallCapabilityId $ NonEmpty.head msgs + , binaryCallStack = concatMap binaryCallStack $ 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. +chunkCallStackMessage :: Word16 -> BinaryCallStackMessage -> [BinaryEventlogMessage] +chunkCallStackMessage chunkSize msg0 = + let + items = binaryCallStack msg0 + chunked = chunksOf (word16ToInt chunkSize) items + in + go chunked + + 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 + +-- ---------------------------------------------------------------------------- +-- 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) + +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 + nameId <- lookupTextMessage $ functionName s + fileId <- lookupTextMessage $ fileName s + 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 new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Core/Util.hs @@ -0,0 +1,119 @@ +module GHC.Stack.Profiler.Core.Util where + +import Control.Monad (replicateM) +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Data.Coerce (coerce, Coercible) +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 + +-- | @'chunksOf' n@ splits a list into length-n pieces. The last +-- piece will be shorter if @n@ does not evenly divide the length of +-- the list. If @n <= 0@, @'chunksOf' n l@ returns an infinite list +-- of empty lists. +-- +-- >>> chunksOf 3 [1..12] +-- [[1,2,3],[4,5,6],[7,8,9],[10,11,12]] +-- +-- >>> chunksOf 3 "Hello there" +-- ["Hel","lo ","the","re"] +-- +-- >>> chunksOf 3 ([] :: [Int]) +-- [] +-- +-- Note that @'chunksOf' n []@ is @[]@, not @[[]]@. This is +-- intentional, and satisfies the property that +-- +-- @chunksOf n xs ++ chunksOf n ys == chunksOf n (xs ++ ys)@ +-- +-- whenever @n@ evenly divides the length of @xs@. +-- +-- +-- This is the definition of 'chunksOf' as defined in +-- https://hackage.haskell.org/package/split-0.2.5/docs/Data-List-Split-Internals.html#v:chunksOf +-- +-- We avoid an extra dependency on 'split', as we want to +-- only depend on GHC boot libraries in the core package. +chunksOf :: Int -> [e] -> [[e]] +chunksOf i ls = map (take i) (build (splitter ls)) + where + splitter :: [e] -> ([e] -> a -> a) -> a -> a + splitter [] _ n = n + splitter l c n = l `c` splitter (drop i l) c n + +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build g = g (:) []