[Git][ghc/ghc][wip/decode_cloned_stack] Decode and test underflow frames
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Tue Oct 11 10:46:27 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
a3dacb40 by Sven Tennie at 2022-10-11T10:45:17+00:00
Decode and test underflow frames
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/all.T
- testsuite/tests/rts/all.T
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -41,6 +41,9 @@ data StackFrameIter = StackFrameIter StackFrameIter#
instance Show StackFrameIter where
show (StackFrameIter (# _, i# #)) = "StackFrameIter " ++ "(StackSnapshot _" ++ " " ++ show (W# i#)
+instance Show StackSnapshot where
+ show _ = "StackSnapshot _"
+
-- | Get an interator starting with the top-most stack frame
stackHead :: StackSnapshot -> StackFrameIter
stackHead (StackSnapshot s) = StackFrameIter (# s , 0## #) -- GHC stacks are never empty
@@ -136,7 +139,10 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
exceptionsBlocked = W# (getCatchFrameExceptionsBlocked# s# i#)
in
CatchFrame exceptionsBlocked c
- UNDERFLOW_FRAME -> UnderflowFrame
+ UNDERFLOW_FRAME -> let
+ nextChunk# = getUnderflowFrameNextChunk# s# i#
+ in
+ UnderflowFrame (StackSnapshot nextChunk#)
STOP_FRAME -> StopFrame
ATOMICALLY_FRAME -> AtomicallyFrame
CATCH_RETRY_FRAME -> CatchRetryFrame
@@ -179,6 +185,8 @@ foreign import prim "unpackHandlerFromCatchFramezh" unpackHandlerFromCatchFrame#
foreign import prim "getCatchFrameExceptionsBlockedzh" getCatchFrameExceptionsBlocked# :: StackSnapshot# -> Word# -> Word#
+foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> StackSnapshot#
+
data BitmapPayload = Closure CL.Closure | Primitive Word
instance Show BitmapPayload where
@@ -222,7 +230,7 @@ data StackFrame =
CatchStmFrame |
CatchRetryFrame |
AtomicallyFrame |
- UnderflowFrame |
+ UnderflowFrame { nextChunk:: StackSnapshot } |
StopFrame |
RetSmall SpecialRetSmall [BitmapPayload] |
RetBig [BitmapPayload] |
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -147,8 +147,12 @@ StgArrBytes* getLargeBitmaps(Capability *cap, StgClosure *c){
}
#if defined(DEBUG)
-extern void printStack ( StgStack *stack );
+extern void printStack (StgStack *stack);
void belchStack(StgStack* stack){
printStack(stack);
}
#endif
+
+StgStack* getUnderflowFrameNextChunk(StgUnderflowFrame* frame){
+ return frame->next_chunk;
+}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -28,7 +28,7 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
stackBottom = stackSizeInBytes + stackArrayPtr;
if(nextClosurePtr < stackBottom) (likely: True) {
- ccall debugBelch("advanceStackFrameIterzh - ordinary frame \n");
+ // ccall debugBelch("advanceStackFrameIterzh - ordinary frame \n");
newStack = stack;
newIndex = index + frameSize;
hasNext = 1;
@@ -36,12 +36,12 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
P_ underflowFrameStack;
(underflowFrameStack) = ccall getUnderflowFrameStack(stack, index);
if (underflowFrameStack == NULL) (likely: True) {
- ccall debugBelch("advanceStackFrameIterzh - last frame \n");
+ // ccall debugBelch("advanceStackFrameIterzh - last frame \n");
newStack = NULL;
newIndex = NULL;
hasNext = NULL;
} else {
- ccall debugBelch("advanceStackFrameIterzh - overflow frame \n");
+ // ccall debugBelch("advanceStackFrameIterzh - underflow frame \n");
newStack = underflowFrameStack;
newIndex = NULL;
hasNext = 1;
@@ -49,12 +49,14 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
}
// TODO: Execute this block only in -DDEBUG
+#if DEBUG
if(hasNext > 0) {
P_ nextClosure;
nextClosure = StgStack_sp(stack) + WDS(index);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(nextClosure));
ccall checkSTACK(stack);
}
+#endif
// ccall debugBelch("advanceStackFrameIterzh - stack %p, newStack %p, frameSize %ul, newIdex %ul, hasNext %ul, stackBottom %p\n", stack, newStack, frameSize, newIndex, hasNext, stackBottom);
return (newStack, newIndex, hasNext);
@@ -154,3 +156,14 @@ getCatchFrameExceptionsBlockedzh(P_ stack, W_ index){
exceptions_blocked = StgCatchFrame_exceptions_blocked(closurePtr);
return (exceptions_blocked);
}
+
+getUnderflowFrameNextChunkzh(P_ stack, W_ index){
+ P_ closurePtr, closurePtrPrime, updateePtr;
+ closurePtr = (StgStack_sp(stack) + WDS(index));
+ ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr));
+
+ P_ next_chunk;
+ (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
+ ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk));
+ return (next_chunk);
+}
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -64,3 +64,13 @@ test('decode_cloned_stack',
test('decode_cloned_stack_big_ret',
[only_ways(['normal'])],
compile_and_run, ['-debug -optc-g -g -DDEBUG'])
+
+# Options:
+# - `-kc512B -kb64B`: Make stack chunk size small to provoke underflow stack frames.
+test('stack_underflow',
+ [
+ extra_run_opts('+RTS -kc512B -kb64B -RTS'),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run, ['-rtsopts'])
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -508,6 +508,7 @@ test('cloneMyStack2', ignore_stdout, compile_and_run, [''])
test('cloneMyStack_retBigStackFrame', [extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c'])
test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded'])
test('decodeMyStack', normal, compile_and_run, ['-finfo-table-map'])
+# TODO: This comment is wrong! 8K is not the minimum of -kc (though, -kb has to be adjusted)!
# Options:
# - `-kc8K`: Set stack chunk size to it's minimum to provoke underflow stack frames.
test('decodeMyStack_underflowFrames', [extra_run_opts('+RTS -kc8K -RTS')], compile_and_run, ['-finfo-table-map -rtsopts'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3dacb40265d711ae87dfa8e43ebdc252f88d95f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3dacb40265d711ae87dfa8e43ebdc252f88d95f
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/20221011/c01fb159/attachment-0001.html>
More information about the ghc-commits
mailing list