packages feed

ghc-stack-profiler-core (empty) → 0.1.0.0

raw patch · 7 files changed

+901/−0 lines, 7 filesdep +basedep +binarydep +bytestring

Dependencies added: base, binary, bytestring, containers, text, transformers

Files

+ CHANGELOG.md view
@@ -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.
+ ghc-stack-profiler-core.cabal view
@@ -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
+ src/GHC/Stack/Profiler/Core/Eventlog.hs view
@@ -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" <stack: STACK>+--   | "FF" "CB" <prefix: STACK>+--   | "FF" "CC" <stringId: Word64> <string: CStringLen>+--   | "FF" "CD" <srcLocId: Word64> <row: Word32> <col: Word32> <functionId: Word64> <filename: Word64>+--+-- STACK+--  := <capability: Word32> <threadId: Word32> <length: Int16> <ENTRY>++--   # check that length < (2^16-8) / 9+--+-- ENTRY+--  := "01" <ipe: Word64>+--   | "02" <stringId: Word64>+--   | "03" <srcLocId: Word64>+--+-- CStringLen+--   := <length: Int16> <Char>++--    # check that length < 2^16-8+-- @+--+data BinaryEventlogMessage+  = CallStackFinal !BinaryCallStackMessage+  | CallStackChunk !BinaryCallStackMessage+  | StringDef !BinaryStringMessage+  | SourceLocationDef !BinarySourceLocationMessage+  deriving (Eq, Ord, Show, 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
+ src/GHC/Stack/Profiler/Core/SourceLocation.hs view
@@ -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)
+ src/GHC/Stack/Profiler/Core/SymbolTable.hs view
@@ -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
+ src/GHC/Stack/Profiler/Core/ThreadSample.hs view
@@ -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
+ src/GHC/Stack/Profiler/Core/Util.hs view
@@ -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 (:) []