More on boxes: Increase lazy-ness

11 files changed, 60 insertions, 431 deletions

diff --git a/libraries/ghc-heap/GHC/Exts/DecodeStack.hs b/libraries/ghc-heap/GHC/Exts/DecodeStack.hs
index c73d66632e..a708b346f5 100644
--- a/libraries/ghc-heap/GHC/Exts/DecodeStack.hs
+++ b/libraries/ghc-heap/GHC/Exts/DecodeStack.hs
@@ -17,8 +17,7 @@
 
 -- TODO: Find better place than top level. Re-export from top-level?
 module GHC.Exts.DecodeStack (
-  decodeStack,
-  decodeStack'
+  decodeStack
                             ) where
 
 import GHC.Exts.StackConstants
@@ -148,11 +147,13 @@ toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize = BitmapEntry {
   } : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) (bitmapWord `shiftR` 1) (bSize - 1)
 
 toBitmapPayload :: BitmapEntry -> Box
-toBitmapPayload e | isPrimitive e = DecodedClosureBox $ (CL.UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame) e
+toBitmapPayload e | isPrimitive e = let !b = (UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame) e
+                                    in DecodedBox b
 toBitmapPayload e = getClosure (closureFrame e) 0
 
 getClosure :: StackFrameIter ->  WordOffset-> Box
 getClosure StackFrameIter {..} relativeOffset =
+-- TODO: What happens if the GC kicks in here?
   let offset = wordOffsetToWord# (index + relativeOffset)
       !ptr = (getAddr# stackSnapshot# offset)
       !a :: Any = unsafeCoerce# ptr
@@ -191,10 +192,11 @@ byteArrayToList bArray = go 0
 wordOffsetToWord# :: WordOffset -> Word#
 wordOffsetToWord# wo = intToWord# (fromIntegral wo)
 
-unpackStackFrameIter :: StackFrameIter -> IO CL.Closure
+unpackStackFrameIter :: StackFrameIter -> IO Box
 unpackStackFrameIter sfi = do
   info <- getInfoTable sfi
-  pure $ unpackStackFrameIter' info
+  let !c = unpackStackFrameIter' info
+  pure $ DecodedBox c
   where
     -- TODO: Check all (missing?) bang patterns
     unpackStackFrameIter' :: StgInfoTable -> CL.Closure
@@ -264,13 +266,12 @@ intToWord# i = int2Word# (toInt# i)
 decodeStack :: StackSnapshot -> IO CL.Closure
 decodeStack s = do
   stack <- decodeStack' s
-  let boxed = map DecodedClosureBox stack
-  pure $ SimpleStack boxed
+  pure $ SimpleStack stack
 
-decodeStack' :: StackSnapshot -> IO [CL.Closure]
+decodeStack' :: StackSnapshot -> IO [Box]
 decodeStack' s = unpackStackFrameIter (stackHead s) >>= \frame -> (frame :) <$> go (advanceStackFrameIter (stackHead s))
   where
-    go :: Maybe StackFrameIter -> IO [CL.Closure]
+    go :: Maybe StackFrameIter -> IO [Box]
     go Nothing = pure []
     go (Just sfi) = (trace "decode\n" (unpackStackFrameIter sfi)) >>= \frame -> (frame :) <$> go (advanceStackFrameIter sfi)
 
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index b1b5f3b17d..9d7191e42b 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -161,6 +161,7 @@ getClosureDataFromHeapObject x = do
         (# infoTableAddr, heapRep, pointersArray #) -> do
             let infoTablePtr = Ptr infoTableAddr
                 ptrList = [case indexArray# pointersArray i of
+-- TODO: What happens if the GC kicks in here? Is that possible? check Cmm.
                                 (# ptr #) -> Box ptr
                             | I# i <- [0..I# (sizeofArray# pointersArray) - 1]
                             ]
@@ -175,5 +176,5 @@ getClosureDataFromHeapObject x = do
 getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a
 #if MIN_TOOL_VERSION_ghc(9,5,0)
-getBoxedClosureData (DecodedClosureBox a) = pure a
+getBoxedClosureData (DecodedBox a) = pure a
 #endif
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 46efffe378..7c386da194 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -53,6 +53,7 @@ import Numeric
 
 #if MIN_VERSION_base(4,17,0)
 import GHC.Stack.CloneStack (StackSnapshot(..))
+import Unsafe.Coerce (unsafeCoerce)
 #endif
 
 ------------------------------------------------------------------------
@@ -68,13 +69,14 @@ foreign import prim "reallyUnsafePtrEqualityUpToTag"
 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
 -- to evaluate the argument.
 #if MIN_VERSION_base(4,17,0)
-data Box = Box Any | DecodedClosureBox Closure
+data Box = Box Any | DecodedBox Closure
 
 
 #else
 data Box = Box Any
 #endif
 
+-- TODO: Handle PrimitiveWordHolder
 instance Show Box where
 -- From libraries/base/GHC/Ptr.lhs
    showsPrec _ (Box a) rs =
@@ -86,19 +88,21 @@ instance Show Box where
        addr = ptr - tag
        pad_out ls = '0':'x':ls
 #if MIN_VERSION_base(4,17,0)
-   showsPrec _ (DecodedClosureBox a) rs = "(DecodedClosureBox " ++ show a ++ ")" ++ rs
+   showsPrec _ (DecodedBox a) rs = "(DecodedBox " ++ show a ++ ")" ++ rs
 #endif
 
 -- | Boxes can be compared, but this is not pure, as different heap objects can,
 -- after garbage collection, become the same object.
+-- TODO: Handle PrimitiveWordHolder
 areBoxesEqual :: Box -> Box -> IO Bool
 areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
     0# -> pure False
     _  -> pure True
 #if MIN_VERSION_base(4,17,0)
--- TODO: Implement
-areBoxesEqual (DecodedClosureBox _) (DecodedClosureBox _) = error "Not implemented, yet!"
-areBoxesEqual _ _ = pure $ False
+areBoxesEqual (DecodedBox a) (DecodedBox b) = areBoxesEqual
+  (Box (unsafeCoerce a))
+  (Box (unsafeCoerce b))
+areBoxesEqual _ _ = pure False
 #endif
 
 -- |This takes an arbitrary value and puts it into a box.
@@ -600,10 +604,6 @@ allClosures _ = []
 -- Includes header and payload. Does not follow pointers.
 --
 -- @since 8.10.1
+-- TODO: Handle PrimitiveWordHolder
 closureSize :: Box -> Int
 closureSize (Box x) = I# (closureSize# x)
-#if MIN_VERSION_base(4,17,0)
--- TODO: Add comment to explain. This is a bit weird because it returns the size
--- of the representation, not the closure itself.
-closureSize (DecodedClosureBox dc) = closureSize $ asBox dc
-#endif
diff --git a/libraries/ghc-heap/tests/TestUtils.hs b/libraries/ghc-heap/tests/TestUtils.hs
index c37c68109b..59bba718c2 100644
--- a/libraries/ghc-heap/tests/TestUtils.hs
+++ b/libraries/ghc-heap/tests/TestUtils.hs
@@ -9,11 +9,15 @@ module TestUtils
   ( assertEqual,
     assertThat,
     assertStackInvariants,
+    getDecodedStack,
     unbox,
   )
 where
 
+import Control.Monad.IO.Class
 import Data.Array.Byte
+import Data.Foldable
+import Debug.Trace
 import GHC.Exts
 import GHC.Exts.DecodeStack
 import GHC.Exts.Heap
@@ -22,9 +26,13 @@ import GHC.Records
 import GHC.Stack (HasCallStack)
 import GHC.Stack.CloneStack
 import Unsafe.Coerce (unsafeCoerce)
-import Debug.Trace
-import Data.Foldable
-import Control.Monad.IO.Class
+
+getDecodedStack :: IO (StackSnapshot, [Closure])
+getDecodedStack = do
+  s <- cloneMyStack
+  (SimpleStack cs) <- decodeStack s
+  unboxedCs <- mapM getBoxedClosureData cs
+  pure (s, unboxedCs)
 
 assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
 assertEqual a b
@@ -43,141 +51,6 @@ assertStackInvariants stack decodedStack = do
         _ -> False
     )
     (last decodedStack)
-  ts1 <- liftIO $ toClosureTypes decodedStack
-  ts2 <- liftIO $ toClosureTypes stack
-  assertEqual ts1 ts2
-
-class ToClosureTypes a where
-  toClosureTypes ::  a -> IO [ClosureType]
-
-instance ToClosureTypes StackSnapshot where
-  toClosureTypes = pure . stackSnapshotToClosureTypes . foldStackToArrayClosure
-
-instance ToClosureTypes Closure where
-  toClosureTypes = stackFrameToClosureTypes
-
-instance ToClosureTypes a => ToClosureTypes [a] where
-  toClosureTypes cs = concat <$> mapM toClosureTypes cs
-
-foreign import ccall "foldStackToArrayClosure" foldStackToArrayClosure# :: StackSnapshot# -> ByteArray#
-
-foldStackToArrayClosure :: StackSnapshot -> ByteArray
-foldStackToArrayClosure (StackSnapshot s#) = ByteArray (foldStackToArrayClosure# s#)
-
-foreign import ccall "bytesInWord" bytesInWord# :: Word
-
-stackSnapshotToClosureTypes :: ByteArray -> [ClosureType]
-stackSnapshotToClosureTypes = wordsToClosureTypes . toWords
-  where
-    toWords :: ByteArray -> [Word]
-    toWords ba@(ByteArray b#) =
-      let s = I# (sizeofByteArray# b#)
-       in [W# (indexWordArray# b# (toInt# i)) | i <- [0 .. maxWordIndex (ba)]]
-      where
-        maxWordIndex :: ByteArray -> Int
-        maxWordIndex (ByteArray ba#) =
-          let s = I# (sizeofByteArray# ba#)
-              words = s `div` fromIntegral bytesInWord#
-           in case words of
-                w | w == 0 -> error "ByteArray contains no content!"
-                w -> w - 1
-
-    wordsToClosureTypes :: [Word] -> [ClosureType]
-    wordsToClosureTypes = map (toEnum . fromIntegral)
-
-toInt# :: Int -> Int#
-toInt# (I# i#) = i#
-
--- TODO: Can probably be simplified once all stack closures have into tables attached.
-stackFrameToClosureTypes :: Closure -> IO [ClosureType]
-stackFrameToClosureTypes = getClosureTypes
-  where
-    getClosureTypes :: Closure -> IO [ClosureType]
-    -- Stack frame closures
-    getClosureTypes (UpdateFrame {info, updatee, ..}) = do
-      u <- unbox updatee
-      ts <- getClosureTypes u
-      pure $ tipe info : ts
-    getClosureTypes (CatchFrame {info, handler, ..}) = do
-      h <- unbox handler
-      ts <- getClosureTypes h
-      pure $ tipe info : ts
-    getClosureTypes (CatchStmFrame {info, catchFrameCode, handler}) = do
-      c <- unbox catchFrameCode
-      h <- unbox handler
-      ts1 <- getClosureTypes c
-      ts2 <- getClosureTypes h
-      pure $ tipe info : ts1 ++ ts2
-    getClosureTypes (CatchRetryFrame {info, first_code, alt_code, ..}) = do
-      a <- unbox alt_code
-      f <- unbox first_code
-      ts1 <- getClosureTypes f
-      ts2 <- getClosureTypes a
-      pure $ tipe info : ts1 ++ ts2
-    getClosureTypes (AtomicallyFrame {info, atomicallyFrameCode, result}) = do
-      r <- unbox result
-      a <- unbox atomicallyFrameCode
-      ts1 <- getClosureTypes a
-      ts2 <- getClosureTypes r
-      pure $ tipe info : ts1 ++ ts2
-    getClosureTypes (UnderflowFrame {..}) = pure [tipe info]
-    getClosureTypes (StopFrame info) = pure [tipe info]
-    getClosureTypes (RetSmall {info, payload, ..}) = do
-      ts <- getBitmapClosureTypes payload
-      pure $ tipe info : ts
-    getClosureTypes (RetBig {info, payload}) = do
-      ts <- getBitmapClosureTypes payload
-      pure $ tipe info : ts
-    getClosureTypes (RetFun {info, retFunFun, retFunPayload, ..}) = do
-      rf <- unbox retFunFun
-      ts1 <- getClosureTypes rf
-      ts2 <- getBitmapClosureTypes retFunPayload
-      pure $ tipe info : ts1  ++ ts2
-    getClosureTypes (RetBCO {info, bco, bcoArgs, ..}) = do
-      bco <- unbox bco
-      bcoCls <- getClosureTypes bco
-      bcoArgsCls <- getBitmapClosureTypes bcoArgs
-      pure $ tipe info : bcoCls  ++ bcoArgsCls
-    -- Other closures
-    getClosureTypes (ConstrClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (FunClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (ThunkClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (SelectorClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (PAPClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (APClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (APStackClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (IndClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (BCOClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (BlackholeClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (ArrWordsClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (MutArrClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (SmallMutArrClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (MVarClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (IOPortClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (MutVarClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (BlockingQueueClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (WeakClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (TSOClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (StackClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (OtherClosure {info, ..}) = pure [tipe info]
-    getClosureTypes (UnsupportedClosure {info, ..}) = pure [tipe info]
-    getClosureTypes _ = pure []
-
-    getBitmapClosureTypes :: [Box] -> IO [ClosureType]
-    getBitmapClosureTypes bps =
-      reverse <$>
-        foldlM
-          ( \acc p -> do
-              c <- unbox p
-              case c of
-                UnknownTypeWordSizedPrimitive _ -> pure acc
-                c -> do
-                  cls <- getClosureTypes c
-                  pure $ cls ++ acc
-          )
-          []
-          bps
 
 unbox :: Box -> IO Closure
-unbox (DecodedClosureBox c) = pure c
-unbox box = getBoxedClosureData box
+unbox = getBoxedClosureData
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index fcd7ecfc1a..7aca5e065e 100644
--- a/libraries/ghc-heap/tests/all.T
+++ b/libraries/ghc-heap/tests/all.T
@@ -60,40 +60,40 @@ test('T21622',
 # TODO: Remove debug flags
 test('stack_big_ret',
      [
-        extra_files(['stack_lib.c', 'TestUtils.hs']),
+        extra_files(['TestUtils.hs']),
         ignore_stdout,
         ignore_stderr
      ],
-     multi_compile_and_run,
-     ['stack_big_ret', [('stack_lib.c','')], '-debug -optc-g -g'])
+     compile_and_run,
+     ['-debug -optc-g -g'])
 
 # TODO: Remove debug flags
 # Options:
 #   - `-kc512B -kb64B`: Make stack chunk size small to provoke underflow stack frames.
 test('stack_underflow',
      [
-        extra_files(['stack_lib.c', 'TestUtils.hs']),
+        extra_files(['TestUtils.hs']),
         extra_run_opts('+RTS -kc512B -kb64B -RTS'),
         ignore_stdout,
         ignore_stderr
      ],
-     multi_compile_and_run,
-     ['stack_underflow', [('stack_lib.c','')], '-debug -optc-g -g'])
+     compile_and_run,
+     ['-debug -optc-g -g'])
 
 # TODO: Remove debug flags
 test('stack_stm_frames',
      [
-        extra_files(['stack_lib.c', 'TestUtils.hs']),
+        extra_files(['TestUtils.hs']),
         ignore_stdout,
         ignore_stderr
       ],
-     multi_compile_and_run,
-     ['stack_stm_frames', [('stack_lib.c','')], '-debug -optc-g -g'])
+     compile_and_run,
+     ['-debug -optc-g -g'])
 
 # TODO: Remove debug flags
 test('stack_misc_closures',
      [
-        extra_files(['stack_misc_closures_c.c', 'stack_misc_closures_prim.cmm','stack_lib.c', 'TestUtils.hs']),
+        extra_files(['stack_misc_closures_c.c', 'stack_misc_closures_prim.cmm', 'TestUtils.hs']),
         ignore_stdout,
         ignore_stderr
       ],
@@ -101,7 +101,6 @@ test('stack_misc_closures',
      ['stack_misc_closures',
         [ ('stack_misc_closures_c.c', '')
          ,('stack_misc_closures_prim.cmm', '')
-         ,('stack_lib.c', '')
          ]
-      , '-debug -optc-g -g -ddump-to-file -dlint -dppr-debug -ddump-cmm'
+      , '-debug -optc-g -optc-O0 -g -ddump-to-file -dlint -ddump-cmm'
       ])
diff --git a/libraries/ghc-heap/tests/stack_big_ret.hs b/libraries/ghc-heap/tests/stack_big_ret.hs
index a7a7ec2094..9f95b5823a 100644
--- a/libraries/ghc-heap/tests/stack_big_ret.hs
+++ b/libraries/ghc-heap/tests/stack_big_ret.hs
@@ -18,6 +18,7 @@ import GHC.Stack.CloneStack
 import System.IO (hPutStrLn, stderr)
 import System.Mem
 import TestUtils
+import GHC.Exts.Heap
 
 cloneStackReturnInt :: IORef (Maybe StackSnapshot) -> Int
 cloneStackReturnInt ioRef = unsafePerformIO $ do
@@ -36,14 +37,15 @@ main = do
 
   mbStackSnapshot <- readIORef stackRef
   let stackSnapshot = fromJust mbStackSnapshot
-  !decodedStack <- decodeStack' stackSnapshot
+  (SimpleStack boxedFrames) <- decodeStack stackSnapshot
+  stackFrames <- mapM getBoxedClosureData boxedFrames
 
-  assertStackInvariants stackSnapshot decodedStack
+  assertStackInvariants stackSnapshot stackFrames
   assertThat
     "Stack contains one big return frame"
     (== 1)
-    (length $ filter isBigReturnFrame decodedStack)
-  cs <- (mapM unbox . payload . head) $ filter isBigReturnFrame decodedStack
+    (length $ filter isBigReturnFrame stackFrames)
+  cs <- (mapM unbox . payload . head) $ filter isBigReturnFrame stackFrames
   let  xs = zip [1 ..] cs
   mapM_ (uncurry checkArg) xs
 
diff --git a/libraries/ghc-heap/tests/stack_lib.c b/libraries/ghc-heap/tests/stack_lib.c
deleted file mode 100644
index fee05753a3..0000000000
--- a/libraries/ghc-heap/tests/stack_lib.c
+++ /dev/null
@@ -1,246 +0,0 @@
-#include "Rts.h"
-#include "RtsAPI.h"
-#include "rts/Messages.h"
-#include "rts/Types.h"
-#include "rts/storage/ClosureMacros.h"
-#include "rts/storage/ClosureTypes.h"
-#include "rts/storage/Closures.h"
-#include "stg/Types.h"
-#include <stdlib.h>
-
-typedef struct ClosureTypeList {
-  struct ClosureTypeList *next;
-  StgWord closureType;
-} ClosureTypeList;
-
-ClosureTypeList *last(ClosureTypeList *list) {
-  while (list->next != NULL) {
-    list = list->next;
-  }
-  return list;
-}
-ClosureTypeList *add(ClosureTypeList *list, StgWord closureType) {
-  ClosureTypeList *newEntry = malloc(sizeof(ClosureTypeList));
-  newEntry->next = NULL;
-  newEntry->closureType = closureType;
-  if (list != NULL) {
-    last(list)->next = newEntry;
-  } else {
-    list = newEntry;
-  }
-  return list;
-}
-
-void freeList(ClosureTypeList *list) {
-  ClosureTypeList *tmp;
-  while (list != NULL) {
-    tmp = list;
-    list = list->next;
-    free(tmp);
-  }
-}
-
-StgWord listSize(ClosureTypeList *list) {
-  StgWord s = 0;
-  while (list != NULL) {
-    list = list->next;
-    s++;
-  }
-  return s;
-}
-
-ClosureTypeList *concat(ClosureTypeList *begin, ClosureTypeList *end) {
-  last(begin)->next = end;
-  return begin;
-}
-void printSmallBitmap(StgPtr spBottom, StgPtr payload, StgWord bitmap,
-                      uint32_t size);
-
-ClosureTypeList *foldSmallBitmapToList(StgPtr spBottom, StgPtr payload,
-                                       StgWord bitmap, uint32_t size) {
-  ClosureTypeList *list = NULL;
-  uint32_t i;
-
-  for (i = 0; i < size; i++, bitmap >>= 1) {
-    if ((bitmap & 1) == 0) {
-      const StgClosure *c = (StgClosure *)payload[i];
-      c = UNTAG_CONST_CLOSURE(c);
-      const StgInfoTable *info = get_itbl(c);
-      list = add(list, info->type);
-    }
-    // TODO: Primitives are ignored here.
-  }
-
-  return list;
-}
-
-ClosureTypeList *foldLargeBitmapToList(StgPtr spBottom, StgPtr payload,
-                                       StgLargeBitmap *large_bitmap,
-                                       uint32_t size) {
-  ClosureTypeList *list = NULL;
-  StgWord bmp;
-  uint32_t i, j;
-
-  i = 0;
-  for (bmp = 0; i < size; bmp++) {
-    StgWord bitmap = large_bitmap->bitmap[bmp];
-    j = 0;
-    for (; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1) {
-      if ((bitmap & 1) == 0) {
-        const StgClosure *c = (StgClosure *)payload[i];
-        c = UNTAG_CONST_CLOSURE(c);
-        list = add(list, get_itbl(c)->type);
-      }
-      // TODO: Primitives are ignored here.
-    }
-  }
-  return list;
-}
-
-// Do not traverse the whole heap. Instead add all closures that are on the
-// stack itself or referenced directly by such closures.
-ClosureTypeList *foldStackToList(StgStack *stack) {
-  ClosureTypeList *result = NULL;
-  StgPtr sp = stack->sp;
-  StgPtr spBottom = stack->stack + stack->stack_size;
-
-  for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
-    const StgInfoTable *info = get_itbl((StgClosure *)sp);
-
-    result = add(result, info->type);
-    switch (info->type) {
-    case UNDERFLOW_FRAME: {
-      StgUnderflowFrame *f = (StgUnderflowFrame *)sp;
-      result = concat(result, foldStackToList(f->next_chunk));
-      continue;
-    }
-    case UPDATE_FRAME: {
-      StgUpdateFrame *f = (StgUpdateFrame *)sp;
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->updatee))->type);
-      continue;
-    }
-    case CATCH_FRAME: {
-      StgCatchFrame *f = (StgCatchFrame *)sp;
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->handler))->type);
-      continue;
-    }
-    case CATCH_RETRY_FRAME: {
-      StgCatchRetryFrame *f = (StgCatchRetryFrame *)sp;
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->first_code))->type);
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->alt_code))->type);
-      continue;
-    }
-    case STOP_FRAME: {
-      continue;
-    }
-    case CATCH_STM_FRAME: {
-      StgCatchSTMFrame *f = (StgCatchSTMFrame *)sp;
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->code))->type);
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->handler))->type);
-      continue;
-    }
-    case ATOMICALLY_FRAME: {
-      StgAtomicallyFrame *f = (StgAtomicallyFrame *)sp;
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->code))->type);
-      result = add(result, get_itbl(UNTAG_CONST_CLOSURE(f->result))->type);
-      continue;
-    }
-    case RET_SMALL: {
-      StgWord bitmap = info->layout.bitmap;
-      ClosureTypeList *bitmapList = foldSmallBitmapToList(
-          spBottom, sp + 1, BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
-      result = concat(result, bitmapList);
-      continue;
-    }
-    case RET_BCO: {
-      StgWord c = *sp;
-      StgBCO *bco = ((StgBCO *)sp[1]);
-      result = add(result, get_itbl((StgClosure*) bco)->type);
-      ClosureTypeList *bitmapList = foldLargeBitmapToList(
-          spBottom, sp + 2, BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
-      result = concat(result, bitmapList);
-      continue;
-    }
-    case RET_BIG: {
-      StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
-      ClosureTypeList *bitmapList = foldLargeBitmapToList(
-          spBottom, (StgPtr)((StgClosure *)sp)->payload, bitmap, bitmap->size);
-      result = concat(result, bitmapList);
-      continue;
-    }
-    case RET_FUN: {
-      StgRetFun *ret_fun = (StgRetFun *)sp;
-      const StgFunInfoTable *fun_info =
-          get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
-
-      result = add(result, fun_info->i.type);
-
-      ClosureTypeList *bitmapList;
-      switch (fun_info->f.fun_type) {
-      case ARG_GEN:
-        bitmapList = foldSmallBitmapToList(spBottom, sp + 3,
-                                           BITMAP_BITS(fun_info->f.b.bitmap),
-                                           BITMAP_SIZE(fun_info->f.b.bitmap));
-        break;
-      case ARG_GEN_BIG: {
-        bitmapList = foldLargeBitmapToList(
-            spBottom, sp + 3, GET_FUN_LARGE_BITMAP(fun_info),
-            GET_FUN_LARGE_BITMAP(fun_info)->size);
-        break;
-      }
-      default: {
-        bitmapList = foldSmallBitmapToList(
-            spBottom, sp + 3,
-            BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
-            BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
-        break;
-      }
-      }
-      result = concat(result, bitmapList);
-      continue;
-    }
-    default: {
-      errorBelch("Unexpected closure type: %us", info->type);
-      break;
-    }
-    }
-  }
-
-  return result;
-}
-
-// Copied from Cmm.h
-/* Converting quantities of words to bytes */
-#define SIZEOF_W SIZEOF_VOID_P
-#define WDS(n) ((n)*SIZEOF_W)
-
-StgArrBytes *createArrayClosure(ClosureTypeList *list) {
-  Capability *cap = rts_lock();
-  // Mapping closure types to StgWord is pretty generous as they would fit
-  // in Bytes. However, the handling of StgWords is much simpler.
-  StgWord neededWords = listSize(list);
-  StgArrBytes *array =
-      (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
-  SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
-  array->bytes = WDS(listSize(list));
-
-  for (int i = 0; list != NULL; i++) {
-    array->payload[i] = list->closureType;
-    list = list->next;
-  }
-  rts_unlock(cap);
-  return array;
-}
-
-// Traverse the stack and return an arry representation of it's closure
-// types.
-StgArrBytes *foldStackToArrayClosure(StgStack *stack) {
-  ClosureTypeList *cl = foldStackToList(stack);
-  StgArrBytes *arrayClosure = createArrayClosure(cl);
-  freeList(cl);
-  return arrayClosure;
-}
-
-StgWord bytesInWord() {
-  return SIZEOF_W;
-}
diff --git a/libraries/ghc-heap/tests/stack_misc_closures.hs b/libraries/ghc-heap/tests/stack_misc_closures.hs
index 3c1679fdaf..5113a5e242 100644
--- a/libraries/ghc-heap/tests/stack_misc_closures.hs
+++ b/libraries/ghc-heap/tests/stack_misc_closures.hs
@@ -281,7 +281,9 @@ test setup assertion = do
   -- when the GC suddenly does it's work and there were bad closures or pointers.
   -- Better fail early, here.
   performGC
-  stack <- decodeStack' sn
+  (SimpleStack boxedFrames) <- decodeStack sn
+  performGC
+  stack <- mapM getBoxedClosureData boxedFrames
   performGC
   assert sn stack
   -- The result of HasHeapRep should be similar (wrapped in the closure for
@@ -354,6 +356,9 @@ getWordFromConstr01 c = case c of
 getWordFromBlackhole :: HasCallStack => Closure -> IO Word
 getWordFromBlackhole c = case c of
   BlackholeClosure {..} -> getWordFromConstr01 <$> getBoxedClosureData indirectee
+  -- For test stability reasons: Expect that the blackhole might have been
+  -- resolved.
+  ConstrClosure {..} -> pure $ head dataArgs
   e -> error $ "Wrong closure type: " ++ show e
 
 getWordFromUnknownTypeWordSizedPrimitive :: HasCallStack => Closure -> Word
diff --git a/libraries/ghc-heap/tests/stack_stm_frames.hs b/libraries/ghc-heap/tests/stack_stm_frames.hs
index e2122edf6c..752a1a392d 100644
--- a/libraries/ghc-heap/tests/stack_stm_frames.hs
+++ b/libraries/ghc-heap/tests/stack_stm_frames.hs
@@ -11,6 +11,7 @@ import GHC.Exts.Heap.Closures
 import GHC.Exts.Heap.InfoTable.Types
 import GHC.Stack.CloneStack
 import TestUtils
+import GHC.Exts.Heap
 
 main :: IO ()
 main = do
@@ -28,12 +29,6 @@ main = do
     (== 1)
     (length $ filter isAtomicallyFrame decodedStack)
 
-getDecodedStack :: IO (StackSnapshot, [Closure])
-getDecodedStack = do
-  s <- cloneMyStack
-  fs <- decodeStack' s
-  pure (s, fs)
-
 isCatchStmFrame :: Closure -> Bool
 isCatchStmFrame (CatchStmFrame {..}) = tipe info == CATCH_STM_FRAME
 isCatchStmFrame _ = False
diff --git a/libraries/ghc-heap/tests/stack_underflow.hs b/libraries/ghc-heap/tests/stack_underflow.hs
index 1ae84dc322..d7e63309dc 100644
--- a/libraries/ghc-heap/tests/stack_underflow.hs
+++ b/libraries/ghc-heap/tests/stack_underflow.hs
@@ -20,8 +20,7 @@ loop n = print "x" >> loop (n - 1) >> print "x"
 
 getStack :: HasCallStack => IO ()
 getStack = do
-  !s <- cloneMyStack
-  !decodedStack <- decodeStack' s
+  (s, decodedStack) <- getDecodedStack
   -- Uncomment to see the frames (for debugging purposes)
   -- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
   assertStackInvariants s decodedStack
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index f1eaaaa50d..4a42459d8d 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -97,7 +97,7 @@ run m = case m of
     mapM (\case
              Heap.Box x -> mkRemoteRef (HValue x)
              -- TODO: Is this unsafeCoerce really necessary?
-             Heap.DecodedClosureBox d -> mkRemoteRef (HValue (unsafeCoerce d))
+             Heap.DecodedBox d -> mkRemoteRef (HValue (unsafeCoerce d))
          ) clos
   Seq ref -> doSeq ref
   ResumeSeq ref -> resumeSeq ref