Test underflow framewip/decode_cloned_stack_save

5 files changed, 48 insertions, 1 deletions

diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index 0b451cc6fa..4b8a3f45c3 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -208,5 +208,7 @@ closureSize (StackFrameBox sfi) = unpackStackFrameIter sfi <&>
       RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
       -- The one additional word is a pointer to the StgBCO in the closure's payload
       RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
+      -- The one additional word is a pointer to the next stack chunk
+      UnderflowFrame {} -> sizeStgClosure + 1
       _ -> error "Unexpected closure type"
 #endif
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index d7032f50d5..8576800f7c 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -404,7 +404,7 @@ data GenClosure b
     -- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
   | UnderflowFrame
       { info            :: !StgInfoTable
-      , nextChunk:: !b
+      , nextChunk       :: !b
       }
 
   | StopFrame
diff --git a/libraries/ghc-heap/tests/stack_misc_closures.hs b/libraries/ghc-heap/tests/stack_misc_closures.hs
index 1f4abda458..e6dbcd3a4d 100644
--- a/libraries/ghc-heap/tests/stack_misc_closures.hs
+++ b/libraries/ghc-heap/tests/stack_misc_closures.hs
@@ -58,6 +58,8 @@ foreign import prim "any_ret_fun_arg_gen_big_framezh" any_ret_fun_arg_gen_big_fr
 
 foreign import prim "any_bco_framezh" any_bco_frame# :: SetupFunction
 
+foreign import prim "any_underflow_framezh" any_underflow_frame# :: SetupFunction
+
 foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word
 
 foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
@@ -311,6 +313,30 @@ main = do
   traceM $ "Test 31"
   testSize any_bco_frame# 3
   traceM $ "Test 32"
+  test any_underflow_frame# $
+    \case
+      UnderflowFrame {..} -> do
+        assertEqual (tipe info) UNDERFLOW_FRAME
+        nextStack <- getBoxedClosureData nextChunk
+        case nextStack of
+          StackClosure {..} -> do
+            assertEqual (tipe info) STACK
+            assertEqual stack_size 27
+            assertEqual stack_dirty 0
+            assertEqual stack_marking 0
+            nextStackClosures <- mapM getBoxedClosureData stack
+            assertEqual (length nextStackClosures) 2
+            case head nextStackClosures of
+              RetSmall {..} ->
+                assertEqual (tipe info) RET_SMALL
+              e -> error $ "Wrong closure type: " ++ show e
+            case last nextStackClosures of
+              StopFrame {..} ->
+                assertEqual (tipe info) STOP_FRAME
+              e -> error $ "Wrong closure type: " ++ show e
+          e -> error $ "Wrong closure type: " ++ show e
+      e -> error $ "Wrong closure type: " ++ show e
+  testSize any_underflow_frame# 2
 
 type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
 
diff --git a/libraries/ghc-heap/tests/stack_misc_closures_c.c b/libraries/ghc-heap/tests/stack_misc_closures_c.c
index 582d636881..55edf30568 100644
--- a/libraries/ghc-heap/tests/stack_misc_closures_c.c
+++ b/libraries/ghc-heap/tests/stack_misc_closures_c.c
@@ -242,6 +242,14 @@ void create_any_bco_frame(Capability *cap, StgStack *stack, StgWord w) {
   c->payload[1] = (StgClosure *)rts_mkWord(cap, w);
 }
 
+StgStack *any_ret_small_prim_frame(Capability *cap);
+
+void create_any_underflow_frame(Capability *cap, StgStack *stack, StgWord w) {
+  StgUnderflowFrame *underflowF = (StgUnderflowFrame *)stack->sp;
+  underflowF->info = &stg_stack_underflow_frame_info;
+  underflowF->next_chunk = any_ret_small_prim_frame(cap);
+}
+
 // Import from Sanity.c
 extern void checkSTACK(StgStack *stack);
 
@@ -355,4 +363,9 @@ StgStack *any_bco_frame(Capability *cap) {
                &create_any_bco_frame);
 }
 
+StgStack *any_underflow_frame(Capability *cap) {
+  return setup(cap, sizeofW(StgUnderflowFrame),
+               &create_any_underflow_frame);
+}
+
 void belchStack(StgStack *stack) { printStack(stack); }
diff --git a/libraries/ghc-heap/tests/stack_misc_closures_prim.cmm b/libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
index 47f1bd544d..839c202da1 100644
--- a/libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
+++ b/libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
@@ -96,6 +96,12 @@ any_bco_framezh() {
     return (stack);
 }
 
+any_underflow_framezh() {
+    P_ stack;
+    (stack) = ccall any_underflow_frame(MyCapability() "ptr");
+    return (stack);
+}
+
 INFO_TABLE_RET ( test_small_ret_full_p, RET_SMALL, W_ info_ptr,
 #if SIZEOF_VOID_P == 4
 P_ ptr1, P_ ptr2, P_ ptr3, P_ ptr4, P_ ptr5, P_ ptr6, P_ ptr7, P_ ptr8, P_ ptr9, P_ ptr10,