Introduce stack snapshotting / cloning (#18741)

Add `StackSnapshot#` primitive type that represents a cloned stack (StgStack).
The cloning interface consists of two functions, that clone either the treads
own stack (cloneMyStack) or another threads stack (cloneThreadStack).

The stack snapshot is offline/cold, i.e. it isn't evaluated any further. This is
useful for analyses as it prevents concurrent modifications.

For technical details, please see Note [Stack Cloning].

Co-authored-by: Ben Gamari <bgamari.foss@gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>

24 files changed, 650 insertions, 28 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index d5da296cb6..b7f54060b9 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -1885,7 +1885,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
     eqReprPrimTyConKey, eqPhantPrimTyConKey,
-    compactPrimTyConKey :: Unique
+    compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -1913,6 +1913,7 @@ ptrTyConKey                             = mkPreludeTyConUnique 77
 funPtrTyConKey                          = mkPreludeTyConUnique 78
 tVarPrimTyConKey                        = mkPreludeTyConUnique 79
 compactPrimTyConKey                     = mkPreludeTyConUnique 80
+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81
 
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index ce4f1e5dc0..9ba6d87927 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -83,6 +83,7 @@ module GHC.Builtin.Types.Prim(
         bcoPrimTyCon,                   bcoPrimTy,
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
+        stackSnapshotPrimTyCon,         stackSnapshotPrimTy,
 
         int8PrimTyCon,          int8PrimTy, int8PrimTyConName,
         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,
@@ -203,6 +204,7 @@ exposedPrimTyCons
     , word16PrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
+    , stackSnapshotPrimTyCon
 
     , tYPETyCon
     , funTyCon
@@ -225,7 +227,7 @@ mkBuiltInPrimTc fs unique tycon
                   BuiltInSyntax
 
 
-charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, stackSnapshotPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
@@ -261,6 +263,7 @@ tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr
 stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
 stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
 compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
+stackSnapshotPrimTyConName    = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon
 bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
@@ -1159,6 +1162,21 @@ compactPrimTy = mkTyConTy compactPrimTyCon
 {-
 ************************************************************************
 *                                                                      *
+   The @StackSnapshot#@ type
+*                                                                      *
+************************************************************************
+-}
+
+stackSnapshotPrimTyCon :: TyCon
+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName UnliftedRep
+
+stackSnapshotPrimTy :: Type
+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon
+
+
+{-
+************************************************************************
+*                                                                      *
    The ``bytecode object'' type
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index bf3b879449..58d4ec91f3 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -190,9 +190,9 @@ defaults
 -- Note [Levity and representation polymorphic primops]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- In the types of primops in this module,
--- 
+--
 -- * The names `a,b,c,s` stand for type variables of kind Type
--- 
+--
 -- * The names `v` and `w` stand for levity-polymorphic
 --   type variables.
 --   For example:
@@ -207,7 +207,7 @@ defaults
 --     - `v` and `w` end up written as `a` and `b` (respectively) in types,
 --       which means that one shouldn't write a primop type involving both
 --       `a` and `v`, nor `b` and `w`.
--- 
+--
 -- * The names `o` and `p` stand for representation-polymorphic
 --   type variables, similarly to `v` and `w` above. For example:
 --      op :: o -> p -> Int
@@ -3259,29 +3259,29 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- The primop `reallyUnsafePtrEquality#` does a direct pointer
 -- equality between two (boxed) values.  Several things to note:
--- 
+--
 -- * It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and
 --   TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example.
 --   This levity-polymorphism comes from the use of the type variables
 --   "v" and "w". See Note [Levity and representation polymorphic primops]
--- 
+--
 -- * It does not evaluate its arguments. The user of the primop is responsible
 --   for doing so.
--- 
+--
 -- * It is hetero-typed; you can compare pointers of different types.
 --   This is used in various packages such as containers & unordered-containers.
--- 
+--
 -- * It is obviously very dangerous, because
 --      let x = f y in reallyUnsafePtrEquality# x x
 --   will probably return True, whereas
 --      reallyUnsafePtrEquality# (f y) (f y)
 --   will probably return False. ("probably", because it's affected
 --   by CSE and inlining).
--- 
+--
 -- * reallyUnsafePtrEquality# can't fail, but it is marked as such
 --   to prevent it from floating out.
 --   See Note [reallyUnsafePtrEquality# can_fail]
--- 
+--
 -- The library GHC.Exts provides several less Wild-West functions
 -- for use in specific cases, namely:
 --
@@ -3647,6 +3647,21 @@ primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
+primtype StackSnapshot#
+
+primop  CloneMyStack "cloneMyStack#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
+   { Clones the stack of the current (active) Haskell thread. A cloned stack is
+     represented by {\tt StackSnapshot# } and is not evaluated any further
+     (i.e. it's "cold"). This is useful for stack decoding (backtraces) and
+     analyses because there are no concurrent mutations on a cloned stack.
+     The module {\tt GHC.Stack.CloneStack } contains related funcions.
+     Please see Note [Stack Cloning] for technical details. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+
 ------------------------------------------------------------------------
 section "Safe coercions"
 ------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index dff86341b1..0f5943bf48 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1669,6 +1669,7 @@ emitPrimOp dflags primop = case primop of
   TraceEventBinaryOp -> alwaysExternal
   TraceMarkerOp -> alwaysExternal
   SetThreadAllocationCounter -> alwaysExternal
+  CloneMyStack -> alwaysExternal
 
   -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
   KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"
diff --git a/libraries/base/GHC/Stack/CloneStack.hs b/libraries/base/GHC/Stack/CloneStack.hs
new file mode 100644
index 0000000000..68077d4299
--- /dev/null
+++ b/libraries/base/GHC/Stack/CloneStack.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash        #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes#-}
+
+-- |
+-- This module exposes an interface for capturing the state of a thread's
+-- execution stack for diagnostics purposes.
+--
+-- @since 2.16.0.0
+module GHC.Stack.CloneStack (
+  StackSnapshot(..),
+  cloneMyStack,
+  cloneThreadStack
+  ) where
+
+import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#)
+import Control.Concurrent.MVar
+import GHC.Conc.Sync
+import GHC.Stable
+import GHC.IO (IO(..))
+
+-- | A frozen snapshot of the state of an execution stack.
+--
+-- @since 2.16.0.0
+data StackSnapshot = StackSnapshot !StackSnapshot#
+
+{-
+Note [Stack Cloning]
+~~~~~~~~~~~~~~~~~~~~
+"Cloning" a stack means that it's `StgStack` closure is copied including the
+stack memory (`stack[]`). Closures referenced by stack closures are not copied,
+i.e. pointer payloads are still referred to by the same pointer.
+In other words: Only those parts that are affected by stack evaluation are
+"cloned".
+
+The stack pointer (sp) of the clone is adjusted to be valid, i.e. to point into
+the cloned stack.
+
+The clone is "offline"/"cold", i.e. it won't be evaluated any further. This is
+useful for further analyses like stack unwinding or traversal because all
+pointers stay valid.
+
+StackSnapshot#
+--------------
+A cloned stack is represented in Haskell by `StackSnapshot !StackSnapshot#`.
+`StackSnapshot#` is a primitive type, it's value is a pointer to the stack in
+RTS (`StgStack*`).
+
+To take advantage of the garbage collector, the representation cannot be `Ptr`
+or `StablePtr`:
+- Closures referenced by a `Ptr` may be garbage collected at any time (without
+  checking if it's still in use).
+- `StablePtr` has to be freed explictly, which would introduce nasty state
+   handling.
+
+By using a primitive type, the stack closure is kept and managed by the garbage
+collector as long as it's in use and automatically freed later.
+As closures referred to by stack closures (e.g. payloads) may be used by other
+closures that are not related to stack cloning, the memory has to be managed by
+the garbage collector; i.e. one cannot simply call free() in the RTS C code
+because it's hard to figure out what to free while the garbage collector is
+built to do this job.
+
+RTS interface
+-------------
+There are two different ways to clone a stack:
+1. `cloneMyStack#` - A primop for cloning the active thread's stack.
+2. `sendCloneStackMessage` - A FFI function for cloning another thread's stack.
+   Sends a RTS message (Messages.c) with a MVar to that thread. The cloned
+   stack is reveived by taking it out of this MVar.
+
+`cloneMyStack#` has to be a primop, because new primitive types
+(`StackSnapshot#`) cannot be marshalled by FFI. Using a `Ptr StackSnapshot` as
+FFI return type would not save the snapshot from being garbage collected, as
+discussed in the section above.
+
+C API
+-------------
+`cloneStack` is the function that really clones a given stack and returns
+the clone:
+`StgStack* cloneStack(Capability* capability, const StgStack* stack)`
+
+It's called directly by `stg_cloneMyStackzh` (`PrimOps.cmm`), the
+`cloneMyStack#` primop.
+
+To clone another thread's stack, there's a message passing mechanism such that
+the receiver's capability clones its. So, there's no need to stop/pause the
+other thread as it's capability will fulfill the cloning request when it's
+ready to do so.
+
+The message is defined in `Closures.h`:
+
+```
+typedef struct MessageCloneStack_ {
+    StgHeader header;
+    Message   *link;
+    StgMVar   *result;
+    StgTSO    *tso;
+} MessageCloneStack;
+```
+
+The fields are:
+- `header`: It's a closure and thus subject to garbage collection (no manual
+   memory management needed)
+- `link`: Messages form a singly linked list in `Capability`, referred to by
+  `capability->inbox`.
+- `result`: An `MVar`. When the message is sent it's empty, after cloning the
+  `StackSnapshot` is put into it.
+- `tso`: `tso->stackobj` is the stack to clone.
+
+The asynchronous flow can be split into sending this message and putting the
+cloned stack into the MVar (expecting the sender to get it from there).
+
+Sending:
+The public C function to send is
+`void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar)`.
+It prepares the message for the thread to clone (identified by it's `tso`) and
+sets the `result` MVar (pointed to by `mvar`). Then it sends the message by
+calling `sendMessage` which puts it into the Capabilities `inbox`.
+
+Receiving:
+Inbox processing is part of the big work finding loop in `schedule`. The
+function that dispatches messages is `executeMessage`. From there
+`void handleCloneStackMessage(MessageCloneStack *msg)` is called.
+
+`handleCloneStackMessage` clones the stack, lifts the result to `StackSnapshot`
+(MVar needs a lifted value, no primitive) and puts it into the MVar
+(`msg->mvar`).
+-}
+
+-- | Clone the stack of the executing thread
+--
+-- @since 2.16.0.0
+cloneMyStack :: IO StackSnapshot
+cloneMyStack = IO $ \s ->
+   case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+
+foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO ()
+
+-- | Clone the stack of a thread identified by its 'ThreadId'
+--
+-- @since 2.16.0.0
+cloneThreadStack :: ThreadId -> IO StackSnapshot
+cloneThreadStack (ThreadId tid#) = do
+  resultVar <- newEmptyMVar @StackSnapshot
+  ptr <- newStablePtrPrimMVar resultVar
+  -- Use the RTS's "message" mechanism to request that
+  -- the thread captures its stack, saving the result
+  -- into resultVar.
+  sendCloneStackMessage tid# ptr
+  freeStablePtr ptr
+  takeMVar resultVar
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 9b9d5ba2d2..90ab51c214 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -264,6 +264,7 @@ Library
         GHC.ResponseFile
         GHC.RTS.Flags
         GHC.ST
+        GHC.Stack.CloneStack
         GHC.StaticPtr
         GHC.STRef
         GHC.Show
diff --git a/rts/CloneStack.c b/rts/CloneStack.c
new file mode 100644
index 0000000000..a8e826eec1
--- /dev/null
+++ b/rts/CloneStack.c
@@ -0,0 +1,103 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2021
+ *
+ * Stack snapshotting.
+ */
+
+#include <string.h>
+
+#include "Rts.h"
+#include "rts/Messages.h"
+#include "Messages.h"
+#include "rts/storage/TSO.h"
+#include "stg/Types.h"
+#include "CloneStack.h"
+#include "StablePtr.h"
+#include "Threads.h"
+
+#if defined(DEBUG)
+#include "sm/Sanity.h"
+#endif
+
+static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
+{
+  StgWord spOffset = stack->sp - stack->stack;
+  StgWord closureSizeBytes = sizeof(StgStack) + (stack->stack_size * sizeof(StgWord));
+
+  StgStack* newStackClosure = (StgStack*) allocate(capability, ROUNDUP_BYTES_TO_WDS(closureSizeBytes));
+
+  memcpy(newStackClosure, stack, closureSizeBytes);
+
+  newStackClosure->sp = newStackClosure->stack + spOffset;
+  // The new stack is not on the mutable list; clear the dirty flag such that
+  // we don't claim that it is.
+  newStackClosure->dirty = 0;
+
+#if defined(DEBUG)
+  checkClosure((StgClosure*) newStackClosure);
+#endif
+
+  return newStackClosure;
+}
+
+StgStack* cloneStack(Capability* capability, const StgStack* stack)
+{
+  StgStack *top_stack = cloneStackChunk(capability, stack);
+  StgStack *last_stack = top_stack;
+  while (true) {
+    // check whether the stack ends in an underflow frame
+    StgPtr top = last_stack->stack + last_stack->stack_size;
+    StgUnderflowFrame *underFlowFrame = ((StgUnderflowFrame *) top);
+    StgUnderflowFrame *frame = underFlowFrame--;
+    if (frame->info == &stg_stack_underflow_frame_info) {
+      StgStack *s = cloneStackChunk(capability, frame->next_chunk);
+      frame->next_chunk = s;
+      last_stack = s;
+    } else {
+      break;
+    }
+  }
+  return top_stack;
+}
+
+#if defined(THREADED_RTS)
+
+// ThreadId# in Haskell is a StgTSO* in RTS.
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
+  Capability *srcCapability = rts_unsafeGetMyCapability();
+
+  MessageCloneStack *msg;
+  msg = (MessageCloneStack *)allocate(srcCapability, sizeofW(MessageCloneStack));
+  msg->tso = tso;
+  msg->result = (StgMVar*)deRefStablePtr(mvar);
+  SET_HDR(msg, &stg_MSG_CLONE_STACK_info, CCS_SYSTEM);
+  // Ensure that writes constructing Message are committed before sending.
+  write_barrier();
+
+  sendMessage(srcCapability, tso->cap, (Message *)msg);
+}
+
+void handleCloneStackMessage(MessageCloneStack *msg){
+  StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj);
+
+  // Lift StackSnapshot# to StackSnapshot by applying it's constructor.
+  // This is necessary because performTryPutMVar() puts the closure onto the
+  // stack for evaluation and stacks can not be evaluated (entered).
+  HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure);
+
+  bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result);
+
+  if(!putMVarWasSuccessful) {
+    barf("Can't put stack cloning result into MVar.");
+  }
+}
+
+#else // !defined(THREADED_RTS)
+
+GNU_ATTRIBUTE(__noreturn__)
+void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) {
+  barf("Sending CloneStackMessages is only available in threaded RTS!");
+}
+
+#endif // end !defined(THREADED_RTS)
diff --git a/rts/CloneStack.h b/rts/CloneStack.h
new file mode 100644
index 0000000000..5f1c22039d
--- /dev/null
+++ b/rts/CloneStack.h
@@ -0,0 +1,23 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2021
+ *
+ * Stack snapshotting.
+ */
+
+#pragma once
+
+extern StgClosure DLL_IMPORT_DATA_VARNAME(base_GHCziStackziCloneStack_StackSnapshot_closure);
+#define StackSnapshot_constructor_closure DLL_IMPORT_DATA_REF(base_GHCziStackziCloneStack_StackSnapshot_closure)
+
+StgStack* cloneStack(Capability* capability, const StgStack* stack);
+
+void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
+
+#include "BeginPrivate.h"
+
+#if defined(THREADED_RTS)
+void handleCloneStackMessage(MessageCloneStack *msg);
+#endif
+
+#include "EndPrivate.h"
diff --git a/rts/Messages.c b/rts/Messages.c
index 8cd0a5570f..2ec12da3ad 100644
--- a/rts/Messages.c
+++ b/rts/Messages.c
@@ -14,6 +14,7 @@
 #include "Threads.h"
 #include "RaiseAsync.h"
 #include "sm/Storage.h"
+#include "CloneStack.h"
 
 /* ----------------------------------------------------------------------------
    Send a message to another Capability
@@ -32,7 +33,8 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
             i != &stg_MSG_BLACKHOLE_info &&
             i != &stg_MSG_TRY_WAKEUP_info &&
             i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked
-            i != &stg_WHITEHOLE_info) {
+            i != &stg_WHITEHOLE_info &&
+            i != &stg_MSG_CLONE_STACK_info) {
             barf("sendMessage: %p", i);
         }
     }
@@ -130,6 +132,10 @@ loop:
 #endif
         goto loop;
     }
+    else if(i == &stg_MSG_CLONE_STACK_info){
+        MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
+        handleCloneStackMessage(cloneStackMessage);
+    }
     else
     {
         barf("executeMessage: %p", i);
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 8f99105b18..122bac4e08 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2927,3 +2927,14 @@ stg_setThreadAllocationCounterzh ( I64 counter )
     StgTSO_alloc_limit(CurrentTSO) = counter + TO_I64(offset);
     return ();
 }
+
+stg_cloneMyStackzh () {
+    W_ stgStack;
+    W_ clonedStack;
+    stgStack = StgTSO_stackobj(CurrentTSO);
+    StgStack_sp(stgStack) = Sp;
+
+    ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr");
+
+    return (clonedStack);
+}
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index b17d017c31..56d94ee7d2 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -12,6 +12,7 @@
 #include "Rts.h"
 #include "TopHandler.h"
 #include "HsFFI.h"
+#include "CloneStack.h"
 
 #include "sm/Storage.h"
 #include "sm/NonMovingMark.h"
@@ -988,6 +989,7 @@
       SymI_HasProto(stg_traceBinaryEventzh)                             \
       SymI_HasProto(stg_getThreadAllocationCounterzh)                   \
       SymI_HasProto(stg_setThreadAllocationCounterzh)                   \
+      SymI_HasProto(stg_cloneMyStackzh)                                 \
       SymI_HasProto(getMonotonicNSec)                                   \
       SymI_HasProto(lockFile)                                           \
       SymI_HasProto(unlockFile)                                         \
@@ -1012,6 +1014,7 @@
       SymI_HasProto(keepCAFs)                                           \
       SymI_HasProto(registerInfoProvList)                               \
       SymI_HasProto(lookupIPE)                                          \
+      SymI_HasProto(sendCloneStackMessage)                              \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 244f55d67a..b78fca74cc 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -775,6 +775,9 @@ INFO_TABLE_CONSTR(stg_MSG_BLACKHOLE,3,0,0,PRIM,"MSG_BLACKHOLE","MSG_BLACKHOLE")
 INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL")
 { foreign "C" barf("MSG_NULL object (%p) entered!", R1) never returns; }
 
+INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK")
+{ foreign "C" barf("stg_MSG_CLONE_STACK object (%p) entered!", R1) never returns; }
+
 /* ----------------------------------------------------------------------------
    END_TSO_QUEUE
 
diff --git a/rts/include/rts/storage/Closures.h b/rts/include/rts/storage/Closures.h
index ebb836bca2..b28315f76a 100644
--- a/rts/include/rts/storage/Closures.h
+++ b/rts/include/rts/storage/Closures.h
@@ -427,6 +427,14 @@ typedef struct MessageBlackHole_ {
     StgClosure *bh;
 } MessageBlackHole;
 
+typedef struct MessageCloneStack_ {
+    StgHeader header;
+    Message   *link;
+    StgMVar   *result;
+    StgTSO    *tso;
+} MessageCloneStack;
+
+
 /* ----------------------------------------------------------------------------
    Compact Regions
    ------------------------------------------------------------------------- */
diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h
index c4cb7d45a4..1eed441eae 100644
--- a/rts/include/stg/MiscClosures.h
+++ b/rts/include/stg/MiscClosures.h
@@ -200,6 +200,7 @@ RTS_ENTRY(stg_STM_AWOKEN);
 RTS_ENTRY(stg_MSG_TRY_WAKEUP);
 RTS_ENTRY(stg_MSG_THROWTO);
 RTS_ENTRY(stg_MSG_BLACKHOLE);
+RTS_ENTRY(stg_MSG_CLONE_STACK);
 RTS_ENTRY(stg_MSG_NULL);
 RTS_ENTRY(stg_MVAR_TSO_QUEUE);
 RTS_ENTRY(stg_catch);
@@ -570,6 +571,7 @@ RTS_FUN_DECL(stg_traceBinaryEventzh);
 RTS_FUN_DECL(stg_traceMarkerzh);
 RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
 RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_cloneMyStackzh);
 
 
 /* Other misc stuff */
diff --git a/rts/package.conf.in b/rts/package.conf.in
index bc24614085..8baf62bc7d 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -192,6 +192,7 @@ ld-options:
            * so we need to force it to be included in the binary. */
          , "-Wl,-u,_findPtr"
 #endif
+         , "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure"
 #else
            "-Wl,-u,base_GHCziTopHandler_runIO_closure"
          , "-Wl,-u,base_GHCziTopHandler_runNonIO_closure"
@@ -304,6 +305,7 @@ ld-options:
            * so we need to force it to be included in the binary. */
          , "-Wl,-u,findPtr"
 #endif
+         , "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure"
 #endif
 
 /*  Pick up static libraries in preference over dynamic if in earlier search
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index 6e535a777c..300a3bcd46 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -309,6 +309,7 @@ library
          "-Wl,-u,_hs_atomicwrite8"
          "-Wl,-u,_hs_atomicwrite16"
          "-Wl,-u,_hs_atomicwrite32"
+         "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure"
 
       if flag(find-ptr)
         -- This symbol is useful in gdb, but not referred to anywhere,
@@ -391,6 +392,7 @@ library
          "-Wl,-u,hs_atomicwrite8"
          "-Wl,-u,hs_atomicwrite16"
          "-Wl,-u,hs_atomicwrite32"
+         "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure"
 
       if flag(find-ptr)
         -- This symbol is useful in gdb, but not referred to anywhere,
@@ -454,6 +456,7 @@ library
                Arena.c
                Capability.c
                CheckUnload.c
+               CloneStack.c
                ClosureFlags.c
                Disassembler.c
                FileLock.c
diff --git a/testsuite/tests/profiling/should_run/T7275.stdout b/testsuite/tests/profiling/should_run/T7275.stdout
index f99f019120..d0146366a7 100644
--- a/testsuite/tests/profiling/should_run/T7275.stdout
+++ b/testsuite/tests/profiling/should_run/T7275.stdout
@@ -3,19 +3,19 @@
 2
 3
 4
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
-(282)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
+(284)suzanne/robert
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 1dfb20b791..2c73973680 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -487,3 +487,8 @@ test('T19381', extra_run_opts('+RTS -T -RTS'), compile_and_run, [''])
 test('T20199', normal, makefile_test, [])
 
 test('ipeMap', [c_src], compile_and_run, [''])
+test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c'])
+test('cloneMyStack2', ignore_stdout, compile_and_run, [''])
+test('cloneMyStack_retBigStackFrame', [extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c'])
+
+test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded'])
diff --git a/testsuite/tests/rts/cloneMyStack.hs b/testsuite/tests/rts/cloneMyStack.hs
new file mode 100644
index 0000000000..cdc93e6004
--- /dev/null
+++ b/testsuite/tests/rts/cloneMyStack.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+import Foreign
+import Foreign.C.Types (CUInt)
+import System.Mem
+
+foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> Ptr CUInt -> Int -> IO ()
+
+-- | Clone the stack and check that all expected closures are on it in order.
+-- (The check is done by closure type.)
+-- In the meanwhile enforce a garbage collection to ensure that the stack
+-- snapshot is still valid afterwards (is not gc'ed while in use).
+main :: IO ()
+main = do
+    stackSnapshot <- cloneMyStack
+
+    performMajorGC
+
+    let (StackSnapshot stack) = stackSnapshot
+    let expectedClosureTypes = [ 30 -- RET_SMALL
+                               , 30 -- RET_SMALL
+                               , 34 -- CATCH_FRAME
+                               , 36 -- STOP_FRAME
+                               ]
+    withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes))
diff --git a/testsuite/tests/rts/cloneMyStack2.hs b/testsuite/tests/rts/cloneMyStack2.hs
new file mode 100644
index 0000000000..068c816ce5
--- /dev/null
+++ b/testsuite/tests/rts/cloneMyStack2.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import GHC.Stack.CloneStack
+
+main = foo 100
+
+{-# NOINLINE foo #-}
+foo 0 = () <$ getStack
+foo n = print "x" >> foo (n - 1) >> print "x"
+
+-- This shouldn't segfault
+getStack = do
+  !s <- cloneMyStack
+  return ()
diff --git a/testsuite/tests/rts/cloneMyStack_retBigStackFrame.hs b/testsuite/tests/rts/cloneMyStack_retBigStackFrame.hs
new file mode 100644
index 0000000000..cccc8ec618
--- /dev/null
+++ b/testsuite/tests/rts/cloneMyStack_retBigStackFrame.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import Control.Concurrent
+import Data.IORef
+import GHC.IO.Unsafe
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+import System.Mem
+
+foreign import ccall "expectSixtyFourOnesInRetBigFrame" expectSixtyFourOnesInRetBigFrame :: StackSnapshot# -> IO ()
+
+cloneStack_returnInt :: IORef (Maybe StackSnapshot) -> Int
+cloneStack_returnInt ioRef = unsafePerformIO $ do
+  stackSnapshot <- cloneMyStack
+
+  performMajorGC
+
+  writeIORef ioRef (Just stackSnapshot)
+
+  performMajorGC
+
+  return 42
+
+-- | Clone a stack with a RET_BIG closure and check it in snapshot.
+-- In the meanwhile enforce several garbage collections in different places to
+-- ensure that the stack snapshot is still valid afterwards (is not gc'ed while
+-- in use).
+main :: IO ()
+main = do
+  stackRef <- newIORef Nothing
+
+  bigFun (cloneStack_returnInt stackRef) 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+
+  Just (StackSnapshot stackSnapshot) <- readIORef stackRef
+
+  performMajorGC
+
+  expectSixtyFourOnesInRetBigFrame stackSnapshot
+
+  return ()
+
+bigFun !a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 =
+  do
+    print $ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + a60 + a61 + a62 + a63 + a64 + a65
+
+    return ()
diff --git a/testsuite/tests/rts/cloneStackLib.c b/testsuite/tests/rts/cloneStackLib.c
new file mode 100644
index 0000000000..a89a069886
--- /dev/null
+++ b/testsuite/tests/rts/cloneStackLib.c
@@ -0,0 +1,111 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+#include <string.h>
+
+
+void expectStacksToBeEqual(StgStack *clonedStack, StgTSO *tso) {
+    StgStack *liveStack = tso->stackobj;
+
+    if(liveStack->header.info != clonedStack->header.info){
+        barf("info table pointer not equal! Expected same pointer address, but got %p and %p", liveStack->header.info, clonedStack->header.info);
+    }
+
+    StgInfoTable *info = INFO_PTR_TO_STRUCT(liveStack->header.info);
+
+    if (info->type != STACK) {
+        barf("Expected a closure of type STACK!");
+    }
+
+    if(liveStack->stack_size != clonedStack->stack_size){
+        barf("Expected same stack_size!");
+    }
+
+    if(liveStack->marking != clonedStack->marking){
+        barf("Expected same marking flags!");
+    }
+
+    for(StgWord i = liveStack->stack_size - 1; (liveStack->stack + i) >= liveStack->sp; i--){
+        if(liveStack->stack[i] != clonedStack->stack[i]){
+            barf("Expected stack word %lu to be equal on both stacks.", i);
+        }
+    }
+}
+
+void expectStackToBeNotDirty(StgStack *stack) {
+    if(stack->dirty != 0) {
+        barf("Expected stack to be not dirty. But dirty flag was set to %u", stack->dirty);
+    }
+}
+
+void expectClosureTypes(StgStack *stack, unsigned int types[], size_t typesSize){
+    StgPtr sp = stack->sp;
+    StgPtr spBottom = stack->stack + stack->stack_size;
+
+    for (StgWord i = 0; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp), i++) {
+        const StgInfoTable *info = get_itbl((StgClosure *)sp);
+
+        if(i >= typesSize) {
+            barf("Stack size exceeds expectation!");
+        }
+
+        if(info->type != types[i]) {
+            barf("Wrong closure type on stack! Expected %u but got %u in position %lu", types[i], info->type, i);
+        }
+    }
+}
+
+// Count all (#I 1) closures of the RET_BIG closure's payload.
+static int countOnes(StgPtr spBottom, StgPtr payload,
+                     StgLargeBitmap *large_bitmap, uint32_t size) {
+  StgWord bmp;
+  uint32_t i, j;
+  int ones = 0;
+
+  i = 0;
+  for (bmp = 0; i < size; bmp++) {
+    StgWord bitmap = large_bitmap->bitmap[bmp];
+    j = 0;
+    for (; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1) {
+      if ((bitmap & 1) == 0) {
+        const StgClosure *closure = UNTAG_CLOSURE((StgClosure *)payload[i]);
+        const StgInfoTable *info = get_itbl(closure);
+
+        switch (info->type) {
+        case CONSTR_0_1: {
+          const StgConInfoTable *con_info = get_con_itbl(closure);
+          if (strcmp(GET_CON_DESC(con_info), "ghc-prim:GHC.Types.I#") == 0 &&
+              closure->payload[0] == 1) {
+            ones++;
+          }
+          break;
+        }
+        default: {
+          break;
+        }
+        }
+      }
+    }
+  }
+
+  return ones;
+}
+
+void expectSixtyFourOnesInRetBigFrame(StgStack *stack) {
+  StgPtr sp = stack->sp;
+  StgPtr spBottom = stack->stack + stack->stack_size;
+
+  for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
+    const StgInfoTable *info = get_itbl((StgClosure *)sp);
+
+    if (info->type == RET_BIG) {
+      StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+      int ones = countOnes(spBottom, (StgPtr)((StgClosure *)sp)->payload,
+                           bitmap, bitmap->size);
+
+      if (ones != 64) {
+        barf("Expected 64 ones, got %i!", ones);
+      }
+    }
+  }
+}
diff --git a/testsuite/tests/rts/cloneThreadStack.hs b/testsuite/tests/rts/cloneThreadStack.hs
new file mode 100644
index 0000000000..11b37d3577
--- /dev/null
+++ b/testsuite/tests/rts/cloneThreadStack.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#, ThreadId#)
+import GHC.Conc.Sync (ThreadId(..))
+import GHC.Stack.CloneStack
+import Control.Concurrent
+import GHC.Conc
+import System.Mem
+
+foreign import ccall "expectStacksToBeEqual" expectStacksToBeEqual:: StackSnapshot# -> ThreadId# -> IO ()
+
+foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSnapshot# -> IO ()
+
+-- | Clone the stack of another thread and check it's snapshot for being equal
+-- with the live stack.
+-- In the meanwhile enforce a garbage collection to ensure that the stack
+-- snapshot is still valid afterwards (is not gc'ed while in use).
+main :: IO ()
+main = do
+    mVarToBeBlockedOn <- newEmptyMVar
+    threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
+
+    waitUntilBlocked threadId
+
+    stackSnapshot <- cloneThreadStack threadId
+
+    performMajorGC
+
+    let (StackSnapshot stack) = stackSnapshot
+    let (ThreadId tid#) = threadId
+    expectStacksToBeEqual stack tid#
+    expectStackToBeNotDirty stack
+
+immediatelyBlocking :: MVar Int -> IO ()
+immediatelyBlocking mVarToBeBlockedOn = do
+    takeMVar mVarToBeBlockedOn
+    return ()
+
+waitUntilBlocked :: ThreadId -> IO ()
+waitUntilBlocked tid = do
+    blocked <- isBlocked tid
+    if blocked then
+        return ()
+    else
+        do
+            threadDelay 100000
+            waitUntilBlocked tid
+
+isBlocked:: ThreadId -> IO Bool
+isBlocked = fmap isThreadStatusBlocked . threadStatus
+
+isThreadStatusBlocked :: ThreadStatus -> Bool
+isThreadStatusBlocked (ThreadBlocked _) = True
+isThreadStatusBlocked _ = False
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 06a4922aa3..c13447e527 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -884,6 +884,7 @@ ppType (TyApp (TyCon "ThreadId#")   []) = "threadIdPrimTy"
 ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
 ppType (TyApp (TyCon "BCO")         []) = "bcoPrimTy"
 ppType (TyApp (TyCon "Compact#")    []) = "compactPrimTy"
+ppType (TyApp (TyCon "StackSnapshot#") []) = "stackSnapshotPrimTy"
 ppType (TyApp (TyCon "()")          []) = "unitTy"      -- unitTy is GHC.Builtin.Types's name for ()
 
 ppType (TyVar "a")                      = "alphaTy"