packages feed

ghc-stack-profiler 0.4.0.0 → 0.5.0.0

raw patch · 23 files changed

+1931/−919 lines, 23 filesdep +ghc-stack-profilerdep +tastydep +tasty-hunitdep ~basedep ~ghc-stack-profiler-core

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

Dependency ranges changed: base, ghc-stack-profiler-core

Files

CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for ghc-stack-profiler +## 0.5.0.0 -- 2026-09-14++Major revision of the public API.+ ## 0.4.0.0 -- 2026-07-14  Major version number changed to match `ghc-stack-profiler-speedscope`.
+ README.md view
@@ -0,0 +1,255 @@+![GitHub Actions Workflow Status](https://img.shields.io/github/actions/workflow/status/well-typed/ghc-stack-profiler/ci.yml?style=for-the-badge) ![Hackage Version](https://img.shields.io/hackage/v/ghc-stack-profiler?style=for-the-badge) ![License: BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue?style=for-the-badge) ![Stability: Experimental](https://img.shields.io/badge/stability-experimental-yellow?style=for-the-badge)++_A light-weight call-stack profiler for GHC!_++# GHC Stack Profiler++> ⚠️ **Warning:** This package is experimental. It is versioned according to the PVP. Breaking changes should be expected and no effort will be made to avoid major version bumps.++> ⚠️ **Warning:** Due to a bug in GHC, copying the call-stack may cause a segfault at runtime in applications built with GHC 9.14.1 and older. If you use GHC Stack Profiler in production, you should build your application with GHC 9.14.2 or newer.++GHC Stack Profiler periodically samples the GHC runtime call-stack and writes these samples to the eventlog.+These eventlogs can be used in two ways:++- [`ghc-stack-profiler-speedscope`](https://hackage.haskell.org/package/ghc-stack-profiler-speedscope) can be used to export call-stack profiles to [speedscope](https://www.speedscope.app/).+- [`eventlog-live-otlp`](https://github.com/well-typed/eventlog-live#readme) can stream call-stack profiles, in real-time, to any observability platform that supports the [OpenTelemetry](https://opentelemetry.io/) protocol, such as [Grafana Cloud](https://grafana.com/).++Unlike GHC's built-in cost-centre stack profiler, GHC Stack Profiler does _not_ require you to rebuild your program with profiling support and has virtually no overhead when it's not running. (See [Benchmarks](#benchmarks).)++The following is a screenshot of [speedscope](https://www.speedscope.app/) that shows a call-stack profile of Agda version 2.8.0.1 checking the standard library created using GHC Stack Profiler:++![A call-stack profile of Agda 2.8.0.1 checking the standard library.](https://github.com/well-typed/ghc-stack-profiler/blob/0.5.0.0/assets/agda-with-ghc-stack-profiler-2026-09-11.png?raw=true)++## Table of Contents++- [Getting Started](#getting-started)+  - [Instrument your application with GHC Stack Profiler](#instrument-your-application-with-ghc-stack-profiler)+  - [GHC Stack Profiler with Speedscope](#ghc-stack-profiler-with-speedscope)+  - [GHC Stack Profiler with Eventlog Live – Real-Time Call-Stack Profiles](#ghc-stack-profiler-with-eventlog-live-real-time-call-stack-profiles)+  - [GHC Stack Profiler with Eventlog Socket – Dynamic Control](#ghc-stack-profiler-with-eventlog-socket--dynamic-control)+- [Benchmarks](#benchmarks)+  - [Benchmark: Agda 2.8.0.1 checking the standard library](#benchmark-agda-2801-checking-the-standard-library)+  - [Benchmark: GHC 10.1 loading `Cabal-syntax`](#benchmark-ghc-101-loading-cabal-syntax)++## Getting Started++Let's get GHC Stack Profiler working with your application, which we'll conveniently call `your-application`.++In the first two sections, we'll instrument your application with GHC Stack Profiler and visualise the call-stack profile of a completed run using [speedscope](https://www.speedscope.app/). In the last two sections, we'll add [Eventlog Live](https://github.com/well-typed/eventlog-live) and [Eventlog Socket](https://github.com/well-typed/eventlog-socket) to visualise your application's call-stack profiles in real-time and control GHC Stack Profiler from your observability dashboard.++### Instrument your application with GHC Stack Profiler++To instrument your application with GHC Stack Profiler, you need to make four changes:++1.  Add `ghc-stack-profiler` to the `build-depends` for your application:++    ```diff+      executable your-application+        ...++        build-depends:+          ...+    +     , ghc-stack-profiler ==0.5.0.0+    ```++    > ⚠️ **Warning:** If you're using `ghc-stack-profiler-speedscope`, `eventlog-live-otlp`, or any other program that processes the eventlog produced by `ghc-stack-profiler`, it is important that both are built with the same version of `ghc-stack-profiler-core`.++2.  Build your application with support for RTS options and the threaded runtime.++    Add the following to the `executable` section of your application:++    ```diff+      executable your-application+        ...++    +   ghc-options: -rtsopts+    +   ghc-options: -threaded+    ```++    The [`-rtsopts`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-rtsopts-none-some-all-ignore-ignoreAll) flag enables the RTS options for your application. This allows us to enable the eventlog at runtime and enable various kinds of profiling. Setting this option may pose a security risk. If this is a concern, you can set all the required RTS options at compile time using [`-with-rtsopts`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-with-rtsopts-opts).++    The [`-threaded`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-threaded) flag builds your application with the threaded RTS.++3.  Instrument your main function:++    ```diff+      module Main where+      ...++    + import GHC.Stack.Profiler (withProfilerFromEnv)++      main :: IO ()+      main =+    +   withProfilerFromEnv $+          ...+    ```++    > ℹ️ **Tip:**+    > If you prefer not to configure your program from the environment, the [GHC.Stack.Profiler](https://hackage.haskell.org/package/ghc-stack-profiler/docs/GHC-Stack-Profiler.html) exposes a variety of function that instrument your program.++    > ℹ️ **Tip:**+    > You can use the [`annotateStackIO`](https://hackage-content.haskell.org/package/ghc-stack-annotations/docs/GHC-Stack-Annotation.html#v:annotateStackIO) functions from [`ghc-stack-annotations`](https://hackage-content.haskell.org/package/ghc-stack-annotations) to push annotation frames onto the call-stack at runtime.+    > These annotation frames are visible in call-stack profiles captured by GHC Stack Profiler.+    > See [Better Haskell stack traces via user annotations](https://www.well-typed.com/blog/2025/09/better-haskell-stack-traces/).++4.  Build your application and its dependencies with info table maps.++    Let's do this in two steps:+    1.  To build your application and its dependencies with info table maps, you must ensure that they are built with the `-finfo-table-map` and `-fdistinct-constructor-tables` GHC options.++        The easiest way to do this is to add the following to your `cabal.project` file:++        ```+        package *+          ghc-options:+            -finfo-table-map+            -fdistinct-constructor-tables+        ```++        There is currently no easy way to pass GHC options to all packages when using `cabal install`.+        As a workaround, you can add a `cabal.project` file to a source distribution and install from there.++        If you run GHC Stack Profiler with your application built this way, you will get detailed information for all the symbols defined in your application and most symbols defined in your dependencies.+        However, you will see some unresolved info tables, which will show as numbers, e.g., `0x100000000`.+        These are symbols that are either built into GHC or defined in the [_boot libraries_](https://gitlab.haskell.org/ghc/ghc/-/wikis/working-conventions/boot-libraries) that came with GHC, such as `base`.+        The boot packages are _never_ rebuilt by Cabal and are unaffected by the `package *` stanza.++    2.  To build the GHC and the boot libraries with info table maps, you must build GHC with the `+ipe` flavour.++        The easiest way to do this is using `ghcup`. Some variant of the following command may work for you:++        ```sh+        ghcup compile ghc -j0 -b 9.10.3 -v 9.10.3 -f perf+ipe -o '%v-ipe' --+        ```++        You may need to pass the appropriate configure flags for your platform.+        See [Building and Porting GHC](https://gitlab.haskell.org/ghc/ghc/-/wikis/building#building-and-porting-ghc).++    Once you have a version of GHC built with the `+ipe` flavour and rebuilt application, you should no longer see unresolved info tables.++### GHC Stack Profiler with Speedscope++If you have instrumented your application, you can run it with GHC Stack Profiler and export a call-stack profile to the [speedscope](https://www.speedscope.app/) format:++```sh+# Configure GHC Stack Profiler+export GHC_STACK_PROFILER="ON" # or any other non-empty value+export GHC_STACK_PROFILER_SAMPLE_INTERVAL="10" # milliseconds++# Start your application+./your-application               \+    +RTS                         \+    -l                           \+    -olyour-application.eventlog \+    -RTS++# Export the eventlog to speedscope+ghc-stack-profiler-speedscope \+    your-application.eventlog \+    your-application.json+```++To view your call-stack profile, open [speedscope](https://www.speedscope.app/) and load `your-application.json`.++The `ghc-stack-profiler-speedscope` program has several options that control the speedscope profile:++- You can restrict your profile to the section between start and end markers (using `--start`/`--end`), which you can emit from your application using [`traceMarkerIO`](https://hackage-content.haskell.org/package/base/docs/Debug-Trace.html#v:traceMarkerIO).++  Let's say your application has to do some setup and cleanup, but you're only interested in profiling The Big Chore. If you instrument your application as follows and call `ghc-stack-profiler-speedscope` with `--start=START` and `--end=END`, your profile will only include samples from The Big Chore:++  ```hs+  main = do+    doSomeSetup           -- Not included in profile.+    traceMarkerIO "START" -- Start marker.+    doTheBigChore         -- Included in profile.+    traceMarkerIO "END"   -- End marker.+    doSomeCleanup         -- Not included in profile.+  ```++  > ℹ️ **Tip:** This applies a post-hoc filter, which means that GHC Stack Profiling will still be sampling during the setup and cleanup. If you want to sample _only_ during The Big Chore, you can use either [`startProfiling`](https://hackage-content.haskell.org/package/ghc-stack-profiler/docs/GHC-Stack-Profiler.html#v:startProfiling)/[`stopProfiling`](https://hackage-content.haskell.org/package/ghc-stack-profiler/docs/GHC-Stack-Profiler.html#v:stopProfiling) or the [Eventlog Socket control commands](#eventlog-socket--sockets-and-dynamic-control).++- You can aggregate your application's profiles by thread or capability:+  - `--per-thread`: Group the profiles by thread. (Default.)+  - `--per-capability`: Group the profiles by capability.+  - `--no-aggregation`: Do not aggregate the profiles.++### GHC Stack Profiler with Eventlog Live – Real-Time Call-Stack Profiles++If you have instrumented your application, you can run it with GHC Stack Profiler and Eventlog Live and stream call-stack profiles, in real-time, to any observability platform that supports the [OpenTelemetry](https://opentelemetry.io/) protocol, such as [Grafana Cloud](https://grafana.com/). For detailed instructions, see the section [Eventlog Live with GHC Stack Profiler](https://github.com/well-typed/eventlog-live#eventlog-live-with-ghc-stack-profiler) in the README for Eventlog Live.++The following shows real-time call-stack profiles visualised in Grafana:++![A screen recording of the Grafana Call-Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/ghc-stack-profiler/blob/0.5.0.0/assets/jumpy-jump-with-ghc-stack-profiler-2026-07-31.gif?raw=true)++### GHC Stack Profiler with Eventlog Socket – Dynamic Control++When compiled with the `+control` feature flag, GHC Stack Profiler has built-in support for Eventlog Socket's control commands. This lets you dynamically start and stop profiling by writing the command to the eventlog socket. For a detailed explanation of control commands, see the section [Control Commands](https://github.com/well-typed/eventlog-socket#control-commands) in the README for Eventlog Socket.++If you are using Eventlog Live, you can use its control server to send the GHC Stack Profiler control commands via HTTP. This lets you control profiling from your observability dashboard, e.g., using the Start/Stop buttons at the bottom of the Grafana dashboard in [the previous section](#eventlog-live-real-time-call-stack-profiles). For detailed instructions, see the section [Eventlog Live with Eventlog Socket](https://github.com/well-typed/eventlog-live/tree/main/eventlog-live#eventlog-live-with-eventlog-socket) in the README for Eventlog Live.++## Benchmarks++This section discusses our benchmarks that measure the overhead of instrumenting and profiling your application with GHC Stack Profiler and GHC's built-in cost-centre profiler. Our conclusions:++- Instrumenting your application with GHC Stack Profiler has no measurable overhead.++  Running GHC Stack Profiler has about 2% overhead with no significant difference between the measured sample intervals.++- Instrumenting your application with the cost-centre profiler has around 50% overhead with no cost centres and around 100% overhead with late cost centres.++  Running the cost-centre profiler has an additional 2% overhead with no significant difference between the measured sample intervals.++### Benchmark: Agda 2.8.0.1 checking the standard library++The benchmark measures Agda 2.8.0.1 checking the standard library:++```sh+# from within std-lib/ in the Agda repository+agda --build-library +RTS -N1+```++There are three classes of benchmarks:++- The `baseline` benchmark uses Agda with no modifications.++- The `ghc-stack-profiler` benchmarks use Agda instrumented with `ghc-stack-profiler`.++  (For details, see [Instrument your application with GHC Stack Profiler](#instrument-your-application-with-ghc-stack-profiler).)++- The `profiling` benchmarks use Agda instrumented with cost-centre profiling, using the following `cabal.project`, where the value of `profiling-detail` taken from the benchmark name:++  ```hs+  profiling: True++  package *+    profiling-detail: none -- or late+  ```++  (The `-p` RTS option was used to the profiler and the `-V` RTS option was used to set the sample interval.)++The results are normalised as a percentage of the `baseline` benchmark which took, on average, 3 minutes and 55 seconds on an otherwise idle machine. The timings are the result of, on average, 10 runs excluding warm-up.++![A bar chart that shows the relative timing of the various benchmarks compared to the baseline. For GHC Stack Profiler, the "instrumented only" benchmark has no measurable overhead, and both benchmarks that sample the call-stack have about 2% overhead. For cost-centre profiling, the "instrumented only" benchmark that introduces no cost centres has 54% overhead, the "instrumented only" benchmark that introduces late cost centres has 96% overhead, and both benchmarks that sample the cost-centre stacks have another 2% overhead on top of that.](https://github.com/well-typed/ghc-stack-profiler/blob/0.5.0.0/assets/benchmark-agda-2.8.0.1-checking-agda-stdlib.png?raw=true)++### Benchmark: GHC 10.1 loading `Cabal-syntax`++The benchmark measures GHC 10.1 (9a442c9383) loading `Cabal-syntax` in interactive mode, using the GHC command obtained from `hie-bios`:++```sh+# from within libraries/Cabal/ in the GHC repository+hie-bios -v debug Cabal-syntax/src/Distribution/CabalSpecVersion.hs+```++There two classes of benchmarks:++- The `ghc-stack-profiler` benchmarks use GHC instrumented with `ghc-stack-profiler`.++  (For details, see [Instrument your application with GHC Stack Profiler](#instrument-your-application-with-ghc-stack-profiler).)++- The `profiling` benchmarks use GHC instrumented with cost-centre profiling, using the `default` build flavour with the `profiled_ghc` [flavour transformer](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/flavours.md), which builds GHC and its dependencies with profiling and adds late cost centres.++  (The `-pj` RTS option was used to enable the profiler and the `-V` RTS option was used to set the sample interval.)++The results are normalised as a percentage of the `ghc-stack-profiler (instrumented only)` benchmark which took, on average, 7 seconds. The timings are the result of, on average, 3 runs without warm-up on a noisy machine. The measurement that shows that sampling at a 10ms interval is slower than a 1ms interval is likely due to this noise. We did not include a `baseline` benchmark with an uninstrumented GHC, as there was no measurable overhead in the previous benchmark. We also did not include a `profiling (instrumented only, profiling-detail: none)` benchmark, as that would have required adding a new flavour transformer to GHC's build system.++![A bar chart that shows the relative timing of the various benchmarks compared to the "instrumented only" benchmark for GHC Stack Profiler. For GHC Stack Profiler, both benchmarks that sample the call-stack have about 7-8% overhead. For cost-centre profiling, the "instrumented only" benchmark has about 128% overhead, and both benchmarks that sample the cost-centre stacks have another 3-8% overhead.](https://github.com/well-typed/ghc-stack-profiler/blob/0.5.0.0/assets/benchmark-ghc-10.1-9a442c9383-loading-Cabal-syntax.png?raw=true)
ghc-stack-profiler.cabal view
@@ -1,59 +1,16 @@ cabal-version: 3.8 name: ghc-stack-profiler-version: 0.4.0.0+version: 0.5.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com build-type: Simple-synopsis: RTS Callstack profiler for GHC.-description:-  RTS Callstack profiler for GHC.--  The main idea is to periodically sample the Haskell callstack and use IPE and [stack annotation](https://www.well-typed.com/blog/2025/09/better-haskell-stack-traces/) information in order to understand the source locations which-  correspond to the stack frames.-  To profile a program it needs to be compiled and instrumented with the 'ghc-stack-profiler' package via:--  @-  import GHC.Stack.Profiler--  main :: IO ()-  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.--  To improve readability of the profile, compile the program with @-finfo-table-map@ and @-fdistinct-constructor-tables@.-  Using @cabal@, this can be achieved with an appropriate @cabal.project@ file:--  @-  packages: ...--  ...--  package *-      ghc-options: -finfo-table-map -fdistinct-constructor-tables-  @--  To emit the eventlog messages by the profiler, you need to run your program with the @-l@ RTS flag, for example via:--  @-  ./\<program\> ... +RTS -l -RTS-  @--  This will write out an eventlog to @\<program\>.eventlog@ which can be transformed for [speedscope.app](https://www.speedscope.app/) via the script 'ghc-stack-profiler-speedscope'.--  @-  ghc-stack-profiler-speedscope \<program\>.eventlog-  @--  The resulting profile @\<program\>.eventlog.json@ can be viewed and further analysed in [speedscope.app](https://www.speedscope.app/).--  Note that the results are affected by compilation optimisation options, such as @-fno-omit-yields@.+synopsis: A light-weight call-stack profiler for GHC+description: A light-weight call-stack profiler for GHC!+extra-doc-files:+  CHANGELOG.md+  README.md -extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development tested-with:   ghc ==10.1 || ==9.14.1 || ==9.12.2 || ==9.10.3@@ -72,6 +29,7 @@     NamedFieldPuns     NoImportQualifiedPost     PatternSynonyms+    TypeFamilies     ViewPatterns    default-language: GHC2021@@ -96,6 +54,9 @@     warnings, exts    exposed-modules:+    GHC.Stack.Profiler++  other-modules:     Debug.Trace.Binary.Compat     GHC.Internal.ClosureTypes.Compat     GHC.Internal.Heap.Closures.Compat@@ -103,25 +64,24 @@     GHC.Internal.Stack.Constants.Compat     GHC.Internal.Stack.Decode.Compat     GHC.Stack.Annotation.Experimental.Compat-    GHC.Stack.Profiler-    GHC.Stack.Profiler.Commands-    GHC.Stack.Profiler.Decode-    GHC.Stack.Profiler.Eventlog.Socket-    GHC.Stack.Profiler.Manager-    GHC.Stack.Profiler.Stack.Compat-    GHC.Stack.Profiler.Stack.Decode-    GHC.Stack.Profiler.SymbolTable-    GHC.Stack.Profiler.Util+    GHC.Stack.Profiler.Internal.Decode+    GHC.Stack.Profiler.Internal.Eventlog.Socket+    GHC.Stack.Profiler.Internal.Manager+    GHC.Stack.Profiler.Internal.Sampler+    GHC.Stack.Profiler.Internal.Stack.Compat+    GHC.Stack.Profiler.Internal.Stack.Decode+    GHC.Stack.Profiler.Internal.SymbolTable+    GHC.Stack.Profiler.Internal.Util    build-depends:     async >=2.2 && <2.2.6,-    base >=4.20 && <4.23,+    base >=4.20 && <5,     binary >=0.8.9.3 && <0.11,     bytestring >=0.11 && <0.13,     containers >=0.6.8 && <0.9,     ghc-heap >=9.10.1 && <10.2,     ghc-internal >=9.1001 && <10.200,-    ghc-stack-profiler-core >=0.3 && <0.5,+    ghc-stack-profiler-core ==0.5.0.0,     stm ^>=2.5.3.0 || ^>=2.5.0.0,     text >=2 && <2.2, @@ -158,6 +118,19 @@      build-depends:       eventlog-socket ^>=0.1.3++test-suite ghc-stack-profiler-tests+  import: warnings, exts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base,+    ghc-stack-profiler,+    tasty >=1.5.4 && <1.6,+    tasty-hunit,++  default-language: GHC2021  source-repository head   type: git
src/GHC/Internal/InfoProv/Types/Compat.hsc view
@@ -11,7 +11,7 @@ #if !MIN_VERSION_ghc_internal(9,1500,0) import Foreign.C.Types import Foreign.Marshal.Alloc-import GHC.Stack.Profiler.Util (castPtrToWord64)+import GHC.Stack.Profiler.Internal.Util (castPtrToWord64) #endif  import qualified GHC.Internal.InfoProv.Types as InfoProv
src/GHC/Internal/Stack/Decode/Compat.hs view
@@ -46,7 +46,7 @@ type StackFrameLocation = (StackSnapshot, WordOffset)  data StackInfoTable = StackInfoTable-  { infoTableStructPtr :: Ptr InfoProv.StgInfoTable+  { infoTableStructPtr :: Ptr {-InfoProv.-} StgInfoTable   , infoTablePtr :: Ptr InfoProv.StgInfoTable   , infoTable :: StgInfoTable   }
src/GHC/Stack/Profiler.hs view
@@ -1,393 +1,567 @@ module GHC.Stack.Profiler (-  -- * Run sample profiler-  withStackProfiler,-  withStackProfilerForMyThread,-  withStackProfilerForThread,-  withRootStackProfiler,-  shutdownStackProfilerManager,+  -- * High-Level API -  -- * Configuration of sample profiler-  StackProfilerManager (..),-  ProfilerSamplingInterval (..),+  -- ** Profiler+  Profiler (..),+  withProfiler,+  withProfilerWith,+  withProfilerFromEnv,+  startProfiler,+  startProfilerWith,+  startProfilerFromEnv,+  stopProfiler, -  -- * Basic thread sampler-  sampleThread,+  -- ** Options+  Options (+    wait,+    shouldSample,+    sampleRtsThreads,+    sampleProfilerThreads,+    sampleInterval+  ),+  defaultOptions,+  Interval (..), -  -- * Low level helpers for setting up custom sample profilers threads-  runWithStackProfiler,-  setupStackProfilerThread,-  stopStackProfilerThread,+  -- *** Thread Filters and Glob Patterns+  ThreadFilter,+  ThreadLabel,+  ShouldSample (..),+  Glob,+  matches,+  sampleInclude,+  sampleExclude,+  sampleIncludeExclude, -  -- * Thread filtering-  isProfilerThread,-  isRtsThread,-) where+  -- *** Environment Variables+  fromEnv, -import GHC.Conc-import GHC.Conc.Sync (fromThreadId, threadLabel)-import GHC.Stack.CloneStack (cloneThreadStack)+  -- * Low-Level API -import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Concurrent.Chan as Chan-import qualified Control.Concurrent.STM.TVar as STM+  -- ** Manager+  Manager,+  withManager,+  startManager,+  stopManager,++  -- ** Commands+  startProfiling,+  stopProfiling,++  -- ** Samplers+  Sampler,+  withSamplerForMe,+  startSamplerFor,+  startSamplerWith,+  stopSampler,+) where++import Control.Concurrent.Async (Async (..)) import Control.Exception-import Control.Monad-import qualified Control.Monad.STM as STM-import qualified Data.ByteString.Lazy as LBS+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bifunctor (Bifunctor (..)) import Data.Foldable (traverse_)-import qualified Data.List as List+import Data.Functor ((<&>))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (isPrefixOf) import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromMaybe) import Data.Set (Set)+import qualified Data.Set as S import qualified Data.Set as Set-import qualified Debug.Trace-import qualified Debug.Trace.Binary.Compat as Compat--import GHC.Stack.Profiler.Commands (sendStopProfilingMessage)-import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.ThreadSample-import GHC.Stack.Profiler.Core.Util-import GHC.Stack.Profiler.Decode-import qualified GHC.Stack.Profiler.Decode as Decode-import qualified GHC.Stack.Profiler.Eventlog.Socket as EventlogSocket-import GHC.Stack.Profiler.Manager-import GHC.Stack.Profiler.SymbolTable (readSymbolTable)---- | Sampling intervals for the stack profiler.-data ProfilerSamplingInterval-  = -- | Sample every @n@ milliseconds.-    ---    -- Recommended value: @'SampleIntervalMs' 10@ or @'SampleIntervalMs' 20@.-    SampleIntervalMs Int-  deriving (Show, Eq, Ord)+import Data.String (IsString (..))+import GHC.Conc+import GHC.Conc.Sync (threadLabel)+import GHC.IsList (IsList (..))+import qualified GHC.Stack.Profiler.Internal.Eventlog.Socket as Eventlog.Socket+import GHC.Stack.Profiler.Internal.Manager+import GHC.Stack.Profiler.Internal.Sampler (Interval (MkIntervalMillis), SamplerDescr (MkSamplerDescr), startSampler, stopSampler, withSampler)+import qualified GHC.Stack.Profiler.Internal.Sampler as SamplerDescr+import GHC.Stack.Profiler.Internal.Util (DList, Glob, WriterT, matches, runWriterT, tell)+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)+import Text.Printf (printf)+import Text.Read (readMaybe) -profilerSamplingIntervalToThreadDelayTime :: ProfilerSamplingInterval -> Int-profilerSamplingIntervalToThreadDelayTime = \case-  SampleIntervalMs n -> n * 1000+-------------------------------------------------------------------------------+-- High-level API+------------------------------------------------------------------------------- --- ------------------------------------------------------------------------------- High-Level user API--- ----------------------------------------------------------------------------+-------------------------------------------------------------------------------+-- Profiler --- | Sample the all non-rts threads every 'ProfilerSamplingInterval' for the duration of--- the wrapped action.--- Once the wrapped action terminates, the stack profiling stops.+-- | A profiler handle, which can be used to stop the profiler with `stopProfiler`. ----- RTS threads such as the 'TimerManager' and 'IOManager' are not sampled as these--- are usually not interesting for user code.-withStackProfiler :: StackProfilerManager -> ProfilerSamplingInterval -> IO a -> IO a-withStackProfiler manager delay act = do-  runWithStackProfiler-    manager-    (allThreadSampler manager delay)-    (defaultCallStackSerialiser manager)-    act---- | Sample the current thread every 'ProfilerSamplingInterval' for the duration of--- the wrapped action.--- Once the wrapped action terminates, the stack profiling stops.-withStackProfilerForMyThread :: StackProfilerManager -> ProfilerSamplingInterval -> IO a -> IO a-withStackProfilerForMyThread manager delay act = do-  tid <- myThreadId-  withStackProfilerForThread manager tid delay act---- | Sample a specific 'ThreadId' every 'ProfilerSamplingInterval' for the duration of--- the wrapped action.--- Once the wrapped action terminates, the stack profiling stops.-withStackProfilerForThread :: StackProfilerManager -> ThreadId -> ProfilerSamplingInterval -> IO a -> IO a-withStackProfilerForThread manager tid delay act =-  runWithStackProfiler-    manager-    (singleThreadSampler manager delay tid)-    (defaultCallStackSerialiser manager)-    act--withRootStackProfiler :: Bool -> (StackProfilerManager -> IO a) -> IO a-withRootStackProfiler shouldRun act =-  bracket-    (runNewStackProfilerManager shouldRun)-    shutdownStackProfilerManager-    act+--   @since 0.5.0.0+data Profiler = MkProfiler+  { profilerManager :: !Manager+  , profilerSampler :: !Sampler+  } --- ------------------------------------------------------------------------------- Low-level user API--- ----------------------------------------------------------------------------+-- | Run an action with a `Profiler` and the default `Options`.+--+--   __Warning:__ This function spawns a `Manager` thread.+--   Having multiple concurrent `Manager` threads is unsupported and unsafe.+--+--   @since 0.5.0.0+withProfiler :: (Profiler -> IO a) -> IO a+withProfiler action =+  bracket startProfiler stopProfiler action -runNewStackProfilerManager :: Bool -> IO StackProfilerManager-runNewStackProfilerManager shouldRun = do-  manager <- newStackProfilerManager shouldRun-  startEventLoopThread manager-  EventlogSocket.registerWithEventlogSocket manager-  pure manager+-- | Variant of `withProfiler` that accepts `Options`.+--+--   @since 0.5.0.0+withProfilerWith :: Options -> (Profiler -> IO a) -> IO a+withProfilerWith options action =+  bracket (startProfilerWith options) stopProfiler action -shutdownStackProfilerManager :: StackProfilerManager -> IO ()-shutdownStackProfilerManager manager = do-  shutdownAllSamplerThreads manager-  -- TODO: we could also send a stop command instead-  shutdownEventLoop manager+-- | Variant of `withProfiler` that reads `Options` from the environment.+--+--   If @GHC_STACK_PROFILER@ is unset or empty, no `Profiler` is started.+--+--   @since 0.5.0.0+withProfilerFromEnv :: (Maybe Profiler -> IO a) -> IO a+withProfilerFromEnv action =+  bracket startProfilerFromEnv (traverse_ stopProfiler) action -runWithStackProfiler :: StackProfilerManager -> ThreadSampler -> CallStackSerialiser -> IO a -> IO a-runWithStackProfiler manager sampler serializer act = do-  bracket-    (setupStackProfilerThread manager sampler serializer)-    (stopStackProfilerThread manager)-    (const act)+-- | Start a `Profiler` with the default `Options`.+--+--   This function returns a `Profiler` handle, which can be used to stop+--   the profiler with `stopProfiler`.+--+--   __Warning:__ This function spawns a `Manager` thread.+--   Having multiple concurrent `Manager` threads is unsupported and unsafe.+--+--   __Warning:__ If the `Profiler` is not stopped before the program exits,+--   some messages may not be written to the eventlog.+--+--   @since 0.5.0.0+startProfiler :: IO Profiler+startProfiler =+  startProfilerWith defaultOptions -stopStackProfilerThread :: StackProfilerManager -> Async () -> IO ()-stopStackProfilerThread MkStackProfilerManager{profilerThreads} profilerThread = do-  cancel profilerThread-    `finally` atomically-      ( do-          STM.modifyTVar'-            profilerThreads-            ( \threadMap ->-                (Map.delete (asyncThreadId profilerThread) threadMap)-            )-      )+-- | Variant of `startProfiler` that accepts `Options`.+--+--   @since 0.5.0.0+startProfilerWith :: Options -> IO Profiler+startProfilerWith options = do+  profilerManager <- startManager (wait options)+  profilerSampler <- startSamplerWith profilerManager options+  pure MkProfiler{profilerManager, profilerSampler} -setupStackProfilerThread ::-  StackProfilerManager ->-  ThreadSampler ->-  CallStackSerialiser ->-  IO (Async ())-setupStackProfilerThread manager sampler serialiser = do-  barrier <- newEmptyMVar-  workerThread <- async $ do-    () <- takeMVar barrier-    sampleThreadId <- myThreadId-    labelThread sampleThreadId ("Sample Profiler Thread " <> show (fromThreadId sampleThreadId))-    forever $ do-      runStackProfilerSample sampler serialiser+-- | Variant of `startProfiler` that accepts `Options`.+--+--   If @GHC_STACK_PROFILER@ is unset or empty, no `Profiler` is started.+--+--   @since 0.5.0.0+startProfilerFromEnv :: IO (Maybe Profiler)+startProfilerFromEnv =+  fromEnv >>= traverse startProfilerWith -  -- Add this thread to the list of known worker threads to make sure it isn't accidentally sampled-  addSamplerThread manager workerThread-  putMVar barrier ()-  pure workerThread+-- | Stop a `Profiler`.+--+--   @since 0.5.0.0+stopProfiler :: Profiler -> IO ()+stopProfiler MkProfiler{profilerManager, profilerSampler} = do+  stopSampler profilerManager profilerSampler+  stopManager profilerManager --- ------------------------------------------------------------------------------- Sample the RTS CallStack of one or more threads--- ----------------------------------------------------------------------------+-------------------------------------------------------------------------------+-- Options -data ThreadSampler = MkThreadSampler-  { listThreadsToSample :: IO [ThreadId]-  , delaySamplerThread :: IO ()-  , waitForProfilingStart :: IO ()+-- | The options for `withProfilerWith` and `startProfilerWith`.+--+--   To construct options, modify `defaultOptions` using the fields:+--+--   [@`GHC.Stack.Profiler.wait` :: `Bool`@]:+--     Determines if sampler threads are started on creation or wait for a+--     "start profiling" command on the eventlog socket. If you are using+--     @ghc-stack-profiler@ with @eventlog-socket@'s control commands, this+--     should be set to @True@. Otherwise, this should be @False@. The default+--     is @False@.+--   [@`GHC.Stack.Profiler.shouldSample` :: `ThreadId` -> `Maybe` `ThreadLabel` -> `ShouldSample`@]:+--     Determines if the thread idenfied by the `ThreadId` should be sampled.+--     The current `ThreadLabel`, returned by `threadLabel`, is passed as the+--     second argument. If this function returns `Never`, the thread will never+--     be sampled, even if its `ThreadLabel` changes. The default predicate+--     always returns `Yes`. This function is not used for RTS threads or+--     threads spawned by @ghc-stack-profiler@.+--   [@`GHC.Stack.Profiler.sampleRtsThreads` :: `Bool`@]:+--     Determines if builtin RTS threads should be sampled. The builtin RTS+--     threads are the TimerManager and IOManager threads, and do not usually+--     have an interesting call-stack profile. The default is @False@.+--   [@`GHC.Stack.Profiler.sampleProfilerThreads` :: `Bool`@]:+--     Determines if the threads spawned by @ghc-stack-profiler@ should be+--     sampled. The default is @False@.+--   [@`GHC.Stack.Profiler.sampleInterval` :: `Interval`@]:+--     Determines the sampling interval.+--     The default is @10@ milliseconds.+--+--   @since 0.5.0.0+data Options = MkOptions+  { wait :: !Bool+  , shouldSample :: ThreadFilter+  , sampleRtsThreads :: !Bool+  , sampleProfilerThreads :: !Bool+  , sampleInterval :: !Interval   } -defaultThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadSampler-defaultThreadSampler manager delay =-  MkThreadSampler-    { listThreadsToSample = do-        pure []-    , delaySamplerThread =-        threadDelay (profilerSamplingIntervalToThreadDelayTime delay)-    , waitForProfilingStart =-        atomically $ do-          STM.check =<< shouldProfile manager-    }--singleThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadId -> ThreadSampler-singleThreadSampler manager delay tid =-  (defaultThreadSampler manager delay)-    { listThreadsToSample = do-        pure [tid]+-- | The default `Options`. See `Options` for the default values.+--+--   @since 0.5.0.0+defaultOptions :: Options+defaultOptions =+  MkOptions+    { wait = False+    , shouldSample = \_threadId _maybeThreadLabel -> Yes+    , sampleRtsThreads = False+    , sampleProfilerThreads = False+    , sampleInterval = MkIntervalMillis 10     } -allThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadSampler-allThreadSampler manager delay =-  (defaultThreadSampler manager delay)-    { listThreadsToSample = do-        tids <- listThreads-        userThreads <- filterM (isThreadOfInterest manager) tids-        pure userThreads-    }+-- | A thread filter, used to determine which threads should be sampled.+--+--   Used in the `shouldSample` field of `Options`.+--+--   @since 0.5.0.0+type ThreadFilter = ThreadId -> Maybe ThreadLabel -> ShouldSample -runStackProfilerSample :: ThreadSampler -> CallStackSerialiser -> IO ()-runStackProfilerSample sampler serialiser = do-  waitForProfilingStart sampler-  tids <- listThreadsToSample sampler-  mapM_ (runCallStackSerialiser serialiser) tids-  -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well-  delaySamplerThread sampler+-- | A thread label, as set by `labelThread`.+--+--   @since 0.5.0.0+type ThreadLabel = String --- ------------------------------------------------------------------------------- Serialise the RTS CallStack for the eventlog--- ----------------------------------------------------------------------------+-- | The result type of a `ThreadFilter`.+--+--   @since 0.5.0.0+data ShouldSample+  = -- | The thread should be sampled.+    Yes+  | -- | The thread should not be sampled.+    No+  | -- | The thread should never be sampled.+    Never -data CallStackSerialiser = MkCallStackSerialiser-  { sampleCallStack :: ThreadId -> IO (Maybe ThreadSample)-  , decodeThreadSample :: ThreadSample -> IO CallStackMessage-  , serialiseCallStackMessage :: CallStackMessage -> IO ()-  }+-- | Construct a thread filter from an include `Glob` pattern.+--+--   If the thread label matches the given pattern, the thread filter returns `Yes`.+--   Otherwise, the thread filter returns `No`.+--   The thread filter never returns `Never`.+--+--   @since 0.5.0.0+sampleInclude ::+  -- | The include pattern.+  Glob ->+  ThreadFilter+sampleInclude globInclude =+  const . maybe No $+    fromBool . \label ->+      globInclude `matches` label --- | If the thread's callstack can be sampled, we serialise the sample--- and write into the eventlog for later processing.-runCallStackSerialiser :: CallStackSerialiser -> ThreadId -> IO ()-runCallStackSerialiser serialiser tid = do-  sampleCallStack serialiser tid >>= \case-    Nothing -> pure ()-    Just threadSample -> do-      callStackSample <- decodeThreadSample serialiser threadSample-      serialiseCallStackMessage serialiser callStackSample+-- | Construct a thread filter from an exclude `Glob` pattern.+--+--   If the thread label matches the given pattern, the thread filter returns `No`.+--   Otherwise, the thread filter returns `Yes`.+--   The thread filter never returns `Never`.+--+--   @since 0.5.0.0+sampleExclude ::+  -- | The exclude pattern.+  Glob ->+  ThreadFilter+sampleExclude globExclude =+  const . maybe Yes $+    fromBool . \label ->+      not (globExclude `matches` label) -defaultCallStackSerialiser :: StackProfilerManager -> CallStackSerialiser-defaultCallStackSerialiser manager =-  MkCallStackSerialiser-    { sampleCallStack = sampleThread-    , decodeThreadSample = threadSampleToCallStackMessage-    , serialiseCallStackMessage = \callStackSample -> do-        lbss <- atomically $ do-          eventlogMessages <- serializeCallStackMessage (symbolTableRef manager) callStackSample-          let-            lbss = serializeBinaryEventlogMessages eventlogMessages-          -- Only write this message if we are still profiling-          STM.check =<< shouldProfile manager-          pure lbss+-- | Construct a thread filter from include and exclude `Glob` patterns.+--+--   If the thread label matches the given include pattern and does not match+--   the given exclude pattern, the thread filter returns `Yes`.+--   Otherwise, the thread filter returns `No`.+--   The thread filter never returns `Never`.+--+--   @since 0.5.0.0+sampleIncludeExclude ::+  -- | The include pattern.+  Glob ->+  -- | The exclude pattern.+  Glob ->+  ThreadFilter+sampleIncludeExclude globInclude globExclude =+  const . maybe Yes $+    fromBool . \label ->+      globInclude `matches` label && not (globExclude `matches` label) -        writeChan (messageChan manager) (WriteProfileSample $ fmap LBS.toStrict lbss)-    }+-- | Internal helper.+--+--   Construct a `ShouldSample` from a `Bool`.+--+--   Maps `True` to `Yes` and `False` to `No`.+fromBool :: Bool -> ShouldSample+fromBool b = if b then Yes else No --- | Sample the stack of the 'ThreadId' if the thread is currently running.--- If the thread is not running (e.g., because it is dead), then we return 'Nothing'.-sampleThread :: ThreadId -> IO (Maybe ThreadSample)-sampleThread tid = do-  tidStatus <- threadStatus tid-  (cap, _lockedToCap) <- threadCapability tid-  case canCloneStack tidStatus of-    True -> do-      stack <- cloneThreadStack tid+-- | Read the `Options` from the environment.+--+--   [@GHC_STACK_PROFILER@]:+--     If set to any non-empty value, read and return the options.+--     Otherwise, return `Nothing`, which indicates the `Profiler` should not be started.+--   [@GHC_STACK_PROFILER_WAIT@]:+--     If set to any non-empty value, `wait` is set to `True`.+--   [@GHC_STACK_PROFILER_SAMPLE_INCLUDE@]:+--     If set, `shouldSample` is set to the `ThreadFilter` constructed using `sampleInclude` using the value as a `Glob` pattern.+--     If @GHC_STACK_PROFILER_SAMPLE_EXCLUDE@ is also set, `sampleIncludeExclude` is used.+--   [@GHC_STACK_PROFILER_SAMPLE_EXCLUDE@]:+--     If set, `shouldSample` is set to the `ThreadFilter` constructed using `sampleExclude` using the value as a `Glob` pattern.+--     If @GHC_STACK_PROFILER_SAMPLE_INCLUDE@ is also set, `sampleIncludeExclude` is used.+--   [@GHC_STACK_PROFILER_SAMPLE_RTS_THREADS@]:+--     If set to any non-empty value, `sampleRtsThreads` is set to `True`.+--   [@GHC_STACK_PROFILER_SAMPLE_PROFILER_THREADS@]:+--     If set to any non-empty value, `sampleProfilerThreads` is set to `True`.+--   [@GHC_STACK_PROFILER_SAMPLE_INTERVAL@]:+--     If set to any numeric value, `sampleInterval` is set to the `Interval` constructed using the value as milliseconds.+--     If set to any non-numeric value, a warning is printed to `stderr` and the default `sampleInterval` is used.+--+--   __Warning:__ This function reads environment variables, which is not thread-safe.+--                See [@getenv@](https://en.cppreference.com/c/program/getenv).+--+--   @since 0.5.0.0+fromEnv :: IO (Maybe Options)+fromEnv = do+  shouldStart <- testEnv startVar+  if not shouldStart+    then pure Nothing+    else do+      wait <- testEnv waitVar+      shouldSample <-+        (,) <$> lookupEnvGlob sampleIncludeVar <*> lookupEnvGlob sampleExcludeVar <&> \case+          (Nothing, Nothing) -> shouldSample defaultOptions+          (Just includeGlob, Nothing) -> sampleInclude includeGlob+          (Nothing, Just excludeGlob) -> sampleExclude excludeGlob+          (Just includeGlob, Just excludeGlob) -> sampleIncludeExclude includeGlob excludeGlob+      sampleRtsThreads <- testEnv sampleRtsThreadsVar+      sampleProfilerThreads <- testEnv sampleProfilerThreadsVar+      sampleInterval <-+        lookupEnv sampleIntervalVar >>= \case+          Nothing ->+            pure $ sampleInterval defaultOptions+          Just sampleIntervalMillisString ->+            case readMaybe sampleIntervalMillisString of+              Nothing -> do+                hPutStrLn stderr $+                  printf+                    "Could not parse the value of %s. Expected a number, found %s"+                    sampleIntervalVar+                    sampleIntervalMillisString+                pure $ sampleInterval defaultOptions+              Just sampleIntervalMillis ->+                pure $ MkIntervalMillis sampleIntervalMillis       pure $-        Just $-          ThreadSample-            { threadSampleId = tid-            , threadSampleCapability = MkCapabilityId $ intToWord64 cap-            , threadSampleStackSnapshot = stack+        Just+          MkOptions+            { wait+            , shouldSample+            , sampleRtsThreads+            , sampleProfilerThreads+            , sampleInterval             }-    False -> do-      -- Only running threads need to be sampled-      pure Nothing  where-  canCloneStack :: ThreadStatus -> Bool-  canCloneStack = \case-    ThreadRunning -> True-    ThreadBlocked BlockedOnMVar -> True-    _ -> False+  testEnv :: String -> IO Bool+  testEnv = fmap (maybe False (not . null)) . lookupEnv --- ------------------------------------------------------------------------------- Main Event Loop handler--- ----------------------------------------------------------------------------+  lookupEnvGlob :: String -> IO (Maybe Glob)+  lookupEnvGlob = fmap (fmap fromString) . lookupEnv -startEventLoopThread :: StackProfilerManager -> IO ()-startEventLoopThread manager = do-  !sinkAsync <- do-    sinkAsync <- async (forever mainEventHandler)+  startVar :: String+  startVar = "GHC_STACK_PROFILER" -    -- if the main eventloop crashes for any reason, we want to know-    link sinkAsync+  waitVar :: String+  waitVar = "GHC_STACK_PROFILER_WAIT" -    pure-      MkEventThread-        { eventThread = sinkAsync-        }+  sampleIncludeVar :: String+  sampleIncludeVar = "GHC_STACK_PROFILER_SAMPLE_INCLUDE" -  atomically $ do-    writeTVar (mainEventLoopThread manager) (Just sinkAsync)- where-  mainEventHandler = do-    msg <- Chan.readChan (messageChan manager)-    run <- STM.atomically $ shouldProfile manager-    case msg of-      WriteProfileSample msgs ->-        case run of-          True ->-            mapM_ Compat.traceBinaryEventIO msgs-          False ->-            -- If we received a sample but the eventlog is currently locked-            -- discard the message.-            pure ()-      StartProfiling barrier -> do-        STM.atomically $ enableSampling manager-        putMVar barrier ()-      StopProfiling barrier -> do-        STM.atomically $ disableSampling manager-        putMVar barrier ()-      StartEventlog barrier -> do-        STM.atomically $ enableEventLogging manager-        putMVar barrier ()-      StopEventlog barrier -> do-        STM.atomically $ disableEventLogging manager-        putMVar barrier ()-      PublishInitEvents barrier -> do-        symbolTable <- STM.atomically $ readSymbolTable (symbolTableRef manager)-        let-          msgs = Decode.initMessages symbolTable+  sampleExcludeVar :: String+  sampleExcludeVar = "GHC_STACK_PROFILER_SAMPLE_EXCLUDE" -        mapM_-          Compat.traceBinaryEventIO-          (fmap LBS.toStrict msgs)+  sampleRtsThreadsVar :: String+  sampleRtsThreadsVar = "GHC_STACK_PROFILER_SAMPLE_RTS_THREADS" -        Debug.Trace.flushEventLog-        putMVar barrier ()+  sampleProfilerThreadsVar :: String+  sampleProfilerThreadsVar = "GHC_STACK_PROFILER_SAMPLE_PROFILER_THREADS" ------------------------------------------------------------------------- Coordination utils--- ----------------------------------------------------------------------------+  sampleIntervalVar :: String+  sampleIntervalVar = "GHC_STACK_PROFILER_SAMPLE_INTERVAL" -shutdownEventLoop :: StackProfilerManager -> IO ()-shutdownEventLoop manager = do-  sinkAsync <- atomically $ do-    thread <- readTVar (mainEventLoopThread manager)-    writeTVar (mainEventLoopThread manager) Nothing-    pure thread+-------------------------------------------------------------------------------+-- Low-level API+------------------------------------------------------------------------------- -  sendStopProfilingMessage manager-  traverse_ (cancel . eventThread) sinkAsync+-------------------------------------------------------------------------------+-- Manager -addSamplerThread :: StackProfilerManager -> Async () -> IO ()-addSamplerThread manager worker = do-  -- if the worker crashes for any reason, we want to know-  link worker+-- | Run an action with a new `Manager`.+--+--   The first argument indicates if sampler threads should wait for a call to+--  `startProfiling` or a "start profiling" command on the eventlog socket.+--   If you are using @ghc-stack-profiler@ with @eventlog-socket@'s control+--   commands, this should be set to @True@.+--+--   The `Manager` is stopped when the action finishes.+--+--   __Warning:__ This function spawns a `Manager` thread.+--   Having multiple concurrent `Manager` threads is unsupported and unsafe.+--+--   @since 0.5.0.0+withManager ::+  -- | Flag that determines if sampler threads should wait.+  Bool ->+  -- | The action that runs with the `Manager`.+  (Manager -> IO a) ->+  IO a+withManager wait action =+  bracket (startManager wait) stopManager action -  atomically $ do-    STM.modifyTVar' (profilerThreads manager) $ \threadMap ->-      (Map.insert (asyncThreadId worker) worker threadMap)+-- | Start a `Manager`.+--+--   The first argument indicates if sampler threads should wait for a call to+--  `startProfiling` or a "start profiling" command on the eventlog socket.+--   If you are using @ghc-stack-profiler@ with @eventlog-socket@'s control+--   commands, this should be set to @True@.+--+--   __Warning:__ This function spawns a `Manager` thread.+--   Having multiple concurrent `Manager` threads is unsupported and unsafe.+--+--   __Warning:__ The manager should be stopped with `stopManager`.+--+--   @since 0.5.0.0+startManager :: Bool -> IO Manager+startManager wait = do+  -- TODO: Detect if the event loop thread is running and throw an error.+  manager <- newManager wait+  startEventLoop manager+  Eventlog.Socket.registerWithEventlogSocket manager+  pure manager -shutdownAllSamplerThreads :: StackProfilerManager -> IO ()-shutdownAllSamplerThreads MkStackProfilerManager{profilerThreads} = do-  threads <- atomically $ do-    threadsMap <- readTVar profilerThreads-    writeTVar profilerThreads Map.empty-    pure $ Map.elems threadsMap+-------------------------------------------------------------------------------+-- Sampler+------------------------------------------------------------------------------- -  traverse_ cancel threads+-- | Run an action with a `Sampler` for the current thread.+--+--   The `Sampler` is stopped when the action finishes.+--+--   __Warning:__ If the action creates a new thread, it /will not/ be sampled.+--+--   @since 0.5.0.0+withSamplerForMe :: Manager -> Interval -> (Sampler -> IO a) -> IO a+withSamplerForMe manager interval action = do+  myThreadId >>= \threadId ->+    withSampler (samplerFor manager threadId interval) action --- ------------------------------------------------------------------------------- Utils--- ----------------------------------------------------------------------------+-- | Start a sampler for the given `ThreadId`.+--+--   __Warning:__ The sampler should be stopped using `stopSampler` or `stopManager`.+--+--   @since 0.5.0.0+startSamplerFor :: Manager -> ThreadId -> Interval -> IO Sampler+startSamplerFor manager threadId interval =+  startSampler (samplerFor manager threadId interval) --- | We don't want to sample the stack profiler threads themselves.-isProfilerThread :: Maybe EventThread -> Set ThreadId -> ThreadId -> Bool-isProfilerThread writerThread profilerThreadIds tid =-  Set.member tid profilerThreadIds-    || maybe False (== tid) (asyncThreadId . eventThread <$> writerThread)+-- | Internal helper.+--+--   Create a `SamplerDescr` that samples a single thread.+samplerFor :: Manager -> ThreadId -> Interval -> SamplerDescr+samplerFor samplerManager threadId sampleInterval =+  MkSamplerDescr{samplerManager, samplerThreads, sampleInterval}+ where+  samplerThreads = pure [threadId] --- | RTS threads are often not that interesting, we much rather want to focus on--- the user code.-isRtsThread :: ThreadId -> Maybe String -> Bool-isRtsThread _ Nothing = False-isRtsThread _tid (Just lbl) =-  lbl == "TimerManager" || "IOManager on cap" `List.isPrefixOf` lbl+-- | Start a sampler with the given `Options`.+--+--   This function ignores the `wait` field and uses the value that was+--   passed to the `Manager` on creation.+--+--   __Warning:__ The sampler should be stopped using `stopSampler` or `stopManager`.+--+--   @since 0.5.0.0+startSamplerWith :: Manager -> Options -> IO Sampler+startSamplerWith manager options = do+  neverSetRef <- newIORef Set.empty+  startSampler (samplerWith manager neverSetRef options) -isThreadOfInterest :: StackProfilerManager -> ThreadId -> IO Bool-isThreadOfInterest manager tid = do-  lbl <- threadLabel tid-  (profilerThreadIds, eventlogWriter) <- STM.atomically $ do-    threadMap <- readTVar (profilerThreads manager)-    sink <- readTVar (mainEventLoopThread manager)-    pure (Map.keysSet threadMap, sink)-  pure $-    not $-      or-        [ isProfilerThread eventlogWriter profilerThreadIds tid-        , isRtsThread tid lbl-        ]+-- | Internal helper.+--+--   Create a `SamplerDescr` for the given `Options`.+samplerWith ::+  Manager ->+  IORef (Set ThreadId) ->+  Options ->+  SamplerDescr+samplerWith samplerManager neverSetRef options =+  MkSamplerDescr{samplerManager, samplerThreads, sampleInterval}+ where+  MkOptions+    { shouldSample+    , sampleRtsThreads = fromBool -> shouldSampleRtsThreads+    , sampleProfilerThreads = fromBool -> shouldSampleProfilerThreads+    , sampleInterval+    } = options++  samplerThreads = do+    neverSet <- readIORef neverSetRef+    (threadIds', neverSet') <- filterThreads neverSet =<< listThreads+    writeIORef neverSetRef $! neverSet'+    pure threadIds'++  filterThreads :: Set ThreadId -> [ThreadId] -> IO ([ThreadId], Set ThreadId)+  filterThreads neverSet =+    fmap (bimap catMaybes (foldr S.insert neverSet . toList))+      . runWriterT+      . traverse testThread+   where+    testThread :: ThreadId -> WriterT (DList ThreadId) IO (Maybe ThreadId)+    testThread threadId+      -- If the threadId is in the neverSet, do not sample it.+      | threadId `S.member` neverSet =+          pure Nothing+      | otherwise = do+          -- If the threadId is a profiler thread,+          -- it should be sampled if-and-only-if shouldSampleProfilerThreads is true.+          isProfilerThread <- liftIO (isProfilerThreadFor samplerManager threadId)+          if isProfilerThread+            then+              evalShouldSample threadId shouldSampleProfilerThreads+            else do+              maybeThreadLabel <- liftIO (threadLabel threadId)+              -- If the threadId is an RTS thread,+              -- it should be sampled if-and-only-if shouldSampleRtsThreads is true.+              if isRtsThread maybeThreadLabel+                then+                  evalShouldSample threadId shouldSampleRtsThreads+                else+                  -- Otherwise, run the user-provided predicate and follow its instructions.+                  evalShouldSample threadId (shouldSample threadId maybeThreadLabel)++    -- Evaluate a `ShouldSample` judgement for the given threadId.+    evalShouldSample :: ThreadId -> ShouldSample -> WriterT (DList ThreadId) IO (Maybe ThreadId)+    evalShouldSample threadId = \case+      Yes -> pure (Just threadId)+      No -> pure Nothing+      Never -> tell (fromList [threadId]) >> pure Nothing++-- | Was the given thread created by this library?+isProfilerThreadFor :: Manager -> ThreadId -> IO Bool+isProfilerThreadFor manager threadId =+  atomically $ do+    isEventLoopThread <-+      fromMaybe False . fmap ((== threadId) . asyncThreadId . eventLoopAsync)+        <$> readTVar (eventLoopThreadVar manager)+    isSamplerThread <-+      Map.member threadId+        <$> readTVar (samplerThreadMapVar manager)+    pure $ isEventLoopThread || isSamplerThread++-- | Is the given thread an RTS thread?+isRtsThread :: Maybe ThreadLabel -> Bool+isRtsThread =+  maybe False (\label -> label == "TimerManager" || "IOManager on cap" `isPrefixOf` label)
− src/GHC/Stack/Profiler/Commands.hs 
@@ -1,96 +0,0 @@-module GHC.Stack.Profiler.Commands (-  startProfiling,-  stopProfiling,-  sendPublishInitEventMessages,-  sendStartProfilingMessage,-  sendStopProfilingMessage,-  sendEnableEventlogMessage,-  sendDisableEventlogMessage,-) where--import Control.Concurrent.Chan-import qualified Control.Concurrent.MVar as MVar-import qualified Control.Concurrent.STM as STM-import GHC.Stack.Profiler.Manager---- | Start the profiler threads.------ Blocks until all threads started running.-startProfiling :: StackProfilerManager -> IO ()-startProfiling manager = do-  -- TODO: this atomically is redundant, the main loop thread-  -- sets it anyway-  STM.atomically $-    STM.writeTVar (isThreadSamplerRunning manager) True-  sendStartProfilingMessage manager---- | Stop the running profiler threads.------ Blocks until all threads stopped running.-stopProfiling :: StackProfilerManager -> IO ()-stopProfiling manager = do-  -- TODO: this atomically is *not* redundant, it makes sure no new-  -- samples can be created.-  -- Otherwise, new samples could be created and queued while we are waiting-  -- for the event loop to process this message.-  -- It is important, that once this message is processed, that no sampler thread is sampling-  -- at all. Otherwise, there will be new init events that are not published.-  STM.atomically $-    STM.writeTVar (isThreadSamplerRunning manager) False-  sendStopProfilingMessage manager---- | Start profiling.------ Blocks until the message has been processed by the main event loop.-sendStartProfilingMessage :: StackProfilerManager -> IO ()-sendStartProfilingMessage manager = do-  barrier <- MVar.newEmptyMVar-  writeChan-    (messageChan manager)-    (StartProfiling barrier)-  MVar.takeMVar barrier---- | Stop profiling.------ Blocks until the message has been processed by the main event loop.-sendStopProfilingMessage :: StackProfilerManager -> IO ()-sendStopProfilingMessage manager = do-  barrier <- MVar.newEmptyMVar-  writeChan-    (messageChan manager)-    (StopProfiling barrier)-  MVar.takeMVar barrier---- | Start EventLogging now.------ Blocks until the message has been processed by the main event loop.-sendEnableEventlogMessage :: StackProfilerManager -> IO ()-sendEnableEventlogMessage manager = do-  barrier <- MVar.newEmptyMVar-  writeChan-    (messageChan manager)-    (StartEventlog barrier)-  MVar.takeMVar barrier---- | Stop EventLogging now.------ Blocks until the message has been processed by the main event loop.-sendDisableEventlogMessage :: StackProfilerManager -> IO ()-sendDisableEventlogMessage manager = do-  barrier <- MVar.newEmptyMVar-  writeChan-    (messageChan manager)-    (StopEventlog barrier)-  MVar.takeMVar barrier---- | Publish all init messages so far.------ Blocks until the init events have been written to the eventlog and--- eventlog was flushed.-sendPublishInitEventMessages :: StackProfilerManager -> IO ()-sendPublishInitEventMessages manager = do-  barrier <- MVar.newEmptyMVar-  writeChan-    (messageChan manager)-    (PublishInitEvents barrier)-  MVar.takeMVar barrier
− src/GHC/Stack/Profiler/Decode.hs 
@@ -1,94 +0,0 @@-module GHC.Stack.Profiler.Decode (-  StackSymbolTable,-  SymbolTableWriter,-  initMessages,-  serializeCallStackMessage,-  serializeBinaryEventlogMessage,-  serializeBinaryEventlogMessages,-  threadSampleToCallStackMessage,-  binaryEventlogDefinitions,-) where--import Control.Concurrent.STM-import Data.Binary-import Data.Binary.Put-import qualified Data.ByteString.Lazy as LBS-import qualified Data.List.NonEmpty as NonEmpty--import GHC.Conc.Sync (fromThreadId)--import Control.Exception (assert)-import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.SymbolTable-import GHC.Stack.Profiler.Core.ThreadSample-import GHC.Stack.Profiler.Stack.Decode (decodeStackWithIpProvId)-import GHC.Stack.Profiler.SymbolTable--threadSampleToCallStackMessage :: ThreadSample -> IO CallStackMessage-threadSampleToCallStackMessage sample = do-  frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample-  let-    -- removes immediate duplicates-    callStackItems = fmap NonEmpty.head $ NonEmpty.group frames--  pure-    MkCallStackMessage-      { callThreadId = fromThreadId $ threadSampleId sample-      , callCapabilityId = threadSampleCapability sample-      , callStack = callStackItems-      }--serializeCallStackMessage :: StackSymbolTable -> CallStackMessage -> STM [BinaryEventlogMessage]-serializeCallStackMessage tableRef callStackMessage = do-  table <- readSymbolTable tableRef-  let-    (eventlogMessages, newTable) = dehydrateCallStackMessage table callStackMessage-  writeSymbolTable newTable tableRef-  pure eventlogMessages--serializeBinaryEventlogMessage :: BinaryEventlogMessage -> LBS.ByteString-serializeBinaryEventlogMessage = runPut . put--serializeBinaryEventlogMessages :: [BinaryEventlogMessage] -> [LBS.ByteString]-serializeBinaryEventlogMessages = map serializeBinaryEventlogMessage--initMessages :: SymbolTableWriter MapTable -> [LBS.ByteString]-initMessages symbolTable =-  let-    (stringDefs, srcLocDefs) = binaryEventlogDefinitions symbolTable-    binaryEventlogMessages =-      ( map StringDef stringDefs-          ++ map SourceLocationDef srcLocDefs-      )-  in-    serializeBinaryEventlogMessages binaryEventlogMessages--binaryEventlogDefinitions :: SymbolTableWriter MapTable -> ([BinaryStringMessage], [BinarySourceLocationMessage])-binaryEventlogDefinitions table =-  let-    knownStrings = getKnownStrings $ writerTable table-    knownSrcLocs = getKnownSourceLocations $ writerTable table--    stringDefs =-      fmap (uncurry MkBinaryStringMessage) knownStrings--    srcLocDefs =-      map (uncurry go) knownSrcLocs-  in-    ( stringDefs-    , srcLocDefs-    )- where-  go :: SourceLocationId -> SourceLocation -> BinarySourceLocationMessage-  go sid s =-    let-      (fileId, newFileName, _) = lookupOrInsertText table (writerTable table) (fileName s)-    in-      -- These should always be found-      assert (not newFileName) $-        MkBinarySourceLocationMessage-          { binarySourceLocationMessageId = sid-          , binarySourceLocationRow = line s-          , binarySourceLocationColumn = column s-          , binarySourceLocationFilename = fileId-          }
− src/GHC/Stack/Profiler/Eventlog/Socket.hs 
@@ -1,83 +0,0 @@-{-# 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/Internal/Decode.hs view
@@ -0,0 +1,104 @@+module GHC.Stack.Profiler.Internal.Decode (+  CallStackSample (..),+  StackSymbolTable,+  SymbolTableWriter,+  initMessages,+  serializeCallStack,+  serializeMessage,+  serializeMessages,+  decodeToCallStack,+  definitions,+) where++import Control.Concurrent.STM+import Control.Exception (assert)+import Data.Binary+import Data.Binary.Put+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NonEmpty+import GHC.Generics (Generic)+import GHC.Stack.CloneStack (StackSnapshot)+import GHC.Stack.Profiler.Core+import GHC.Stack.Profiler.Internal.Stack.Decode (decodeStackWithIpProvId)+import GHC.Stack.Profiler.Internal.SymbolTable++-- | A 'CallStackSample' 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 CallStackSample = CallStackSample+  { callStackSampleThreadId :: !ThreadId+  , callStackSampleCapabilityId :: !CapabilityId+  , callStackSampleStackSnapshot :: !StackSnapshot+  }+  deriving (Generic)++decodeToCallStack :: CallStackSample -> IO CallStack+decodeToCallStack sample = do+  frames <- decodeStackWithIpProvId $ callStackSampleStackSnapshot sample+  let+    -- removes immediate duplicates+    callStackItems = fmap NonEmpty.head $ NonEmpty.group frames++  pure+    MkCallStack+      { callThreadId = callStackSampleThreadId sample+      , callCapabilityId = callStackSampleCapabilityId sample+      , callStack = callStackItems+      }++serializeCallStack :: StackSymbolTable -> CallStack -> STM [Message]+serializeCallStack tableRef callStackMessage = do+  table <- readSymbolTable tableRef+  let+    (eventlogMessages, newTable) = dehydrateCallStack table callStackMessage+  writeSymbolTable newTable tableRef+  pure eventlogMessages++serializeMessage :: Message -> LBS.ByteString+serializeMessage = runPut . put++serializeMessages :: [Message] -> [LBS.ByteString]+serializeMessages = map serializeMessage++initMessages :: SymbolTableWriter MapTable -> [Message]+initMessages symbolTable =+  let+    (stringDefs, srcLocDefs) = definitions symbolTable+  in+    ( map StringDef stringDefs+        ++ map SourceLocationDef srcLocDefs+    )++definitions :: SymbolTableWriter MapTable -> ([StringDef], [SourceLocationDef])+definitions table =+  let+    knownStrings = getKnownStrings $ writerTable table+    knownSrcLocs = getKnownSourceLocations $ writerTable table++    stringDefs =+      fmap (uncurry MkStringDef) knownStrings++    srcLocDefs =+      map (uncurry go) knownSrcLocs+  in+    ( stringDefs+    , srcLocDefs+    )+ where+  go :: SourceLocationId -> SourceLocation -> SourceLocationDef+  go sid s =+    let+      (fileId, newFileName, _) = lookupOrInsertText table (writerTable table) (fileName s)+    in+      -- These should always be found+      assert (not newFileName) $+        MkSourceLocationDef+          { sourceLocationDefId = sid+          , sourceLocationDefRow = line s+          , sourceLocationDefColumn = column s+          , sourceLocationDefFilename = fileId+          }
+ src/GHC/Stack/Profiler/Internal/Eventlog/Socket.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}++module GHC.Stack.Profiler.Internal.Eventlog.Socket (+  registerWithEventlogSocket,+) where++import GHC.Stack.Profiler.Internal.Manager (Manager)++#ifdef EVENTLOG_SOCKET_SUPPORT+import qualified Control.Monad.STM as STM+import GHC.Eventlog.Socket (CommandId (..), Hook (..), registerCommand, registerHook, registerNamespace)+import GHC.Stack.Profiler.Internal.Manager (disableEventLogging, startProfiling, stopProfiling, sendEnableEventlogMessage, sendDisableEventlogMessage, sendPublishInitEventMessages)+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 :: Manager -> IO ()+#ifdef EVENTLOG_SOCKET_SUPPORT+registerWithEventlogSocket = registerWithEventlogSocketIfSupported+#else+registerWithEventlogSocket = const $ pure ()+#endif++#ifdef EVENTLOG_SOCKET_SUPPORT+-- The real implementation of @registerWithEventlogSocket@.+registerWithEventlogSocketIfSupported :: Manager -> 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 :: Manager -> 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 :: Manager -> IO ()+endEventLoggingHook manager = do+  STM.atomically $ disableEventLogging manager+  sendDisableEventlogMessage manager++-- | The handler for the @StartProfiling@ custom command.+startProfilerCommand :: Manager -> IO ()+startProfilerCommand manager = do+  traceMarkerIO "ghc-stack-profiler: Start profiling"+  startProfiling manager++-- | The handler for the @StopProfiling@ custom command.+stopProfilerCommand :: Manager -> IO ()+stopProfilerCommand manager = do+  stopProfiling manager+  traceMarkerIO "ghc-stack-profiler: Stop profiling"+#endif
+ src/GHC/Stack/Profiler/Internal/Manager.hs view
@@ -0,0 +1,354 @@+module GHC.Stack.Profiler.Internal.Manager (+  Manager (..),+  newManager,+  stopManager,+  shouldProfile,+  enableEventLogging,+  disableEventLogging,+  enableSampling,+  disableSampling,+  registerSamplerThread,+  unregisterSamplerThread,+  stopAllSamplerThreads,++  -- * Sampler Threads+  Sampler (..),+  cancelSampler,++  -- * Event Loop+  EventLoop (..),+  startEventLoop,+  stopEventLoop,++  -- * Control Messages+  ControlMessage (..),+  startProfiling,+  stopProfiling,+  sendPublishInitEventMessages,+  sendStartProfilingMessage,+  sendStopProfilingMessage,+  sendEnableEventlogMessage,+  sendDisableEventlogMessage,+) where++import Control.Concurrent (ThreadId)+import Control.Concurrent.Async (Async (..), async, cancel, link)+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent.STM (STM)+import Control.Concurrent.STM.TVar+import qualified Control.Concurrent.STM.TVar as STM+import qualified Control.Concurrent.STM.TVar as TVar+import Control.Monad (forever)+import Control.Monad.STM (atomically)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (for_)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Debug.Trace+import qualified Debug.Trace.Binary.Compat as Compat+import GHC.Generics (Generic)+import qualified GHC.Stack.Profiler.Core as GSPC (Message (ProtocolVersion), ProtocolVersion (MyProtocolVersion))+import qualified GHC.Stack.Profiler.Internal.Decode as Decode+import GHC.Stack.Profiler.Internal.SymbolTable++-- NOTE: The `Manager` type (but not its implementation) is part of the public API.++-- | A `Manager` handle, which can be used to stop the manager with `stopManager`.+--+--   @since 0.5.0.0+data Manager = MkManager+  { samplerThreadMapVar :: !(TVar (Map ThreadId Sampler))+  -- ^ 'Async' of the stack sampling thread.+  , eventLoopThreadVar :: !(TVar (Maybe EventLoop))+  -- ^ Main event loop thread responsible for processing profiler messages, etc...+  , symbolTableRef :: !StackSymbolTable+  -- ^ Global table for common symbols.+  , shouldSampleVar :: !(TVar Bool)+  -- ^ Is the profiler currently running?+  --+  -- Can be controlled via 'startProfiler' and 'stopProfiler'.+  -- This variable describes whether the user wants to profile, regardless+  -- of the eventlog state.+  , eventLoggingStartedVar :: !(TVar Bool)+  -- ^ Is there an eventlog?+  --+  -- It is fully possible that we start profiling but no eventlog-writer+  -- being connected/configured. The eventlog can be enabled at a later point,+  -- or stopped/started via @eventlog-socket@.+  -- This variable tracks the state of the eventlog-writer.+  , messageChan :: Chan ControlMessage+  }+  deriving (Generic, Eq)++newManager :: Bool -> IO Manager+newManager wait = do+  tracingEnabled <- Compat.userTracingEnabledIO+  samplerThreadMapVar <- newTVarIO Map.empty+  eventLoopThreadVar <- newTVarIO Nothing+  symbolTableRef <- emptySymbolTableIO+  shouldSampleVar <- newTVarIO (not wait)+  eventLoggingStartedVar <- newTVarIO tracingEnabled+  messageChan <- newChan+  pure+    MkManager+      { samplerThreadMapVar+      , eventLoopThreadVar+      , symbolTableRef+      , shouldSampleVar+      , eventLoggingStartedVar+      , messageChan+      }++-- NOTE: `stopManager` is part of the public API.++-- | Stop a `Manager`.+--+--   This also stops every `Sampler` started by this manager.+--+--   __Warning:__ If the `Manager` is not stopped before the program exits,+--   some messages may not be written to the eventlog.+--+--   @since 0.5.0.0+stopManager :: Manager -> IO ()+stopManager manager = do+  stopAllSamplerThreads manager+  stopEventLoop manager++-- | Can we profile right now?+--+-- We only sample a stack if the profiler is instructed to run and the eventlog is enabled.+shouldProfile :: Manager -> STM Bool+shouldProfile manager =+  liftA2+    (&&)+    (readTVar $ shouldSampleVar manager)+    (readTVar $ eventLoggingStartedVar manager)++enableEventLogging :: Manager -> STM ()+enableEventLogging manager = do+  TVar.writeTVar (eventLoggingStartedVar manager) True++disableEventLogging :: Manager -> STM ()+disableEventLogging manager = do+  TVar.writeTVar (eventLoggingStartedVar manager) False++enableSampling :: Manager -> STM ()+enableSampling manager = do+  TVar.writeTVar (shouldSampleVar manager) True++disableSampling :: Manager -> STM ()+disableSampling manager = do+  TVar.writeTVar (shouldSampleVar manager) False++registerSamplerThread :: Manager -> Sampler -> IO ()+registerSamplerThread manager samplerThread@MkSampler{samplerAsync} = do+  link samplerAsync -- If the sampler crashes, we want to know.+  atomically $ do+    STM.modifyTVar' (samplerThreadMapVar manager) $ \threadMap ->+      (Map.insert (asyncThreadId samplerAsync) samplerThread threadMap)++unregisterSamplerThread :: Manager -> Sampler -> IO ()+unregisterSamplerThread manager MkSampler{samplerAsync} =+  atomically $ do+    STM.modifyTVar'+      (samplerThreadMapVar manager)+      (Map.delete (asyncThreadId samplerAsync))++stopAllSamplerThreads :: Manager -> IO ()+stopAllSamplerThreads manager = do+  samplerThreads <-+    atomically $ do+      samplerThreadMap <- readTVar (samplerThreadMapVar manager)+      writeTVar (samplerThreadMapVar manager) Map.empty+      pure $ Map.elems samplerThreadMap+  for_ samplerThreads cancelSampler++-------------------------------------------------------------------------------+-- Sampler Threads+-------------------------------------------------------------------------------++-- NOTE: The `Sampler` type (but not its implementation) is part of the public API.++-- | A `Sampler` handle, which can be used to stop the sampler with `GHC.Stack.Profiler.stopSampler`.+--+--   @since 0.5.0.0+newtype Sampler = MkSampler+  { samplerAsync :: Async ()+  }++cancelSampler :: Sampler -> IO ()+cancelSampler MkSampler{samplerAsync} =+  cancel samplerAsync++-------------------------------------------------------------------------------+-- Event Loop+-------------------------------------------------------------------------------++newtype EventLoop = MkEventLoop+  { eventLoopAsync :: Async ()+  }++data ControlMessage+  = WriteProfileSample [ByteString]+  | PublishInitEvents (MVar ())+  | StartProfiling (MVar ())+  | StopProfiling (MVar ())+  | StartEventlog (MVar ())+  | StopEventlog (MVar ())++startEventLoop :: Manager -> IO ()+startEventLoop manager = do+  !eventLoopThread <- do+    eventLoopAsync <- async $ forever $ eventHandler manager+    link eventLoopAsync -- If the event loop crashes, we want to know.+    pure $ MkEventLoop{eventLoopAsync}+  atomically $ do+    writeTVar (eventLoopThreadVar manager) (Just eventLoopThread)++eventHandler :: Manager -> IO ()+eventHandler manager = do+  msg <- readChan (messageChan manager)+  run <- atomically $ shouldProfile manager+  case msg of+    WriteProfileSample msgs ->+      case run of+        True ->+          mapM_ Compat.traceBinaryEventIO msgs+        False ->+          -- If we received a sample but the eventlog is currently locked+          -- discard the message.+          pure ()+    StartProfiling barrier -> do+      atomically $ enableSampling manager+      putMVar barrier ()+    StopProfiling barrier -> do+      atomically $ disableSampling manager+      putMVar barrier ()+    StartEventlog barrier -> do+      atomically $ enableEventLogging manager+      putMVar barrier ()+    StopEventlog barrier -> do+      atomically $ disableEventLogging manager+      putMVar barrier ()+    PublishInitEvents barrier -> do+      symbolTable <- atomically $ readSymbolTable (symbolTableRef manager)+      let+        versionMessage = GSPC.ProtocolVersion GSPC.MyProtocolVersion+        messages = versionMessage : Decode.initMessages symbolTable+        messagesBytes = Decode.serializeMessages messages++      for_ messagesBytes $ \binaryMessage ->+        Compat.traceBinaryEventIO (BSL.toStrict binaryMessage)++      Debug.Trace.flushEventLog+      putMVar barrier ()++stopEventLoop :: Manager -> IO ()+stopEventLoop manager = do+  maybeEventThread <- atomically $ stateTVar (eventLoopThreadVar manager) (,Nothing)+  case maybeEventThread of+    Nothing ->+      -- Manager is already stopped+      pure ()+    Just MkEventLoop{eventLoopAsync} -> do+      -- Send stopProfilingMessage. This tells the event loop to flush all messages.+      sendStopProfilingMessage manager+      -- Stop the event loop thread.+      cancel eventLoopAsync++-------------------------------------------------------------------------------+-- Events+-------------------------------------------------------------------------------++-- NOTE: The `startProfiling` function is part of the public API.++-- | Start all `Sampler` threads.+--+--   This blocks until all `Sampler` threads have started.+--+--   __Warning:__ This function deadlocks when used with a stopped `Manager`.+--+--  @since 0.5.0.0+startProfiling :: Manager -> IO ()+startProfiling manager = do+  -- TODO: This atomically is redundant, the main loop thread sets it anyway.+  atomically $ writeTVar (shouldSampleVar manager) True+  sendStartProfilingMessage manager++-- NOTE: The `stopProfiling` function is part of the public API.++-- | Start all `Sampler` threads.+--+--   This blocks until all `Sampler` threads have stopped.+--+--   __Warning:__ This function deadlocks when used with a stopped `Manager`.+--+--  @since 0.5.0.0+stopProfiling :: Manager -> IO ()+stopProfiling manager = do+  -- TODO: This atomically is *not* redundant. It makes sure no new samples+  -- can be created. Otherwise, new samples could be created and queued while+  -- we are waiting for the event loop to process this message. It is+  -- important that, once this message is processed, no sampler thread is+  -- sampling at all. Otherwise, there will be new init events that are not+  -- published.+  atomically $ writeTVar (shouldSampleVar manager) False+  sendStopProfilingMessage manager++-- | Start profiling.+--+-- Blocks until the message has been processed by the main event loop.+sendStartProfilingMessage :: Manager -> IO ()+sendStartProfilingMessage manager = do+  barrier <- newEmptyMVar+  writeChan+    (messageChan manager)+    (StartProfiling barrier)+  takeMVar barrier++-- | Stop profiling.+--+-- Blocks until the message has been processed by the main event loop.+sendStopProfilingMessage :: Manager -> IO ()+sendStopProfilingMessage manager = do+  barrier <- newEmptyMVar+  writeChan+    (messageChan manager)+    (StopProfiling barrier)+  takeMVar barrier++-- | Start EventLogging now.+--+-- Blocks until the message has been processed by the main event loop.+sendEnableEventlogMessage :: Manager -> IO ()+sendEnableEventlogMessage manager = do+  barrier <- newEmptyMVar+  writeChan+    (messageChan manager)+    (StartEventlog barrier)+  takeMVar barrier++-- | Stop EventLogging now.+--+-- Blocks until the message has been processed by the main event loop.+sendDisableEventlogMessage :: Manager -> IO ()+sendDisableEventlogMessage manager = do+  barrier <- newEmptyMVar+  writeChan+    (messageChan manager)+    (StopEventlog barrier)+  takeMVar barrier++-- | Publish all init messages so far.+--+-- Blocks until the init events have been written to the eventlog and+-- eventlog was flushed.+sendPublishInitEventMessages :: Manager -> IO ()+sendPublishInitEventMessages manager = do+  barrier <- newEmptyMVar+  writeChan+    (messageChan manager)+    (PublishInitEvents barrier)+  takeMVar barrier
+ src/GHC/Stack/Profiler/Internal/Sampler.hs view
@@ -0,0 +1,175 @@+module GHC.Stack.Profiler.Internal.Sampler (+  Interval (..),+  SamplerDescr (..),+  withSampler,+  startSampler,+  stopSampler,+) where++import Control.Concurrent (ThreadId, myThreadId, threadCapability, threadDelay)+import Control.Concurrent.Async (async)+import Control.Concurrent.Chan (writeChan)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket, finally)+import Control.Monad.STM (atomically)+import qualified Control.Monad.STM as STM+import qualified Data.ByteString.Lazy as BSL+import Data.Coerce (coerce)+import Data.Foldable (for_)+import Data.Word (Word32)+import GHC.Conc (BlockReason (..), ThreadStatus (..), labelThread, threadStatus)+import GHC.Conc.Sync (fromThreadId)+import GHC.Internal.Control.Monad (forever)+import GHC.Stack.CloneStack (cloneThreadStack)+import qualified GHC.Stack.Profiler.Core as GSPC+import GHC.Stack.Profiler.Internal.Decode (+  CallStackSample (..),+  decodeToCallStack,+  serializeCallStack,+  serializeMessages,+ )+import GHC.Stack.Profiler.Internal.Manager (+  ControlMessage (..),+  Manager (..),+  Sampler (..),+  cancelSampler,+  registerSamplerThread,+  shouldProfile,+  unregisterSamplerThread,+ )++-- NOTE: Part of the public API.++-- | The sampling interval.+--+--   @since 0.5.0.0+newtype Interval+  = MkIntervalMillis {intervalMillis :: Int}+  deriving stock (Eq, Show)++-- | @`fromInteger` n@ constructs an interval of @n@ milliseconds.+instance Num Interval where+  (+) :: Interval -> Interval -> Interval+  (+) = coerce @(Int -> Int -> Int) (+)++  (-) :: Interval -> Interval -> Interval+  (-) = coerce @(Int -> Int -> Int) (+)++  (*) :: Interval -> Interval -> Interval+  (*) = coerce @(Int -> Int -> Int) (*)++  abs :: Interval -> Interval+  abs = coerce @(Int -> Int) abs++  signum :: Interval -> Interval+  signum = coerce @(Int -> Int) signum++  fromInteger :: Integer -> Interval+  fromInteger = coerce @(Integer -> Int) fromInteger++-- | Get the interval in microseconds.+intervalMicros :: Interval -> Int+intervalMicros = (* 1_000) . intervalMillis+{-# INLINE intervalMicros #-}++-- | A description used to construct a `Sampler` thread.+data SamplerDescr = MkSamplerDescr+  { samplerManager :: Manager+  , samplerThreads :: IO [ThreadId]+  , sampleInterval :: !Interval+  }++withSampler :: SamplerDescr -> (Sampler -> IO a) -> IO a+withSampler sampler action =+  bracket+    (startSampler sampler)+    (stopSampler (samplerManager sampler))+    action++-- | Run a `SamplerDescr`.+startSampler :: SamplerDescr -> IO Sampler+startSampler sampler@MkSamplerDescr{samplerManager, sampleInterval} = do+  barrier <- newEmptyMVar+  samplerAsync <- async $ do+    () <- takeMVar barrier+    samplerThreadId <- myThreadId+    labelThread samplerThreadId $+      "Stack Sampler " <> show (fromThreadId samplerThreadId)+    forever $ do+      sampleThreads sampler+      -- TODO: Measure the delay at each step and subtract that from the next tick.+      threadDelay (intervalMicros sampleInterval)++  let+    samplerThread = MkSampler{samplerAsync}++  -- Register this sampler thread to avoid sampling it+  registerSamplerThread samplerManager samplerThread+  putMVar barrier ()+  pure samplerThread++-- NOTE: `stopSampler` is part of the public API.++-- | Stop a `Sampler` thread.+--+--   @since 0.5.0.0+stopSampler :: Manager -> Sampler -> IO ()+stopSampler manager samplerThread = do+  cancelSampler samplerThread+    `finally` unregisterSamplerThread manager samplerThread++-- | Take one `CallStackSample` for every thread sampled by the `Sampler`.+sampleThreads :: SamplerDescr -> IO ()+sampleThreads MkSamplerDescr{samplerManager, samplerThreads} = do+  -- Wait until the manager signals to start profiling.+  atomically (STM.check =<< shouldProfile samplerManager)+  -- List all threads that should be sampled.+  threadIds <- samplerThreads+  -- Sample all threads.+  for_ threadIds $ \threadId ->+    sampleThread samplerManager threadId++-- | Take one `CallStackSample` for the given `ThreadId` and send it to the given `Manager`.+sampleThread :: Manager -> ThreadId -> IO ()+sampleThread manager threadId =+  sampleCallStackFor threadId+    >>= maybe (pure ()) (sendCallStackSample manager)++-- | Send a `CallStackSample` to the given `Manager`.+sendCallStackSample :: Manager -> CallStackSample -> IO ()+sendCallStackSample manager callStackSample = do+  callStack <- decodeToCallStack callStackSample+  binaryMessages <-+    atomically $ do+      -- TODO: Should these two STM calls be put in a single transaction?+      messages <- serializeCallStack (symbolTableRef manager) callStack+      STM.check =<< shouldProfile manager+      pure $! serializeMessages messages+  writeChan (messageChan manager) $!+    WriteProfileSample $+      BSL.toStrict <$> binaryMessages++-- | Take a `CallStackSample` for the given `ThreadId`.+sampleCallStackFor :: ThreadId -> IO (Maybe CallStackSample)+sampleCallStackFor threadId = do+  status <- threadStatus threadId+  (capNo, _lockedToCap) <- threadCapability threadId+  if canTakeCallStackSample status+    then do+      cloneThreadStack threadId >>= \stackSnapshot ->+        pure $+          Just $+            CallStackSample+              { callStackSampleThreadId = GSPC.MkThreadId . fromThreadId $ threadId+              , callStackSampleCapabilityId = GSPC.MkCapabilityId . fromIntegral @Int @Word32 $ capNo+              , callStackSampleStackSnapshot = stackSnapshot+              }+    else pure Nothing++-- | Can a `CallStackSample` be taken for the given `ThreadId`?+canTakeCallStackSample :: ThreadStatus -> Bool+canTakeCallStackSample = \case+  ThreadRunning -> True+  ThreadBlocked BlockedOnMVar -> True+  _ -> False+{-# INLINE canTakeCallStackSample #-}
+ src/GHC/Stack/Profiler/Internal/Stack/Compat.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}++module GHC.Stack.Profiler.Internal.Stack.Compat (+  lookupIpeIdForStackFrame,+) where++import Data.Binary+import GHC.Internal.InfoProv.Types.Compat+import GHC.Internal.Stack.Decode.Compat++#if !MIN_VERSION_ghc_internal(9,1500,0)+import GHC.Stack.Profiler.Internal.Util (castPtrToWord64)+#endif++lookupIpeIdForStackFrame :: StackInfoTable -> IO (Maybe Word64)+lookupIpeIdForStackFrame itbl = do+  mId <- lookupIpeId (infoTablePtr itbl)+#if MIN_VERSION_ghc_internal(9,1500,0)+  pure mId+#else+  -- In GHC <9.14, the key for looking up the InfoProv is the Ptr to the 'StgInfoTable'+  -- However, to the eventlog, we write the address of the struct.+  -- So, to check whether there is an InfoProv, we first lookup by the 'StgInfoTable' ptr,+  -- i.e. not adjusting for 'TABLES_NEXT_TO_CODE', but if there is an entry, we use the+  -- the struct address, otherwise the decoder will not be able to find the 'InfoProv'.+  pure $! castPtrToWord64 (infoTableStructPtr itbl) <$ mId+#endif
+ src/GHC/Stack/Profiler/Internal/Stack/Decode.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MagicHash #-}++module GHC.Stack.Profiler.Internal.Stack.Decode (+  decodeStackWithIpProvId,+) where++import Data.Maybe (catMaybes)+import qualified Data.Text as Text+import Unsafe.Coerce (unsafeCoerce)++import GHC.Internal.ClosureTypes.Compat+import GHC.Internal.Stack.Constants.Compat+import GHC.Internal.Stack.Decode.Compat as Decode+import GHC.Internal.Stack.Types+import GHC.Stack.Annotation.Experimental.Compat+import GHC.Stack.CloneStack (StackSnapshot (..))++import GHC.Exts.Heap.InfoTable.Types++import GHC.Stack.Profiler.Core (IpeId (..), SourceLocation (..), StackItem (..))+import GHC.Stack.Profiler.Internal.Stack.Compat (lookupIpeIdForStackFrame)++decodeStackWithIpProvId :: StackSnapshot -> IO [StackItem]+decodeStackWithIpProvId (StackSnapshot stack#) = do+  info <- getInfoTableForStack stack#+  case tipe info of+    STACK -> do+      let+        sfls = stackFrameLocations stack#+      stack' <- stackFrameLocationItems sfls+      pure stack'+    _ -> error $ "Expected STACK closure, got " ++ show info+ where+  stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]+  stackFrameLocations s# =+    stackHead s#+      : go (advanceStackFrameLocation (stackHead s#))+   where+    go :: Maybe StackFrameLocation -> [StackFrameLocation]+    go Nothing = []+    go (Just r) = r : go (advanceStackFrameLocation r)++stackFrameLocationItems :: [StackFrameLocation] -> IO [StackItem]+stackFrameLocationItems frames =+  catMaybes <$> traverse stackFrameLocationItem frames++stackFrameLocationItem :: StackFrameLocation -> IO (Maybe StackItem)+stackFrameLocationItem (StackSnapshot stack#, index) = do+  stackItbl <- getInfoTableOnStack stack# index+  case tipe (infoTable stackItbl) of+    ANN_FRAME ->+      let+        Box annotation = getClosureBox stack# (index + offsetStgAnnFrameAnn)+      in+        pure $ Just $ stackAnnotationToStackItem (unsafeCoerce annotation)+    _ ->+      fmap (IpeId . MkIpeId) <$> lookupIpeIdForStackFrame stackItbl++stackAnnotationToStackItem :: SomeStackAnnotation -> StackItem+stackAnnotationToStackItem someStackAnnotation =+  let+    message = showStackAnnotationDescription someStackAnnotation+    sourceLoc = do+      srcLoc <- showStackAnnotationLocation someStackAnnotation+      Just $+        MkSourceLocation+          { line = fromIntegral $ srcLocStartLine srcLoc+          , column = fromIntegral $ srcLocStartCol srcLoc+          , fileName = Text.pack $ srcLocFile srcLoc+          }+  in+    UserAnnotation message sourceLoc
+ src/GHC/Stack/Profiler/Internal/SymbolTable.hs view
@@ -0,0 +1,37 @@+module GHC.Stack.Profiler.Internal.SymbolTable (+  -- * 'StackSymbolTable' type+  StackSymbolTable,+  emptySymbolTable,+  emptySymbolTableIO,+  readSymbolTable,+  writeSymbolTable,+) where++import Control.Concurrent.STM+import GHC.Generics (Generic)+import GHC.Stack.Profiler.Core++-- | A @'SymbolTableWriter' 'MapTable'@ guarded by a lock for mutable, concurrent access.+--+-- The lock is an 'MVar', but this is considered an implementation detail that may change without warning.+newtype StackSymbolTable = MkStackSymbolTable+  { writerSymbolTable :: TVar (SymbolTableWriter MapTable)+  }+  deriving (Generic, Eq)++-- | Create an empty 'StackSymbolTable'+emptySymbolTableIO :: IO StackSymbolTable+emptySymbolTableIO = atomically emptySymbolTable++emptySymbolTable :: STM StackSymbolTable+emptySymbolTable =+  MkStackSymbolTable+    <$> newTVar emptyMapSymbolTableWriter++readSymbolTable :: StackSymbolTable -> STM (SymbolTableWriter MapTable)+readSymbolTable =+  readTVar . writerSymbolTable++writeSymbolTable :: SymbolTableWriter MapTable -> StackSymbolTable -> STM ()+writeSymbolTable newWriterTbl symTbl =+  writeTVar (writerSymbolTable symTbl) newWriterTbl
+ src/GHC/Stack/Profiler/Internal/Util.hs view
@@ -0,0 +1,190 @@+module GHC.Stack.Profiler.Internal.Util (+  castPtrToWord64,++  -- * Glob Patterns+  Glob,+  matches,++  -- * DList+  DList,++  -- * WriterT+  WriterT,+  tell,+  runWriterT,+) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.String (IsString (..))+import Data.Word+import Foreign.Ptr+import GHC.IsList (IsList (..))++castPtrToWord64 :: Ptr a -> Word64+castPtrToWord64 ptr = case ptrToWordPtr ptr of+  WordPtr w -> fromIntegral w -- On platforms that use 32-bit systems, the key is still Word64++-------------------------------------------------------------------------------+-- Glob+-------------------------------------------------------------------------------++-- NOTE: The `Glob` type (but not its implementation) is part of the public API.++-- | A glob pattern.+--+--   Use `fromString` to construct glob patterns from strings.+--+--   A @*@ matches any string, including the empty string.+--+--   One can remove the special meaning of @*@ by preceding it with a backslash.+--+--  @since 0.5.0.0+newtype Glob = Glob [GlobPart]++data GlobPart = Wildcard | Literal String++instance IsString Glob where+  fromString :: String -> Glob+  fromString = Glob . go+   where+    go :: String -> [GlobPart]+    go [] = []+    go ('*' : pat) = Wildcard : go pat+    go ('\\' : '*' : pat) = literal ['*'] (go pat)+    go (c : pat) = literal [c] (go pat)++    literal :: String -> [GlobPart] -> [GlobPart]+    literal lit (Literal lit' : pat) = Literal (lit <> lit') : pat+    literal lit pat = Literal lit : pat++instance Show Glob where+  showsPrec :: Int -> Glob -> ShowS+  showsPrec p (Glob pat) = showsPrec p (go pat)+   where+    go [] = []+    go (Wildcard : pat') = '*' : go pat'+    go (Literal lit : pat') = escape lit <> go pat'++    escape :: String -> String+    escape [] = []+    escape ('*' : str) = '\\' : '*' : escape str+    escape (c : str) = c : escape str++-- NOTE: The `matches` function is part of the public API.++-- | Test if the given `Glob` pattern matches the given `String`.+--+--   @since 0.5.0.0+matches :: Glob -> String -> Bool+matches (Glob parts) = go parts+ where+  go [] _str = True+  go [Wildcard] _str = True+  go (Wildcard : pat'@(Wildcard : _)) str = go pat' str+  go (Wildcard : Literal lit : pat') str = any (go pat') (skipWildcardLiteral lit str)+  go (Literal lit : pat') str = maybe False (go pat') (skipPrefix lit str)++  -- Stream the possible remainders after matching a wildcard followed by a literal.+  --+  -- NOTE: O( n * m ) where n = length str and m = length lit.+  skipWildcardLiteral :: String -> String -> [String]+  skipWildcardLiteral _lit [] = []+  skipWildcardLiteral lit str@(_c : str')+    -- NOTE: yield suff, but continue searching from str', in case of overlaps.+    | Just suff <- skipPrefix lit str = suff : skipWildcardLiteral lit str'+    | otherwise = skipWildcardLiteral lit str'++  -- Stream the possible remainders after matching a literal.+  --+  -- NOTE: O( m ) where m = length lit+  skipPrefix :: String -> String -> Maybe String+  skipPrefix [] str = Just str+  skipPrefix (_ : _) [] = Nothing+  skipPrefix (l : lit') (c : str') = if l == c then skipPrefix lit' str' else Nothing++-------------------------------------------------------------------------------+-- DList+-------------------------------------------------------------------------------++newtype DList a = MkDList {unDList :: [a] -> [a]}++instance Semigroup (DList a) where+  (<>) :: DList a -> DList a -> DList a+  MkDList xs <> MkDList ys = MkDList (xs . ys)+  {-# INLINE (<>) #-}++instance Monoid (DList a) where+  mempty :: DList a+  mempty = MkDList id+  {-# INLINE mempty #-}++instance IsList (DList a) where+  type Item (DList a) = a++  toList :: DList a -> [a]+  toList = ($ []) . unDList+  {-# INLINE toList #-}++  fromList :: [a] -> DList a+  fromList = MkDList . (++)+  {-# INLINE fromList #-}++-------------------------------------------------------------------------------+-- WriterT+-------------------------------------------------------------------------------++newtype WriterT w m a = WriterT {unWriterT :: w -> m (a, w)}++instance (Functor m) => Functor (WriterT w m) where+  fmap :: (Functor m) => (a -> b) -> WriterT w m a -> WriterT w m b+  fmap f m = WriterT $ \w -> (\(a, w') -> (f a, w')) <$> unWriterT m w+  {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (WriterT w m) where+  pure ::+    (Functor m, Monad m) =>+    a -> WriterT w m a+  pure a = WriterT $ \w -> return (a, w)+  {-# INLINE pure #-}++  (<*>) ::+    (Functor m, Monad m) =>+    WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b+  WriterT mf <*> WriterT mx = WriterT $ \w -> do+    (f, w') <- mf w+    (x, w'') <- mx w'+    return (f x, w'')+  {-# INLINE (<*>) #-}++instance (Monad m) => Monad (WriterT w m) where+  (>>=) ::+    (Monad m) =>+    WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b+  m >>= k = WriterT $ \w -> do+    (a, w') <- unWriterT m w+    unWriterT (k a) w'+  {-# INLINE (>>=) #-}++writer :: (Monoid w, Monad m) => (a, w) -> WriterT w m a+writer (a, w') = WriterT $ \w ->+  let wt = w `mappend` w' in wt `seq` return (a, wt)+{-# INLINE writer #-}++tell :: (Monoid w, Monad m) => w -> WriterT w m ()+tell w = writer ((), w)+{-# INLINE tell #-}++runWriterT :: (Monoid w) => WriterT w m a -> m (a, w)+runWriterT m = unWriterT m mempty+{-# INLINE runWriterT #-}++lift :: (Monad m) => m a -> WriterT w m a+lift m = WriterT $ \w -> do+  a <- m+  return (a, w)+{-# INLINE lift #-}++instance (MonadIO m) => MonadIO (WriterT w m) where+  liftIO :: (MonadIO m) => IO a -> WriterT w m a+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}
− src/GHC/Stack/Profiler/Manager.hs 
@@ -1,100 +0,0 @@-module GHC.Stack.Profiler.Manager (-  StackProfilerManager (..),-  newStackProfilerManager,-  shouldProfile,-  EventThread (..),-  ProfilerMessage (..),-  enableEventLogging,-  disableEventLogging,-  enableSampling,-  disableSampling,-) where--import Control.Concurrent (ThreadId)-import Control.Concurrent.Async (Async)-import Control.Concurrent.Chan-import Control.Concurrent.MVar-import Control.Concurrent.STM (STM)-import Control.Concurrent.STM.TVar-import qualified Control.Concurrent.STM.TVar as TVar-import Data.ByteString (ByteString)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import qualified Debug.Trace.Binary.Compat as Compat-import GHC.Generics (Generic)-import GHC.Stack.Profiler.SymbolTable---- | A 'StackProfilerManager' records all the relevant information--- to manage the ghc stack profiler run-time.-data StackProfilerManager = MkStackProfilerManager-  { profilerThreads :: !(TVar (Map ThreadId (Async ())))-  -- ^ 'Async' of the stack sampling thread.-  , mainEventLoopThread :: !(TVar (Maybe EventThread))-  -- ^ Main event loop thread responsible for processing profiler messages, etc...-  , symbolTableRef :: !StackSymbolTable-  -- ^ Global table for common symbols.-  , isThreadSamplerRunning :: !(TVar Bool)-  -- ^ Is the profiler currently running?-  ---  -- Can be controlled via 'startProfiler' and 'stopProfiler'.-  -- This variable describes whether the user wants to profile, regardless-  -- of the eventlog state.-  , isEventlogStarted :: !(TVar Bool)-  -- ^ Is there an eventlog?-  ---  -- It is fully possible that we start profiling but no eventlog-writer-  -- being connected/configured. The eventlog can be enabled at a later point,-  -- or stopped/started via @eventlog-socket@.-  -- This variable tracks the state of the eventlog-writer.-  , messageChan :: Chan ProfilerMessage-  }-  deriving (Generic, Eq)--data ProfilerMessage-  = WriteProfileSample [ByteString]-  | PublishInitEvents (MVar ())-  | StartProfiling (MVar ())-  | StopProfiling (MVar ())-  | StartEventlog (MVar ())-  | StopEventlog (MVar ())--newStackProfilerManager :: Bool -> IO StackProfilerManager-newStackProfilerManager running = do-  tracingEnabled <- Compat.userTracingEnabledIO-  MkStackProfilerManager-    <$> newTVarIO Map.empty-    <*> newTVarIO Nothing-    <*> emptySymbolTableIO-    <*> newTVarIO running-    <*> newTVarIO tracingEnabled-    <*> newChan--data EventThread = MkEventThread-  { eventThread :: !(Async ())-  }---- | Can we profile right now?------ We only sample a stack if the profiler is instructed to run and the eventlog is enabled.-shouldProfile :: StackProfilerManager -> STM Bool-shouldProfile manager =-  liftA2-    (&&)-    (readTVar $ isThreadSamplerRunning manager)-    (readTVar $ isEventlogStarted manager)--enableEventLogging :: StackProfilerManager -> STM ()-enableEventLogging manager = do-  TVar.writeTVar (isEventlogStarted manager) True--disableEventLogging :: StackProfilerManager -> STM ()-disableEventLogging manager = do-  TVar.writeTVar (isEventlogStarted manager) False--enableSampling :: StackProfilerManager -> STM ()-enableSampling manager = do-  TVar.writeTVar (isThreadSamplerRunning manager) True--disableSampling :: StackProfilerManager -> STM ()-disableSampling manager = do-  TVar.writeTVar (isThreadSamplerRunning manager) False
− src/GHC/Stack/Profiler/Stack/Compat.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Stack.Profiler.Stack.Compat (-  lookupIpeIdForStackFrame,-) where--import Data.Binary-import GHC.Internal.InfoProv.Types.Compat-import GHC.Internal.Stack.Decode.Compat--#if !MIN_VERSION_ghc_internal(9,1500,0)-import GHC.Stack.Profiler.Util (castPtrToWord64)-#endif--lookupIpeIdForStackFrame :: StackInfoTable -> IO (Maybe Word64)-lookupIpeIdForStackFrame itbl = do-  mId <- lookupIpeId (infoTablePtr itbl)-#if MIN_VERSION_ghc_internal(9,1500,0)-  pure mId-#else-  -- In GHC <9.14, the key for looking up the InfoProv is the Ptr to the 'StgInfoTable'-  -- However, to the eventlog, we write the address of the struct.-  -- So, to check whether there is an InfoProv, we first lookup by the 'StgInfoTable' ptr,-  -- i.e. not adjusting for 'TABLES_NEXT_TO_CODE', but if there is an entry, we use the-  -- the struct address, otherwise the decoder will not be able to find the 'InfoProv'.-  pure $! castPtrToWord64 (infoTableStructPtr itbl) <$ mId-#endif
− src/GHC/Stack/Profiler/Stack/Decode.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE MagicHash #-}--module GHC.Stack.Profiler.Stack.Decode (-  decodeStackWithIpProvId,-) where--import Data.Maybe (catMaybes)-import qualified Data.Text as Text-import Unsafe.Coerce (unsafeCoerce)--import GHC.Internal.ClosureTypes.Compat-import GHC.Internal.Stack.Constants.Compat-import GHC.Internal.Stack.Decode.Compat as Decode-import GHC.Internal.Stack.Types-import GHC.Stack.Annotation.Experimental.Compat-import GHC.Stack.CloneStack (StackSnapshot (..))--import GHC.Exts.Heap.InfoTable.Types--import GHC.Stack.Profiler.Core.Eventlog-import GHC.Stack.Profiler.Core.ThreadSample-import GHC.Stack.Profiler.Core.Util-import GHC.Stack.Profiler.Stack.Compat (lookupIpeIdForStackFrame)--decodeStackWithIpProvId :: StackSnapshot -> IO [StackItem]-decodeStackWithIpProvId (StackSnapshot stack#) = do-  info <- getInfoTableForStack stack#-  case tipe info of-    STACK -> do-      let-        sfls = stackFrameLocations stack#-      stack' <- stackFrameLocationItems sfls-      pure stack'-    _ -> error $ "Expected STACK closure, got " ++ show info- where-  stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]-  stackFrameLocations s# =-    stackHead s#-      : go (advanceStackFrameLocation (stackHead s#))-   where-    go :: Maybe StackFrameLocation -> [StackFrameLocation]-    go Nothing = []-    go (Just r) = r : go (advanceStackFrameLocation r)--stackFrameLocationItems :: [StackFrameLocation] -> IO [StackItem]-stackFrameLocationItems frames =-  catMaybes <$> traverse stackFrameLocationItem frames--stackFrameLocationItem :: StackFrameLocation -> IO (Maybe StackItem)-stackFrameLocationItem (StackSnapshot stack#, index) = do-  stackItbl <- getInfoTableOnStack stack# index-  case tipe (infoTable stackItbl) of-    ANN_FRAME ->-      let-        Box annotation = getClosureBox stack# (index + offsetStgAnnFrameAnn)-      in-        pure $ Just $ stackAnnotationToStackItem (unsafeCoerce annotation)-    _ ->-      fmap (IpeId . MkIpeId) <$> lookupIpeIdForStackFrame stackItbl--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
− src/GHC/Stack/Profiler/SymbolTable.hs 
@@ -1,37 +0,0 @@-module GHC.Stack.Profiler.SymbolTable (-  -- * 'StackSymbolTable' type-  StackSymbolTable,-  emptySymbolTable,-  emptySymbolTableIO,-  readSymbolTable,-  writeSymbolTable,-) where--import Control.Concurrent.STM-import GHC.Generics (Generic)-import GHC.Stack.Profiler.Core.SymbolTable---- | A @'SymbolTableWriter' 'MapTable'@ guarded by a lock for mutable, concurrent access.------ The lock is an 'MVar', but this is considered an implementation detail that may change without warning.-newtype StackSymbolTable = MkStackSymbolTable-  { writerSymbolTable :: TVar (SymbolTableWriter MapTable)-  }-  deriving (Generic, Eq)---- | Create an empty 'StackSymbolTable'-emptySymbolTableIO :: IO StackSymbolTable-emptySymbolTableIO = atomically emptySymbolTable--emptySymbolTable :: STM StackSymbolTable-emptySymbolTable =-  MkStackSymbolTable-    <$> newTVar emptyMapSymbolTableWriter--readSymbolTable :: StackSymbolTable -> STM (SymbolTableWriter MapTable)-readSymbolTable =-  readTVar . writerSymbolTable--writeSymbolTable :: SymbolTableWriter MapTable -> StackSymbolTable -> STM ()-writeSymbolTable newWriterTbl symTbl =-  writeTVar (writerSymbolTable symTbl) newWriterTbl
− src/GHC/Stack/Profiler/Util.hs 
@@ -1,10 +0,0 @@-module GHC.Stack.Profiler.Util (-  castPtrToWord64,-) where--import Data.Word-import Foreign.Ptr--castPtrToWord64 :: Ptr a -> Word64-castPtrToWord64 ptr = case ptrToWordPtr ptr of-  WordPtr w -> fromIntegral w -- On platforms that use 32-bit systems, the key is still Word64
+ test/Main.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (myThreadId)+import Data.Maybe (isNothing)+import GHC.Stack.Profiler (Glob, startManager, startSamplerFor, stopManager, stopSampler, withManager)+import qualified GHC.Stack.Profiler as Glob (matches)+import System.Timeout (timeout)+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main =+  defaultMain $+    testGroup "Tests" $+      [ testGroup "Profiler" $+          [ bug_stopManagerTwice+          , test_stopSamplerTwice+          ]+      , testGroup "Glob" $+          [ runGlobTest globTest+          | globTest <- globTests+          ]+      ]++-------------------------------------------------------------------------------+-- Manager+-------------------------------------------------------------------------------++bug_stopManagerTwice :: TestTree+bug_stopManagerTwice = do+  testCase "stopManager twice" $ do+    manager <- startManager False+    stopManager manager+    timedOut <-+      fmap isNothing . timeout 5_000_000 $ do+        stopManager manager+    assertBool "Test timed out" (not timedOut)++test_stopSamplerTwice :: TestTree+test_stopSamplerTwice = do+  testCase "stopSampler twice" $+    withManager False $ \manager -> do+      threadId <- myThreadId+      sampler <- startSamplerFor manager threadId 10+      stopSampler manager sampler+      timedOut <-+        fmap isNothing . timeout 5_000_000 $ do+          stopSampler manager sampler+      assertBool "Test timed out" (not timedOut)++-------------------------------------------------------------------------------+-- Glob+-------------------------------------------------------------------------------++globTests :: [GlobTest]+globTests =+  [ "*" `Matches` ""+  , "*" `Matches` "hello, world!"+  , "hell*" `Matches` "hello, world!"+  , "*!" `Matches` "hello, world!"+  , "hell*world!" `Matches` "hello, world!"+  , "henlo*" `NotMatches` "hello, world!"+  , "*worldy!" `NotMatches` "hello, world!"+  , "beach party" `NotMatches` "hello, world!"+  , "\\*" `NotMatches` ""+  , "\\*" `Matches` "*"+  , "hello\\*" `Matches` "hello*"+  , "\\*world" `Matches` "*world"+  , "hello\\*world" `Matches` "hello*world"+  , "\\**\\*" `Matches` "*helloworld*"+  ]++data GlobTest+  = Glob `Matches` String+  | Glob `NotMatches` String+  deriving (Show)++runGlobTest :: GlobTest -> TestTree+runGlobTest test =+  testCase (show test) $+    assertBool (show test) $+      case test of+        pat `Matches` str -> pat `Glob.matches` str+        pat `NotMatches` str -> not (pat `Glob.matches` str)