rts: Refactor GHC.Stack.CloneStack.decode

Don't allocate a Ptr constructor per frame.

libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs

@@ -25,10 +25,12 @@ module GHC.Internal.Stack.CloneStack (
 import GHC.Internal.MVar
 import GHC.Internal.Data.Maybe (catMaybes)
 import GHC.Internal.Base
+import GHC.Internal.Foreign.Storable
 import GHC.Internal.Conc.Sync
 import GHC.Internal.IO (unsafeInterleaveIO)
 import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable)
 import GHC.Internal.Num
+import GHC.Internal.Real (div)
 import GHC.Internal.Stable
 import GHC.Internal.Text.Show
 import GHC.Internal.Ptr
@@ -39,7 +41,7 @@ import GHC.Internal.ClosureTypes
 -- @since base-4.17.0.0
 data StackSnapshot = StackSnapshot !StackSnapshot#
 
-foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr StgInfoTable) #)
+foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
 
 foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
 
@@ -245,18 +247,21 @@ toStackEntry infoProv =
 getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
 getDecodedStackArray (StackSnapshot s) =
   IO $ \s0 -> case decodeStack# s s0 of
-    (# s1, arr #) -> unIO (go arr (I# (sizeofArray# arr) - 1)) s1
+    (# s1, arr #) ->
+      let n = I# (sizeofByteArray# arr) `div` wordSize - 1
+       in unIO (go arr n) s1
   where
-    go :: Array# (Ptr StgInfoTable) -> Int -> IO [Maybe StackEntry]
+    go :: ByteArray# -> Int -> IO [Maybe StackEntry]
     go _stack (-1) = return []
     go stack i = do
       infoProv <- lookupIPE (stackEntryAt stack i)
       rest <- unsafeInterleaveIO $ go stack (i-1)
       return ((toStackEntry `fmap` infoProv) : rest)
 
-    stackEntryAt :: Array# (Ptr StgInfoTable) -> Int -> Ptr StgInfoTable
-    stackEntryAt stack (I# i) = case indexArray# stack i of
-      (# se #) -> se
+    stackEntryAt :: ByteArray# -> Int -> Ptr StgInfoTable
+    stackEntryAt stack (I# i) = Ptr (indexAddrArray# stack i)
+
+    wordSize = sizeOf (nullPtr :: Ptr ())
 
 prettyStackEntry :: StackEntry -> String
 prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =

rts/CloneStack.c

@@ -28,9 +28,8 @@
 
 static StgWord getStackFrameCount(StgStack* stack);
 static StgWord getStackChunkClosureCount(StgStack* stack);
-static void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack);
-static StgClosure* createPtrClosure(Capability* cap, const StgInfoTable* itbl);
-static StgMutArrPtrs* allocateMutableArray(StgWord size);
+static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes);
+static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack);
 
 static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
 {
@@ -116,12 +115,12 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED)
 // array is the count of stack frames.
 // Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack
 // frame it's represented by null.
-StgMutArrPtrs* decodeClonedStack(Capability *cap, StgStack* stack) {
+StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) {
   StgWord closureCount = getStackFrameCount(stack);
 
-  StgMutArrPtrs* array = allocateMutableArray(closureCount);
+  StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount);
 
-  copyPtrsToArray(cap, array, stack);
+  copyPtrsToArray(array, stack);
 
   return array;
 }
@@ -157,36 +156,33 @@ StgWord getStackChunkClosureCount(StgStack* stack) {
     return closureCount;
 }
 
-// Allocate and initialize memory for a MutableArray# (Haskell representation).
-StgMutArrPtrs* allocateMutableArray(StgWord closureCount) {
+// Allocate and initialize memory for a ByteArray# (Haskell representation).
+StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) {
   // Idea stolen from PrimOps.cmm:stg_newArrayzh()
-  StgWord size = closureCount + mutArrPtrsCardTableSize(closureCount);
-  StgWord words = sizeofW(StgMutArrPtrs) + size;
+  StgWord words = sizeofW(StgArrBytes) + bytes;
 
-  StgMutArrPtrs* array = (StgMutArrPtrs*) allocate(myTask()->cap, words);
-
-  SET_HDR(array, &stg_MUT_ARR_PTRS_DIRTY_info, CCS_SYSTEM);
-  array->ptrs  = closureCount;
-  array->size = size;
+  StgArrBytes* array = (StgArrBytes*) allocate(cap, words);
 
+  SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
+  array->bytes  = bytes;
   return array;
 }
 
-
-void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack) {
+static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) {
   StgWord index = 0;
   StgStack *last_stack = stack;
+  const StgInfoTable **result = (const StgInfoTable **) arr->payload;
   while (true) {
     StgPtr sp = last_stack->sp;
     StgPtr spBottom = last_stack->stack + last_stack->stack_size;
     for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
       const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info;
-      arr->payload[index] = createPtrClosure(cap, infoTable);
+      result[index] = infoTable;
       index++;
     }
 
     // Ensure that we didn't overflow the result array
-    ASSERT(index-1 < arr->ptrs);
+    ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*));
 
     // check whether the stack ends in an underflow frame
     StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack
@@ -198,12 +194,3 @@ void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack) {
     }
   }
 }
-
-// Create a GHC.Ptr (Haskell constructor: `Ptr StgInfoTable`) pointing to the
-// info table.
-StgClosure* createPtrClosure(Capability *cap, const StgInfoTable* itbl) {
-  StgClosure *p = (StgClosure *) allocate(cap, CONSTR_sizeW(0,1));
-  SET_HDR(p, &ghczminternal_GHCziInternalziPtr_Ptr_con_info, CCS_SYSTEM);
-  p->payload[0] = (StgClosure*) itbl;
-  return TAG_CLOSURE(1, p);
-}

rts/CloneStack.h

@@ -15,7 +15,7 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack);
 
 void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar);
 
-StgMutArrPtrs* decodeClonedStack(Capability *cap, StgStack* stack);
+StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack);
 
 #include "BeginPrivate.h"