diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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.
diff --git a/cbits/Stack.cmm b/cbits/Stack.cmm
new file mode 100644
--- /dev/null
+++ b/cbits/Stack.cmm
@@ -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
diff --git a/cbits/Stack_c.c b/cbits/Stack_c.c
new file mode 100644
--- /dev/null
+++ b/cbits/Stack_c.c
@@ -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; }
diff --git a/ghc-stack-profiler.cabal b/ghc-stack-profiler.cabal
new file mode 100644
--- /dev/null
+++ b/ghc-stack-profiler.cabal
@@ -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
diff --git a/src/Debug/Trace/Binary/Compat.hs b/src/Debug/Trace/Binary/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/Debug/Trace/Binary/Compat.hs
@@ -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
diff --git a/src/GHC/Internal/ClosureTypes/Compat.hs b/src/GHC/Internal/ClosureTypes/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Internal/ClosureTypes/Compat.hs
@@ -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
diff --git a/src/GHC/Internal/Heap/Closures/Compat.hs b/src/GHC/Internal/Heap/Closures/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Internal/Heap/Closures/Compat.hs
@@ -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
diff --git a/src/GHC/Internal/InfoProv/Types/Compat.hsc b/src/GHC/Internal/InfoProv/Types/Compat.hsc
new file mode 100644
--- /dev/null
+++ b/src/GHC/Internal/InfoProv/Types/Compat.hsc
@@ -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
diff --git a/src/GHC/Internal/Stack/Constants/Compat.hs b/src/GHC/Internal/Stack/Constants/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Internal/Stack/Constants/Compat.hs
@@ -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
+
diff --git a/src/GHC/Internal/Stack/Decode/Compat.hs b/src/GHC/Internal/Stack/Decode/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Internal/Stack/Decode/Compat.hs
@@ -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)
diff --git a/src/GHC/Stack/Annotation/Experimental/Compat.hs b/src/GHC/Stack/Annotation/Experimental/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Annotation/Experimental/Compat.hs
@@ -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
diff --git a/src/GHC/Stack/Profiler/Decode.hs b/src/GHC/Stack/Profiler/Decode.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Profiler/Decode.hs
@@ -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
diff --git a/src/GHC/Stack/Profiler/Sampler.hs b/src/GHC/Stack/Profiler/Sampler.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Profiler/Sampler.hs
@@ -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
diff --git a/src/GHC/Stack/Profiler/Stack/Compat.hs b/src/GHC/Stack/Profiler/Stack/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Profiler/Stack/Compat.hs
@@ -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
+
+
diff --git a/src/GHC/Stack/Profiler/Stack/Decode.hs b/src/GHC/Stack/Profiler/Stack/Decode.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Profiler/Stack/Decode.hs
@@ -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
diff --git a/src/GHC/Stack/Profiler/Util.hs b/src/GHC/Stack/Profiler/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Stack/Profiler/Util.hs
@@ -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