packages feed

ghc-stack-profiler 0.2.0.0 → 0.3.0.0

raw patch · 8 files changed

+149/−149 lines, 8 filesdep ~binarydep ~ghc-experimentaldep ~ghc-heap

Dependency ranges changed: binary, ghc-experimental, ghc-heap, ghc-internal, ghc-stack-profiler-core

Files

CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for ghc-stack-profiler +## 0.3.0.0 -- 2026-06-23++* Support GHC 10.1 [#29](https://github.com/well-typed/ghc-stack-profiler/pull/29)+  * Adds supports for optional source locations in stack annotations+* Add eventlog-socket tests to ghc-stack-profiler [#25](https://github.com/well-typed/ghc-stack-profiler/pull/25)+ ## 0.2.0.0 -- 2026-04-10  * Backport stack decoding segmentation fault fix from GHC HEAD [#20](https://github.com/well-typed/ghc-stack-profiler/pull/20)
ghc-stack-profiler.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler-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@@ -14,11 +14,13 @@   To profile a program it needs to be compiled and instrumented with the 'ghc-stack-profiler' package via:    @-  import GHC.Stack.Profiler.Sampler+  import GHC.Stack.Profiler    main :: IO ()-  main = 'withStackProfilerForMyThread' ('SampleIntervalMs' 10) $ do-      ...+  main = +    'withRootStackProfiler' True $ \ manager -> +      'withStackProfilerForMyThread' manager ('SampleIntervalMs' 10) $ do+        ...   @    This will spawn a profiling thread that will periodically take a snapshot of the current RTS callstack of your program and serialises it to the eventlog.@@ -54,9 +56,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  common warnings   ghc-options:@@ -106,7 +106,7 @@     GHC.Stack.Profiler     GHC.Stack.Profiler.Commands     GHC.Stack.Profiler.Decode-    GHC.Stack.Profiler.FFI+    GHC.Stack.Profiler.Eventlog.Socket     GHC.Stack.Profiler.Manager     GHC.Stack.Profiler.Stack.Compat     GHC.Stack.Profiler.Stack.Decode@@ -119,9 +119,9 @@     binary >=0.8.9.3 && <0.11,     bytestring >=0.11 && <0.13,     containers >=0.6.8 && <0.9,-    ghc-heap >=9.10.1 && <9.16,-    ghc-internal >=9.1001 && <9.1600,-    ghc-stack-profiler-core ==0.2.0.0,+    ghc-heap >=9.10.1 && <10.2,+    ghc-internal >=9.1001 && <10.200,+    ghc-stack-profiler-core ==0.3.0.0,     stm ^>=2.5.3.0 || ^>=2.5.0.0,     text >=2 && <2.2, @@ -129,7 +129,7 @@     src    if impl(ghc >=9.14)-    build-depends: ghc-experimental >=9.1400 && <9.1600+    build-depends: ghc-experimental >=9.1400 && <10.200    if flag(use-ghc-trace-events) || impl(ghc <9.12)     cpp-options:
src/GHC/Stack/Annotation/Experimental/Compat.hs view
@@ -3,21 +3,39 @@  module GHC.Stack.Annotation.Experimental.Compat (   SomeStackAnnotation (..),-  CallStackAnnotation (..),-  StringAnnotation (..),+  showStackAnnotationLocation,+  showStackAnnotationDescription, ) where  #if MIN_VERSION_ghc_internal(9,1400,0) import GHC.Stack.Annotation.Experimental #else import Data.Typeable-import GHC.Stack.Types (CallStack)+#endif+import GHC.Stack.Types (SrcLoc) ++#if !MIN_VERSION_ghc_internal(9,1400,0) data SomeStackAnnotation where   SomeStackAnnotation :: forall a. (Typeable a) => a -> SomeStackAnnotation+#endif -data StringAnnotation where-  StringAnnotation :: String -> StringAnnotation -newtype CallStackAnnotation = CallStackAnnotation CallStack+showStackAnnotationLocation :: SomeStackAnnotation -> Maybe SrcLoc+showStackAnnotationLocation =+#if MIN_VERSION_ghc_internal(9,1402,0)+  stackAnnotationSourceLocation+#else+  \ _ann -> Nothing+#endif+++showStackAnnotationDescription :: SomeStackAnnotation -> String+showStackAnnotationDescription =+#if MIN_VERSION_ghc_internal(9,1402,0)+  displayStackAnnotationShort+#elif MIN_VERSION_ghc_internal(9,1400,0)+  displayStackAnnotation+#else+  \ _ann -> "showStackAnnotationLocation: Impossible, no value should be created with ghc-internal < 9.1400" #endif
src/GHC/Stack/Profiler.hs view
@@ -49,7 +49,7 @@ import GHC.Stack.Profiler.Core.Util import GHC.Stack.Profiler.Decode import qualified GHC.Stack.Profiler.Decode as Decode-import qualified GHC.Stack.Profiler.FFI as FFI+import qualified GHC.Stack.Profiler.Eventlog.Socket as EventlogSocket import GHC.Stack.Profiler.Manager import GHC.Stack.Profiler.SymbolTable (readSymbolTable) @@ -117,7 +117,7 @@ runNewStackProfilerManager shouldRun = do   manager <- newStackProfilerManager shouldRun   startEventLoopThread manager-  FFI.installEventlogSocketHandlers manager `catches` FFI.defaultErrorHandlers+  EventlogSocket.registerWithEventlogSocket manager   pure manager  shutdownStackProfilerManager :: StackProfilerManager -> IO ()
src/GHC/Stack/Profiler/Decode.hs view
@@ -82,16 +82,13 @@   go :: SourceLocationId -> SourceLocation -> BinarySourceLocationMessage   go sid s =     let-      (funcId, newFuncName, _) = lookupOrInsertText table (writerTable table) (functionName s)       (fileId, newFileName, _) = lookupOrInsertText table (writerTable table) (fileName s)     in       -- These should always be found-      assert (not newFuncName) $-        assert (not newFileName) $-          MkBinarySourceLocationMessage-            { binarySourceLocationMessageId = sid-            , binarySourceLocationRow = line s-            , binarySourceLocationColumn = column s-            , binarySourceLocationFunctionId = funcId-            , binarySourceLocationFilename = fileId-            }+      assert (not newFileName) $+        MkBinarySourceLocationMessage+          { binarySourceLocationMessageId = sid+          , binarySourceLocationRow = line s+          , binarySourceLocationColumn = column s+          , binarySourceLocationFilename = fileId+          }
+ src/GHC/Stack/Profiler/Eventlog/Socket.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}++module GHC.Stack.Profiler.Eventlog.Socket (+  registerWithEventlogSocket,+) where++import GHC.Stack.Profiler.Manager (StackProfilerManager)++#ifdef EVENTLOG_SOCKET_SUPPORT+import qualified Control.Monad.STM as STM+import GHC.Eventlog.Socket (CommandId (..), Hook (..), registerCommand, registerHook, registerNamespace)+import GHC.Stack.Profiler.Commands (startProfiling, stopProfiling, sendEnableEventlogMessage, sendDisableEventlogMessage, sendPublishInitEventMessages)+import GHC.Stack.Profiler.Manager (disableEventLogging)+import Debug.Trace (traceMarkerIO)+#endif++-- | Register the @eventlog-socket@ custom command handlers and lifecycle hooks.+--+-- This adds support for the following @eventlog-socket@ custom commands:+--+-- * @0x01@: Start profiling.+-- * @0x02@: Stop profiling.+--+-- If built with @+control@, this may throw an [@EventlogSocketControlError@](https://hackage-content.haskell.org/package/eventlog-socket/docs/GHC-Eventlog-Socket.html#t:EventlogSocketControlError).+registerWithEventlogSocket :: StackProfilerManager -> IO ()+#ifdef EVENTLOG_SOCKET_SUPPORT+registerWithEventlogSocket = registerWithEventlogSocketIfSupported+#else+registerWithEventlogSocket = const $ pure ()+#endif++#ifdef EVENTLOG_SOCKET_SUPPORT+-- The real implementation of @registerWithEventlogSocket@.+registerWithEventlogSocketIfSupported :: StackProfilerManager -> IO ()+registerWithEventlogSocketIfSupported manager = do+  -- Register the PostStartEventLogging and PreEndEventLogging hooks.+  registerHook HookPostStartEventLogging $ startEventLoggingHook manager+  registerHook HookPreEndEventLogging $ endEventLoggingHook manager++  -- Register the custom commands under the ghc-stack-profiler namespace.+  ns <- registerNamespace "ghc-stack-profiler"+  registerCommand ns startProfilerCommandId (startProfilerCommand manager)+  registerCommand ns stopProfilerCommandId (stopProfilerCommand manager)++-- The @startProfiler@ command ID.+startProfilerCommandId :: CommandId+startProfilerCommandId = CommandId 0x1++-- The @stopProfiler@ command ID.+stopProfilerCommandId :: CommandId+stopProfilerCommandId = CommandId 0x2++-- | The handler for @eventlog-socket@'s @PostStartEventLogging@ hook.+--+-- This publishes the init events, flushes the eventlog, informs the manager+-- that the eventlog is enabled, and blocks until this message is processed.+startEventLoggingHook :: StackProfilerManager -> IO ()+startEventLoggingHook manager = do+  sendPublishInitEventMessages manager+  sendEnableEventlogMessage manager++-- | The handler for @eventlog-socket@'s @PreEndEventLogging@ hook.+--+-- This stops all profiler threads from writing to the eventlog, which stops+-- all sampler threads, informs the manager that the eventlog is disabled, and+-- blocks until this message is processed.+endEventLoggingHook :: StackProfilerManager -> IO ()+endEventLoggingHook manager = do+  STM.atomically $ disableEventLogging manager+  sendDisableEventlogMessage manager++-- | The handler for the @StartProfiling@ custom command.+startProfilerCommand :: StackProfilerManager -> IO ()+startProfilerCommand manager = do+  traceMarkerIO "ghc-stack-profiler: Start profiling"+  startProfiling manager++-- | The handler for the @StopProfiling@ custom command.+stopProfilerCommand :: StackProfilerManager -> IO ()+stopProfilerCommand manager = do+  stopProfiling manager+  traceMarkerIO "ghc-stack-profiler: Stop profiling"+#endif
− src/GHC/Stack/Profiler/FFI.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--module GHC.Stack.Profiler.FFI (-  installEventlogSocketHandlers,-  defaultErrorHandlers,-) where--#if defined(EVENTLOG_SOCKET_SUPPORT)-import GHC.Eventlog.Socket-import System.IO (hPutStrLn, stderr)-#endif--import Control.Exception-import qualified Control.Monad.STM as STM-import GHC.Stack.Profiler.Manager-import GHC.Stack.Profiler.Commands--#if defined(EVENTLOG_SOCKET_SUPPORT)-startProfilerCommandId :: CommandId-startProfilerCommandId = CommandId 0x1--stopProfilerCommandId :: CommandId-stopProfilerCommandId = CommandId 0x2-#endif---- | Install the @eventlog-socket@ custom command handlers and lifecycle hooks.------ The supported custom commands are:--- * Start the profiler--- * Stop the profiler------ We implement the lifecycle hooks for stopping the eventlog and starting--- writing to the eventlog.--- When we start eventlogging, we post the definitions of the existing callstack--- definitions, e.g., string and source locations.------ May throw 'EventlogSocketControlError' when registering @eventlog-socket@--- hooks fails.-installEventlogSocketHandlers :: StackProfilerManager -> IO ()-installEventlogSocketHandlers =-#if defined(EVENTLOG_SOCKET_SUPPORT)-  \ manager -> do-    registerEventlogSocketHooks manager-  where-    registerEventlogSocketHooks manager = do-      registerHook HookPostStartEventLogging $-        startEventLoggingHook manager-      registerHook HookPreEndEventLogging $-        endEventLoggingHook manager-      ns <- registerNamespace "ghc-stack-profiler"-      registerCommand ns startProfilerCommandId (startProfilerCommand manager)-      registerCommand ns stopProfilerCommandId (stopProfilerCommand manager)-#else-  \ _manager ->-    pure ()-#endif--defaultErrorHandlers :: [Handler ()]-defaultErrorHandlers =-  [-#if defined(EVENTLOG_SOCKET_SUPPORT)-    Handler $ \ (e :: EventlogSocketControlError) -> do-      hPutStrLn stderr "Failed to register eventlog-socket commands"-      hPutStrLn stderr (displayException e)-#endif-  ]---- | Post-start EventLogging hook.------ 1. Publish init events and flush the eventlog.--- 2. Inform the main loop that the eventlog is ready for messages now.-startEventLoggingHook :: StackProfilerManager -> IO ()-startEventLoggingHook manager = do-  sendPublishInitEventMessages manager-  -- Block until start message has been processed-  sendEnableEventlogMessage manager---- | Pre-end EventLogging hook.-endEventLoggingHook :: StackProfilerManager -> IO ()-endEventLoggingHook manager = do-  -- Disallow logging any more messages to the eventlog.-  -- Stops the profiler sampling threads.-  STM.atomically $ disableEventLogging manager--  -- Block until all messages have been processed-  sendDisableEventlogMessage manager--startProfilerCommand :: StackProfilerManager -> IO ()-startProfilerCommand manager = do-  startProfiling manager--stopProfilerCommand :: StackProfilerManager -> IO ()-stopProfilerCommand manager = do-  stopProfiling manager
src/GHC/Stack/Profiler/Stack/Decode.hs view
@@ -6,7 +6,6 @@  import Data.Maybe (catMaybes) import qualified Data.Text as Text-import Data.Typeable (cast) import Unsafe.Coerce (unsafeCoerce)  import GHC.Internal.ClosureTypes.Compat@@ -55,28 +54,21 @@       let         Box annotation = getClosureBox stack# (index + offsetStgAnnFrameAnn)       in-        pure $ stackAnnotationToStackItem (unsafeCoerce annotation)+        pure $ Just $ stackAnnotationToStackItem (unsafeCoerce annotation)     _ ->       fmap (IpeId . MkIpeId) <$> lookupIpeIdForStackFrame stackItbl -stackAnnotationToStackItem :: SomeStackAnnotation -> Maybe StackItem-stackAnnotationToStackItem = \case-  SomeStackAnnotation ann ->-    case cast ann of-      Just (CallStackAnnotation cs) ->-        case getCallStack cs of-          [] -> Nothing-          ((name, sourceLoc) : _) ->-            Just $-              SourceLocation $-                MkSourceLocation-                  { line = intToWord32 $ srcLocStartLine sourceLoc-                  , column = intToWord32 $ srcLocStartCol sourceLoc-                  , functionName = Text.pack $ name-                  , fileName = Text.pack $ srcLocFile sourceLoc-                  }-      Nothing -> case cast ann of-        Just (StringAnnotation msg) ->-          Just $ UserMessage msg-        Nothing ->-          Nothing+stackAnnotationToStackItem :: SomeStackAnnotation -> StackItem+stackAnnotationToStackItem someStackAnnotation =+  let+    message = showStackAnnotationDescription someStackAnnotation+    sourceLoc = do+      srcLoc <- showStackAnnotationLocation someStackAnnotation+      Just $+        MkSourceLocation+          { line = intToWord32 $ srcLocStartLine srcLoc+          , column = intToWord32 $ srcLocStartCol srcLoc+          , fileName = Text.pack $ srcLocFile srcLoc+          }+  in+    UserAnnotation message sourceLoc