packages feed

ghc-stack-profiler (empty) → 0.1.0.0

raw patch · 16 files changed

+1084/−0 lines, 16 filesdep +basedep +binarydep +bytestring

Dependencies added: base, binary, bytestring, ghc-experimental, ghc-heap, ghc-internal, ghc-prim, ghc-stack-profiler-core, ghc-trace-events, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for ghc-stack-profiler++## 0.1.0.0 -- 2025-12-09++* Adds API for sampling the RTS callstack and writing the results to the eventlog.+* First version. Released on an unsuspecting world.
+ cbits/Stack.cmm view
@@ -0,0 +1,191 @@+// ////////////////////////////////////////////////////////////////////////////+//+// DO NOT MODIFY THIS FILE+//+// It has been copy pasted from+// https://gitlab.haskell.org/ghc/ghc/-/blob/ac7b737e8da74b2508994867ede0becb387cfc47/libraries/ghc-internal/cbits/Stack.cmm+//+// ////////////////////////////////////////////////////////////////////////////++// Uncomment to enable assertions during development+// #define DEBUG 1++#include "Cmm.h"++// StgStack_marking was not available in the Stage0 compiler at the time of+// writing. Because, it has been added to derivedConstants when Stack.cmm was+// developed.+#if defined(StgStack_marking)++// Returns the next stackframe's StgStack* and offset in it. And, an indicator+// if this frame is the last one (`hasNext` bit.)+// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)+advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {+  W_ frameSize;+  (frameSize) = ccall stackFrameSize(stack, offsetWords);++  P_ nextClosurePtr;+  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));++  P_ stackArrayPtr;+  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;++  P_ stackBottom;+  W_ stackSize, stackSizeInBytes;+  stackSize = TO_W_(StgStack_stack_size(stack));+  stackSizeInBytes = WDS(stackSize);+  stackBottom = stackSizeInBytes + stackArrayPtr;++  P_ newStack;+  W_ newOffsetWords, hasNext;+  if(nextClosurePtr < stackBottom) (likely: True) {+    newStack = stack;+    newOffsetWords = offsetWords + frameSize;+    hasNext = 1;+  } else {+    P_ underflowFrameStack;+    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);+    if (underflowFrameStack == NULL) (likely: True) {+      newStack = NULL;+      newOffsetWords = NULL;+      hasNext = NULL;+    } else {+      newStack = underflowFrameStack;+      newOffsetWords = NULL;+      hasNext = 1;+    }+  }++  return (newStack, newOffsetWords, hasNext);+}++// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)+getSmallBitmapzh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ bitmap, size;+  (bitmap) = ccall getBitmapWord(c);+  (size) = ccall getBitmapSize(c);++  return (bitmap, size);+}+++// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)+getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ bitmap, size, specialType;+  (bitmap) = ccall getRetFunBitmapWord(c);+  (size) = ccall getRetFunBitmapSize(c);++  return (bitmap, size);+}++// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getLargeBitmap(MyCapability(), c);+  (size) = ccall getLargeBitmapSize(c);++  return (words, size);+}++// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getBCOLargeBitmap(MyCapability(), c);+  (size) = ccall getBCOLargeBitmapSize(c);++  return (words, size);+}++// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {+  P_ c, words;+  W_ size;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);+  (size) = ccall getRetFunSize(c);++  return (words, size);+}++// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)+getWordzh(P_ stack, W_ offsetWords) {+  P_ wordAddr;+  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));+  return (W_[wordAddr]);+}++// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)+getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {+  P_ closurePtr;+  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));++  P_ next_chunk;+  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk));+  return (next_chunk);+}++// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)+isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {+  P_ c;+  c = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  W_ type;+  (type) = ccall isArgGenBigRetFunType(c);+  return (type);+}++// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)+getInfoTableAddrszh(P_ stack, W_ offsetWords) {+  P_ p, info_struct, info_ptr_ipe_key;+  p = StgStack_sp(stack) + WDS(offsetWords);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));+  info_struct = %GET_STD_INFO(UNTAG(p));+  info_ptr_ipe_key = %INFO_PTR(UNTAG(p));+  return (info_struct, info_ptr_ipe_key);+}++// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)+getStackInfoTableAddrzh(P_ stack) {+  P_ info;+  info = %GET_STD_INFO(UNTAG(stack));+  return (info);+}++// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)+getStackClosurezh(P_ stack, W_ offsetWords) {+  P_ ptr;+  ptr = StgStack_sp(stack) + WDS(offsetWords);++  P_ closure;+  (closure) = ccall getStackClosure(ptr);+  return (closure);+}++// (bits32) getStackFieldszh(StgStack* stack)+getStackFieldszh(P_ stack){+  bits32 size;+  size = StgStack_stack_size(stack);+  return (size);+}+#endif
+ cbits/Stack_c.c view
@@ -0,0 +1,159 @@+// ////////////////////////////////////////////////////////////////////////////+//+// DO NOT MODIFY THIS FILE+//+// It has been copy pasted from+// https://gitlab.haskell.org/ghc/ghc/-/blob/ac7b737e8da74b2508994867ede0becb387cfc47/libraries/ghc-internal/cbits/Stack_c.c+//+// ////////////////////////////////////////////////////////////////////////////+#include "MachDeps.h"+#include "Rts.h"+#include "RtsAPI.h"+#include "rts/Messages.h"+#include "rts/Types.h"+#include "rts/storage/ClosureTypes.h"+#include "rts/storage/Closures.h"+#include "rts/storage/FunTypes.h"+#include "rts/storage/InfoTables.h"++StgWord stackFrameSize(StgStack *stack, StgWord offset) {+  StgClosure *c = (StgClosure *)(stack->sp + offset);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));+  return stack_frame_sizeW(c);+}++StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {+  StgClosure *frame = (StgClosure *)(stack->sp + offset);+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));+  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);++  if (info->i.type == UNDERFLOW_FRAME) {+    return ((StgUnderflowFrame *)frame)->next_chunk;+  } else {+    return NULL;+  }+}++// Only exists to make the get_itbl macro available in Haskell code (via FFI).+const StgInfoTable *getItbl(StgClosure *closure) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));+  return get_itbl(closure);+}++StgWord getBitmapSize(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgWord bitmap = info->layout.bitmap;+  return BITMAP_SIZE(bitmap);+}++StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  switch (fun_info->f.fun_type) {+  case ARG_GEN:+    return BITMAP_SIZE(fun_info->f.b.bitmap);+  case ARG_GEN_BIG:+    return GET_FUN_LARGE_BITMAP(fun_info)->size;+  default:+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);+  }+}++StgWord getBitmapWord(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgWord bitmap = info->layout.bitmap;+  StgWord bitmapWord = BITMAP_BITS(bitmap);+  return bitmapWord;+}++StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  switch (fun_info->f.fun_type) {+  case ARG_GEN:+    return BITMAP_BITS(fun_info->f.b.bitmap);+  case ARG_GEN_BIG:+    // Cannot do more than warn and exit.+    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);+    stg_exit(EXIT_INTERNAL_ERROR);+  default:+    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);+  }+}++StgWord getLargeBitmapSize(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  const StgInfoTable *info = get_itbl(c);+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);+  return bitmap->size;+}++StgWord getRetFunSize(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  switch (fun_info->f.fun_type) {+  case ARG_GEN:+    return BITMAP_SIZE(fun_info->f.b.bitmap);+  case ARG_GEN_BIG:+    return GET_FUN_LARGE_BITMAP(fun_info)->size;+  default:+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);+  }+}++StgWord getBCOLargeBitmapSize(StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  StgBCO *bco = (StgBCO *)*c->payload;++  return BCO_BITMAP_SIZE(bco);+}++StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));+  const StgInfoTable *info = get_itbl(c);+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);++  return bitmap->bitmap;+}++StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);++  return bitmap->bitmap;+}++StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));++  StgBCO *bco = (StgBCO *)*c->payload;+  StgLargeBitmap *bitmap = BCO_BITMAP(bco);++  return bitmap->bitmap;+}++StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {+  return frame->next_chunk;+}++StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) {+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));++  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));+  return fun_info->f.fun_type == ARG_GEN_BIG;+}++StgClosure *getStackClosure(StgClosure **c) { return *c; }
+ ghc-stack-profiler.cabal view
@@ -0,0 +1,130 @@+cabal-version: 3.8+name: ghc-stack-profiler+version: 0.1.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.Sampler++  main :: IO ()+  main = 'withStackProfilerForMyThread' ('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@.++extra-doc-files: CHANGELOG.md+category: Profiling, Benchmarking, Development+tested-with: ghc ==9.14 || ==9.12 || ==9.10++common warnings+  ghc-options:+    -Wall+    -Wunused-packages++common exts+  default-extensions:+    DeriveGeneric+    DerivingStrategies+    DuplicateRecordFields+    LambdaCase+    NamedFieldPuns+    PatternSynonyms+    ViewPatterns++flag use-ghc-trace-events+  description:+    Use the package 'ghc-trace-events'. Disabling this flag makes it much easier to use @ghc-stack-profiler@ on the @ghc@ codebase, as+    we don't have to package 'ghc-trace-events' for hadrian. Always enabled on GHC <9.12.++  manual: True+  default: True++library+  import:+    warnings, exts++  exposed-modules:+    Debug.Trace.Binary.Compat+    GHC.Internal.ClosureTypes.Compat+    GHC.Internal.Heap.Closures.Compat+    GHC.Internal.InfoProv.Types.Compat+    GHC.Internal.Stack.Constants.Compat+    GHC.Internal.Stack.Decode.Compat+    GHC.Stack.Annotation.Experimental.Compat+    GHC.Stack.Profiler.Decode+    GHC.Stack.Profiler.Sampler+    GHC.Stack.Profiler.Stack.Compat+    GHC.Stack.Profiler.Stack.Decode+    GHC.Stack.Profiler.Util++  build-depends:+    base >=4.20 && <4.23,+    binary >=0.8.9.3 && <0.11,+    bytestring >=0.11 && <0.13,+    ghc-heap >=9.10.1 && <9.16,+    ghc-internal >=9.1001 && <9.1600,+    ghc-stack-profiler-core ^>=0.1,+    text >=2 && <2.2,++  if impl(ghc >=9.14)+    build-depends: ghc-experimental >=9.1400 && <9.1600++  if flag(use-ghc-trace-events) || impl(ghc <9.12)+    cpp-options:+      -DUSE_GHC_TRACE_EVENTS++    build-depends:+      ghc-trace-events ^>=0.1.2.10+  else+    build-depends:+      ghc-prim++  if impl(ghc <9.14)+    cmm-sources:+      cbits/Stack.cmm++    c-sources:+      cbits/Stack_c.c+  hs-source-dirs:+    src++  default-language: GHC2021
+ src/Debug/Trace/Binary/Compat.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedTuples #-}+module Debug.Trace.Binary.Compat (+  -- * For tracing user binary events+  traceBinaryEventIO,+  -- * Flag to check whether the eventlog is enabled+  userTracingEnabled,+  ) where++#if defined(USE_GHC_TRACE_EVENTS)+import Debug.Trace.Binary (traceBinaryEventIO)+import Debug.Trace.Flags (userTracingEnabled)+#else+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as BU+import GHC.Types (IO(..))+import GHC.Exts (Ptr(..), Int(..), traceBinaryEvent#)+import GHC.Internal.RTS.Flags.Test (getUserEventTracingEnabled)+import System.IO.Unsafe (unsafePerformIO)++traceBinaryEventIO :: B.ByteString -> IO ()+traceBinaryEventIO bytes = traceBinaryEventIO' bytes++traceBinaryEventIO' :: B.ByteString -> IO ()+traceBinaryEventIO' bytes =+  BU.unsafeUseAsCStringLen bytes $ \(Ptr p, I# n) -> IO $ \s ->+    case traceBinaryEvent# p n s of+      s' -> (# s', () #)++userTracingEnabled :: Bool+userTracingEnabled = unsafePerformIO getUserEventTracingEnabled+#endif
+ src/GHC/Internal/ClosureTypes/Compat.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP  #-}+module GHC.Internal.ClosureTypes.Compat (+  ClosureType(..),+#if !MIN_VERSION_ghc_internal(9,1400,0)+  pattern ANN_FRAME,+#endif+) where++import GHC.Internal.ClosureTypes++#if !MIN_VERSION_ghc_internal(9,1400,0)+-- Unmatchable, as ANN_FRAME is a stack frame type introduced in GHC 9.14+pattern ANN_FRAME :: ClosureType+pattern ANN_FRAME <- (const Nothing -> Just _)+#endif
+ src/GHC/Internal/Heap/Closures/Compat.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+module GHC.Internal.Heap.Closures.Compat (+  Box(..),+) where++#if MIN_VERSION_ghc_internal(9,1400,0)+import GHC.Internal.Heap.Closures ( Box(..) )+#else+import GHC.Exts.Heap.Closures ( Box(..) )+#endif
+ src/GHC/Internal/InfoProv/Types/Compat.hsc view
@@ -0,0 +1,42 @@+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE CPP     #-}+#include "Rts.h"++module GHC.Internal.InfoProv.Types.Compat (+    lookupIpeId+) where++import Data.Word+import Foreign.Ptr+#if !MIN_VERSION_ghc_internal(9,1500,0)+import Foreign.C.Types+import Foreign.Marshal.Alloc+import GHC.Stack.Profiler.Util (castPtrToWord64)+#endif++import qualified GHC.Internal.InfoProv.Types as InfoProv++#if MIN_VERSION_ghc_internal(9,1500,0)+foreign import ccall "lookupIPEId" c_lookupIPEId ::+  Ptr InfoProv.StgInfoTable ->+  IO Word64+#else+foreign import ccall "lookupIPE" c_lookupIPE ::+  Ptr InfoProv.StgInfoTable ->+  Ptr InfoProv.InfoProvEnt ->+  IO CBool+#endif++lookupIpeId :: Ptr InfoProv.StgInfoTable -> IO (Maybe Word64)+lookupIpeId itbl = do+#if MIN_VERSION_ghc_internal(9,1500,0)+  c_lookupIPEId itbl >>= \ case+    0 -> pure Nothing+    ipeId -> pure $ Just ipeId+#else+  allocaBytes (#size InfoProvEnt) $ \p -> do+    res <- c_lookupIPE itbl p+    case res of+      1 -> pure $ Just $ castPtrToWord64 itbl+      _ -> return Nothing+#endif
+ src/GHC/Internal/Stack/Constants/Compat.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+module GHC.Internal.Stack.Constants.Compat (+  WordOffset(..),+  offsetStgAnnFrameAnn,+) where++#if MIN_VERSION_ghc_internal(9,1400,0)+#if defined(PROFILING)+import GHC.Internal.Stack.ConstantsProf+#else+import GHC.Internal.Stack.Constants+#endif+#else+import GHC.Exts.Stack.Constants++offsetStgAnnFrameAnn :: WordOffset+offsetStgAnnFrameAnn = error "offsetStgAnnFrameAnn is only available in GHC >=9.14"+#endif+
+ src/GHC/Internal/Stack/Decode/Compat.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE CPP #-}+module GHC.Internal.Stack.Decode.Compat (+  StackFrameLocation,+  StackSnapshot#,+  StackInfoTable(..),+  getInfoTableForStack,+  getInfoTableOnStack,+  advanceStackFrameLocation,+  stackHead,+  Box(..),+  getClosureBox,+) where++import GHC.Exts+import GHC.Stack.CloneStack (StackSnapshot (..))+-- See Note [No way-dependent imports]+#if defined(PROFILING)+import GHC.Exts.Heap.InfoTableProf+#else+import GHC.Exts.Heap.InfoTable+#endif+import qualified GHC.Internal.InfoProv.Types as InfoProv+import GHC.Internal.Heap.Closures.Compat+import GHC.Internal.Stack.Constants.Compat (WordOffset)++{-+Note [No way-dependent imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`ghc -M` currently assumes that the imports for a module are the same+in every way.  This is arguably a bug, but breaking this assumption by+importing different things in different ways can cause trouble.  For+example, this module in the profiling way imports and uses+GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the+vanilla way, there were intermittent build failures due to this module+being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf+in the profiling way. (#15197)+-}++type StackFrameLocation = (StackSnapshot, WordOffset)++data StackInfoTable = StackInfoTable+  { infoTableStructPtr :: Ptr InfoProv.StgInfoTable+  , infoTablePtr :: Ptr InfoProv.StgInfoTable+  , infoTable :: StgInfoTable+  }++-- | Get the 'StgInfoTable' of the stack frame.+-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.+getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StackInfoTable+getInfoTableOnStack stackSnapshot# index = do+  let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)+      itbl_struct = Ptr itbl_struct#+      itbl_ptr = Ptr itbl_ptr_ipe_key#++  itbl <- peekItbl itbl_struct+  pure StackInfoTable+    { infoTableStructPtr = itbl_struct+    , infoTablePtr = itbl_ptr+    , infoTable = itbl+    }++getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable+getInfoTableForStack stackSnapshot# =+  peekItbl $+    Ptr (getStackInfoTableAddr# stackSnapshot#)++-- | Advance to the next stack frame (if any)+advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation+advanceStackFrameLocation (StackSnapshot stackSnapshot#, index) =+  let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)+   in if I# hasNext > 0+        then Just (StackSnapshot s', primWordToWordOffset i')+        else Nothing+  where+    primWordToWordOffset :: Word# -> WordOffset+    primWordToWordOffset w# = fromIntegral (W# w#)++-- | `StackFrameLocation` of the top-most stack frame+stackHead :: StackSnapshot# -> StackFrameLocation+stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty++getClosureBox :: StackSnapshot# -> WordOffset -> Box+getClosureBox stackSnapshot# index =+  case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of+    -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and+    -- will later be decoded as such)+    !c -> Box c++-- | Advance to the next stack frame (if any)+--+-- The last `Int#` in the result tuple is meant to be treated as bool+-- (has_next).+foreign import prim "advanceStackFrameLocationzh"+  advanceStackFrameLocation# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)++foreign import prim "getInfoTableAddrszh"+  getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)++foreign import prim "getStackInfoTableAddrzh"+  getStackInfoTableAddr# :: StackSnapshot# -> Addr#++foreign import prim "getStackClosurezh"+  getStackClosure# :: StackSnapshot# -> Word# ->  Any++-- ----------------------------------------------------------------------------+-- Utilities that really should live somewhere else+-- ----------------------------------------------------------------------------++-- | Unbox 'Int#' from 'Int'+toInt# :: Int -> Int#+toInt# (I# i) = i++-- | Convert `Int` to `Word#`+intToWord# :: Int -> Word#+intToWord# i = int2Word# (toInt# i)++wordOffsetToWord# :: WordOffset -> Word#+wordOffsetToWord# wo = intToWord# (fromIntegral wo)
+ src/GHC/Stack/Annotation/Experimental/Compat.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+module GHC.Stack.Annotation.Experimental.Compat (+  SomeStackAnnotation(..),+  CallStackAnnotation(..),+  StringAnnotation(..),+) where++#if MIN_VERSION_ghc_internal(9,1400,0)+import GHC.Stack.Annotation.Experimental+#else+import Data.Typeable+import GHC.Stack.Types (CallStack)++data SomeStackAnnotation where+  SomeStackAnnotation :: forall a. (Typeable a) => a -> SomeStackAnnotation++data StringAnnotation where+  StringAnnotation :: String -> StringAnnotation++newtype CallStackAnnotation = CallStackAnnotation CallStack+#endif
+ src/GHC/Stack/Profiler/Decode.hs view
@@ -0,0 +1,40 @@+module GHC.Stack.Profiler.Decode (+  SymbolTable,+  serializeThreadSample,+  threadSampleToCallStackMessage,+) where++import Data.Binary+import Data.Binary.Put+import qualified Data.ByteString.Lazy as LBS+import Data.IORef+import qualified Data.List.NonEmpty as NonEmpty+import Data.Tuple++import GHC.Internal.Conc.Sync++import GHC.Stack.Profiler.Core.SymbolTable+import GHC.Stack.Profiler.Core.ThreadSample+import GHC.Stack.Profiler.Core.Eventlog+import GHC.Stack.Profiler.Stack.Decode (decodeStackWithIpProvId)++type SymbolTable = SymbolTableWriter MapTable++serializeThreadSample :: IORef SymbolTable -> ThreadSample -> IO [LBS.ByteString]+serializeThreadSample tableRef sample = do+  eventlogMessages <- threadSampleToCallStackMessage tableRef sample+  pure $ map (runPut . put) eventlogMessages++threadSampleToCallStackMessage :: IORef SymbolTable -> ThreadSample -> IO [BinaryEventlogMessage]+threadSampleToCallStackMessage tableRef sample = do+  frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample+  -- removes immediate duplicates+  let callStackItems = fmap NonEmpty.head $ NonEmpty.group frames+  let callStackMessage = MkCallStackMessage+        { callThreadId = fromThreadId $ threadSampleId sample+        , callCapabilityId = threadSampleCapability sample+        , callStack = callStackItems+        }+  -- TODO: Abstract IORef SymbolTable somehow+  atomicModifyIORef' tableRef $ \ table ->+    swap $ dehydrateCallStackMessage table callStackMessage
+ src/GHC/Stack/Profiler/Sampler.hs view
@@ -0,0 +1,180 @@+module GHC.Stack.Profiler.Sampler (+  -- * Run sample profiler+  withStackProfiler,+  withStackProfilerForMyThread,+  withStackProfilerForThread,+  -- * Configuration of sample profiler+  StackProfilerManager(..),+  ProfilerSamplingInterval(..),+  -- * Basic thread sampler+  sampleThread,+  -- * Low level helpers for setting up custom+  -- sample profilers threads+  runWithStackProfiler,+  setupStackProfilerManager,+  stopStackProfilerManager,+  sampleToEventlog,+  -- * Thread filtering+  isProfilerThread,+  isRtsThread,+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List+import Data.IORef+import GHC.Conc+import GHC.Conc.Sync++import GHC.Stack.CloneStack (cloneThreadStack)++import qualified Debug.Trace.Binary.Compat as Compat+import GHC.Stack.Profiler.Decode+import GHC.Stack.Profiler.Core.Eventlog+import GHC.Stack.Profiler.Core.ThreadSample+import GHC.Stack.Profiler.Core.SymbolTable+import GHC.Stack.Profiler.Core.Util++-- | A 'StackProfilerManager' records all the relevant information+-- to manage the ghc stack profiler run-time.+data StackProfilerManager = MkStackProfilerManager+  { profilerThreadId :: ThreadId+  -- ^ 'ThreadId' of the stack sampling thread.+  , symbolTableRef :: IORef SymbolTable+  } deriving (Eq)++-- | Sampling intervals for the stack profiler.+data ProfilerSamplingInterval+  = SampleIntervalMs Int+  -- ^ Sample every @n@ milliseconds.+  --+  -- Recommended value: @'SampleIntervalMs' 10@ or @'SampleIntervalMs' 20@.+  deriving (Show, Eq, Ord)++profilerSamplingIntervalToThreadDelayTime :: ProfilerSamplingInterval -> Int+profilerSamplingIntervalToThreadDelayTime = \ case+  SampleIntervalMs n -> n * 1000++-- ----------------------------------------------------------------------------+-- High-Level user API+-- ----------------------------------------------------------------------------++-- | Sample the all non-rts threads every 'ProfilerSamplingInterval' for the duration of+-- the wrapped action.+-- Once the wrapped action terminates, the stack profiling stops.+--+-- RTS threads such as the 'TimerManager' and 'IOManager' are not sampled as these+-- are usually not interesting for user code.+withStackProfiler :: ProfilerSamplingInterval -> IO a -> IO a+withStackProfiler delay act = do+  runWithStackProfiler sampleAction delay act+  where+    sampleAction config = do+      tids <- listThreads+      userThreads <- filterM (isThreadOfInterest config) tids+      forM_ userThreads $ \tid ->+        sampleToEventlog (symbolTableRef config) tid++    isThreadOfInterest :: StackProfilerManager -> ThreadId -> IO Bool+    isThreadOfInterest config tid = do+      lbl <- threadLabel tid+      pure $ not $ or+        [ isProfilerThread config tid lbl+        , isRtsThread tid lbl+        ]++-- | Sample the current thread every 'ProfilerSamplingInterval' for the duration of+-- the wrapped action.+-- Once the wrapped action terminates, the stack profiling stops.+withStackProfilerForMyThread :: ProfilerSamplingInterval -> IO a -> IO a+withStackProfilerForMyThread delay act = do+  tid <- myThreadId+  withStackProfilerForThread 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 :: ThreadId -> ProfilerSamplingInterval -> IO a -> IO a+withStackProfilerForThread tid delay act =+  runWithStackProfiler (\ config -> sampleToEventlog (symbolTableRef config) tid) delay act++-- ----------------------------------------------------------------------------+-- Low-level user API+-- ----------------------------------------------------------------------------++runWithStackProfiler :: (StackProfilerManager -> IO ()) -> ProfilerSamplingInterval -> IO a -> IO a+runWithStackProfiler sampleAction delay act = do+  if Compat.userTracingEnabled+    then bracket (setupStackProfilerManager sampleAction delay) stopStackProfilerManager (const act)+    else act++stopStackProfilerManager :: StackProfilerManager -> IO ()+stopStackProfilerManager MkStackProfilerManager{profilerThreadId} =+  killThread profilerThreadId++setupStackProfilerManager :: (StackProfilerManager -> IO ()) -> ProfilerSamplingInterval -> IO StackProfilerManager+setupStackProfilerManager sampleAction delay = do+  samplerThreadConfigMVar <- newEmptyMVar+  sid <- forkIO $ do+    config <- takeMVar samplerThreadConfigMVar+    sampleThreadId <- myThreadId+    labelThread sampleThreadId "Sample Profiler Thread"+    forever $ do+      sampleAction config+      -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well+      threadDelay (profilerSamplingIntervalToThreadDelayTime delay)++  tableRef <- newIORef emptyMapSymbolTableWriter+  let sampleThreadConf = MkStackProfilerManager+        { profilerThreadId = sid+        , symbolTableRef = tableRef+        }+  putMVar samplerThreadConfigMVar sampleThreadConf+  pure sampleThreadConf++-- | We don't want to sample the stack profiler itself.+isProfilerThread :: StackProfilerManager -> ThreadId -> Maybe String -> Bool+isProfilerThread MkStackProfilerManager {profilerThreadId} tid _lbl = tid == profilerThreadId++-- | 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 `elem` ["TimerManager"] || "IOManager on cap" `List.isPrefixOf` lbl++-- | 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+      pure $ Just $ ThreadSample+        { threadSampleId = tid+        , threadSampleCapability = MkCapabilityId $ intToWord64 cap+        , threadSampleStackSnapshot = stack+        }+    False -> do+      -- Only running threads need to be sampled+      pure Nothing+  where+    canCloneStack :: ThreadStatus -> Bool+    canCloneStack = \ case+      ThreadRunning -> True+      ThreadBlocked BlockedOnMVar -> True+      _ -> False++-- | If the thread's callstack can be sampled, we serialise the sample+-- and write into the eventlog for later processing.+sampleToEventlog :: IORef SymbolTable -> ThreadId -> IO ()+sampleToEventlog tableRef tid = do+  sampleThread tid >>= \ case+    Nothing -> pure ()+    Just threadSample -> do+      msgs <- serializeThreadSample tableRef threadSample+      mapM_ (Compat.traceBinaryEventIO . LBS.toStrict) msgs
+ src/GHC/Stack/Profiler/Stack/Compat.hs view
@@ -0,0 +1,28 @@+{-# 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 view
@@ -0,0 +1,77 @@+{-# LANGUAGE MagicHash #-}+module GHC.Stack.Profiler.Stack.Decode (+  decodeStackWithIpProvId,+) where++import Unsafe.Coerce (unsafeCoerce)+import Data.Maybe (catMaybes)+import qualified Data.Text as Text+import Data.Typeable (cast)++import GHC.Stack.Annotation.Experimental.Compat+import GHC.Stack.CloneStack (StackSnapshot(..))+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.Exts.Heap.InfoTable.Types++import GHC.Stack.Profiler.Core.ThreadSample+import GHC.Stack.Profiler.Core.Eventlog+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 $ stackAnnotationToStackItem (unsafeCoerce annotation)+    _ ->+      fmap (IpeId . MkIpeId) <$> lookupIpeIdForStackFrame stackItbl++stackAnnotationToStackItem :: SomeStackAnnotation -> Maybe StackItem+stackAnnotationToStackItem = \ case+  SomeStackAnnotation ann ->+    case cast ann of+      Just (CallStackAnnotation cs) ->+        case getCallStack cs of+          [] -> Nothing+          ((name, sourceLoc):_) ->+            Just $ SourceLocation $ MkSourceLocation+              { line = intToWord32 $ srcLocStartLine sourceLoc+              , column = intToWord32 $ srcLocStartCol sourceLoc+              , functionName = Text.pack $ name+              , fileName = Text.pack $ srcLocFile sourceLoc+              }++      Nothing -> case cast ann of+        Just (StringAnnotation msg) ->+          Just $ UserMessage msg+        Nothing ->+          Nothing
+ src/GHC/Stack/Profiler/Util.hs view
@@ -0,0 +1,10 @@+module GHC.Stack.Profiler.Util (+  castPtrToWord64,+) where++import Foreign.Ptr+import Data.Word++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