ghc-stack-profiler-core 0.2.0.0 → 0.3.0.0

raw patch · 8 files changed

+188/−105 lines, 8 filesdep +ghc-stack-profiler-coredep +tastydep +tasty-hunitdep ~basedep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-stack-profiler-core, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: base, binary

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• ghc-stack-profiler-core.cabal +16/−4
• src/GHC/Stack/Profiler/Core/Eventlog.hs +32/−26
• src/GHC/Stack/Profiler/Core/SourceLocation.hs +0/−1
• src/GHC/Stack/Profiler/Core/SymbolTable.hs +2/−6
• src/GHC/Stack/Profiler/Core/ThreadSample.hs +47/−30
• src/GHC/Stack/Profiler/Core/Util.hs +23/−38
• test/Main.hs +61/−0

@@ -1,5 +1,12 @@ # Revision history for ghc-stack-profiler-core +## 0.3.0.0 -- 2026-06-23++* Support GHC 9.4, 9.6 and 9.8 for ghc-stack-profiler-core [#30](https://github.com/well-typed/ghc-stack-profiler/pull/30)+* Support GHC 10.1 [#29](https://github.com/well-typed/ghc-stack-profiler/pull/29)+  * Adds supports for optional source locations in stack annotations+* Fix rendering of the protocol specification with haddock [#28](https://github.com/well-typed/ghc-stack-profiler/pull/28)+ ## 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)

@@ -1,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler-core-version: 0.2.0.0+version: 0.3.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com@@ -13,9 +13,7 @@ extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development tested-with:-  ghc ==9.10.3-  ghc ==9.12.2-  ghc ==9.14.1+  ghc ==10.1 || ==9.14.1 || ==9.12.2 || ==9.10.3 || ==9.8.4 || ==9.6.7 || ==9.4.8  common warnings   ghc-options:@@ -53,6 +51,20 @@    hs-source-dirs:     src++  default-language: GHC2021++test-suite ghc-stack-profiler-core-tests+  import: warnings, exts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base,+    ghc-stack-profiler-core,+    tasty >=1.5.4 && <1.6,+    tasty-hunit >=0.9 && <0.13,+    tasty-quickcheck >=0.10 && <0.12,    default-language: GHC2021 

@@ -18,7 +18,8 @@   callStackStringMessageTag,   callStackSourceLocationMessageTag,   callStackMessageTags,-  callStackItemLimit,+  callStackSizeLimit,+  byteSizeOf,   eventlogBufferSize,   stringLengthLimit, ) where@@ -42,22 +43,22 @@ -- -- @ -- 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>+--  := 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>++--  := (capability: 'Word32') (threadId: 'Word32') (length: 'Int16') (ENTRY)+ --   # check that length < (2^16-8) / 9 -- -- ENTRY---  := "01" <ipe: Word64>---   | "02" <stringId: Word64>---   | "03" <srcLocId: Word64>+--  := 01 (ipe: 'Word64')+--   | 02 (stringId: 'Word64')+--   | 03 (stringId: 'Word64') (srcLocId: 'Word64') -- -- CStringLen---   := <length: Int16> <Char>++--   := (length: 'Int16') (Char)+ --    # check that length < 2^16-8 -- @ data BinaryEventlogMessage@@ -84,15 +85,15 @@   { 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+  | BinaryMessage+      {-# UNPACK #-} !StringId+      {-# UNPACK #-} !(Maybe SourceLocationId)   deriving (Eq, Ord, Show, Generic)  -- | Simple newtype for the ID of a capability.@@ -160,8 +161,8 @@       - 8 {- Word64 of 'StringId' -}       - 2 {- Word16 for the length of the string to serialise -} -callStackItemLimit :: Word16-callStackItemLimit =+callStackSizeLimit :: Word16+callStackSizeLimit =   word64ToWord16     ( eventlogBufferSize         - 2 {- 0xFFCA or 0xFFCB -}@@ -169,8 +170,14 @@         - 4 {- Word32 of 'ThreadId' -}         - 2 {- Word16 for the length of stack entry -}     )-    `div` 9 {- Each 'BinaryStackItem' has at most 9 bytes -} +-- | Size in bytes of the given 'BinaryStackItem'+byteSizeOf :: BinaryStackItem -> Word16+byteSizeOf = \ case+  BinaryIpe{} -> 9+  BinaryMessage _ Nothing -> 9+  BinaryMessage _ (Just _) -> 17+ instance Binary BinaryEventlogMessage where   put = \case     CallStackFinal msg ->@@ -229,20 +236,21 @@ instance Binary BinaryStackItem where   put = \case     BinaryIpe ipeId -> do-      putWord8 1+      putWord8 0x1       put ipeId-    BinaryString sid -> do-      putWord8 2+    BinaryMessage sid Nothing -> do+      putWord8 0x2       put sid-    BinarySourceLocation lid -> do-      putWord8 3+    BinaryMessage sid (Just lid) -> do+      putWord8 0x3+      put sid       put lid    get = do     getWord8 >>= \case-      1 -> BinaryIpe <$> get-      2 -> BinaryString <$> get-      3 -> BinarySourceLocation <$> get+      0x1 -> BinaryIpe <$> get+      0x2 -> BinaryMessage <$> get <*> pure Nothing+      0x3 -> BinaryMessage <$> get <*> (Just <$> get)       n -> fail $ "StackItem: Unexpected tag byte encounter: " <> show n  instance Binary BinarySourceLocationMessage where@@ -250,7 +258,6 @@     put $ binarySourceLocationMessageId msg     putWord32 (binarySourceLocationRow msg)     putWord32 (binarySourceLocationColumn msg)-    put (binarySourceLocationFunctionId msg)     put (binarySourceLocationFilename msg)    get = do@@ -258,7 +265,6 @@       <$> get       <*> getWord32       <*> getWord32-      <*> get       <*> get  instance Binary BinaryStringMessage where

@@ -8,7 +8,6 @@ data SourceLocation = MkSourceLocation   { line :: !Word32   , column :: !Word32-  , functionName :: !Text   , fileName :: !Text   }   deriving (Eq, Ord, Show, Generic)

@@ -217,11 +217,8 @@ 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 @@ -230,15 +227,14 @@       { srcLocLookupTable =           IntMap.insert             (idToInt srcLocId)-            (mkSourceLocation funcName fileName)+            (mkSourceLocation fileName)             (srcLocLookupTable tbl)       }  where-  mkSourceLocation funcName fileName =+  mkSourceLocation fileName =     MkSourceLocation       { line = binarySourceLocationRow msg       , column = binarySourceLocationColumn msg-      , functionName = funcName       , fileName = fileName       } 

@@ -35,18 +35,18 @@ import Data.Binary import Data.Binary.Get import qualified Data.ByteString.Lazy as LBS+import Data.Either (partitionEithers)+import qualified Data.List as List import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text import GHC.Generics -import Data.Either (partitionEithers) import GHC.Stack.CloneStack (StackSnapshot) import GHC.Stack.Profiler.Core.Eventlog import GHC.Stack.Profiler.Core.SourceLocation import GHC.Stack.Profiler.Core.SymbolTable-import GHC.Stack.Profiler.Core.Util (chunksOf, word16ToInt)  -- ---------------------------------------------------------------------------- -- Thread Sample@@ -85,8 +85,7 @@  data StackItem   = IpeId !IpeId-  | UserMessage !String-  | SourceLocation !SourceLocation+  | UserAnnotation !String !(Maybe SourceLocation)   deriving (Eq, Ord, Show, Generic)  -- ----------------------------------------------------------------------------@@ -126,8 +125,9 @@     sourceLocDefs =       map SourceLocationDef $ sourceLocMessages finalState +    -- TODO: this needs to be fixed     stackMsgChunks =-      chunkCallStackMessage callStackItemLimit $+      chunkCallStackMessage         MkBinaryCallStackMessage           { binaryCallThreadId = callThreadId msg           , binaryCallCapabilityId = callCapabilityId msg@@ -142,10 +142,11 @@   go = \case     IpeId ipeId ->       pure $ BinaryIpe ipeId-    UserMessage s ->-      BinaryString <$> lookupTextMessage (Text.pack s)-    SourceLocation srcLoc ->-      BinarySourceLocation <$> lookupSourceLocationMessage srcLoc+    UserAnnotation s mSrcLoc -> do+      srcLocId <- case mSrcLoc of+        Nothing -> pure Nothing+        Just srcLoc -> Just <$> lookupSourceLocationMessage srcLoc+      BinaryMessage <$> lookupTextMessage (Text.pack s) <*> pure srcLocId  data BinaryCallStackDecodeError   = StringIdNotFound StringId@@ -168,16 +169,18 @@     decodeItem = \case       BinaryIpe ipeId ->         Right $ IpeId ipeId-      BinaryString stringId ->-        maybe+      BinaryMessage stringId mSrcLocId -> do+        str <- maybe           (Left $ StringIdNotFound stringId)-          (Right . UserMessage . Text.unpack)+          (Right . Text.unpack)           (lookupStringId decodeTable stringId)-      BinarySourceLocation srcLocId ->-        maybe-          (Left $ SourceLocationIdNotFound srcLocId)-          (Right . SourceLocation)-          (lookupSourceLocationId decodeTable srcLocId)+        srcLoc <- case mSrcLocId of+          Nothing -> pure Nothing+          Just srcLocId -> maybe+            (Left $ SourceLocationIdNotFound srcLocId)+            (Right . Just)+            (lookupSourceLocationId decodeTable srcLocId)+        pure $ UserAnnotation str srcLoc      itemsOrErros = map decodeItem (binaryCallStack msg)     (errors, items) = partitionEithers itemsOrErros@@ -193,13 +196,13 @@ -- | 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' is the conceptually inverse of 'chunkCallStackMessage'. catCallStackMessage :: NonEmpty BinaryCallStackMessage -> BinaryCallStackMessage catCallStackMessage msgs =   MkBinaryCallStackMessage     { binaryCallThreadId = binaryCallThreadId $ NonEmpty.head msgs     , binaryCallCapabilityId = binaryCallCapabilityId $ NonEmpty.head msgs-    , binaryCallStack = concatMap binaryCallStack $ NonEmpty.toList msgs+    , binaryCallStack = concatMap (reverse . binaryCallStack) . reverse $ NonEmpty.toList msgs     }  -- | Chunk the 'binaryCallStack' of the 'BinaryCallStackMessage' by the given 'Word16'.@@ -210,13 +213,29 @@ -- -- * 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 =+--+-- The resulting 'CallStackChunk' are in reverse order and so are the chunks themselves.+--+-- This means, for a stack @[1,2,3,4,5,6]@ and an assumed chunk size of 2,+-- we produce @[[6,5],[4,3],[2,1]]@.+chunkCallStackMessage :: BinaryCallStackMessage -> [BinaryEventlogMessage]+chunkCallStackMessage msg0 =   let     items = binaryCallStack msg0-    chunked = chunksOf (word16ToInt chunkSize) items+    chunked =+      let+        go (!size, curChunk, restChunk) item =+          let+            !bytes = byteSizeOf item+          in+            if size + bytes > callStackSizeLimit+              then (0, [item], curChunk : restChunk)+              else (size + bytes, item:curChunk, restChunk)+        (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items+      in+        lastChunk:initChunk   in-    go chunked+    mkEventlogMessages chunked  where   mkCallStack chunk =     MkBinaryCallStackMessage@@ -225,16 +244,16 @@       , binaryCallStack = chunk       } -  go :: [[BinaryStackItem]] -> [BinaryEventlogMessage]-  go [] =+  mkEventlogMessages :: [[BinaryStackItem]] -> [BinaryEventlogMessage]+  mkEventlogMessages [] =     -- If there are no chunks, we simply return the original message     [ CallStackFinal msg0     ]-  go [chunk] =+  mkEventlogMessages [chunk] =     [ CallStackFinal $ mkCallStack chunk     ]-  go (chunk : chunks) =-    CallStackChunk (mkCallStack chunk) : go chunks+  mkEventlogMessages (chunk : chunks) =+    CallStackChunk (mkCallStack chunk) : mkEventlogMessages chunks  -- ---------------------------------------------------------------------------- -- Helper types and functions to implement the conversion to the binary@@ -297,14 +316,12 @@ 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

@@ -1,4 +1,26 @@-module GHC.Stack.Profiler.Core.Util where+module GHC.Stack.Profiler.Core.Util (+  idToInt,+  putTextWord16,+  getTextWord16,+  showAsHex,+  putWord64,+  putWord32,+  putWord16,+  getWord64,+  getWord32,+  getWord16,+  word64ToWord32,+  word32ToWord64,+  word64ToWord16,+  word32ToInt,+  word64ToInt,+  intToWord64,+  intToWord32,+  intToWord16,+  word16ToInt,+  intToWord8,+  word8ToInt,+  ) where  import Control.Monad (replicateM) import Data.Binary@@ -80,40 +102,3 @@  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 (:) []

@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Main where+import Test.Tasty+import Test.Tasty.QuickCheck+import GHC.Stack.Profiler.Core.Eventlog+import GHC.Stack.Profiler.Core.ThreadSample+import Data.Maybe+import qualified Data.List.NonEmpty as NonEmpty++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "tests"+  [ properties+  ]++properties :: TestTree+properties =+  testGroup "property"+    [ testProperty "chunkCallStackMessage" $+        \ message ->+          let+            msgs = mapMaybe go (chunkCallStackMessage message)+            go = \ case+              CallStackChunk csm -> Just csm+              CallStackFinal csm -> Just csm+              _ -> Nothing+          in+            catCallStackMessage (NonEmpty.fromList msgs) === message+    ]++instance Arbitrary BinaryCallStackMessage where+  arbitrary =+    MkBinaryCallStackMessage+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary++instance Arbitrary CapabilityId where+  arbitrary =+    MkCapabilityId <$> arbitrary++instance Arbitrary BinaryStackItem where+  arbitrary =+    oneof+      [ BinaryIpe <$> arbitrary+      , BinaryMessage <$> arbitrary <*> arbitrary+      ]++instance Arbitrary IpeId where+  arbitrary =+    MkIpeId <$> arbitrary++instance Arbitrary StringId where+  arbitrary =+    MkStringId <$> arbitrary++instance Arbitrary SourceLocationId where+  arbitrary =+    MkSourceLocationId <$> arbitrary