diff --git a/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs b/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs index f87ae9f8f1318db484d0f2ce689ebcb2d1aec82d..d5b7686520bd7f117cc0cd095ec0d89c7a191fa0 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs +++ b/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}) = diff --git a/rts/CloneStack.c b/rts/CloneStack.c index d10bc21178c268e19c5e54e43a39c7cb2f46efa6..0ae0979bd255ee0d540ebfbd9e41e7b1a5744b7b 100644 --- a/rts/CloneStack.c +++ b/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); -} diff --git a/rts/CloneStack.h b/rts/CloneStack.h index a1f03e290f27912c8de27b4ef220d2b77c79aeac..d01ac3a8b1d8e256089854e025a08ce74038b247 100644 --- a/rts/CloneStack.h +++ b/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"