[Git][ghc/ghc][wip/decode_cloned_stack] ghc-heap: Decode StgStack and its frames
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Feb 4 15:44:17 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
d5eca620 by Sven Tennie at 2023-02-04T15:39:50+00:00
ghc-heap: Decode StgStack and its frames
Previously, ghc-heap could only decode heap closures.
The approach is explained in detail in note
[Decoding the stack].
- - - - -
30 changed files:
- compile_flags.txt
- libraries/base/GHC/Stack/CloneStack.hs
- + libraries/ghc-heap/GHC/Exts/DecodeHeap.hs
- + libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- + libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- + libraries/ghc-heap/cbits/Stack.c
- + libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/stack_big_ret.hs
- + libraries/ghc-heap/tests/stack_misc_closures.hs
- + libraries/ghc-heap/tests/stack_misc_closures_c.c
- + libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
- + libraries/ghc-heap/tests/stack_stm_frames.hs
- + libraries/ghc-heap/tests/stack_underflow.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Heap.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RtsSymbols.c
- rts/include/rts/storage/InfoTables.h
- rts/sm/Sanity.c
- rts/sm/Sanity.h
- utils/deriveConstants/Main.hs
Changes:
=====================================
compile_flags.txt
=====================================
@@ -2,4 +2,5 @@
-Irts
-Irts/include
-I.hie-bios/stage0/lib
-
+-I_build/stage1/rts/build/include/
+-DDEBUG
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -26,7 +26,7 @@ import Control.Concurrent.MVar
import Data.Maybe (catMaybes)
import Foreign
import GHC.Conc.Sync
-import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#)
+import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#, Word#, unsafeCoerce#, eqWord#, isTrue#)
import GHC.IO (IO (..))
import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipLoc, ipeProv, peekInfoProv)
import GHC.Stable
@@ -36,6 +36,15 @@ import GHC.Stable
-- @since 4.17.0.0
data StackSnapshot = StackSnapshot !StackSnapshot#
+
+-- TODO: Cast to Addr representation instead?
+instance Eq StackSnapshot where
+ (StackSnapshot s1#) == (StackSnapshot s2#) = isTrue# (((unsafeCoerce# s1#) :: Word#) `eqWord#` ((unsafeCoerce# s2#) :: Word#))
+
+-- TODO: Show and Eq instances are mainly here to fulfill Closure deriving requirements
+-- instance Show StackSnapshot where
+-- show _ = "StackSnapshot"
+
foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #)
foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
=====================================
libraries/ghc-heap/GHC/Exts/DecodeHeap.hs
=====================================
@@ -0,0 +1,244 @@
+{-# 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 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 -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+ hd : _ -> pure $ SelectorClosure itbl hd
+
+ t | t >= FUN && t <= FUN_STATIC -> do
+ pure $ FunClosure itbl pts npts
+
+ AP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ 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
+ hd tl
+ _ -> fail "Expected at least 2 raw words to AP"
+
+ PAP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to PAP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ 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
+ hd tl
+ _ -> fail "Expected at least 2 raw words to PAP"
+
+ AP_STACK -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP_STACK"
+ hd : tl -> pure $ APStackClosure itbl hd tl
+
+ IND -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ IND_STATIC -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ BLACKHOLE -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
+ hd : _ -> pure $ BlackholeClosure itbl hd
+
+ BCO -> case pts of
+ pts0 : pts1 : pts2 : _ -> case payloadWords of
+ _ : _ : _ : splitWord : payloadRest ->
+ pure $ BCOClosure itbl pts0 pts1 pts2
+#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
+ payloadRest
+ _ -> fail $ "Expected at least 4 words to BCO, found "
+ ++ show (length payloadWords)
+ _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
+ ++ show (length pts)
+
+ ARR_WORDS -> case payloadWords of
+ [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
+ ++ show (length payloadWords)
+ hd : tl -> pure $ ArrWordsClosure itbl hd tl
+
+ t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
+ _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+
+ t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+ hd : _ -> pure $ SmallMutArrClosure itbl hd pts
+
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
+ [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
+ ++ show (length pts)
+ hd : _ -> pure $ MutVarClosure itbl hd
+
+ t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
+ pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
+ _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
+ ++ show (length pts)
+
+ BLOCKING_QUEUE ->
+ pure $ OtherClosure itbl pts rawHeapWords
+
+ WEAK -> case pts of
+ pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
+ { info = itbl
+ , cfinalizers = pts0
+ , key = pts1
+ , value = pts2
+ , finalizer = pts3
+ , weakLink = case rest of
+ [] -> Nothing
+ [p] -> Just p
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
+ }
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
+ TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- 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
+ , thread_label = case other of
+ [tl] -> Just tl
+ [] -> Nothing
+ _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
+ , 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 at least 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
+ , stack = []
+ })
+ | otherwise
+ -> fail $ "Expected 0 ptr argument to STACK, found "
+ ++ show (length pts)
+
+ _ ->
+ pure $ UnsupportedClosure itbl
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -0,0 +1,406 @@
+{-# LANGUAGE CPP #-}
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+-- TODO: Find better place than top level. Re-export from top-level?
+module GHC.Exts.DecodeStack
+ ( decodeStack,
+ unpackStackFrameIter
+ )
+where
+
+import Data.Bits
+import Data.Maybe
+-- TODO: Remove before releasing
+import Debug.Trace
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
+import GHC.Exts.Heap.InfoTable
+import GHC.Exts.StackConstants
+import GHC.Stack.CloneStack
+import Prelude
+import GHC.IO (IO (..))
+import Data.Array.Byte
+import GHC.Word
+
+{- Note [Decoding the stack]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The stack is represented by a chain of StgStack closures. Each of these closures
+is subject to garbage collection. I.e. they can be moved in memory (in a
+simplified perspective) at any time.
+
+The array of closures inside an StgStack (that makeup the execution stack; the
+stack frames) is moved as bare memory by the garbage collector. References
+(pointers) to stack frames are not updated.
+
+As the StgStack closure is moved as whole, the relative offsets inside it stay
+the same. (Though, the absolute addresses change!)
+
+Stack frame iterator
+====================
+
+A stack frame interator (StackFrameIter) consists of a StackSnapshot# and a
+relative offset into the the array of stack frames (StgStack->stack). The
+StackSnapshot# represents a StgStack closure. It is updated by the garbage
+collector when the stack closure is moved.
+
+The relative offset describes the location of a stack frame. As stack frames
+come in various sizes, one cannot simply step over the stack array with a
+constant offset.
+
+The head of the stack frame array has offset 0. To traverse the stack frames the
+latest stack frame's offset is incremented by the closure size. The unit of the
+offset is machine words (32bit or 64bit).
+
+Additionally, StackFrameIter contains a flag (isPrimitive) to indicate if a
+location on the stack should be interpreted as plain data word (in contrast to
+being a closure or a pointer to a closure.) It's used when bitmap encoded
+arguments are interpreted.
+
+Boxes
+=====
+
+As references into the stack frame array aren't updated by the garbage collector,
+creating a Box with a pointer (address) to a stack frame would break as soon as
+the StgStack closure is moved.
+
+To deal with this another kind of Box is introduced: A StackFrameBox contains a
+stack frame iterator for a decoded stack frame or it's payload.
+
+Heap-represented closures referenced by stack frames are boxed the usual way,
+with a Box that contains a pointer to the closure as it's payload. In
+Haskell-land this means: A Box which contains the closure.
+
+Technical details
+=================
+
+- All access to StgStack/StackSnapshot# closures is made through Cmm code. This
+ keeps the closure from being moved by the garbage collector during the
+ operation.
+
+- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is
+ implemented in Cmm and C. It's just easier to reuse existing helper macros and
+ functions, than reinventing them in Haskell.
+
+- Offsets and sizes of closures are imported from DerivedConstants.h via HSC.
+ This keeps the code very portable.
+-}
+
+foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
+
+derefStackWord :: StackFrameIter -> Word
+derefStackWord (StackFrameIter {..}) = W# (derefStackWord# stackSnapshot# (wordOffsetToWord# index))
+
+foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+getUpdateFrameType :: StackFrameIter -> IO UpdateFrameType
+getUpdateFrameType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getUpdateFrameType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, uft# #) -> (# s1, W# uft# #))
+
+foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
+
+getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
+getUnderflowFrameNextChunk (StackFrameIter {..}) = IO $ \s ->
+ case getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, stack# #) -> (# s1, StackSnapshot stack# #)
+
+foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+foreign import prim "getAddrzh" getAddr# :: StackSnapshot# -> Word# -> Addr#
+
+getWord :: StackFrameIter -> WordOffset -> IO Word
+getWord (StackFrameIter {..}) relativeOffset = IO $ \s ->
+ case getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset) s of
+ (# s1, w# #) -> (# s1, W# w# #)
+
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+-- TODO: Could use getWord
+getRetFunType :: StackFrameIter -> IO RetFunType
+getRetFunType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getRetFunType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
+
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
+
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
+
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
+
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
+
+foreign import prim "getRetSmallSpecialTypezh" getRetSmallSpecialType# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+getRetSmallSpecialType :: StackFrameIter -> IO SpecialRetSmall
+getRetSmallSpecialType (StackFrameIter {..}) = (toEnum . fromInteger . toInteger) <$> IO (\s ->
+ case (getRetSmallSpecialType# stackSnapshot# (wordOffsetToWord# index) s) of (# s1, rft# #) -> (# s1, W# rft# #))
+
+foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
+
+foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
+foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
+
+foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
+
+getInfoTable :: StackFrameIter -> IO StgInfoTable
+getInfoTable StackFrameIter {..} | sfiKind == SfiClosure =
+ let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
+ in peekItbl infoTablePtr
+getInfoTable StackFrameIter {..} | sfiKind == SfiStack = peekItbl $ Ptr (getStackInfoTableAddr# stackSnapshot#)
+getInfoTable StackFrameIter {..} | sfiKind == SfiPrimitive = error "Primitives have no info table!"
+
+foreign import prim "getBoxedClosurezh" getBoxedClosure# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #)
+
+foreign import prim "getStackFieldszh" getStackFields# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Word32#, Word8#, Word8# #)
+
+getStackFields :: StackFrameIter -> IO (Word32, Word8, Word8)
+getStackFields StackFrameIter {..} = IO $ \s ->
+ case getStackFields# stackSnapshot# s of (# s1, sSize#, sDirty#, sMarking# #)
+ -> (# s1, (W32# sSize#, W8# sDirty#, W8# sMarking#) #)
+
+-- | Get an interator starting with the top-most stack frame
+stackHead :: StackSnapshot -> StackFrameIter
+stackHead (StackSnapshot s) = StackFrameIter s 0 SfiClosure -- GHC stacks are never empty
+
+-- | Advance iterator to the next stack frame (if any)
+advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
+advanceStackFrameIter (StackFrameIter {..}) =
+ let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
+ in if (I# hasNext) > 0
+ then Just $ StackFrameIter s' (primWordToWordOffset i') SfiClosure
+ else Nothing
+
+primWordToWordOffset :: Word# -> WordOffset
+primWordToWordOffset w# = fromIntegral (W# w#)
+
+wordsToBitmapEntries :: StackFrameIter -> [Word] -> Word -> [StackFrameIter]
+wordsToBitmapEntries _ [] 0 = []
+wordsToBitmapEntries _ [] i = error $ "Invalid state: Empty list, size " ++ show i
+wordsToBitmapEntries _ l 0 = error $ "Invalid state: Size 0, list " ++ show l
+wordsToBitmapEntries sfi (b : bs) bitmapSize =
+ let entries = toBitmapEntries sfi b (min bitmapSize (fromIntegral wORD_SIZE_IN_BITS))
+ mbLastFrame = (listToMaybe . reverse) entries
+ in case mbLastFrame of
+ Just (StackFrameIter {..}) ->
+ entries ++ wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + 1) SfiClosure) bs (subtractDecodedBitmapWord bitmapSize)
+ Nothing -> error "This should never happen! Recursion ended not in base case."
+ where
+ subtractDecodedBitmapWord :: Word -> Word
+ subtractDecodedBitmapWord bSize = fromIntegral $ max 0 ((fromIntegral bSize) - wORD_SIZE_IN_BITS)
+
+toBitmapEntries :: StackFrameIter -> Word -> Word -> [StackFrameIter]
+toBitmapEntries _ _ 0 = []
+toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize =
+ -- TODO: overriding isPrimitive field is a bit weird. Could be calculated before
+ sfi {
+ sfiKind = if (bitmapWord .&. 1) /= 0 then SfiPrimitive else SfiClosure
+ }
+ : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1) SfiClosure) (bitmapWord `shiftR` 1) (bSize - 1)
+
+toBitmapPayload :: StackFrameIter -> IO Box
+toBitmapPayload sfi | sfiKind sfi == SfiPrimitive = pure (StackFrameBox sfi)
+toBitmapPayload sfi = getClosure sfi 0
+
+getClosure :: StackFrameIter -> WordOffset -> IO Box
+getClosure sfi at StackFrameIter {..} relativeOffset = trace ("getClosure " ++ show sfi ++ " " ++ show relativeOffset) $
+ IO $ \s ->
+ case (getBoxedClosure# stackSnapshot# (wordOffsetToWord# (index + relativeOffset)) s) of (# s1, ptr #) ->
+ (# s1, Box ptr #)
+
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+ (bitmapArray, size) <- IO $ \s ->
+ case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, ba#, s# #) -> (# s1, (ByteArray ba#, W# s#) #)
+ let bitmapWords :: [Word] = byteArrayToList bitmapArray
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+
+decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
+decodeBitmaps (StackFrameIter {..}) relativePayloadOffset bitmapWords size =
+ let bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset) SfiClosure) bitmapWords size
+ in mapM toBitmapPayload bes
+
+decodeSmallBitmap :: (StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset = do
+ (bitmap, size) <- IO $ \s ->
+ case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, b# , s# #) -> (# s1, (W# b# , W# s#) #)
+ let bitmapWords = if size > 0 then [bitmap] else []
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+
+byteArrayToList :: ByteArray -> [Word]
+byteArrayToList (ByteArray bArray) = go 0
+ where
+ go i
+ | i < maxIndex = (W# (indexWordArray# bArray (toInt# i))) : (go (i + 1))
+ | otherwise = []
+ maxIndex = sizeofByteArray bArray `quot` sizeOf (undefined :: Word)
+
+wordOffsetToWord# :: WordOffset -> Word#
+wordOffsetToWord# wo = intToWord# (fromIntegral wo)
+
+unpackStackFrameIter :: StackFrameIter -> IO Closure
+unpackStackFrameIter sfi | sfiKind sfi == SfiPrimitive = UnknownTypeWordSizedPrimitive <$> (getWord sfi 0)
+unpackStackFrameIter sfi | sfiKind sfi == SfiStack = do
+ info <- getInfoTable sfi
+ (stack_size', stack_dirty', stack_marking') <- getStackFields sfi
+ case tipe info of
+ STACK -> do
+ let stack' = decodeStack' (StackSnapshot (stackSnapshot# sfi))
+ pure $ StackClosure {
+ info = info,
+ stack_size = stack_size',
+ stack_dirty = stack_dirty',
+ stack_marking = stack_marking',
+ stack = stack'
+ }
+ _ -> error $ "Expected STACK closure, got " ++ show info
+unpackStackFrameIter sfi = do
+ traceM $ "unpackStackFrameIter - sfi " ++ show sfi
+ info <- getInfoTable sfi
+ res <- unpackStackFrameIter' info
+ traceM $ "unpackStackFrameIter - unpacked " ++ show res
+ pure res
+ where
+ unpackStackFrameIter' :: StgInfoTable -> IO Closure
+ unpackStackFrameIter' info =
+ case tipe info of
+ RET_BCO -> do
+ bco' <- getClosure sfi offsetStgClosurePayload
+ -- The arguments begin directly after the payload's one element
+ bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
+ pure $ RetBCO
+ { info = info,
+ bco = bco',
+ bcoArgs = bcoArgs'
+ }
+ RET_SMALL ->
+ trace "RET_SMALL" $ do
+ payload' <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ knownRetSmallType' <- getRetSmallSpecialType sfi
+ pure $ RetSmall
+ { info = info,
+ knownRetSmallType = knownRetSmallType',
+ payload = payload'
+ }
+ RET_BIG -> do
+ payload' <- decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ pure $ RetBig
+ { info = info,
+ payload = payload'
+ }
+ RET_FUN -> do
+ retFunType' <- getRetFunType sfi
+ retFunSize' <- getWord sfi offsetStgRetFunFrameSize
+ retFunFun' <- getClosure sfi offsetStgRetFunFrameFun
+ retFunPayload' <-
+ if retFunType' == ARG_GEN_BIG
+ then decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
+ else decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
+ pure $ RetFun
+ { info = info,
+ retFunType = retFunType',
+ retFunSize = retFunSize',
+ retFunFun = retFunFun',
+ retFunPayload = retFunPayload'
+ }
+ UPDATE_FRAME -> do
+ updatee' <- getClosure sfi offsetStgUpdateFrameUpdatee
+ knownUpdateFrameType' <- getUpdateFrameType sfi
+ pure $ UpdateFrame
+ { info = info,
+ knownUpdateFrameType = knownUpdateFrameType',
+ updatee = updatee'
+ }
+ CATCH_FRAME -> do
+ exceptions_blocked' <- getWord sfi offsetStgCatchFrameExceptionsBlocked
+ handler' <- getClosure sfi offsetStgCatchFrameHandler
+ pure $ CatchFrame
+ { info = info,
+ exceptions_blocked = exceptions_blocked',
+ handler = handler'
+ }
+ UNDERFLOW_FRAME -> do
+ (StackSnapshot nextChunk') <- getUnderflowFrameNextChunk sfi
+ pure $ UnderflowFrame
+ { info = info,
+ nextChunk = StackFrameBox $ StackFrameIter {
+ stackSnapshot# = nextChunk',
+ index = 0,
+ sfiKind = SfiStack
+ }
+ }
+ STOP_FRAME -> pure $ StopFrame {info = info}
+ ATOMICALLY_FRAME -> do
+ atomicallyFrameCode' <- getClosure sfi offsetStgAtomicallyFrameCode
+ result' <- getClosure sfi offsetStgAtomicallyFrameResult
+ pure $ AtomicallyFrame
+ { info = info,
+ atomicallyFrameCode = atomicallyFrameCode',
+ result = result'
+ }
+ CATCH_RETRY_FRAME -> do
+ running_alt_code' <- getWord sfi offsetStgCatchRetryFrameRunningAltCode
+ first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
+ alt_code' <- getClosure sfi offsetStgCatchRetryFrameAltCode
+ pure $ CatchRetryFrame
+ { info = info,
+ running_alt_code = running_alt_code',
+ first_code = first_code',
+ alt_code = alt_code'
+ }
+ CATCH_STM_FRAME -> do
+ catchFrameCode' <- getClosure sfi offsetStgCatchSTMFrameCode
+ handler' <- getClosure sfi offsetStgCatchSTMFrameHandler
+ pure $ CatchStmFrame
+ { info = info,
+ catchFrameCode = catchFrameCode',
+ handler = handler'
+ }
+ x -> error $ "Unexpected closure type on stack: " ++ show x
+
+-- | Size of the byte array in bytes.
+-- Copied from `primitive`
+sizeofByteArray :: ByteArray# -> Int
+{-# INLINE sizeofByteArray #-}
+sizeofByteArray arr# = I# (sizeofByteArray# arr#)
+
+-- | Unbox 'Int#' from 'Int'
+toInt# :: Int -> Int#
+toInt# (I# i) = i
+
+intToWord# :: Int -> Word#
+intToWord# i = int2Word# (toInt# i)
+
+decodeStack :: StackSnapshot -> IO Closure
+decodeStack (StackSnapshot stack#) = unpackStackFrameIter $ StackFrameIter {
+ stackSnapshot# = stack#,
+ index = 0,
+ sfiKind = SfiStack
+ }
+decodeStack' :: StackSnapshot -> [Box]
+decodeStack' s = StackFrameBox (stackHead s) : go (advanceStackFrameIter (stackHead s))
+ where
+ go :: Maybe StackFrameIter -> [Box]
+ go Nothing = []
+ go (Just sfi) = (StackFrameBox sfi) : go (advanceStackFrameIter sfi)
+#else
+module GHC.Exts.DecodeStack where
+#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,6 +7,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+{-# LANGUAGE RecordWildCards #-}
+#endif
{-# LANGUAGE UnliftedFFITypes #-}
{-|
@@ -27,6 +31,9 @@ module GHC.Exts.Heap (
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
+ , UpdateFrameType(..)
+ , SpecialRetSmall(..)
+ , RetFunType(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
, getClosureDataFromHeapRep
@@ -50,6 +57,7 @@ module GHC.Exts.Heap (
-- * Closure inspection
, getBoxedClosureData
, allClosures
+ , closureSize
-- * Boxes
, Box(..)
@@ -60,22 +68,25 @@ module GHC.Exts.Heap (
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 GHC.Exts.DecodeHeap
-import Data.Bits
-import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+import GHC.Stack.CloneStack
+import GHC.Exts.DecodeStack
+import GHC.Exts.StackConstants
+import Data.Functor
+import Debug.Trace
+#endif
+
#include "ghcconfig.h"
@@ -130,6 +141,11 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+instance {-# OVERLAPPING #-} HasHeapRep StackSnapshot# where
+ getClosureData s# = decodeStack (StackSnapshot s#)
+#endif
+
-- | Get the heap representation of a closure _at this moment_, even if it is
-- unevaluated or an indirection or other exotic stuff. Beware when passing
-- something to this function, the same caveats as for
@@ -153,6 +169,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]
]
@@ -163,223 +180,35 @@ getClosureDataFromHeapObject x = do
STACK -> pure $ UnsupportedClosure infoTable
_ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
+getBoxedClosureData :: Box -> IO Closure
+getBoxedClosureData (Box a) = getClosureData a
--- | 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 -> case pts of
- [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
- hd : _ -> pure $ SelectorClosure itbl hd
-
- t | t >= FUN && t <= FUN_STATIC -> do
- pure $ FunClosure itbl pts npts
-
- AP -> case pts of
- [] -> fail "Expected at least 1 ptr argument to AP"
- hd : tl -> case payloadWords of
- -- We expect at least the arity, n_args, and fun fields
- splitWord : _ : _ ->
- 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
- hd tl
- _ -> fail "Expected at least 2 raw words to AP"
-
- PAP -> case pts of
- [] -> fail "Expected at least 1 ptr argument to PAP"
- hd : tl -> case payloadWords of
- -- We expect at least the arity, n_args, and fun fields
- splitWord : _ : _ ->
- 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
- hd tl
- _ -> fail "Expected at least 2 raw words to PAP"
-
- AP_STACK -> case pts of
- [] -> fail "Expected at least 1 ptr argument to AP_STACK"
- hd : tl -> pure $ APStackClosure itbl hd tl
-
- IND -> case pts of
- [] -> fail "Expected at least 1 ptr argument to IND"
- hd : _ -> pure $ IndClosure itbl hd
-
- IND_STATIC -> case pts of
- [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
- hd : _ -> pure $ IndClosure itbl hd
-
- BLACKHOLE -> case pts of
- [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
- hd : _ -> pure $ BlackholeClosure itbl hd
-
- BCO -> case pts of
- pts0 : pts1 : pts2 : _ -> case payloadWords of
- _ : _ : _ : splitWord : payloadRest ->
- pure $ BCOClosure itbl pts0 pts1 pts2
-#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))
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+getBoxedClosureData b@(StackFrameBox sfi) = trace ("unpack " ++ show b) $ unpackStackFrameIter sfi
#endif
- payloadRest
- _ -> fail $ "Expected at least 4 words to BCO, found "
- ++ show (length payloadWords)
- _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
- ++ show (length pts)
-
- ARR_WORDS -> case payloadWords of
- [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
- ++ show (length payloadWords)
- hd : tl -> pure $ ArrWordsClosure itbl hd tl
-
- t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
- p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
- _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
-
- t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
- [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
- hd : _ -> pure $ SmallMutArrClosure itbl hd pts
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
- [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
- ++ show (length pts)
- hd : _ -> pure $ MutVarClosure itbl hd
-
- t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
- pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
- _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
- ++ show (length pts)
-
- BLOCKING_QUEUE ->
- pure $ OtherClosure itbl pts rawHeapWords
-
- WEAK -> case pts of
- pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
- { info = itbl
- , cfinalizers = pts0
- , key = pts1
- , value = pts2
- , finalizer = pts3
- , weakLink = case rest of
- [] -> Nothing
- [p] -> Just p
- _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
- }
- _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
- TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- 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
- , thread_label = case other of
- [tl] -> Just tl
- [] -> Nothing
- _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
- , 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 at least 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
+-- | Get the size of the top-level closure in words.
+-- Includes header and payload. Does not follow pointers.
+--
+-- @since 8.10.1
+closureSize :: Box -> IO Int
+closureSize (Box x) = pure $ I# (closureSize# x)
+#if MIN_VERSION_base(4,17,0)
+closureSize (StackFrameBox sfi) = unpackStackFrameIter sfi <&>
+ \c ->
+ case c of
+ UpdateFrame {} -> sizeStgUpdateFrame
+ CatchFrame {} -> sizeStgCatchFrame
+ CatchStmFrame {} -> sizeStgCatchSTMFrame
+ CatchRetryFrame {} -> sizeStgCatchRetryFrame
+ AtomicallyFrame {} -> sizeStgAtomicallyFrame
+ RetSmall {..} -> sizeStgClosure + length payload
+ RetBig {..} -> sizeStgClosure + length payload
+ 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
- })
- | otherwise
- -> fail $ "Expected 0 ptr argument to STACK, found "
- ++ show (length pts)
-
- _ ->
- pure $ UnsupportedClosure itbl
-
--- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
-getBoxedClosureData :: Box -> IO Closure
-getBoxedClosureData (Box a) = getClosureData a
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -15,13 +15,19 @@ module GHC.Exts.Heap.Closures (
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
+ , UpdateFrameType(..)
+ , SpecialRetSmall(..)
+ , RetFunType(..)
, allClosures
- , closureSize
-- * Boxes
, Box(..)
, areBoxesEqual
, asBox
+#if MIN_VERSION_base(4,17,0)
+ , SfiKind(..)
+ , StackFrameIter(..)
+#endif
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -48,6 +54,13 @@ import GHC.Exts
import GHC.Generics
import Numeric
+#if MIN_VERSION_base(4,17,0)
+import GHC.Stack.CloneStack (StackSnapshot(..))
+import GHC.Exts.StackConstants
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Functor
+#endif
+
------------------------------------------------------------------------
-- Boxes
@@ -56,12 +69,47 @@ foreign import prim "aToWordzh" aToWord# :: Any -> Word#
foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
+#if MIN_VERSION_base(4,17,0)
+foreign import prim "stackSnapshotToWordzh" stackSnapshotToWord# :: StackSnapshot# -> Word#
+
+foreign import prim "eqStackSnapshotszh" eqStackSnapshots# :: StackSnapshot# -> StackSnapshot# -> Word#
+#endif
-- | An arbitrary Haskell value in a safe Box. The point is that even
-- unevaluated thunks can safely be moved around inside the Box, and when
-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
-- to evaluate the argument.
+#if MIN_VERSION_base(4,17,0)
+data SfiKind = SfiClosure | SfiPrimitive | SfiStack
+ deriving (Eq, Show)
+
+data StackFrameIter = StackFrameIter
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset,
+ sfiKind :: !SfiKind
+ }
+
+instance Show StackFrameIter where
+ showsPrec _ (StackFrameIter s# i p) rs =
+ -- TODO: Record syntax could be nicer to read
+ "StackFrameIter(" ++ pad_out (showHex addr "") ++ ", " ++ show i ++ ", " ++ show p ++ ")" ++ rs
+ where
+ addr = W# (stackSnapshotToWord# s#)
+ pad_out ls = '0':'x':ls
+
+instance Show StackSnapshot where
+ showsPrec _ (StackSnapshot s#) rs =
+ -- TODO: Record syntax could be nicer to read
+ "StackSnapshot(" ++ pad_out (showHex addr "") ++ ")" ++ rs
+ where
+ addr = W# (stackSnapshotToWord# s#)
+ pad_out ls = '0':'x':ls
+
+data Box = Box Any | StackFrameBox StackFrameIter
+#else
data Box = Box Any
+#endif
+-- TODO: Handle PrimitiveWordHolder
instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
showsPrec _ (Box a) rs =
@@ -72,6 +120,29 @@ instance Show Box where
tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
addr = ptr - tag
pad_out ls = '0':'x':ls
+#if MIN_VERSION_base(4,17,0)
+ showsPrec _ (StackFrameBox sfi) rs =
+ -- TODO: Record syntax could be nicer to read
+ "(StackFrameBox StackFrameIter(" ++ show sfi ++ ")" ++ 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: Could be used for `instance Eq StackFrameIter`
+areBoxesEqual
+ (StackFrameBox (StackFrameIter s1# i1 p1))
+ (StackFrameBox (StackFrameIter s2# i2 p2)) = pure $
+ W# (eqStackSnapshots# s1# s2#) == 1
+ && i1 == i2
+ && p1 == p2
+areBoxesEqual _ _ = pure False
+#endif
-- |This takes an arbitrary value and puts it into a box.
-- Note that calls like
@@ -85,14 +156,6 @@ instance Show Box where
asBox :: a -> Box
asBox x = Box (unsafeCoerce# x)
--- | Boxes can be compared, but this is not pure, as different heap objects can,
--- after garbage collection, become the same object.
-areBoxesEqual :: Box -> Box -> IO Bool
-areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
- 0# -> pure False
- _ -> pure True
-
-
------------------------------------------------------------------------
-- Closures
@@ -301,8 +364,78 @@ data GenClosure b
#if __GLASGOW_HASKELL__ >= 811
, stack_marking :: !Word8
#endif
+ -- | The frames of the stack. Only available if a cloned stack was
+ -- decoded, otherwise empty.
+ , stack :: ![b]
+ }
+
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+ | UpdateFrame
+ { info :: !StgInfoTable
+ , knownUpdateFrameType :: !UpdateFrameType
+ , updatee :: !b
}
+ | CatchFrame
+ { info :: !StgInfoTable
+ , exceptions_blocked :: Word
+ , handler :: !b
+ }
+
+ | CatchStmFrame
+ { info :: !StgInfoTable
+ , catchFrameCode :: !b
+ , handler :: !b
+ }
+
+ | CatchRetryFrame
+ { info :: !StgInfoTable
+ , running_alt_code :: !Word
+ , first_code :: !b
+ , alt_code :: !b
+ }
+
+ | AtomicallyFrame
+ { info :: !StgInfoTable
+ , atomicallyFrameCode :: !b
+ , result :: !b
+ }
+
+ -- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
+ | UnderflowFrame
+ { info :: !StgInfoTable
+ , nextChunk :: !b
+ }
+
+ | StopFrame
+ { info :: !StgInfoTable }
+
+ | RetSmall
+ { info :: !StgInfoTable
+ , knownRetSmallType :: !SpecialRetSmall
+ , payload :: ![b]
+ }
+
+ | RetBig
+ { info :: !StgInfoTable
+ , payload :: ![b]
+ }
+
+ | RetFun
+ { info :: !StgInfoTable
+ , retFunType :: RetFunType
+ , retFunSize :: Word
+ , retFunFun :: !b
+ , retFunPayload :: ![b]
+ }
+
+ | RetBCO
+ -- TODO: Add pre-defined BCO closures (like knownUpdateFrameType)
+ { info :: !StgInfoTable
+ , bco :: !b -- must be a BCOClosure
+ , bcoArgs :: ![b]
+ }
+#endif
------------------------------------------------------------
-- Unboxed unlifted closures
@@ -354,8 +487,73 @@ data GenClosure b
| UnsupportedClosure
{ info :: !StgInfoTable
}
- deriving (Show, Generic, Functor, Foldable, Traversable)
+ | UnknownTypeWordSizedPrimitive
+ { wordVal :: !Word }
+ deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+
+-- TODO There are likely more. See MiscClosures.h
+data SpecialRetSmall =
+ -- TODO: Shoudn't `None` be better `Maybe ...`?
+ None |
+ ApV |
+ ApF |
+ ApD |
+ ApL |
+ ApN |
+ ApP |
+ ApPP |
+ ApPPP |
+ ApPPPP |
+ ApPPPPP |
+ ApPPPPPP |
+ RetV |
+ RetP |
+ RetN |
+ RetF |
+ RetD |
+ RetL |
+ RestoreCCCS |
+ RestoreCCCSEval
+ deriving (Enum, Eq, Show, Generic)
+
+data UpdateFrameType =
+ NormalUpdateFrame |
+ BhUpdateFrame |
+ MarkedUpdateFrame
+ deriving (Enum, Eq, Show, Generic, Ord)
+
+data RetFunType =
+ ARG_GEN |
+ ARG_GEN_BIG |
+ ARG_BCO |
+ ARG_NONE |
+ ARG_N |
+ ARG_P |
+ ARG_F |
+ ARG_D |
+ ARG_L |
+ ARG_V16 |
+ ARG_V32 |
+ ARG_V64 |
+ ARG_NN |
+ ARG_NP |
+ ARG_PN |
+ ARG_PP |
+ ARG_NNN |
+ ARG_NNP |
+ ARG_NPN |
+ ARG_NPP |
+ ARG_PNN |
+ ARG_PNP |
+ ARG_PPN |
+ ARG_PPP |
+ ARG_PPPP |
+ ARG_PPPPP |
+ ARG_PPPPPP |
+ ARG_PPPPPPP |
+ ARG_PPPPPPPP
+ deriving (Show, Eq, Enum, Generic)
data PrimType
= PInt
@@ -424,11 +622,17 @@ allClosures (FunClosure {..}) = ptrArgs
allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink
allClosures (OtherClosure {..}) = hvalues
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+allClosures (StackClosure {..}) = stack
+allClosures (UpdateFrame {..}) = [updatee]
+allClosures (CatchFrame {..}) = [handler]
+allClosures (CatchStmFrame {..}) = [catchFrameCode, handler]
+allClosures (CatchRetryFrame {..}) = [first_code, alt_code]
+allClosures (AtomicallyFrame {..}) = [atomicallyFrameCode, result]
+allClosures (RetSmall {..}) = payload
+allClosures (RetBig {..}) = payload
+allClosures (RetFun {..}) = retFunFun : retFunPayload
+allClosures (RetBCO {..}) = bco : bcoArgs
+#endif
allClosures _ = []
--- | Get the size of the top-level closure in words.
--- Includes header and payload. Does not follow pointers.
---
--- @since 8.10.1
-closureSize :: Box -> Int
-closureSize (Box x) = I# (closureSize# x)
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
@@ -14,6 +15,7 @@ import GHC.Exts
import GHC.Exts.Heap.ProfInfo.PeekProfInfo
import GHC.Exts.Heap.ProfInfo.Types
import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
+import Numeric
data TSOFields = TSOFields {
tso_what_next :: WhatNext,
@@ -102,10 +104,11 @@ data StackFields = StackFields {
#if __GLASGOW_HASKELL__ >= 811
stack_marking :: Word8,
#endif
- stack_sp :: Addr##
+ stack_sp :: Addr##,
+ stack_stack :: Addr##
}
--- | Get non-closure fields from @StgStack_@ (@TSO.h@)
+-- | Get fields from @StgStack_@ (@TSO.h@)
peekStackFields :: Ptr a -> IO StackFields
peekStackFields ptr = do
stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32
@@ -114,8 +117,7 @@ peekStackFields ptr = do
marking' <- (#peek struct StgStack_, marking) ptr
#endif
Ptr sp' <- (#peek struct StgStack_, sp) ptr
-
- -- TODO decode the stack.
+ let !(Ptr stack') = (#ptr struct StgStack_, stack) ptr
return StackFields {
stack_size = stack_size',
@@ -123,6 +125,9 @@ peekStackFields ptr = do
#if __GLASGOW_HASKELL__ >= 811
stack_marking = marking',
#endif
- stack_sp = sp'
+ stack_sp = sp',
+ stack_stack = stack'
}
+showAddr## :: Addr## -> String
+showAddr## addr## = (showHex $ I## (addr2Int## addr##)) ""
=====================================
libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
=====================================
@@ -37,4 +37,4 @@ data StgInfoTable = StgInfoTable {
tipe :: ClosureType,
srtlen :: HalfWord,
code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
- } deriving (Show, Generic)
+ } deriving (Eq, Show, Generic)
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -0,0 +1,115 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module GHC.Exts.StackConstants where
+
+-- TODO: Better expression to allow is only for the latest (this branch) GHC?
+#if MIN_TOOL_VERSION_ghc(9,5,0)
+
+import Prelude
+
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+newtype WordOffset = WordOffset { offsetInWords :: Int }
+ deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+offsetStgCatchFrameHandler :: WordOffset
+offsetStgCatchFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+
+offsetStgCatchFrameExceptionsBlocked :: WordOffset
+offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader)
+
+sizeStgCatchFrame :: Int
+sizeStgCatchFrame = bytesToWords $ (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchSTMFrameCode :: WordOffset
+offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+
+offsetStgCatchSTMFrameHandler :: WordOffset
+offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+
+sizeStgCatchSTMFrame :: Int
+sizeStgCatchSTMFrame = bytesToWords $ (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
+
+offsetStgUpdateFrameUpdatee :: WordOffset
+offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+
+sizeStgUpdateFrame :: Int
+sizeStgUpdateFrame = bytesToWords $ (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
+
+offsetStgAtomicallyFrameCode :: WordOffset
+offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+
+offsetStgAtomicallyFrameResult :: WordOffset
+offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+
+sizeStgAtomicallyFrame :: Int
+sizeStgAtomicallyFrame = bytesToWords $ (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningAltCode :: WordOffset
+offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
+offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameAltCode :: WordOffset
+offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+
+sizeStgCatchRetryFrame :: Int
+sizeStgCatchRetryFrame = bytesToWords $ (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
+
+offsetStgRetFunFrameSize :: WordOffset
+-- StgRetFun has no header, but only a pointer to the info table at the beginning.
+offsetStgRetFunFrameSize = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_size)
+
+offsetStgRetFunFrameFun :: WordOffset
+offsetStgRetFunFrameFun = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_fun)
+
+offsetStgRetFunFramePayload :: WordOffset
+offsetStgRetFunFramePayload = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_payload)
+
+sizeStgRetFunFrame :: Int
+sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
+
+offsetStgBCOFrameInstrs :: ByteOffset
+offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
+
+offsetStgBCOFrameLiterals :: ByteOffset
+offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
+
+offsetStgBCOFramePtrs :: ByteOffset
+offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
+
+offsetStgBCOFrameArity :: ByteOffset
+offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
+
+offsetStgBCOFrameSize :: ByteOffset
+offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
+
+offsetStgClosurePayload :: WordOffset
+offsetStgClosurePayload = byteOffsetToWordOffset $ (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+
+sizeStgClosure :: Int
+sizeStgClosure = bytesToWords (#size StgHeader)
+
+byteOffsetToWordOffset :: ByteOffset -> WordOffset
+byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger
+
+bytesToWords :: Int -> Int
+bytesToWords b =
+ if b `mod` bytesInWord == 0 then
+ fromIntegral $ b `div` bytesInWord
+ else
+ error "Unexpected struct alignment!"
+
+bytesInWord :: Int
+bytesInWord = (#const SIZEOF_VOID_P)
+
+#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -0,0 +1,253 @@
+#include "MachDeps.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+#include "rts/Types.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/InfoTables.h"
+
+StgWord stackFrameSize(StgStack *stack, StgWord index) {
+ StgClosure *c = (StgClosure *)stack->sp + index;
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+ return stack_frame_sizeW(c);
+}
+
+StgStack *getUnderflowFrameStack(StgStack *stack, StgWord index) {
+ StgClosure *frame = (StgClosure *)stack->sp + index;
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
+ const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
+
+ if (info->i.type == UNDERFLOW_FRAME) {
+ return ((StgUnderflowFrame *)frame)->next_chunk;
+ } else {
+ return NULL;
+ }
+}
+
+// Only exists to make the get_itbl macro available in Haskell code (via FFI).
+const StgInfoTable *getItbl(StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+ // printObj(closure);
+ return get_itbl(closure);
+};
+
+StgWord getSpecialRetSmall(StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+ StgWord c = *(StgWord *)closure;
+ if (c == (StgWord)&stg_ap_v_info) {
+ return 1;
+ } else if (c == (StgWord)&stg_ap_f_info) {
+ return 2;
+ } else if (c == (StgWord)&stg_ap_d_info) {
+ return 3;
+ } else if (c == (StgWord)&stg_ap_l_info) {
+ return 4;
+ } else if (c == (StgWord)&stg_ap_n_info) {
+ return 5;
+ } else if (c == (StgWord)&stg_ap_p_info) {
+ return 6;
+ } else if (c == (StgWord)&stg_ap_pp_info) {
+ return 7;
+ } else if (c == (StgWord)&stg_ap_ppp_info) {
+ return 8;
+ } else if (c == (StgWord)&stg_ap_pppp_info) {
+ return 9;
+ } else if (c == (StgWord)&stg_ap_ppppp_info) {
+ return 10;
+ } else if (c == (StgWord)&stg_ap_pppppp_info) {
+ return 11;
+ } else if (c == (StgWord)&stg_ret_v_info) {
+ return 12;
+ } else if (c == (StgWord)&stg_ret_p_info) {
+ return 13;
+ } else if (c == (StgWord)&stg_ret_n_info) {
+ return 14;
+ } else if (c == (StgWord)&stg_ret_f_info) {
+ return 15;
+ } else if (c == (StgWord)&stg_ret_d_info) {
+ return 16;
+ } else if (c == (StgWord)&stg_ret_l_info) {
+ return 17;
+#if defined(PROFILING)
+ } else if (c == (StgWord)&stg_restore_cccs_info) {
+ return 18;
+ } else if (c == (StgWord)&stg_restore_cccs_eval_info) {
+ return 19;
+#endif
+ } else {
+ return 0;
+ }
+}
+
+StgWord getUpdateFrameType(StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ const StgInfoTable *info = c->header.info;
+ if (info == &stg_upd_frame_info) {
+ return 0;
+ } else if (info == &stg_bh_upd_frame_info) {
+ return 1;
+ } else if (info == &stg_marked_upd_frame_info) {
+ return 2;
+ } else {
+ // Cannot do more than warn and exit.
+ errorBelch("Cannot decide Update Frame type for info table %p closure %p.",
+ info, c);
+ stg_exit(EXIT_INTERNAL_ERROR);
+ }
+}
+
+StgWord getBitmapSize(StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ const StgInfoTable *info = get_itbl(c);
+ StgWord bitmap = info->layout.bitmap;
+ return BITMAP_SIZE(bitmap);
+}
+
+StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ return BITMAP_SIZE(fun_info->f.b.bitmap);
+ case ARG_GEN_BIG:
+ return GET_FUN_LARGE_BITMAP(fun_info)->size;
+ default:
+ return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+ }
+}
+
+StgWord getBitmapWord(StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ const StgInfoTable *info = get_itbl(c);
+ StgWord bitmap = info->layout.bitmap;
+ StgWord bitmapWord = BITMAP_BITS(bitmap);
+ return bitmapWord;
+}
+
+StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ return BITMAP_BITS(fun_info->f.b.bitmap);
+ case ARG_GEN_BIG:
+ // Cannot do more than warn and exit.
+ errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
+ stg_exit(EXIT_INTERNAL_ERROR);
+ default:
+ return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+ }
+}
+
+StgWord getLargeBitmapSize(StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+ return bitmap->size;
+}
+
+StgWord getRetFunSize(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ switch (fun_info->f.fun_type) {
+ case ARG_GEN:
+ return BITMAP_SIZE(fun_info->f.b.bitmap);
+ case ARG_GEN_BIG:
+ return GET_FUN_LARGE_BITMAP(fun_info)->size;
+ default:
+ return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+ }
+}
+
+StgWord getBCOLargeBitmapSize(StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ StgBCO *bco = (StgBCO *)*c->payload;
+
+ return BCO_BITMAP_SIZE(bco);
+}
+
+#define ROUNDUP_BITS_TO_WDS(n) \
+ (((n) + WORD_SIZE_IN_BITS - 1) / WORD_SIZE_IN_BITS)
+
+// Copied from Cmm.h
+#define SIZEOF_W SIZEOF_VOID_P
+#define WDS(n) ((n)*SIZEOF_W)
+
+static StgArrBytes *largeBitmapToStgArrBytes(Capability *cap, StgLargeBitmap *bitmap) {
+ StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
+ StgArrBytes *array =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + neededWords);
+ SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM);
+ array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
+
+ for (int i = 0; i < neededWords; i++) {
+ array->payload[i] = bitmap->bitmap[i];
+ }
+
+ return array;
+}
+
+StgArrBytes *getLargeBitmap(Capability *cap, StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+ debugBelch("getLargeBitmap %p \n", c);
+ const StgInfoTable *info = get_itbl(c);
+ debugBelch("getLargeBitmap tipe %ul \n", info->type);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+ debugBelch("getLargeBitmap size %lu \n", bitmap->size);
+
+ return largeBitmapToStgArrBytes(cap, bitmap);
+}
+
+StgArrBytes *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
+
+ return largeBitmapToStgArrBytes(cap, bitmap);
+}
+
+StgArrBytes *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ StgBCO *bco = (StgBCO *)*c->payload;
+ StgLargeBitmap *bitmap = BCO_BITMAP(bco);
+
+ return largeBitmapToStgArrBytes(cap, bitmap);
+}
+
+#if defined(DEBUG)
+extern void printStack(StgStack *stack);
+void belchStack(StgStack *stack) { printStack(stack); }
+#endif
+
+StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
+ return frame->next_chunk;
+}
+
+StgWord getRetFunType(StgRetFun *ret_fun) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ return fun_info->f.fun_type;
+}
+
+RTS_INFO(box_info);
+StgClosure* getBoxedClosure(Capability *cap, StgClosure **c){
+// StgClosure *box = (StgClosure*) allocate(cap, sizeofW(StgClosure) + 1);
+// SET_HDR(box, &box_info, CCS_SYSTEM);
+// box->payload[0] = *c;
+// return box;
+ return *c;
+}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -0,0 +1,223 @@
+// Uncomment to enable assertions during development
+// #define DEBUG 1
+
+#include "Cmm.h"
+
+#if defined(StgStack_marking)
+advanceStackFrameIterzh (P_ stack, W_ offsetWords) {
+ W_ frameSize;
+ (frameSize) = ccall stackFrameSize(stack, offsetWords);
+
+ P_ nextClosurePtr;
+ nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));
+
+ P_ stackArrayPtr;
+ stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;
+
+ P_ stackBottom;
+ W_ stackSize, stackSizeInBytes;
+ stackSize = TO_W_(StgStack_stack_size(stack));
+ stackSizeInBytes = WDS(stackSize);
+ stackBottom = stackSizeInBytes + stackArrayPtr;
+
+ P_ newStack;
+ W_ newOffsetWords, hasNext;
+ if(nextClosurePtr < stackBottom) (likely: True) {
+ newStack = stack;
+ newOffsetWords = offsetWords + frameSize;
+ hasNext = 1;
+ } else {
+ P_ underflowFrameStack;
+ (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
+ if (underflowFrameStack == NULL) (likely: True) {
+ newStack = NULL;
+ newOffsetWords = NULL;
+ hasNext = NULL;
+ } else {
+ newStack = underflowFrameStack;
+ newOffsetWords = NULL;
+ hasNext = 1;
+ }
+ }
+
+ return (newStack, newOffsetWords, hasNext);
+}
+
+derefStackWordzh (P_ stack, W_ offsetWords) {
+ P_ sp;
+ sp = StgStack_sp(stack);
+
+ return (W_[sp + WDS(offsetWords)]);
+}
+
+getSmallBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ bitmap, size;
+ (bitmap) = ccall getBitmapWord(c);
+ (size) = ccall getBitmapSize(c);
+
+ return (bitmap, size);
+}
+
+getRetSmallSpecialTypezh(P_ stack, W_ offsetWords) {
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ specialType;
+ (specialType) = ccall getSpecialRetSmall(c);
+
+ return (specialType);
+}
+
+getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ bitmap, size, specialType;
+ (bitmap) = ccall getRetFunBitmapWord(c);
+ (size) = ccall getRetFunBitmapSize(c);
+
+ return (bitmap, size);
+}
+
+getLargeBitmapzh(P_ stack, W_ offsetWords){
+ P_ c, stgArrBytes;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (stgArrBytes) = ccall getLargeBitmap(MyCapability(), c);
+ (size) = ccall getLargeBitmapSize(c);
+
+ return (stgArrBytes, size);
+}
+
+getBCOLargeBitmapzh(P_ stack, W_ offsetWords){
+ P_ c, stgArrBytes;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (stgArrBytes) = ccall getBCOLargeBitmap(MyCapability(), c);
+ (size) = ccall getBCOLargeBitmapSize(c);
+
+ return (stgArrBytes, size);
+}
+
+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords){
+ P_ c, stgArrBytes;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (stgArrBytes) = ccall getRetFunLargeBitmap(MyCapability(), c);
+ (size) = ccall getRetFunSize(c);
+
+ return (stgArrBytes, size);
+}
+
+getUpdateFrameTypezh(P_ stack, W_ offsetWords){
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ type;
+ (type) = ccall getUpdateFrameType(c);
+ return (type);
+}
+
+getWordzh(P_ stack, W_ offsetWords, W_ offsetBytes){
+ P_ wordAddr;
+ wordAddr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(offsetBytes));
+ return (W_[wordAddr]);
+}
+
+getAddrzh(P_ stack, W_ offsetWords){
+ P_ addr;
+ addr = (StgStack_sp(stack) + WDS(offsetWords));
+ P_ ptr;
+ ptr = P_[addr];
+// ccall printObj(ptr);
+ return (ptr);
+}
+
+getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords){
+ P_ closurePtr;
+ closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
+ ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr));
+
+ P_ next_chunk;
+ (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
+ ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk));
+ return (next_chunk);
+}
+
+getRetFunTypezh(P_ stack, W_ offsetWords){
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ type;
+ (type) = ccall getRetFunType(c);
+ return (type);
+}
+
+getInfoTableAddrzh(P_ stack, W_ offsetWords){
+ P_ p, info;
+ p = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+ info = %GET_STD_INFO(UNTAG(p));
+
+ return (info);
+}
+
+getStackInfoTableAddrzh(P_ stack){
+ P_ info;
+ info = %GET_STD_INFO(UNTAG(stack));
+ return (info);
+}
+
+// Just a cast
+stackSnapshotToWordzh(P_ stack) {
+ return (stack);
+}
+
+eqStackSnapshotszh(P_ stack1, P_ stack2) {
+ ccall checkSTACK(stack1);
+ ccall checkSTACK(stack2);
+ return (stack1 == stack2);
+}
+
+getBoxedClosurezh(P_ stack, W_ offsetWords){
+ ccall debugBelch("getBoxedClosurezh - stack %p , offsetWords %lu", stack, offsetWords);
+
+ ccall checkSTACK(stack);
+ P_ ptr;
+ ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+ P_ box;
+ (box) = ccall getBoxedClosure(MyCapability(), ptr);
+ ccall debugBelch("getBoxedClosurezh - box %p", box);
+ return (box);
+}
+
+// TODO: Unused?
+INFO_TABLE_CONSTR(box, 1, 0, 0, CONSTR_1_0, "BOX", "BOX")
+{ foreign "C" barf("BOX object (%p) entered!", R1) never returns; }
+
+getStackFieldszh(P_ stack){
+ bits32 size;
+ bits8 dirty, marking;
+
+ size = StgStack_stack_size(stack);
+ dirty = StgStack_dirty(stack);
+ marking = StgStack_marking(stack);
+
+ return (size, dirty, marking);
+}
+#endif
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -30,6 +30,8 @@ library
ghc-options: -Wall
if !os(ghcjs)
cmm-sources: cbits/HeapPrim.cmm
+ cbits/Stack.cmm
+ c-sources: cbits/Stack.c
default-extensions: NoImplicitPrelude
@@ -37,6 +39,8 @@ library
GHC.Exts.Heap.Closures
GHC.Exts.Heap.ClosureTypes
GHC.Exts.Heap.Constants
+ GHC.Exts.DecodeHeap
+ GHC.Exts.DecodeStack
GHC.Exts.Heap.InfoTable
GHC.Exts.Heap.InfoTable.Types
GHC.Exts.Heap.InfoTableProf
@@ -48,3 +52,4 @@ library
GHC.Exts.Heap.ProfInfo.PeekProfInfo
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+ GHC.Exts.StackConstants
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -1,7 +1,56 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
-module TestUtils where
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UnliftedFFITypes #-}
-assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+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
+import GHC.Exts.Heap.Closures
+import GHC.Records
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import Unsafe.Coerce (unsafeCoerce)
+
+getDecodedStack :: IO (StackSnapshot, [Closure])
+getDecodedStack = do
+ s@(StackSnapshot s#) <- cloneMyStack
+ stackClosure <- getClosureData s#
+ unboxedCs <- mapM getBoxedClosureData (stack stackClosure)
+ pure (s, unboxedCs)
+
+assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
assertEqual a b
| a /= b = error (show a ++ " /= " ++ show b)
- | otherwise = return ()
+ | otherwise = pure ()
+
+assertThat :: (HasCallStack, Monad m) => String -> (a -> Bool) -> a -> m ()
+assertThat s f a = if f a then pure () else error s
+
+assertStackInvariants :: (HasCallStack, MonadIO m) => StackSnapshot -> [Closure] -> m ()
+assertStackInvariants stack decodedStack = do
+ assertThat
+ "Last frame is stop frame"
+ ( \case
+ StopFrame info -> tipe info == STOP_FRAME
+ _ -> False
+ )
+ (last decodedStack)
+
+unbox :: Box -> IO Closure
+unbox = getBoxedClosureData
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -39,20 +39,68 @@ test('closure_size_noopt',
compile_and_run, [''])
test('tso_and_stack_closures',
- [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs','stack_lib.c']),
only_ways(['profthreaded']),
ignore_stdout,
ignore_stderr
],
- multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+ multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c',''), ('stack_lib.c', '')], ''])
test('parse_tso_flags',
- [extra_files(['TestUtils.hs']),
+ [extra_files(['stack_lib.c', 'TestUtils.hs']),
only_ways(['normal']),
ignore_stdout,
ignore_stderr
],
- compile_and_run, [''])
+ multi_compile_and_run, ['parse_tso_flags', [('stack_lib.c','')], ''])
test('T21622',
only_ways(['normal']),
compile_and_run, [''])
+
+# TODO: Remove debug flags
+test('stack_big_ret',
+ [
+ extra_files(['TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ 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(['TestUtils.hs']),
+ extra_run_opts('+RTS -kc512B -kb64B -RTS'),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run,
+ ['-debug -optc-g -g'])
+
+# TODO: Remove debug flags
+test('stack_stm_frames',
+ [
+ extra_files(['TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ 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', 'TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run,
+ ['stack_misc_closures',
+ [ ('stack_misc_closures_c.c', '')
+ ,('stack_misc_closures_prim.cmm', '')
+ ]
+ , '-debug -optc-g -optc-O0 -g -ddump-to-file -dlint -ddump-cmm' # -with-rtsopts="-Dg -Ds -Db"'
+ ])
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -0,0 +1,140 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import Control.Concurrent
+import Data.IORef
+import Data.Maybe
+import GHC.Exts (StackSnapshot#)
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.IO.Unsafe
+import GHC.Stack (HasCallStack)
+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
+ stackSnapshot <- cloneMyStack
+
+ writeIORef ioRef (Just stackSnapshot)
+
+ pure 42
+
+-- | Clone a stack with a RET_BIG closure and decode it.
+main :: HasCallStack => IO ()
+main = do
+ stackRef <- newIORef Nothing
+
+ bigFun (cloneStackReturnInt stackRef) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
+
+ mbStackSnapshot <- readIORef stackRef
+ let stackSnapshot@(StackSnapshot s#) = fromJust mbStackSnapshot
+ stackClosure <- getClosureData s#
+ stackFrames <- mapM getBoxedClosureData (stack stackClosure)
+
+ assertStackInvariants stackSnapshot stackFrames
+ assertThat
+ "Stack contains one big return frame"
+ (== 1)
+ (length $ filter isBigReturnFrame stackFrames)
+ cs <- (mapM unbox . payload . head) $ filter isBigReturnFrame stackFrames
+ let xs = zip [1 ..] cs
+ mapM_ (uncurry checkArg) xs
+
+checkArg :: Word -> Closure -> IO ()
+checkArg w bp =
+ case bp of
+ 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 info _) = tipe info == RET_BIG
+isBigReturnFrame _ = False
+
+{-# NOINLINE bigFun #-}
+bigFun ::
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ Int ->
+ IO ()
+bigFun !a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 =
+ do
+ print $ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + a60 + a61 + a62 + a63 + a64 + a65
+
+ pure ()
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -0,0 +1,553 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+-- TODO: Remove later
+import Debug.Trace
+import GHC.Exts
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap
+import GHC.Exts.Heap.Closures
+import GHC.IO (IO (..))
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack (StackSnapshot (..))
+import System.Mem
+import TestUtils
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Functor
+
+foreign import prim "any_update_framezh" any_update_frame# :: SetupFunction
+
+foreign import prim "any_catch_framezh" any_catch_frame# :: SetupFunction
+
+foreign import prim "any_catch_stm_framezh" any_catch_stm_frame# :: SetupFunction
+
+foreign import prim "any_catch_retry_framezh" any_catch_retry_frame# :: SetupFunction
+
+foreign import prim "any_atomically_framezh" any_atomically_frame# :: SetupFunction
+
+foreign import prim "any_ret_small_prim_framezh" any_ret_small_prim_frame# :: SetupFunction
+
+foreign import prim "any_ret_small_prims_framezh" any_ret_small_prims_frame# :: SetupFunction
+
+foreign import prim "any_ret_small_closure_framezh" any_ret_small_closure_frame# :: SetupFunction
+
+foreign import prim "any_ret_small_closures_framezh" any_ret_small_closures_frame# :: SetupFunction
+
+foreign import prim "any_ret_big_prims_min_framezh" any_ret_big_prims_min_frame# :: SetupFunction
+
+foreign import prim "any_ret_big_closures_min_framezh" any_ret_big_closures_min_frame# :: SetupFunction
+
+foreign import prim "any_ret_big_closures_two_words_framezh" any_ret_big_closures_two_words_frame# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_n_prim_framezh" any_ret_fun_arg_n_prim_framezh# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_gen_framezh" any_ret_fun_arg_gen_framezh# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_gen_big_framezh" any_ret_fun_arg_gen_big_framezh# :: SetupFunction
+
+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 ()
+
+{- Test stategy
+ ~~~~~~~~~~~~
+
+- Create @StgStack at s in C that contain two closures (as they are on stack they
+may also be called "frames"). A stop frame and the frame which's decoding should
+be tested.
+
+- Cmm primops are used to get `StackSnapshot#` values. (This detour ensures that
+the closures are referenced by `StackSnapshot#` and not garbage collected right
+away.)
+
+- These can then be decoded and checked.
+
+This strategy may look pretty complex for a test. But, it can provide very
+specific corner cases that would be hard to (reliably!) produce in Haskell.
+
+N.B. `StackSnapshots` are managed by the garbage collector. This isn't much of
+an issue regarding the test data, as it's already very terse. However, it's
+important to know that the GC may rewrite parts of the stack and that the stack
+must be sound (otherwise, the GC may fail badly.)
+
+The decission to make `StackSnapshots`s (and their closures) being managed by the
+GC isn't accidential. It's closer to the reality of decoding stacks.
+
+N.B. the test data stack are only meant be de decoded. They are not executable
+(the result would likely be a crash or non-sense.)
+-}
+main :: HasCallStack => IO ()
+main = do
+ traceM $ "Test 1"
+ test any_update_frame# $
+ \case
+ UpdateFrame {..} -> do
+ assertEqual (tipe info) UPDATE_FRAME
+ assertEqual knownUpdateFrameType NormalUpdateFrame
+ assertEqual 1 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 2"
+ testSize any_update_frame# 2
+ traceM $ "Test 3"
+ test any_catch_frame# $
+ \case
+ CatchFrame {..} -> do
+ assertEqual (tipe info) CATCH_FRAME
+ assertEqual exceptions_blocked 1
+ assertConstrClosure 1 =<< getBoxedClosureData handler
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 4"
+ testSize any_catch_frame# 3
+ traceM $ "Test 5"
+ test any_catch_stm_frame# $
+ \case
+ CatchStmFrame {..} -> do
+ assertEqual (tipe info) CATCH_STM_FRAME
+ assertConstrClosure 1 =<< getBoxedClosureData catchFrameCode
+ assertConstrClosure 2 =<< getBoxedClosureData handler
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 6"
+ testSize any_catch_stm_frame# 3
+ traceM $ "Test 7"
+ test any_catch_retry_frame# $
+ \case
+ CatchRetryFrame {..} -> do
+ assertEqual (tipe info) CATCH_RETRY_FRAME
+ assertEqual running_alt_code 1
+ assertConstrClosure 1 =<< getBoxedClosureData first_code
+ assertConstrClosure 2 =<< getBoxedClosureData alt_code
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 8"
+ testSize any_catch_retry_frame# 4
+ traceM $ "Test 9"
+ test any_atomically_frame# $
+ \case
+ AtomicallyFrame {..} -> do
+ assertEqual (tipe info) ATOMICALLY_FRAME
+ assertConstrClosure 1 =<< getBoxedClosureData atomicallyFrameCode
+ assertConstrClosure 2 =<< getBoxedClosureData result
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 10"
+ testSize any_atomically_frame# 3
+ -- TODO: Test for UnderflowFrame once it points to a Box payload
+ traceM $ "Test 11"
+ test any_ret_small_prim_frame# $
+ \case
+ RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
+ assertEqual knownRetSmallType RetN
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 1
+ assertUnknownTypeWordSizedPrimitive 1 (head pCs)
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 12"
+ testSize any_ret_small_prim_frame# 2
+ traceM $ "Test 13"
+ test any_ret_small_closure_frame# $
+ \case
+ RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
+ assertEqual knownRetSmallType RetP
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 1
+ assertConstrClosure 1 (head pCs)
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 14"
+ testSize any_ret_small_closure_frame# 2
+ traceM $ "Test 15"
+ test any_ret_small_closures_frame# $
+ \case
+ RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
+ assertEqual knownRetSmallType None
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. 58]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 16"
+ testSize any_ret_small_closures_frame# (1 + fromIntegral maxSmallBitmapBits_c)
+ traceM $ "Test 17"
+ test any_ret_small_prims_frame# $
+ \case
+ RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
+ assertEqual knownRetSmallType None
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) (fromIntegral maxSmallBitmapBits_c)
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1 .. 58]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 18"
+ testSize any_ret_small_prims_frame# (1 + fromIntegral maxSmallBitmapBits_c)
+ traceM $ "Test 19"
+ test any_ret_big_prims_min_frame# $
+ \case
+ RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 59
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1 .. 59]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 20"
+ testSize any_ret_big_prims_min_frame# (minBigBitmapBits + 1)
+ traceM $ "Test 21"
+ test any_ret_big_closures_min_frame# $
+ \case
+ RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) 59
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. 59]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 22"
+ testSize any_ret_big_closures_min_frame# (minBigBitmapBits + 1)
+ traceM $ "Test 23"
+ test any_ret_big_closures_two_words_frame# $
+ \case
+ RetBig {..} -> do
+ assertEqual (tipe info) RET_BIG
+ pCs <- mapM getBoxedClosureData payload
+ let closureCount = 64 + 1
+ assertEqual (length pCs) closureCount
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. (fromIntegral closureCount)]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 24"
+ testSize any_ret_big_closures_two_words_frame# (64 + 1 + 1)
+ traceM $ "Test 25"
+ test any_ret_fun_arg_n_prim_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
+ assertEqual retFunType ARG_N
+ assertEqual retFunSize 1
+ assertFun01Closure 1 =<< getBoxedClosureData retFunFun
+ pCs <- mapM getBoxedClosureData retFunPayload
+ assertEqual (length pCs) 1
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 26"
+ test any_ret_fun_arg_gen_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
+ assertEqual retFunType ARG_GEN
+ assertEqual retFunSize 9
+ fc <- getBoxedClosureData retFunFun
+ case fc of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_STATIC
+ assertEqual (null dataArgs) True
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+ pCs <- mapM getBoxedClosureData retFunPayload
+ assertEqual (length pCs) 9
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. 9]
+ e -> error $ "Wrong closure type: " ++ show e
+ traceM $ "Test 27"
+ testSize any_ret_fun_arg_gen_framezh# (3 + 9)
+ traceM $ "Test 28"
+ test any_ret_fun_arg_gen_big_framezh# $
+ \case
+ RetFun {..} -> do
+ assertEqual (tipe info) RET_FUN
+ assertEqual retFunType ARG_GEN_BIG
+ assertEqual retFunSize 59
+ fc <- getBoxedClosureData retFunFun
+ case fc of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_STATIC
+ assertEqual (null dataArgs) True
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+ pCs <- mapM getBoxedClosureData retFunPayload
+ assertEqual (length pCs) 59
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. 59]
+ traceM $ "Test 29"
+ testSize any_ret_fun_arg_gen_big_framezh# (3 + 59)
+ traceM $ "Test 30"
+ test any_bco_frame# $
+ \case
+ RetBCO {..} -> do
+ assertEqual (tipe info) RET_BCO
+ pCs <- mapM getBoxedClosureData bcoArgs
+ assertEqual (length pCs) 1
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [3]
+ bco <- getBoxedClosureData bco
+ case bco of
+ BCOClosure {..} -> do
+ assertEqual (tipe info) BCO
+ assertEqual arity 3
+ assertArrWordsClosure [1] =<< getBoxedClosureData instrs
+ assertArrWordsClosure [2] =<< getBoxedClosureData literals
+ assertMutArrClosure [3] =<< getBoxedClosureData bcoptrs
+ assertEqual
+ [ 1, -- StgLargeBitmap size in words
+ 0 -- StgLargeBitmap first words
+ ]
+ bitmap
+ e -> error $ "Wrong closure type: " ++ show e
+ e -> error $ "Wrong closure type: " ++ show e
+ 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# #)
+
+test :: HasCallStack => SetupFunction -> (Closure -> IO ()) -> IO ()
+test setup assertion = do
+ traceM $ "test - getStackSnapshot"
+ sn@(StackSnapshot sn#) <- getStackSnapshot setup
+ traceM $ "test - sn " ++ show sn
+ performGC
+ traceM $ "entertainGC - " ++ (entertainGC 10)
+ -- Run garbage collection now, to prevent later surprises: It's hard to debug
+ -- when the GC suddenly does it's work and there were bad closures or pointers.
+ -- Better fail early, here.
+ performGC
+ traceM $ "test - sn' " ++ show sn
+ stackClosure <- getClosureData sn#
+ traceM $ "test - ss" ++ show stackClosure
+ performGC
+ traceM $ "call getBoxedClosureData"
+ let boxedFrames = stack stackClosure
+ stack <- mapM getBoxedClosureData boxedFrames
+ performGC
+ assert sn stack
+ -- The result of HasHeapRep should be similar (wrapped in the closure for
+ -- StgStack itself.)
+ let (StackSnapshot sn#) = sn
+ stack' <- getClosureData sn#
+ case stack' of
+ StackClosure {..} -> do
+ !cs <- mapM getBoxedClosureData stack
+ assert sn cs
+ _ -> error $ "Unexpected closure type : " ++ show stack'
+ where
+ assert :: StackSnapshot -> [Closure] -> IO ()
+ assert sn stack = do
+ assertStackInvariants sn stack
+ assertEqual (length stack) 2
+ -- TODO: Isn't this also a stack invariant? (assertStackInvariants)
+ assertThat
+ "Last frame is stop frame"
+ ( \case
+ StopFrame info -> tipe info == STOP_FRAME
+ _ -> False
+ )
+ (last stack)
+ assertion $ head stack
+
+entertainGC :: Int -> String
+entertainGC 0 = "0"
+entertainGC x = show x ++ entertainGC (x -1)
+
+testSize :: HasCallStack => SetupFunction -> Int -> IO ()
+testSize setup expectedSize = do
+ (StackSnapshot sn#) <- getStackSnapshot setup
+ stackClosure <- getClosureData sn#
+ assertEqual expectedSize =<< (closureSize . head . stack) stackClosure
+
+-- | Get a `StackSnapshot` from test setup
+--
+-- This function mostly resembles `cloneStack`. Though, it doesn't clone, but
+-- just pulls a @StgStack@ from RTS to Haskell land.
+getStackSnapshot :: SetupFunction -> IO StackSnapshot
+getStackSnapshot action# = IO $ \s ->
+ case action# s of (# s1, stack #) -> (# s1, StackSnapshot stack #)
+
+assertConstrClosure :: HasCallStack => Word -> Closure -> IO ()
+assertConstrClosure w c = case c of
+ ConstrClosure {..} -> do
+ assertEqual (tipe info) CONSTR_0_1
+ assertEqual dataArgs [w]
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertArrWordsClosure :: HasCallStack => [Word] -> Closure -> IO ()
+assertArrWordsClosure wds c = case c of
+ ArrWordsClosure {..} -> do
+ assertEqual (tipe info) ARR_WORDS
+ assertEqual arrWords wds
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertMutArrClosure :: HasCallStack => [Word] -> Closure -> IO ()
+assertMutArrClosure wds c = case c of
+ MutArrClosure {..} -> do
+ assertEqual (tipe info) MUT_ARR_PTRS_FROZEN_CLEAN
+ xs <- mapM getBoxedClosureData mccPayload
+ assertEqual wds $ map getWordFromConstr01 xs
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertFun01Closure :: HasCallStack => Word -> Closure -> IO ()
+assertFun01Closure w c = case c of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_0_1
+ assertEqual dataArgs [w]
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+
+getWordFromConstr01 :: HasCallStack => Closure -> Word
+getWordFromConstr01 c = case c of
+ ConstrClosure {..} -> head dataArgs
+ e -> error $ "Wrong closure type: " ++ show e
+
+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
+getWordFromUnknownTypeWordSizedPrimitive c = case c of
+ UnknownTypeWordSizedPrimitive {..} -> wordVal
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertUnknownTypeWordSizedPrimitive :: HasCallStack => Word -> Closure -> IO ()
+assertUnknownTypeWordSizedPrimitive w c = case c of
+ UnknownTypeWordSizedPrimitive {..} -> do
+ assertEqual wordVal w
+ e -> error $ "Wrong closure type: " ++ show e
+
+unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
+unboxSingletonTuple (# s# #) = s#
+
+minBigBitmapBits :: Num a => a
+minBigBitmapBits = 1 + fromIntegral maxSmallBitmapBits_c
+
+-- | A function with 59 arguments
+--
+-- A small bitmap has @64 - 6 = 58@ entries on 64bit machines. On 32bit machines
+-- it's less (for obvious reasons.) I.e. this function's bitmap a large one;
+-- function type is @ARG_GEN_BIG at .
+{-# NOINLINE argGenBigFun #-}
+argGenBigFun ::
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word
+argGenBigFun a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 =
+ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59
+
+-- | A function with more arguments than the pre-generated (@ARG_PPPPPPPP -> 8@) ones
+-- have
+--
+-- This results in a @ARG_GEN@ function (the number of arguments still fits in a
+-- small bitmap).
+{-# NOINLINE argGenFun #-}
+argGenFun ::
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word ->
+ Word
+argGenFun a1 a2 a3 a4 a5 a6 a7 a8 a9 = a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -0,0 +1,371 @@
+#include "MachDeps.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "alloca.h"
+#include "rts/Messages.h"
+#include "rts/Types.h"
+#include "rts/storage/ClosureMacros.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/InfoTables.h"
+#include "rts/storage/TSO.h"
+#include "stg/MiscClosures.h"
+#include "stg/Types.h"
+
+// TODO: Delete when development finished
+extern void printStack(StgStack *stack);
+extern void printObj(StgClosure *obj);
+
+// See rts/Threads.c
+#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)
+
+// Copied from Cmm.h
+#define SIZEOF_W SIZEOF_VOID_P
+#define WDS(n) ((n)*SIZEOF_W)
+
+// Update frames are interpreted by the garbage collector. We play it some
+// tricks here with a fake blackhole.
+RTS_RET(test_fake_blackhole);
+void create_any_update_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgUpdateFrame *updF = (StgUpdateFrame *)stack->sp;
+ SET_HDR(updF, &stg_upd_frame_info, CCS_SYSTEM);
+ // StgInd and a BLACKHOLE have the same structure
+ StgInd *blackhole = allocate(cap, sizeofW(StgInd));
+ SET_HDR(blackhole, &test_fake_blackhole_info, CCS_SYSTEM);
+ StgClosure *payload = rts_mkWord(cap, w);
+ blackhole->indirectee = payload;
+ updF->updatee = (StgClosure *)blackhole;
+}
+
+void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgCatchFrame *catchF = (StgCatchFrame *)stack->sp;
+ SET_HDR(catchF, &stg_catch_frame_info, CCS_SYSTEM);
+ StgClosure *payload = rts_mkWord(cap, w);
+ catchF->exceptions_blocked = 1;
+ catchF->handler = payload;
+}
+
+void create_any_catch_stm_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgCatchSTMFrame *catchF = (StgCatchSTMFrame *)stack->sp;
+ SET_HDR(catchF, &stg_catch_stm_frame_info, CCS_SYSTEM);
+ StgClosure *payload1 = rts_mkWord(cap, w);
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
+ catchF->code = payload1;
+ catchF->handler = payload2;
+}
+
+// TODO: Use `w` for running_alt_code, too.
+void create_any_catch_retry_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgCatchRetryFrame *catchRF = (StgCatchRetryFrame *)stack->sp;
+ SET_HDR(catchRF, &stg_catch_retry_frame_info, CCS_SYSTEM);
+ StgClosure *payload1 = rts_mkWord(cap, w);
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
+ catchRF->running_alt_code = 1;
+ catchRF->first_code = payload1;
+ catchRF->alt_code = payload2;
+}
+
+void create_any_atomically_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgAtomicallyFrame *aF = (StgAtomicallyFrame *)stack->sp;
+ SET_HDR(aF, &stg_atomically_frame_info, CCS_SYSTEM);
+ StgClosure *payload1 = rts_mkWord(cap, w);
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
+ aF->code = payload1;
+ aF->result = payload2;
+}
+
+void create_any_ret_small_prim_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &stg_ret_n_info, CCS_SYSTEM);
+ // The cast is a lie (w is interpreted as plain Word, not as pointer), but the
+ // memory layout fits.
+ c->payload[0] = (StgClosure *)w;
+}
+
+void create_any_ret_small_closure_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &stg_ret_p_info, CCS_SYSTEM);
+ StgClosure *payload = rts_mkWord(cap, w);
+ c->payload[0] = payload;
+}
+
+#define MAX_SMALL_BITMAP_BITS (BITS_IN(W_) - BITMAP_BITS_SHIFT)
+
+StgWord maxSmallBitmapBits() { return MAX_SMALL_BITMAP_BITS; }
+
+RTS_RET(test_small_ret_full_p);
+void create_any_ret_small_closures_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_small_ret_full_p_info, CCS_SYSTEM);
+ for (int i = 0; i < MAX_SMALL_BITMAP_BITS; i++) {
+ StgClosure *payload1 = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ w++;
+ c->payload[i] = payload1;
+ }
+}
+
+RTS_RET(test_small_ret_full_n);
+void create_any_ret_small_prims_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_small_ret_full_n_info, CCS_SYSTEM);
+ for (int i = 0; i < MAX_SMALL_BITMAP_BITS; i++) {
+ c->payload[i] = (StgClosure *)w;
+ w++;
+ }
+}
+
+#define MIN_LARGE_BITMAP_BITS (MAX_SMALL_BITMAP_BITS + 1)
+
+RTS_RET(test_big_ret_min_n);
+void create_any_ret_big_prims_min_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_big_ret_min_n_info, CCS_SYSTEM);
+
+ for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = (StgClosure *)w;
+ w++;
+ }
+}
+
+RTS_RET(test_big_ret_min_p);
+void create_any_ret_big_closures_min_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_big_ret_min_p_info, CCS_SYSTEM);
+
+ for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ w++;
+ }
+}
+
+#define TWO_WORDS_LARGE_BITMAP_BITS (BITS_IN(W_) + 1)
+
+RTS_RET(test_big_ret_two_words_p);
+void create_any_ret_big_closures_two_words_frame(Capability *cap,
+ StgStack *stack, StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_big_ret_two_words_p_info, CCS_SYSTEM);
+
+ for (int i = 0; i < TWO_WORDS_LARGE_BITMAP_BITS; i++) {
+ c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w));
+ w++;
+ }
+}
+
+RTS_RET(test_ret_fun);
+RTS_RET(test_arg_n_fun_0_1);
+void create_any_ret_fun_arg_n_prim_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgRetFun *c = (StgRetFun *)stack->sp;
+ c->info = &test_ret_fun_info;
+ StgClosure *f =
+ (StgClosure *)allocate(cap, sizeofW(StgClosure) + sizeofW(StgWord));
+ SET_HDR(f, &test_arg_n_fun_0_1_info, ccs)
+ c->fun = f;
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
+ c->size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+ // The cast is a lie (w is interpreted as plain Word, not as pointer), but the
+ // memory layout fits.
+ c->payload[0] = (StgClosure *)w;
+ f->payload[0] = (StgClosure *)w;
+}
+
+RTS_CLOSURE(Main_argGenFun_closure);
+void create_any_ret_fun_arg_gen_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgRetFun *c = (StgRetFun *)stack->sp;
+ c->info = &test_ret_fun_info;
+ c->fun = &Main_argGenFun_closure;
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
+ c->size = BITMAP_SIZE(fun_info->f.b.bitmap);
+ for (int i = 0; i < c->size; i++) {
+ c->payload[i] = rts_mkWord(cap, w++);
+ }
+}
+
+RTS_CLOSURE(Main_argGenBigFun_closure);
+void create_any_ret_fun_arg_gen_big_frame(Capability *cap, StgStack *stack,
+ StgWord w) {
+ StgRetFun *c = (StgRetFun *)stack->sp;
+ c->info = &test_ret_fun_info;
+ c->fun = &Main_argGenBigFun_closure;
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun));
+ c->size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ for (int i = 0; i < c->size; i++) {
+ c->payload[i] = rts_mkWord(cap, w++);
+ }
+}
+
+RTS_RET(test_ret_bco);
+void create_any_bco_frame(Capability *cap, StgStack *stack, StgWord w) {
+ StgClosure *c = (StgClosure *)stack->sp;
+ SET_HDR(c, &test_ret_bco_info, CCS_SYSTEM);
+ StgWord bcoSizeWords = sizeofW(StgBCO) + sizeofW(StgLargeBitmap) + sizeofW(StgWord);
+ StgBCO *bco = allocate(cap, bcoSizeWords);
+ SET_HDR(bco, &stg_BCO_info, CCS_MAIN);
+ c->payload[0] = (StgClosure *)bco;
+
+ bco->size = bcoSizeWords;
+ bco->arity = 3;
+
+ StgArrBytes *instrs =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + sizeofW(StgWord));
+ SET_HDR(instrs, &stg_ARR_WORDS_info, CCCS);
+ instrs->bytes = WDS(1);
+ instrs->payload[0] = w++;
+ bco->instrs = instrs;
+
+ StgArrBytes *literals =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + sizeofW(StgWord));
+ SET_HDR(literals, &stg_ARR_WORDS_info, CCCS);
+ bco->literals = literals;
+ literals->bytes = WDS(1);
+ literals->payload[0] = w++;
+ bco->literals = literals;
+
+ StgWord ptrsSize = 1 + mutArrPtrsCardTableSize(1);
+ StgMutArrPtrs *ptrs = allocate(cap, sizeofW(StgMutArrPtrs) + ptrsSize);
+ SET_HDR(ptrs, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, ccs);
+ ptrs->ptrs = 1;
+ ptrs->size = ptrsSize;
+ ptrs->payload[0] = rts_mkWord(cap, w);
+ bco->ptrs = ptrs;
+
+ StgLargeBitmap *bitmap = (StgLargeBitmap *)bco->bitmap;
+ bitmap->size = 1;
+ bitmap->bitmap[0] = 0; // set bit 0 to 0 indicating a closure
+ 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);
+
+// Basically, a stripped down version of createThread() (regarding stack
+// creation)
+StgStack *setup(Capability *cap, StgWord closureSizeWords,
+ void (*f)(Capability *, StgStack *, StgWord)) {
+ StgWord totalSizeWords =
+ sizeofW(StgStack) + closureSizeWords + MIN_STACK_WORDS;
+ StgStack *stack = (StgStack *)allocate(cap, totalSizeWords);
+ SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM);
+ stack->stack_size = totalSizeWords - sizeofW(StgStack);
+ stack->dirty = 0;
+ stack->marking = 0;
+
+ StgPtr spBottom = stack->stack + stack->stack_size;
+ stack->sp = spBottom;
+ stack->sp -= sizeofW(StgStopFrame);
+ SET_HDR((StgClosure *)stack->sp, &stg_stop_thread_info, CCS_SYSTEM);
+ stack->sp -= closureSizeWords;
+
+ // Pointers can easÃly be confused with each other. Provide a start value for
+ // values (1) in closures and increment it after every usage. The goal is to
+ // have distinct values in the closure to ensure nothing gets mixed up.
+ f(cap, stack, 1);
+
+ // Make a sanitiy check to find unsound closures before the GC and the decode
+ // code.
+ checkSTACK(stack);
+ return stack;
+}
+
+StgStack *any_update_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgUpdateFrame), &create_any_update_frame);
+}
+
+StgStack *any_catch_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchFrame), &create_any_catch_frame);
+}
+
+StgStack *any_catch_stm_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchSTMFrame), &create_any_catch_stm_frame);
+}
+
+StgStack *any_catch_retry_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgCatchRetryFrame), &create_any_catch_retry_frame);
+}
+
+StgStack *any_atomically_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgAtomicallyFrame), &create_any_atomically_frame);
+}
+
+StgStack *any_ret_small_prim_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgClosure) + sizeofW(StgWord),
+ &create_any_ret_small_prim_frame);
+}
+
+StgStack *any_ret_small_closure_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgClosure) + sizeofW(StgClosurePtr),
+ &create_any_ret_small_closure_frame);
+}
+
+StgStack *any_ret_small_closures_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgClosurePtr),
+ &create_any_ret_small_closures_frame);
+}
+
+StgStack *any_ret_small_prims_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgWord),
+ &create_any_ret_small_prims_frame);
+}
+
+StgStack *any_ret_big_closures_min_frame(Capability *cap) {
+ return setup(
+ cap, sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgClosure),
+ &create_any_ret_big_closures_min_frame);
+}
+
+StgStack *any_ret_big_closures_two_words_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) +
+ TWO_WORDS_LARGE_BITMAP_BITS * sizeofW(StgClosure),
+ &create_any_ret_big_closures_two_words_frame);
+}
+
+StgStack *any_ret_big_prims_min_frame(Capability *cap) {
+ return setup(cap,
+ sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgWord),
+ &create_any_ret_big_prims_min_frame);
+}
+
+StgStack *any_ret_fun_arg_n_prim_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgRetFun) + sizeofW(StgWord),
+ &create_any_ret_fun_arg_n_prim_frame);
+}
+
+StgStack *any_ret_fun_arg_gen_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgRetFun) + 9 * sizeofW(StgClosure),
+ &create_any_ret_fun_arg_gen_frame);
+}
+
+StgStack *any_ret_fun_arg_gen_big_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgRetFun) + 59 * sizeofW(StgWord),
+ &create_any_ret_fun_arg_gen_big_frame);
+}
+
+StgStack *any_bco_frame(Capability *cap) {
+ return setup(cap, sizeofW(StgClosure) + 2 * sizeofW(StgWord),
+ &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); }
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -0,0 +1,231 @@
+#include "Cmm.h"
+
+any_update_framezh() {
+ P_ stack;
+ ("ptr" stack) = ccall any_update_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_catch_framezh() {
+ P_ stack;
+ (stack) = ccall any_catch_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_catch_stm_framezh() {
+ P_ stack;
+ (stack) = ccall any_catch_stm_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_catch_retry_framezh() {
+ P_ stack;
+ (stack) = ccall any_catch_retry_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_atomically_framezh() {
+ P_ stack;
+ (stack) = ccall any_atomically_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_small_prim_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_small_prim_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_small_prims_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_small_prims_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_small_closure_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_small_closure_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_small_closures_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_small_closures_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_big_prims_min_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_big_prims_min_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_big_closures_min_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_big_closures_min_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_big_closures_two_words_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_big_closures_two_words_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_fun_arg_n_prim_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_n_prim_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_fun_arg_gen_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_gen_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_ret_fun_arg_gen_big_framezh() {
+ P_ stack;
+ (stack) = ccall any_ret_fun_arg_gen_big_frame(MyCapability() "ptr");
+ return (stack);
+}
+
+any_bco_framezh() {
+ P_ stack;
+ (stack) = ccall any_bco_frame(MyCapability() "ptr");
+ 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,
+P_ ptr11, P_ ptr12, P_ ptr13, P_ ptr14, P_ ptr15, P_ ptr16, P_ ptr17, P_ ptr18, P_ ptr19, P_ ptr20,
+P_ ptr21, P_ ptr22, P_ ptr23, P_ ptr24, P_ ptr25, P_ ptr26, P_ ptr27
+)
+#elif SIZEOF_VOID_P == 8
+P_ ptr1, P_ ptr2, P_ ptr3, P_ ptr4, P_ ptr5, P_ ptr6, P_ ptr7, P_ ptr8, P_ ptr9, P_ ptr10,
+P_ ptr11, P_ ptr12, P_ ptr13, P_ ptr14, P_ ptr15, P_ ptr16, P_ ptr17, P_ ptr18, P_ ptr19, P_ ptr20,
+P_ ptr21, P_ ptr22, P_ ptr23, P_ ptr24, P_ ptr25, P_ ptr26, P_ ptr27, P_ ptr28, P_ ptr29, P_ ptr30,
+P_ ptr31, P_ ptr32, P_ ptr33, P_ ptr34, P_ ptr35, P_ ptr36, P_ ptr37, P_ ptr38, P_ ptr39, P_ ptr40,
+P_ ptr41, P_ ptr42, P_ ptr43, P_ ptr44, P_ ptr45, P_ ptr46, P_ ptr47, P_ ptr48, P_ ptr49, P_ ptr50,
+P_ ptr51, P_ ptr52, P_ ptr53, P_ ptr54, P_ ptr55, P_ ptr56, P_ ptr57, P_ ptr58
+)
+#endif
+ return (/* no return values */)
+{
+ return ();
+}
+
+INFO_TABLE_RET ( test_small_ret_full_n, RET_SMALL, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
+W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
+W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27
+)
+#elif SIZEOF_VOID_P == 8
+W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
+W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
+W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28, W_ n29, W_ n30,
+W_ n31, W_ n32, W_ n33, W_ n34, W_ n35, W_ n36, W_ n37, W_ n38, W_ n39, W_ n40,
+W_ n41, W_ n42, W_ n43, W_ n44, W_ n45, W_ n46, W_ n47, W_ n48, W_ n49, W_ n50,
+W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58
+)
+#endif
+ return (/* no return values */)
+{
+ return ();
+}
+
+// Size of this large bitmap closure is: max size of small bitmap + 1
+INFO_TABLE_RET ( test_big_ret_min_n, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
+W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
+W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28
+#elif SIZEOF_VOID_P == 8
+W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10,
+W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20,
+W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28, W_ n29, W_ n30,
+W_ n31, W_ n32, W_ n33, W_ n34, W_ n35, W_ n36, W_ n37, W_ n38, W_ n39, W_ n40,
+W_ n41, W_ n42, W_ n43, W_ n44, W_ n45, W_ n46, W_ n47, W_ n48, W_ n49, W_ n50,
+W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58, W_ n59
+#endif
+)
+ return (/* no return values */)
+{
+ return ();
+}
+
+// Size of this large bitmap closure is: max size of small bitmap + 1
+INFO_TABLE_RET ( test_big_ret_min_p, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28
+#elif SIZEOF_VOID_P == 8
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40,
+P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50,
+P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59
+#endif
+)
+ return (/* no return values */)
+{
+ return ();
+}
+
+// Size of this large bitmap closure is: max size of bits in word + 1
+// This results in a two word StgLargeBitmap.
+INFO_TABLE_RET ( test_big_ret_two_words_p, RET_BIG, W_ info_ptr,
+#if SIZEOF_VOID_P == 4
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33
+#elif SIZEOF_VOID_P == 8
+P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10,
+P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20,
+P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30,
+P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40,
+P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50,
+P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59, P_ p60,
+P_ p61, P_ p62, P_ p63, P_ p64, P_ p65
+#endif
+)
+ return (/* no return values */)
+{
+ return ();
+}
+
+// A BLACKHOLE without any code. Just a placeholder to keep the GC happy.
+INFO_TABLE(test_fake_blackhole,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+ (P_ node)
+{
+ return ();
+}
+
+INFO_TABLE_RET ( test_ret_fun, RET_FUN, W_ info_ptr, W_ size, P_ fun, P_ payload)
+ return (/* no return values */)
+{
+ return ();
+}
+
+INFO_TABLE_FUN ( test_arg_n_fun_0_1, 0 , 0, FUN_0_1, "FUN_0_1", "FUN_0_1", 1, ARG_N)
+ return (/* no return values */)
+{
+ return ();
+}
+
+INFO_TABLE_RET( test_ret_bco, RET_BCO)
+ return (/* no return values */)
+{
+ return ();
+}
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -0,0 +1,38 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Concurrent.STM
+import Control.Exception
+import GHC.Conc
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap.ClosureTypes
+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
+ (stackSnapshot, decodedStack) <-
+ atomically $
+ catchSTM @SomeException (unsafeIOToSTM getDecodedStack) throwSTM
+
+ assertStackInvariants stackSnapshot decodedStack
+ assertThat
+ "Stack contains one catch stm frame"
+ (== 1)
+ (length $ filter isCatchStmFrame decodedStack)
+ assertThat
+ "Stack contains one atomically frame"
+ (== 1)
+ (length $ filter isAtomicallyFrame decodedStack)
+
+isCatchStmFrame :: Closure -> Bool
+isCatchStmFrame (CatchStmFrame {..}) = tipe info == CATCH_STM_FRAME
+isCatchStmFrame _ = False
+
+isAtomicallyFrame :: Closure -> Bool
+isAtomicallyFrame (AtomicallyFrame {..}) = tipe info == ATOMICALLY_FRAME
+isAtomicallyFrame _ = False
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Data.Bool (Bool (True))
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import TestUtils
+
+main = loop 128
+
+{-# NOINLINE loop #-}
+loop 0 = () <$ getStack
+loop n = print "x" >> loop (n - 1) >> print "x"
+
+getStack :: HasCallStack => IO ()
+getStack = do
+ (s, decodedStack) <- getDecodedStack
+ -- Uncomment to see the frames (for debugging purposes)
+ -- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
+ assertStackInvariants s decodedStack
+ assertThat
+ "Stack contains underflow frames"
+ (== True)
+ (any isUnderflowFrame decodedStack)
+ assertStackChunksAreDecodable decodedStack
+ return ()
+
+isUnderflowFrame (UnderflowFrame {..}) = tipe info == UNDERFLOW_FRAME
+isUnderflowFrame _ = False
+
+assertStackChunksAreDecodable :: HasCallStack => [Closure] -> IO ()
+assertStackChunksAreDecodable s = do
+ let underflowFrames = filter isUnderflowFrame s
+ stackClosures <- mapM (getBoxedClosureData . nextChunk) underflowFrames
+ let stackBoxes = map stack stackClosures
+ framesOfChunks <- sequence (map (mapM getBoxedClosureData) stackBoxes)
+ assertThat
+ "No empty stack chunks"
+ (== True)
+ ( not (any null framesOfChunks)
+ )
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
- CPP #-}
+ CPP, MagicHash, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
-- |
@@ -53,7 +53,11 @@ import qualified Language.Haskell.TH.Syntax as TH
import System.Exit
import System.IO
import System.IO.Error
-
+#if MIN_VERSION_base(4,17,0)
+import GHC.Stack.CloneStack
+import GHC.Word (Word(W#))
+import GHC.Exts (Word#, unsafeCoerce#, StackSnapshot#)
+#endif
-- -----------------------------------------------------------------------------
-- The RPC protocol between GHC and the interactive server
@@ -471,6 +475,21 @@ instance Binary Heap.WhyBlocked
instance Binary Heap.TsoFlags
#endif
+#if MIN_VERSION_base(4,17,0)
+instance Binary Heap.SpecialRetSmall
+instance Binary Heap.UpdateFrameType
+instance Binary Heap.RetFunType
+-- TODO: Revisit this. This instance is pretty hacky (unsafeCoerce# ...)
+instance Binary StackSnapshot where
+ get = do
+ v <- get @Word
+ pure $ StackSnapshot (toPrim v)
+ where
+ toPrim :: Word -> StackSnapshot#
+ toPrim (W# w#) = unsafeCoerce# w#
+ put (StackSnapshot s#) = put (W# ((unsafeCoerce# s#) :: Word#))
+#endif
+
instance Binary Heap.StgInfoTable
instance Binary Heap.ClosureType
instance Binary Heap.PrimType
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
- UnboxedTuples #-}
+ UnboxedTuples, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -94,7 +94,11 @@ run m = case m of
StartTH -> startTH
GetClosure ref -> do
clos <- Heap.getClosureData =<< localRef ref
- mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
+ mapM (\case
+ Heap.Box x -> mkRemoteRef (HValue x)
+ -- TODO: Is this unsafeCoerce really necessary?
+ Heap.StackFrameBox d -> mkRemoteRef (HValue (unsafeCoerce d))
+ ) clos
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
_other -> error "GHCi.Run.run"
=====================================
rts/Heap.c
=====================================
@@ -12,6 +12,7 @@
#include "Capability.h"
#include "Printer.h"
+#include "rts/storage/InfoTables.h"
StgWord heap_view_closureSize(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
@@ -256,7 +257,6 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) {
StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
-
StgWord size = heap_view_closureSize(closure);
// First collect all pointers here, with the comfortable memory bound
=====================================
rts/PrimOps.cmm
=====================================
@@ -2518,7 +2518,6 @@ stg_unpackClosurezh ( P_ closure )
W_ clos;
clos = UNTAG(closure);
-
W_ len;
// The array returned, dat_arr, is the raw data for the entire closure.
// The length is variable based upon the closure type, ptrs, and non-ptrs
=====================================
rts/Printer.c
=====================================
@@ -260,6 +260,7 @@ printClosure( const StgClosure *obj )
case UPDATE_FRAME:
{
StgUpdateFrame* u = (StgUpdateFrame*)obj;
+ debugBelch("printObj - frame %p, indirectee %p\n", u, u->updatee);
debugBelch("%s(", info_update_frame(obj));
printPtr((StgPtr)GET_INFO((StgClosure *)u));
debugBelch(",");
@@ -279,6 +280,32 @@ printClosure( const StgClosure *obj )
break;
}
+ case CATCH_STM_FRAME:
+ {
+ StgCatchSTMFrame* c = (StgCatchSTMFrame*)obj;
+ debugBelch("CATCH_STM_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)c));
+ debugBelch(",");
+ printPtr((StgPtr)c->code);
+ debugBelch(",");
+ printPtr((StgPtr)c->handler);
+ debugBelch(")\n");
+ break;
+ }
+
+ case ATOMICALLY_FRAME :
+ {
+ StgAtomicallyFrame* f = (StgAtomicallyFrame*)obj;
+ debugBelch("ATOMICALLY_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)f));
+ debugBelch(",");
+ printPtr((StgPtr)f->code);
+ debugBelch(",");
+ printPtr((StgPtr)f->result);
+ debugBelch(")\n");
+ break;
+ }
+
case UNDERFLOW_FRAME:
{
StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
@@ -464,6 +491,7 @@ const char *info_update_frame(const StgClosure *closure)
// it pointing to the code or struct members when compiling with
// TABLES_NEXT_TO_CODE.
const StgInfoTable *info = closure->header.info;
+ debugBelch("info_update_frame - closure %p, info %p\n", closure, info);
if (info == &stg_upd_frame_info) {
return "NORMAL_UPDATE_FRAME";
} else if (info == &stg_bh_upd_frame_info) {
@@ -474,21 +502,46 @@ const char *info_update_frame(const StgClosure *closure)
return "ERROR: Not an update frame!!!";
}
}
+// TODO: Remove later
+// Assumes little endian
+void printBits(size_t const size, void const * const ptr)
+{
+ unsigned char *b = (unsigned char*) ptr;
+ unsigned char byte;
+ int i, j;
+
+ for (i = size-1; i >= 0; i--) {
+ for (j = 7; j >= 0; j--) {
+ byte = (b[i] >> j) & 1;
+ debugBelch("%u", byte);
+ }
+ }
+ debugBelch("\n");
+}
+
+StgPtr origSp = NULL;
static void
printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
uint32_t size )
{
+ debugBelch("printSmallBitmap - payload %p\n", payload);
+ debugBelch("printSmallBitmap - bitmap ");
+ printBits(sizeof(StgWord), &bitmap);
+ debugBelch("printSmallBitmap - size %u, bitmap %ul\n", size, bitmap);
+
uint32_t i;
for(i = 0; i < size; i++, bitmap >>= 1 ) {
+ debugBelch("printSmallBitmap - index %ld\n", &payload[i] - origSp);
debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
+ debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
@@ -503,36 +556,44 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
i = 0;
for (bmp=0; i < size; bmp++) {
StgWord bitmap = large_bitmap->bitmap[bmp];
+ debugBelch("printLargeBitmap - bitmap no %ul, bits ", bmp);
+ printBits(sizeof(StgWord), &bitmap);
j = 0;
for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
debugBelch(" stk[%" FMT_Word "] (%p) = ", (W_)(spBottom-(payload+i)), payload+i);
if ((bitmap & 1) == 0) {
+ debugBelch("closure - ");
printPtr((P_)payload[i]);
debugBelch(" -- ");
printObj((StgClosure*) payload[i]);
} else {
- debugBelch("Word# %" FMT_Word "\n", (W_)payload[i]);
+ debugBelch("primitive - Word# %" FMT_Word "\n", (W_)payload[i]);
}
}
}
}
+
void
printStackChunk( StgPtr sp, StgPtr spBottom )
{
const StgInfoTable *info;
+ origSp = sp;
ASSERT(sp <= spBottom);
for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) {
-
info = get_itbl((StgClosure *)sp);
+ debugBelch("printStackChunk - closure size : %lu , sp : %p, spBottom %p, info ptr %p, itbl type %ul \n", stack_frame_sizeW((StgClosure *)sp), sp, spBottom, info, info->type);
+ debugBelch("printStackChunk - index: %ld \n", sp - origSp);
switch (info->type) {
+ case UNDERFLOW_FRAME:
case UPDATE_FRAME:
case CATCH_FRAME:
- case UNDERFLOW_FRAME:
case STOP_FRAME:
+ case CATCH_STM_FRAME:
+ case ATOMICALLY_FRAME:
printClosure((StgClosure*)sp);
continue;
@@ -590,6 +651,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("RET_SMALL (%p)\n", info);
}
StgWord bitmap = info->layout.bitmap;
+ debugBelch("printStackChunk - RET_SMALL - bitmap: %lu \n", bitmap);
printSmallBitmap(spBottom, sp+1,
BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
continue;
@@ -648,7 +710,10 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case RET_BIG:
debugBelch("RET_BIG (%p)\n", sp);
+ debugBelch("payload ptr : %p \n", (StgPtr)((StgClosure *) sp)->payload);
StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ debugBelch("bitmap ptr %p\n", bitmap);
+ debugBelch("bitmap size %ul\n", bitmap->size);
printLargeBitmap(spBottom,
(StgPtr)((StgClosure *) sp)->payload,
bitmap,
@@ -664,17 +729,18 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
switch (fun_info->f.fun_type) {
case ARG_GEN:
- printSmallBitmap(spBottom, sp+2,
+ printSmallBitmap(spBottom, sp+3,
BITMAP_BITS(fun_info->f.b.bitmap),
BITMAP_SIZE(fun_info->f.b.bitmap));
break;
case ARG_GEN_BIG:
- printLargeBitmap(spBottom, sp+2,
+ printLargeBitmap(spBottom, sp+3,
GET_FUN_LARGE_BITMAP(fun_info),
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
- printSmallBitmap(spBottom, sp+2,
+ // sp + 3 because the payload's offset is 24
+ printSmallBitmap(spBottom, sp+3,
BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
break;
@@ -691,6 +757,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
void printStack( StgStack *stack )
{
+ debugBelch("printStack - stack %p, sp %p, size %ul, bottom %p\n", stack, stack->sp, stack->stack_size, stack->stack + stack->stack_size);
+
printStackChunk( stack->sp, stack->stack + stack->stack_size );
}
=====================================
rts/RtsSymbols.c
=====================================
@@ -985,6 +985,7 @@ extern char **environ;
SymI_HasDataProto(stg_unpack_cstring_info) \
SymI_HasDataProto(stg_unpack_cstring_utf8_info) \
SymI_HasDataProto(stg_upd_frame_info) \
+ SymI_HasDataProto(stg_marked_upd_frame_info) \
SymI_HasDataProto(stg_bh_upd_frame_info) \
SymI_HasProto(suspendThread) \
SymI_HasDataProto(stg_takeMVarzh) \
=====================================
rts/include/rts/storage/InfoTables.h
=====================================
@@ -122,7 +122,7 @@ extern const StgWord16 closure_flags[];
/*
* A large bitmap.
*/
-typedef struct {
+typedef struct StgLargeBitmap_ {
StgWord size;
StgWord bitmap[];
} StgLargeBitmap;
=====================================
rts/sm/Sanity.c
=====================================
@@ -42,7 +42,6 @@ int isHeapAlloced ( StgPtr p);
static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t );
static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t );
static void checkClosureShallow ( const StgClosure * );
-static void checkSTACK (StgStack *stack);
static W_ countNonMovingSegments ( struct NonmovingSegment *segs );
static W_ countNonMovingHeap ( struct NonmovingHeap *heap );
@@ -63,6 +62,7 @@ checkSmallBitmap( StgPtr payload, StgWord bitmap, uint32_t size )
{
uint32_t i;
+ debugBelch("checkSmallBitmap - payload %p , bitmap %lu, size %u\n", payload, bitmap, size);
for(i = 0; i < size; i++, bitmap >>= 1 ) {
if ((bitmap & 1) == 0) {
checkClosureShallow((StgClosure *)payload[i]);
@@ -713,7 +713,7 @@ checkCompactObjects(bdescr *bd)
}
}
-static void
+void
checkSTACK (StgStack *stack)
{
StgPtr sp = stack->sp;
@@ -1325,5 +1325,9 @@ memInventory (bool show)
}
-
+//TODO: Remove after debugging
+#else
+void
+checkSTACK (StgStack *stack){}
+void checkSanity (bool after_gc, bool major_gc){}
#endif /* DEBUG */
=====================================
rts/sm/Sanity.h
=====================================
@@ -39,6 +39,7 @@ void memInventory (bool show);
void checkBQ (StgTSO *bqe, StgClosure *closure);
+void checkSTACK (StgStack *stack);
#include "EndPrivate.h"
#endif /* DEBUG */
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -476,6 +476,7 @@ wanteds os = concat
,closureFieldOffset Both "StgStack" "stack"
,closureField C "StgStack" "stack_size"
,closureField C "StgStack" "dirty"
+ ,closureField C "StgStack" "marking"
,structSize C "StgTSOProfInfo"
@@ -484,6 +485,11 @@ wanteds os = concat
,closureField C "StgCatchFrame" "handler"
,closureField C "StgCatchFrame" "exceptions_blocked"
+ ,structSize C "StgRetFun"
+ ,fieldOffset C "StgRetFun" "size"
+ ,fieldOffset C "StgRetFun" "fun"
+ ,fieldOffset C "StgRetFun" "payload"
+
,closureSize C "StgPAP"
,closureField C "StgPAP" "n_args"
,closureFieldGcptr C "StgPAP" "fun"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5eca62068019172d87da9451cde56bf527141c3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5eca62068019172d87da9451cde56bf527141c3
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/20230204/5b0f6aef/attachment-0001.html>
More information about the ghc-commits
mailing list