[Git][ghc/ghc][wip/ipe-sharing] rts: Refactor GHC.Stack.CloneStack.decode
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed Sep 27 03:18:02 UTC 2023
Ben Gamari pushed to branch wip/ipe-sharing at Glasgow Haskell Compiler / GHC
Commits:
5a42def1 by Ben Gamari at 2023-09-26T23:17:22-04:00
rts: Refactor GHC.Stack.CloneStack.decode
Don't allocate a Ptr constructor per frame.
- - - - -
3 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- rts/CloneStack.c
- rts/CloneStack.h
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -26,7 +26,8 @@ import Control.Concurrent.MVar
import Data.Maybe (catMaybes)
import Foreign
import GHC.Conc.Sync
-import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#)
+import GHC.Ptr (Ptr(..))
+import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, ByteArray#, sizeofByteArray#, indexAddrArray#, State#, StablePtr#)
import GHC.IO (IO (..), unIO, unsafeInterleaveIO)
import GHC.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable)
import GHC.Stable
@@ -36,7 +37,7 @@ import GHC.Stable
-- @since 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# #)
@@ -243,15 +244,16 @@ 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` 8 - 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)
=====================================
rts/CloneStack.c
=====================================
@@ -27,9 +27,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)
{
@@ -115,12 +114,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;
}
@@ -156,36 +155,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
@@ -197,12 +193,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, &base_GHCziPtr_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"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a42def178bb4c0bc52168e39761d20db459f8a2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a42def178bb4c0bc52168e39761d20db459f8a2
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/20230926/90996baa/attachment-0001.html>
More information about the ghc-commits
mailing list