[Git][ghc/ghc][wip/stack_cloning] 3 commits: Introduce snapshotting of thread's own stack

Matthew Pickering gitlab at gitlab.haskell.org
Wed Nov 11 07:24:43 UTC 2020



Matthew Pickering pushed to branch wip/stack_cloning at Glasgow Haskell Compiler / GHC


Commits:
162747f9 by Sven Tennie at 2020-11-11T07:24:15+00:00
Introduce snapshotting of thread's own stack

Introduce `StackSnapshot#` type and the `cloneMyStack#` primop, allowing
the user to reify the state of the calling thread's stack for later
inspection.

The stack snapshot is offline/cold, i.e. it isn't evaluated any further.

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

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

- - - - -
89dbab58 by Sven Tennie at 2020-11-11T07:24:15+00:00
Introduce cloning of other threads' stacks

Introduce `cloneThreadStack` function, allowing threads to request
snapshots of other threads' stacks.

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

Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>

- - - - -
b3af82b7 by Matthew Pickering at 2020-11-11T07:24:15+00:00
Add another test for stack cloning

This test triggers at least one GC, which showed up the problem with the
stale sp field.

- - - - -


22 changed files:

- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- includes/rts/storage/Closures.h
- includes/stg/MiscClosures.h
- + libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/base.cabal
- + rts/CloneStack.c
- + rts/CloneStack.h
- rts/Messages.c
- rts/PrimOps.cmm
- rts/RtsSymbols.c
- rts/StgMiscClosures.cmm
- rts/package.conf.in
- rts/rts.cabal.in
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/cloneMyStack.hs
- + testsuite/tests/rts/cloneMyStack2.hs
- + testsuite/tests/rts/cloneStackLib.c
- + testsuite/tests/rts/cloneThreadStack.hs
- utils/genprimopcode/Main.hs


Changes:

=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1770,7 +1770,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
@@ -1801,6 +1801,7 @@ ptrTyConKey                             = mkPreludeTyConUnique 77
 funPtrTyConKey                          = mkPreludeTyConUnique 78
 tVarPrimTyConKey                        = mkPreludeTyConUnique 79
 compactPrimTyConKey                     = mkPreludeTyConUnique 80
+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81
 
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84


=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -69,6 +69,7 @@ module GHC.Builtin.Types.Prim(
         bcoPrimTyCon,                   bcoPrimTy,
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
+        stackSnapshotPrimTyCon,         stackSnapshotPrimTy,
 
         int8PrimTyCon,          int8PrimTy, int8PrimTyConName,
         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,
@@ -189,6 +190,7 @@ exposedPrimTyCons
     , word16PrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
+    , stackSnapshotPrimTyCon
 
     , tYPETyCon
     , funTyCon
@@ -211,7 +213,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
@@ -247,6 +249,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
@@ -1087,6 +1090,21 @@ compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep
 compactPrimTy :: Type
 compactPrimTy = mkTyConTy compactPrimTyCon
 
+{-
+************************************************************************
+*                                                                      *
+   The @StackSnapshot#@ type
+*                                                                      *
+************************************************************************
+-}
+
+stackSnapshotPrimTyCon :: TyCon
+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName UnliftedRep
+
+stackSnapshotPrimTy :: Type
+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon
+
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3151,6 +3151,16 @@ 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 Haskell thread. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+
 ------------------------------------------------------------------------
 section "Safe coercions"
 ------------------------------------------------------------------------


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1521,6 +1521,7 @@ emitPrimOp dflags primop = case primop of
   TraceEventBinaryOp -> alwaysExternal
   TraceMarkerOp -> alwaysExternal
   SetThreadAllocationCounter -> alwaysExternal
+  CloneMyStack -> alwaysExternal
 
  where
   profile = targetProfile dflags


=====================================
includes/rts/storage/Closures.h
=====================================
@@ -431,6 +431,14 @@ typedef struct MessageBlackHole_ {
     StgClosure *bh;
 } MessageBlackHole;
 
+typedef struct MessageCloneStack_ {
+    StgHeader header;
+    Message   *link;
+    StgMVar   *result;
+    StgTSO    *tso;
+} MessageCloneStack;
+
+
 /* ----------------------------------------------------------------------------
    Compact Regions
    ------------------------------------------------------------------------- */


=====================================
includes/stg/MiscClosures.h
=====================================
@@ -129,6 +129,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);
@@ -492,6 +493,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 */


=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -0,0 +1,70 @@
+{-# 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[]). The stack pointer (sp) of the clone is adjusted to be
+valid.
+
+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.
+
+There are two different ways to clone a stack:
+1. By the corresponding thread via a primop call (cloneMyStack#).
+2. By sending a RTS message (Messages.c) with a MVar to the corresponding
+   thread and receiving the stack by taking it out of this MVar.
+
+A StackSnapshot# is really a pointer to an immutable StgStack closure with
+the invariant that stack->sp points to a valid frame.
+-}
+
+-- | 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
+


=====================================
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


=====================================
rts/CloneStack.c
=====================================
@@ -0,0 +1,104 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (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);
+  freeStablePtr(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)


=====================================
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"


=====================================
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);
         }
     }
@@ -131,6 +133,10 @@ loop:
 #endif
         goto loop;
     }
+    else if(i == &stg_MSG_CLONE_STACK_info){
+        MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
+        handleCloneStackMessage(cloneStackMessage);
+    }
     else
     {
         barf("executeMessage: %p", i);


=====================================
rts/PrimOps.cmm
=====================================
@@ -2840,3 +2840,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);
+}


=====================================
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"
@@ -979,6 +980,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)                                         \
@@ -998,6 +1000,7 @@
       SymI_HasProto(cas)                                                \
       SymI_HasProto(_assertFail)                                        \
       SymI_HasProto(keepCAFs)                                           \
+      SymI_HasProto(sendCloneStackMessage)                              \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -573,6 +573,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
 


=====================================
rts/package.conf.in
=====================================
@@ -194,6 +194,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"
@@ -308,6 +309,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


=====================================
rts/rts.cabal.in
=====================================
@@ -286,6 +286,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,
@@ -367,6 +368,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,
@@ -410,6 +412,7 @@ library
                Arena.c
                Capability.c
                CheckUnload.c
+               CloneStack.c
                ClosureFlags.c
                Disassembler.c
                FileLock.c


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -418,3 +418,8 @@ test('T17088',
      compile_and_run, ['-rtsopts -O2'])
 
 test('T15427', normal, compile_and_run, [''])
+
+test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c'])
+test('cloneMyStack2', ignore_stdout, compile_and_run, [''])
+
+test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded'])


=====================================
testsuite/tests/rts/cloneMyStack.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+import GHC.Prim (StackSnapshot#)
+import GHC.Stack.CloneStack
+import Foreign
+import Foreign.C.Types (CUInt)
+
+foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> Ptr CUInt -> Int -> IO ()
+
+main :: IO ()
+main = do
+    stackSnapshot <- cloneMyStack
+
+    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))


=====================================
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 ()


=====================================
testsuite/tests/rts/cloneStackLib.c
=====================================
@@ -0,0 +1,55 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.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 %i", types[i], info->type, i);
+        }
+    }
+}


=====================================
testsuite/tests/rts/cloneThreadStack.hs
=====================================
@@ -0,0 +1,49 @@
+{-# 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
+
+foreign import ccall "expectStacksToBeEqual" expectStacksToBeEqual:: StackSnapshot# -> ThreadId# -> IO ()
+
+foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSnapshot# -> IO ()
+
+main :: IO ()
+main = do
+    mVarToBeBlockedOn <- newEmptyMVar
+    threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn
+
+    waitUntilBlocked threadId
+
+    stackSnapshot <- cloneThreadStack threadId
+
+    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


=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -878,6 +878,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"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b09e577cf7afb73a423db02a62a3eff150f8dde...b3af82b74cf8ac9f6523d0506d807b3e0c70c0eb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b09e577cf7afb73a423db02a62a3eff150f8dde...b3af82b74cf8ac9f6523d0506d807b3e0c70c0eb
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201111/362ff8a8/attachment-0001.html>


More information about the ghc-commits mailing list