[Git][ghc/ghc][wip/decode_cloned_stack] Fix tests
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Dec 11 15:20:26 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
651d7b71 by Sven Tennie at 2022-12-11T15:19:58+00:00
Fix tests
- - - - -
9 changed files:
- + libraries/ghc-heap/GHC/Exts/DecodeHeap.hs
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/stack_big_ret.hs
- + libraries/ghc-heap/tests/stack_misc_closures.c
- + libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_stm_frames.hs
- libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeHeap.hs
=====================================
@@ -0,0 +1,257 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module GHC.Exts.DecodeHeap where
+import Prelude
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Constants
+import GHC.Exts.Heap.ProfInfo.Types
+#if defined(PROFILING)
+import GHC.Exts.Heap.InfoTableProf
+#else
+import GHC.Exts.Heap.InfoTable
+#endif
+import GHC.Exts.Heap.Utils
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
+import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
+
+import Control.Monad
+import Data.Bits
+import Foreign
+import GHC.Exts
+
+
+-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
+-- function can be generated from a heap object using `unpackClosure#`.
+getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
+getClosureDataFromHeapRep heapRep infoTablePtr pts = do
+ itbl <- peekItbl infoTablePtr
+ getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts
+
+getClosureDataFromHeapRepPrim
+ :: IO (String, String, String)
+ -- ^ A continuation used to decode the constructor description field,
+ -- in ghc-debug this code can lead to segfaults because dataConNames
+ -- will dereference a random part of memory.
+ -> (Ptr a -> IO (Maybe CostCentreStack))
+ -- ^ A continuation which is used to decode a cost centre stack
+ -- In ghc-debug, this code will need to call back into the debuggee to
+ -- fetch the representation of the CCS before decoding it. Using
+ -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as
+ -- the CCS argument will point outside the copied closure.
+ -> StgInfoTable
+ -- ^ The `StgInfoTable` of the closure, extracted from the heap
+ -- representation.
+ -> ByteArray#
+ -- ^ Heap representation of the closure as returned by `unpackClosure#`.
+ -- This includes all of the object including the header, info table
+ -- pointer, pointer data, and non-pointer data. The ByteArray# may be
+ -- pinned or unpinned.
+ -> [b]
+ -- ^ Pointers in the payload of the closure, extracted from the heap
+ -- representation as returned by `collect_pointers()` in `Heap.c`. The type
+ -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
+ -> IO (GenClosure b)
+ -- ^ Heap representation of the closure.
+getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
+ let -- heapRep as a list of words.
+ rawHeapWords :: [Word]
+ rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
+ where
+ nelems = I# (sizeofByteArray# heapRep) `div` wORD_SIZE
+ end = fromIntegral nelems - 1
+
+ -- Just the payload of rawHeapWords (no header).
+ payloadWords :: [Word]
+ payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords
+
+ -- The non-pointer words in the payload. Only valid for closures with a
+ -- "pointers first" layout. Not valid for bit field layout.
+ npts :: [Word]
+ npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords
+ case tipe itbl of
+ t | t >= CONSTR && t <= CONSTR_NOCAF -> do
+ (p, m, n) <- getConDesc
+ pure $ ConstrClosure itbl pts npts p m n
+
+ t | t >= THUNK && t <= THUNK_STATIC -> do
+ pure $ ThunkClosure itbl pts npts
+
+ THUNK_SELECTOR -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+ pure $ SelectorClosure itbl (head pts)
+
+ t | t >= FUN && t <= FUN_STATIC -> do
+ pure $ FunClosure itbl pts npts
+
+ AP -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to AP"
+ -- We expect at least the arity, n_args, and fun fields
+ unless (length payloadWords >= 2) $
+ fail "Expected at least 2 raw words to AP"
+ let splitWord = payloadWords !! 0
+ pure $ APClosure itbl
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ (head pts) (tail pts)
+
+ PAP -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to PAP"
+ -- We expect at least the arity, n_args, and fun fields
+ unless (length payloadWords >= 2) $
+ fail "Expected at least 2 raw words to PAP"
+ let splitWord = payloadWords !! 0
+ pure $ PAPClosure itbl
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ (head pts) (tail pts)
+
+ AP_STACK -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to AP_STACK"
+ pure $ APStackClosure itbl (head pts) (tail pts)
+
+ IND -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to IND"
+ pure $ IndClosure itbl (head pts)
+
+ IND_STATIC -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to IND_STATIC"
+ pure $ IndClosure itbl (head pts)
+
+ BLACKHOLE -> do
+ unless (length pts >= 1) $
+ fail "Expected at least 1 ptr argument to BLACKHOLE"
+ pure $ BlackholeClosure itbl (head pts)
+
+ BCO -> do
+ unless (length pts >= 3) $
+ fail $ "Expected at least 3 ptr argument to BCO, found "
+ ++ show (length pts)
+ unless (length payloadWords >= 4) $
+ fail $ "Expected at least 4 words to BCO, found "
+ ++ show (length payloadWords)
+ let splitWord = payloadWords !! 3
+ pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ (drop 4 payloadWords)
+
+ ARR_WORDS -> do
+ unless (length payloadWords >= 1) $
+ fail $ "Expected at least 1 words to ARR_WORDS, found "
+ ++ show (length payloadWords)
+ pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
+
+ t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
+ unless (length payloadWords >= 2) $
+ fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+ pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
+
+ t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
+ unless (length payloadWords >= 1) $
+ fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+ pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
+
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
+ unless (length pts >= 1) $
+ fail $ "Expected at least 1 words to MUT_VAR, found "
+ ++ show (length pts)
+ pure $ MutVarClosure itbl (head pts)
+
+ t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
+ unless (length pts >= 3) $
+ fail $ "Expected at least 3 ptrs to MVAR, found "
+ ++ show (length pts)
+ pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+
+ BLOCKING_QUEUE ->
+ pure $ OtherClosure itbl pts rawHeapWords
+ -- pure $ BlockingQueueClosure itbl
+ -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
+
+ -- pure $ OtherClosure itbl pts rawHeapWords
+ --
+ WEAK -> do
+ pure $ WeakClosure
+ { info = itbl
+ , cfinalizers = pts !! 0
+ , key = pts !! 1
+ , value = pts !! 2
+ , finalizer = pts !! 3
+ , weakLink = case drop 4 pts of
+ [] -> Nothing
+ [p] -> Just p
+ _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
+ }
+ TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
+ -> withArray rawHeapWords (\ptr -> do
+ fields <- FFIClosures.peekTSOFields decodeCCS ptr
+ pure $ TSOClosure
+ { info = itbl
+ , link = u_lnk
+ , global_link = u_gbl_lnk
+ , tsoStack = tso_stack
+ , trec = u_trec
+ , blocked_exceptions = u_blk_ex
+ , bq = u_bq
+ , what_next = FFIClosures.tso_what_next fields
+ , why_blocked = FFIClosures.tso_why_blocked fields
+ , flags = FFIClosures.tso_flags fields
+ , threadId = FFIClosures.tso_threadId fields
+ , saved_errno = FFIClosures.tso_saved_errno fields
+ , tso_dirty = FFIClosures.tso_dirty fields
+ , alloc_limit = FFIClosures.tso_alloc_limit fields
+ , tot_stack_size = FFIClosures.tso_tot_stack_size fields
+ , prof = FFIClosures.tso_prof fields
+ })
+ | otherwise
+ -> fail $ "Expected 6 ptr arguments to TSO, found "
+ ++ show (length pts)
+ STACK
+ | [] <- pts
+ -> withArray rawHeapWords (\ptr -> do
+ fields <- FFIClosures.peekStackFields ptr
+ pure $ StackClosure
+ { info = itbl
+ , stack_size = FFIClosures.stack_size fields
+ , stack_dirty = FFIClosures.stack_dirty fields
+#if __GLASGOW_HASKELL__ >= 811
+ , stack_marking = FFIClosures.stack_marking fields
+#endif
+ })
+ | otherwise
+ -> fail $ "Expected 0 ptr argument to STACK, found "
+ ++ show (length pts)
+
+ _ ->
+ pure $ UnsupportedClosure itbl
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -16,7 +16,8 @@
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack (
- decodeStack
+ decodeStack,
+ decodeStack'
) where
import GHC.Exts.StackConstants
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -539,6 +539,7 @@ data TsoFlags
| TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
deriving (Eq, Show, Generic, Ord)
+-- TODO: Fix this to include stack frames
-- | For generic code, this function returns all referenced closures.
allClosures :: GenClosure b -> [b]
allClosures (ConstrClosure {..}) = ptrArgs
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -8,7 +8,8 @@
module TestUtils
( assertEqual,
assertThat,
- assertStackInvariants
+ assertStackInvariants,
+ unbox
)
where
@@ -16,9 +17,11 @@ import Data.Array.Byte
import GHC.Exts
import GHC.Exts.DecodeStack
import GHC.Exts.Heap
+import GHC.Exts.Heap.Closures
import GHC.Records
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
+import Unsafe.Coerce (unsafeCoerce)
assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
assertEqual a b
@@ -28,7 +31,7 @@ assertEqual a b
assertThat :: (HasCallStack, Monad m) => String -> (a -> Bool) -> a -> m ()
assertThat s f a = if f a then pure () else error s
-assertStackInvariants :: (HasCallStack, Monad m) => StackSnapshot -> [StackFrame] -> m ()
+assertStackInvariants :: (HasCallStack, Monad m) => StackSnapshot -> [Closure] -> m ()
assertStackInvariants stack decodedStack = do
assertThat
"Last frame is stop frame"
@@ -47,7 +50,7 @@ class ToClosureTypes a where
instance ToClosureTypes StackSnapshot where
toClosureTypes = stackSnapshotToClosureTypes . foldStackToArrayClosure
-instance ToClosureTypes StackFrame where
+instance ToClosureTypes Closure where
toClosureTypes = stackFrameToClosureTypes
instance ToClosureTypes a => ToClosureTypes [a] where
@@ -81,23 +84,25 @@ stackSnapshotToClosureTypes = wordsToClosureTypes . toWords
toInt# :: Int -> Int#
toInt# (I# i#) = i#
-stackFrameToClosureTypes :: StackFrame -> [ClosureType]
-stackFrameToClosureTypes sf =
- case sf of
- (UpdateFrame {updatee, ..}) -> UPDATE_FRAME : getClosureTypes updatee
- (CatchFrame {handler, ..}) -> CATCH_FRAME : getClosureTypes handler
- (CatchStmFrame {code, handler}) -> CATCH_STM_FRAME : getClosureTypes code ++ getClosureTypes handler
- (CatchRetryFrame {first_code, alt_code, ..}) -> CATCH_RETRY_FRAME : getClosureTypes first_code ++ getClosureTypes alt_code
- (AtomicallyFrame {code, result}) -> ATOMICALLY_FRAME : getClosureTypes code ++ getClosureTypes result
- (UnderflowFrame {..}) -> [UNDERFLOW_FRAME]
- StopFrame -> [STOP_FRAME]
- (RetSmall {payload, ..}) -> RET_SMALL : getBitmapClosureTypes payload
- (RetBig {payload}) -> RET_BIG : getBitmapClosureTypes payload
- (RetFun {fun, payload, ..}) -> RET_FUN : getClosureTypes fun ++ getBitmapClosureTypes payload
- (RetBCO {instrs, literals, ptrs, payload, ..}) ->
- RET_BCO : getClosureTypes instrs ++ getClosureTypes literals ++ getClosureTypes ptrs ++ getBitmapClosureTypes payload
+-- TODO: Can probably be simplified once all stack closures have into tables attached.
+stackFrameToClosureTypes :: Closure -> [ClosureType]
+stackFrameToClosureTypes = getClosureTypes
where
getClosureTypes :: Closure -> [ClosureType]
+ -- Stack frame closures
+ getClosureTypes (UpdateFrame {updatee, ..}) = UPDATE_FRAME : getClosureTypes (unbox updatee)
+ getClosureTypes (CatchFrame {handler, ..}) = CATCH_FRAME : getClosureTypes (unbox handler)
+ getClosureTypes (CatchStmFrame {catchFrameCode, handler}) = CATCH_STM_FRAME : getClosureTypes (unbox catchFrameCode) ++ getClosureTypes (unbox handler)
+ getClosureTypes (CatchRetryFrame {first_code, alt_code, ..}) = CATCH_RETRY_FRAME : getClosureTypes (unbox first_code) ++ getClosureTypes (unbox alt_code)
+ getClosureTypes (AtomicallyFrame {atomicallyFrameCode, result}) = ATOMICALLY_FRAME : getClosureTypes (unbox atomicallyFrameCode) ++ getClosureTypes (unbox result)
+ getClosureTypes (UnderflowFrame {..}) = [UNDERFLOW_FRAME]
+ getClosureTypes StopFrame = [STOP_FRAME]
+ getClosureTypes (RetSmall {payload, ..}) = RET_SMALL : getBitmapClosureTypes payload
+ getClosureTypes (RetBig {payload}) = RET_BIG : getBitmapClosureTypes payload
+ getClosureTypes (RetFun {retFunFun, retFunPayload, ..}) = RET_FUN : getClosureTypes (unbox retFunFun) ++ getBitmapClosureTypes retFunPayload
+ getClosureTypes (RetBCO {bcoInstrs, bcoLiterals, bcoPtrs, bcoPayload, ..}) =
+ RET_BCO : getClosureTypes (unbox bcoInstrs) ++ getClosureTypes (unbox bcoLiterals) ++ getClosureTypes (unbox bcoPtrs) ++ getBitmapClosureTypes bcoPayload
+ -- Other closures
getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
getClosureTypes (FunClosure {info, ..}) = [tipe info]
getClosureTypes (ThunkClosure {info, ..}) = [tipe info]
@@ -122,13 +127,16 @@ stackFrameToClosureTypes sf =
getClosureTypes (UnsupportedClosure {info, ..}) = [tipe info]
getClosureTypes _ = []
- getBitmapClosureTypes :: [BitmapPayload] -> [ClosureType]
+ getBitmapClosureTypes :: [Box] -> [ClosureType]
getBitmapClosureTypes bps =
reverse $
foldl
- ( \acc p -> case p of
- (Closure c) -> getClosureTypes c ++ acc
- (Primitive _) -> acc
+ ( \acc p -> case unbox p of
+ UnknownTypeWordSizedPrimitive _ -> acc
+ c -> getClosureTypes c ++ acc
)
[]
bps
+
+unbox :: Box -> Closure
+unbox (Box c) = unsafeCoerce c
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -10,7 +10,7 @@ import Data.Maybe
import GHC.Exts (StackSnapshot#)
import GHC.Exts.DecodeStack
import GHC.Exts.Heap.ClosureTypes
-import GHC.Exts.Heap.Closures qualified as CL
+import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.InfoTable.Types
import GHC.IO.Unsafe
import GHC.Stack (HasCallStack)
@@ -36,27 +36,27 @@ main = do
mbStackSnapshot <- readIORef stackRef
let stackSnapshot = fromJust mbStackSnapshot
- !decodedStack <- decodeStack stackSnapshot
+ !decodedStack <- decodeStack' stackSnapshot
assertStackInvariants stackSnapshot decodedStack
assertThat
"Stack contains one big return frame"
(== 1)
(length $ filter isBigReturnFrame decodedStack)
- let xs = zip [1 ..] $ (payload . head) $ filter isBigReturnFrame decodedStack
+ let xs = zip [1 ..] $ (map unbox . payload . head) $ filter isBigReturnFrame decodedStack
mapM_ (uncurry checkArg) xs
-checkArg :: Word -> BitmapPayload -> IO ()
+checkArg :: Word -> Closure -> IO ()
checkArg w bp =
case bp of
- Primitive _ -> error "Unexpected payload type from bitmap."
- Closure c -> do
- assertEqual CONSTR_0_1 $ (tipe . CL.info) c
- assertEqual "I#" (CL.name c)
- assertEqual "ghc-prim" (CL.pkg c)
- assertEqual "GHC.Types" (CL.modl c)
- assertEqual True $ (null . CL.ptrArgs) c
- assertEqual [w] (CL.dataArgs c)
+ UnknownTypeWordSizedPrimitive _ -> error "Unexpected payload type from bitmap."
+ c -> do
+ assertEqual CONSTR_0_1 $ (tipe . info) c
+ assertEqual "I#" (name c)
+ assertEqual "ghc-prim" (pkg c)
+ assertEqual "GHC.Types" (modl c)
+ assertEqual True $ (null . ptrArgs) c
+ assertEqual [w] (dataArgs c)
pure ()
isBigReturnFrame (RetBig _) = True
=====================================
libraries/ghc-heap/tests/stack_misc_closures.c
=====================================
@@ -0,0 +1,20 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+#include "rts/Types.h"
+#include "rts/storage/ClosureMacros.h"
+#include "rts/storage/Closures.h"
+#include "stg/Types.h"
+#include <stdlib.h>
+
+StgStack *update_frame() {
+ Capability *cap = rts_lock();
+ StgWord closureSizeBytes = sizeof(StgStack) + sizeof(StgStopFrame) + sizeof(StgUpdateFrame);
+ StgStack *stack = (StgStack*) allocate(cap, ROUNDUP_BYTES_TO_WDS(closureSizeBytes));
+ SET_HDR(stack, &, CCS_SYSTEM);
+ stack->stack_size = closureSizeBytes;
+ stack->dirty = 0;
+ stack->marking = 0;
+ rts_unlock(cap);
+ return stack;
+}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -3,6 +3,7 @@ module Main where
import Control.Concurrent.STM
import Control.Exception
import GHC.Conc
+import GHC.Exts.Heap.Closures
import GHC.Exts.DecodeStack
import GHC.Stack.CloneStack
import TestUtils
@@ -23,16 +24,16 @@ main = do
(== 1)
(length $ filter isAtomicallyFrame decodedStack)
-getDecodedStack :: IO (StackSnapshot, [StackFrame])
+getDecodedStack :: IO (StackSnapshot, [Closure])
getDecodedStack = do
s <-cloneMyStack
- fs <- decodeStack s
+ fs <- decodeStack' s
pure (s, fs)
-isCatchStmFrame :: StackFrame -> Bool
+isCatchStmFrame :: Closure -> Bool
isCatchStmFrame (CatchStmFrame _ _) = True
isCatchStmFrame _ = False
-isAtomicallyFrame :: StackFrame -> Bool
+isAtomicallyFrame :: Closure -> Bool
isAtomicallyFrame (AtomicallyFrame _ _) = True
isAtomicallyFrame _ = False
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -3,6 +3,7 @@
module Main where
import Data.Bool (Bool (True))
+import GHC.Exts.Heap.Closures
import GHC.Exts.DecodeStack
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
@@ -17,7 +18,7 @@ loop n = print "x" >> loop (n - 1) >> print "x"
getStack :: HasCallStack => IO ()
getStack = do
!s <- cloneMyStack
- !decodedStack <- decodeStack s
+ !decodedStack <- decodeStack' s
-- Uncomment to see the frames (for debugging purposes)
-- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
assertStackInvariants s decodedStack
@@ -31,7 +32,7 @@ getStack = do
isUnderflowFrame (UnderflowFrame _) = True
isUnderflowFrame _ = False
-assertStackChunksAreDecodable :: HasCallStack => [StackFrame] -> IO ()
+assertStackChunksAreDecodable :: HasCallStack => [Closure] -> IO ()
assertStackChunksAreDecodable s = do
let underflowFrames = filter isUnderflowFrame s
framesOfChunks <- mapM (decodeStack . nextChunk) underflowFrames
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/651d7b71c7d614f1a90e924bf42c9aabe9ae3e54
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/651d7b71c7d614f1a90e924bf42c9aabe9ae3e54
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/20221211/140b2d20/attachment-0001.html>
More information about the ghc-commits
mailing list