ghc-stack-profiler-core 0.3.0.0 → 0.4.0.0

raw patch · 6 files changed

+137/−59 lines, 6 filesdep −tasty-hunitdep ~binarydep ~bytestringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies removed: tasty-hunit

Dependency ranges changed: binary, bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−8
• ghc-stack-profiler-core.cabal +3/−2
• src/GHC/Stack/Profiler/Core/Eventlog.hs +22/−14
• src/GHC/Stack/Profiler/Core/ThreadSample.hs +23/−14
• src/GHC/Stack/Profiler/Core/Util.hs +1/−1
• test/Main.hs +74/−20

@@ -1,18 +1,24 @@ # Revision history for ghc-stack-profiler-core +## 0.4.0.0 -- 2026-07-14++Major version number changed to match `ghc-stack-profiler-speedscope`.++No changes.+ ## 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)+- 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)-* Never crash on decoding errors [#12](https://github.com/well-typed/ghc-stack-profiler/pull/12)+- 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.-* First version. Released on an unsuspecting world.+- Add types for encoding RTS callstacks to bytes that can be sent to the eventlog.+- First version. Released on an unsuspecting world.

@@ -1,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler-core-version: 0.3.0.0+version: 0.4.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com@@ -61,9 +61,10 @@   main-is: Main.hs   build-depends:     base,+    binary,+    bytestring,     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

@@ -19,6 +19,7 @@   callStackSourceLocationMessageTag,   callStackMessageTags,   callStackSizeLimit,+  callStackSizeLimit_,   byteSizeOf,   eventlogBufferSize,   stringLengthLimit,@@ -66,20 +67,20 @@   | CallStackChunk !BinaryCallStackMessage   | StringDef !BinaryStringMessage   | SourceLocationDef !BinarySourceLocationMessage-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  data BinaryCallStackMessage = MkBinaryCallStackMessage   { binaryCallThreadId :: !Word64   , binaryCallCapabilityId :: !CapabilityId   , binaryCallStack :: ![BinaryStackItem]   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  data BinaryStringMessage = MkBinaryStringMessage   { binaryStringMessageId :: !StringId   , binaryStringMessage :: !Text   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  data BinarySourceLocationMessage = MkBinarySourceLocationMessage   { binarySourceLocationMessageId :: {-# UNPACK #-} !SourceLocationId@@ -87,26 +88,26 @@   , binarySourceLocationColumn :: {-# UNPACK #-} !Word32   , binarySourceLocationFilename :: {-# UNPACK #-} !StringId   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  data BinaryStackItem   = BinaryIpe {-# UNPACK #-} !IpeId   | BinaryMessage       {-# UNPACK #-} !StringId       {-# UNPACK #-} !(Maybe SourceLocationId)-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  -- | Simple newtype for the ID of a capability. newtype CapabilityId   = MkCapabilityId   { getCapabilityId :: Word64   }-  deriving (Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Read, Generic)  newtype StringId = MkStringId   { getStringId :: Word64   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  incrementStringLocationId :: StringId -> StringId incrementStringLocationId (MkStringId sid) = MkStringId (sid + 1)@@ -114,7 +115,7 @@ newtype SourceLocationId = MkSourceLocationId   { getSourceLocationId :: Word64   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  incrementSourceLocationId :: SourceLocationId -> SourceLocationId incrementSourceLocationId (MkSourceLocationId slId) = MkSourceLocationId (slId + 1)@@ -122,7 +123,7 @@ newtype IpeId = MkIpeId   { getIpeId :: Word64   }-  deriving (Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Read, Generic)  -- ---------------------------------------------------------------------------- -- Binary instances@@ -161,10 +162,17 @@       - 8 {- Word64 of 'StringId' -}       - 2 {- Word16 for the length of the string to serialise -} +-- | The limit of stack items that can go in one eventlog message in bytes. callStackSizeLimit :: Word16 callStackSizeLimit =+  callStackSizeLimit_ eventlogBufferSize++-- | The limit of stack items that can go in one eventlog message in bytes+-- with configurable the eventlog message size.+callStackSizeLimit_ :: Word64 -> Word16+callStackSizeLimit_ eventlogSize =   word64ToWord16-    ( eventlogBufferSize+    ( eventlogSize         - 2 {- 0xFFCA or 0xFFCB -}         - 4 {- Word32 of 'CapabilityId' -}         - 4 {- Word32 of 'ThreadId' -}@@ -173,10 +181,10 @@  -- | Size in bytes of the given 'BinaryStackItem' byteSizeOf :: BinaryStackItem -> Word16-byteSizeOf = \ case-  BinaryIpe{} -> 9-  BinaryMessage _ Nothing -> 9-  BinaryMessage _ (Just _) -> 17+byteSizeOf = \case+  BinaryIpe{} -> 1 + 8 {- 0x1 + Word64 of 'IpeId' -}+  BinaryMessage _ Nothing -> 1 + 8 {- 0x2 + Word64 of 'StringId' -}+  BinaryMessage _ (Just _) -> 1 + 8 + 8 {- 0x3 + Word64 of 'StringId' + Word64 of 'SourceLocationId' -}  instance Binary BinaryEventlogMessage where   put = \case

@@ -18,6 +18,7 @@   hydrateEventlogCallStackMessage,   catCallStackMessage,   chunkCallStackMessage,+  chunkCallStackMessage_,    -- * Message dehydration helpers   EncodingState,@@ -47,6 +48,7 @@ import GHC.Stack.Profiler.Core.Eventlog import GHC.Stack.Profiler.Core.SourceLocation import GHC.Stack.Profiler.Core.SymbolTable+import GHC.Stack.Profiler.Core.Util (word16ToInt)  -- ---------------------------------------------------------------------------- -- Thread Sample@@ -170,16 +172,18 @@       BinaryIpe ipeId ->         Right $ IpeId ipeId       BinaryMessage stringId mSrcLocId -> do-        str <- maybe-          (Left $ StringIdNotFound stringId)-          (Right . Text.unpack)-          (lookupStringId decodeTable stringId)+        str <-+          maybe+            (Left $ StringIdNotFound stringId)+            (Right . Text.unpack)+            (lookupStringId decodeTable stringId)         srcLoc <- case mSrcLocId of           Nothing -> pure Nothing-          Just srcLocId -> maybe-            (Left $ SourceLocationIdNotFound srcLocId)-            (Right . Just)-            (lookupSourceLocationId decodeTable srcLocId)+          Just srcLocId ->+            maybe+              (Left $ SourceLocationIdNotFound srcLocId)+              (Right . Just)+              (lookupSourceLocationId decodeTable srcLocId)         pure $ UserAnnotation str srcLoc      itemsOrErros = map decodeItem (binaryCallStack msg)@@ -219,21 +223,26 @@ -- 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 =+chunkCallStackMessage = chunkCallStackMessage_ callStackSizeLimit++-- | Same as 'chunkCallStackMessage', but allows to set the chunking size in bytes.+chunkCallStackMessage_ :: Word16 -> BinaryCallStackMessage -> [BinaryEventlogMessage]+chunkCallStackMessage_ chunkLimit16 msg0 =   let+    chunkLimitInt = word16ToInt chunkLimit16     items = binaryCallStack msg0     chunked =       let         go (!size, curChunk, restChunk) item =           let-            !bytes = byteSizeOf item+            !bytes = word16ToInt $ byteSizeOf item           in-            if size + bytes > callStackSizeLimit-              then (0, [item], curChunk : restChunk)-              else (size + bytes, item:curChunk, restChunk)+            if (size + bytes) < chunkLimitInt+              then (size + bytes, item : curChunk, restChunk)+              else (bytes, [item], curChunk : restChunk)         (_, lastChunk, initChunk) = List.foldl' go (0, [], []) items       in-        lastChunk:initChunk+        lastChunk : initChunk   in     mkEventlogMessages chunked  where

@@ -20,7 +20,7 @@   word16ToInt,   intToWord8,   word8ToInt,-  ) where+) where  import Control.Monad (replicateM) import Data.Binary

@@ -1,45 +1,99 @@ {-# OPTIONS_GHC -Wno-orphans #-}+ module Main where-import Test.Tasty-import Test.Tasty.QuickCheck++import Data.Binary+import Data.Binary.Put+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe import GHC.Stack.Profiler.Core.Eventlog import GHC.Stack.Profiler.Core.ThreadSample-import Data.Maybe-import qualified Data.List.NonEmpty as NonEmpty+import GHC.Stack.Profiler.Core.Util (word32ToWord64)+import Test.Tasty+import Test.Tasty.QuickCheck  main :: IO () main = defaultMain tests  tests :: TestTree-tests = testGroup "tests"-  [ properties-  ]+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+  testGroup+    "property"+    [ testProperty "chunkCallStackMessage . catCallStackMessage" $+        withNumTests 500 $+          withMaxSize (fromIntegral callStackSizeLimit * 3) $+            chunkingRoundTrip_prop callStackSizeLimit+    , testProperty "chunkCallStackMessage size < chunkCallStackMessage" $+        withNumTests 500 $ do+          withMaxSize (fromIntegral callStackSizeLimit * 3) $+            messageChunkSize_prop eventlogBufferSize callStackSizeLimit+    , testProperty "chunkCallStackMessage_ n . catCallStackMessage" $+        withNumTests 500 $+          withEventlogSizeGen $ \eventlogSize ->+            withMaxSize (fromIntegral eventlogSize * 20) $+              chunkingRoundTrip_prop (callStackSizeLimit_ eventlogSize)+    , testProperty "chunkCallStackMessage_ n < size" $+        withNumTests 500 $ do+          withEventlogSizeGen $ \eventlogSize ->+            withMaxSize (fromIntegral eventlogSize * 5) $+              messageChunkSize_prop eventlogSize (callStackSizeLimit_ eventlogSize)     ]+ where+  chunkingRoundTrip_prop stackSizeLimit message =+    let+      msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message)+      go = \case+        CallStackChunk csm -> Just csm+        CallStackFinal csm -> Just csm+        _ -> Nothing+    in+      catCallStackMessage (NonEmpty.fromList msgs) === message +  messageChunkSize_prop eventlogSize stackSizeLimit message =+    let+      msgs = mapMaybe go (chunkCallStackMessage_ stackSizeLimit message)+      go = \case+        CallStackChunk csm -> Just csm+        CallStackFinal csm -> Just csm+        _ -> Nothing+    in+      conjoin $+        map (eventlogMessageSmallerThanStackSizeLimit_prop (fromIntegral eventlogSize)) msgs++  eventlogMessageSmallerThanStackSizeLimit_prop :: Word -> BinaryCallStackMessage -> Property+  eventlogMessageSmallerThanStackSizeLimit_prop eventlogLimit chunk =+    let+      -- We need either 'CallStackFinal' or 'CallStackChunk' to add the leading '0xFFCA' or '0xFFCB'.+      -- This way, the eventlogLimit length is the correct thing to check.+      msg = runPut (put $ CallStackFinal chunk)+    in+      (LBS.length msg <= fromIntegral eventlogLimit) === True++withEventlogSizeGen :: (Word64 -> Property) -> Property+withEventlogSizeGen k =+  -- 29 bytes is minimum possible eventlog size.+  -- 12 bytes need to be subtracted for message overhead.+  -- The largest stack item is 17 bytes.+  forAll (choose (29, 1000)) k+ instance Arbitrary BinaryCallStackMessage where   arbitrary =     MkBinaryCallStackMessage-      <$> arbitrary+      <$> (word32ToWord64 <$> arbitrary)       <*> arbitrary       <*> arbitrary  instance Arbitrary CapabilityId where   arbitrary =-    MkCapabilityId <$> arbitrary+    MkCapabilityId <$> word32ToWord64 <$> arbitrary  instance Arbitrary BinaryStackItem where   arbitrary =