[Git][ghc/ghc][wip/decode_cloned_stack] More on Large Bitmaps
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Oct 7 15:40:07 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
18f594e8 by Sven Tennie at 2022-10-07T15:39:34+00:00
More on Large Bitmaps
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/decode_cloned_stack.hs
- rts/Heap.c
- rts/Printer.c
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -69,14 +69,16 @@ wordsToBitmapEntries _ [] 0 = []
wordsToBitmapEntries _ [] i = error $ "Invalid state: Empty list, size " ++ show i
wordsToBitmapEntries _ l 0 = error $ "Invalid state: Size 0, list " ++ show l
wordsToBitmapEntries sfi (b:bs) size =
- let entries = toBitmapEntries sfi b size
- mbLastEntry = (listToMaybe . reverse) entries
- mbLastFrame = fmap closureFrame mbLastEntry
- in
- case mbLastFrame of
- Just (StackFrameIter (# s'#, i'# #)) ->
- entries ++ wordsToBitmapEntries (StackFrameIter (# s'#, plusWord# i'# 1## #)) bs (subtractDecodedBitmapWord size)
- Nothing -> error "This should never happen! Recursion ended not in base case."
+ trace ("wordsToBitmapEntries - b " ++ show b ++ ", size " ++ show size)
+ (let entries = toBitmapEntries sfi b (min size (fromIntegral wORD_SIZE_IN_BITS))
+ mbLastEntry = (listToMaybe . reverse) entries
+ mbLastFrame = fmap closureFrame mbLastEntry
+ in
+ case mbLastFrame of
+ Just (StackFrameIter (# s'#, i'# #)) ->
+ entries ++ wordsToBitmapEntries (StackFrameIter (# s'#, plusWord# i'# 1## #)) bs (subtractDecodedBitmapWord size)
+ Nothing -> error "This should never happen! Recursion ended not in base case."
+ )
where
subtractDecodedBitmapWord :: Word -> Word
subtractDecodedBitmapWord size = fromIntegral $ max 0 ((fromIntegral size) - wORD_SIZE_IN_BITS)
@@ -84,9 +86,9 @@ wordsToBitmapEntries sfi (b:bs) size =
toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
toBitmapEntries _ _ 0 = []
toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmap size = BitmapEntry {
- closureFrame = sfi,
- isPrimitive = (bitmap .&. 1) == 0
- } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (size - 1)
+ closureFrame = sfi,
+ isPrimitive = (bitmap .&. 1) /= 0
+ } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (size - 1)
toBitmapPayload :: BitmapEntry -> BitmapPayload
toBitmapPayload e | isPrimitive e = Primitive . toWord . closureFrame $ e
@@ -112,13 +114,13 @@ unpackStackFrameIter (StackFrameIter (# s#, i# #)) =
RET_BCO -> RetBCO
RET_SMALL -> let !(# bitmap#, size# #) = getSmallBitmap# s# i#
bes = toBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #))(W# bitmap#) (W# size#)
- payloads = map toBitmapPayload bes
+ payloads = map toBitmapPayload (trace ("bes " ++ show bes) bes)
in
RetSmall None payloads
RET_BIG -> let !(# bitmapArray#, size# #) = getLargeBitmap# s# i#
bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
- bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #)) bitmapWords (trace ("XXX size " ++ show (W# size#))(W# size#))
- payloads = map toBitmapPayload bes
+ bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
+ payloads = map toBitmapPayload (trace ("unpackStackFrameIter - lenght " ++ show (length bes) ++ ", " ++ show bes ) bes)
in
RetBig payloads
RET_FUN -> RetFun
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -83,9 +83,10 @@ getSmallBitmapzh(P_ stack, W_ index) {
}
unpackClosureFromStackFramezh(P_ stack, W_ index){
- P_ closurePtr;
+ P_ closurePtr, closurePtrPrime;
closurePtr = (StgStack_sp(stack) + WDS(index));
- jump stg_unpackClosurezh(closurePtr);
+ closurePtrPrime = P_[closurePtr];
+ jump stg_unpackClosurezh(closurePtrPrime);
}
getLargeBitmapzh(P_ stack, W_ index){
=====================================
libraries/ghc-heap/tests/decode_cloned_stack.hs
=====================================
@@ -2,10 +2,12 @@ module Main where
import GHC.Stack.CloneStack
import GHC.Exts.DecodeStack
+import GHC.Float (minExpt)
+import System.IO (hPutStrLn, stderr)
main :: IO ()
main = do
stack <- cloneMyStack
res <- decodeStack stack
- print res
+ hPutStrLn stderr $ "result: " ++ show res
return ()
=====================================
rts/Heap.c
=====================================
@@ -248,7 +248,8 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) {
StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
-
+ debugBelch("heap_view_closurePtrs : closure %p, printObj ", closure);
+ printObj(closure);
StgWord size = heap_view_closureSize(closure);
// First collect all pointers here, with the comfortable memory bound
=====================================
rts/Printer.c
=====================================
@@ -482,6 +482,8 @@ void printBits(size_t const size, void const * const ptr)
debugBelch("\n");
}
+StgPtr origSp = NULL;
+
static void
printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
uint32_t size )
@@ -494,13 +496,15 @@ printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
uint32_t i;
for(i = 0; i < size; i++, bitmap >>= 1 ) {
+ debugBelch("printSmallBitmap - index %ld\n", &payload[i] - origSp);
debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
+ debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
@@ -515,29 +519,35 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
i = 0;
for (bmp=0; i < size; bmp++) {
StgWord bitmap = large_bitmap->bitmap[bmp];
+ debugBelch("printLargeBitmap - bitmap no %ul, bits ", bmp);
+ printBits(sizeof(StgWord), &bitmap);
j = 0;
for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
+ debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
}
+
void
printStackChunk( StgPtr sp, StgPtr spBottom )
{
const StgInfoTable *info;
+ origSp = sp;
ASSERT(sp <= spBottom);
for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
info = get_itbl((StgClosure *)sp);
debugBelch("printStackChunk - closure size : %lu , sp : %p, spBottom %p, info ptr %p, itbl type %ul \n", stack_frame_sizeW((StgClosure *)sp), sp, spBottom, info, info->type);
+ debugBelch("printStackChunk - index: %ld \n", sp - origSp);
switch (info->type) {
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18f594e85854d5401a31a86fc1bafc431773d08a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18f594e85854d5401a31a86fc1bafc431773d08a
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/20221007/0e06120b/attachment-0001.html>
More information about the ghc-commits
mailing list