diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/ghc-stack-profiler-core.cabal b/ghc-stack-profiler-core.cabal --- a/ghc-stack-profiler-core.cabal +++ b/ghc-stack-profiler-core.cabal @@ -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 diff --git a/src/GHC/Stack/Profiler/Core/Eventlog.hs b/src/GHC/Stack/Profiler/Core/Eventlog.hs --- a/src/GHC/Stack/Profiler/Core/Eventlog.hs +++ b/src/GHC/Stack/Profiler/Core/Eventlog.hs @@ -18,7 +18,8 @@ callStackStringMessageTag, callStackSourceLocationMessageTag, callStackMessageTags, - callStackItemLimit, + callStackSizeLimit, + byteSizeOf, eventlogBufferSize, stringLengthLimit, ) where @@ -42,22 +43,22 @@ -- -- @ -- MESSAGE --- := "FF" "CA" --- | "FF" "CB" --- | "FF" "CC" --- | "FF" "CD" +-- := 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" --- | "02" --- | "03" +-- := 01 (ipe: 'Word64') +-- | 02 (stringId: 'Word64') +-- | 03 (stringId: 'Word64') (srcLocId: 'Word64') -- -- CStringLen --- := + +-- := (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 diff --git a/src/GHC/Stack/Profiler/Core/SourceLocation.hs b/src/GHC/Stack/Profiler/Core/SourceLocation.hs --- a/src/GHC/Stack/Profiler/Core/SourceLocation.hs +++ b/src/GHC/Stack/Profiler/Core/SourceLocation.hs @@ -8,7 +8,6 @@ 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 --- a/src/GHC/Stack/Profiler/Core/SymbolTable.hs +++ b/src/GHC/Stack/Profiler/Core/SymbolTable.hs @@ -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 } diff --git a/src/GHC/Stack/Profiler/Core/ThreadSample.hs b/src/GHC/Stack/Profiler/Core/ThreadSample.hs --- a/src/GHC/Stack/Profiler/Core/ThreadSample.hs +++ b/src/GHC/Stack/Profiler/Core/ThreadSample.hs @@ -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 diff --git a/src/GHC/Stack/Profiler/Core/Util.hs b/src/GHC/Stack/Profiler/Core/Util.hs --- a/src/GHC/Stack/Profiler/Core/Util.hs +++ b/src/GHC/Stack/Profiler/Core/Util.hs @@ -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 (:) [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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