From 6dcf6fa88a7af341c0e451f86a4ca9bfea3061ff Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 24 Jan 2023 18:31:21 +0000 Subject: More on boxes: Increase lazy-ness --- libraries/ghc-heap/GHC/Exts/DecodeStack.hs | 19 +- libraries/ghc-heap/GHC/Exts/Heap.hs | 3 +- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 20 +- libraries/ghc-heap/tests/TestUtils.hs | 151 ++------------- libraries/ghc-heap/tests/all.T | 23 ++- libraries/ghc-heap/tests/stack_big_ret.hs | 10 +- libraries/ghc-heap/tests/stack_lib.c | 246 ------------------------ libraries/ghc-heap/tests/stack_misc_closures.hs | 7 +- libraries/ghc-heap/tests/stack_stm_frames.hs | 7 +- libraries/ghc-heap/tests/stack_underflow.hs | 3 +- libraries/ghci/GHCi/Run.hs | 2 +- 11 files changed, 60 insertions(+), 431 deletions(-) delete mode 100644 libraries/ghc-heap/tests/stack_lib.c 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 - -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 -- cgit v1.2.1