[Git][ghc/ghc][wip/decode_cloned_stack] ghc-heap: Decode StgStack and its frames
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Feb 26 16:50:17 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
531ca427 by Sven Tennie at 2023-02-26T16:48: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].
- - - - -
28 changed files:
- compiler/GHC/Cmm/CLabel.hs
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Decode.hs
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- + libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- + libraries/ghc-heap/cbits/Stack.c
- + libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/ClosureSizeUtils.hs
- 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/Printer.c
- rts/include/rts/storage/InfoTables.h
- rts/sm/Sanity.c
- rts/sm/Sanity.h
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -794,6 +794,7 @@ isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
-- info table defined in cmm (.cmm)
isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True
+isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True
isSomeRODataLabel _lbl = False
-- | Whether label is points to some kind of info table
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -19,29 +19,47 @@ module GHC.Stack.CloneStack (
StackEntry(..),
cloneMyStack,
cloneThreadStack,
- decode
+ decode,
+ stackSnapshotToString
) where
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#)
import GHC.IO (IO (..))
import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipLoc, ipeProv, peekInfoProv)
import GHC.Stable
+import GHC.Word
+import Numeric
-- | A frozen snapshot of the state of an execution stack.
--
-- @since 4.17.0.0
data StackSnapshot = StackSnapshot !StackSnapshot#
+instance Show StackSnapshot where
+ showsPrec _ stack rs =
+ "StackSnapshot(" ++ stackSnapshotToString stack ++ ")" ++ rs
+
+stackSnapshotToString :: StackSnapshot -> String
+stackSnapshotToString (StackSnapshot s#) = pad_out (showHex addr "")
+ where
+ addr = W# (unsafeCoerce# s#)
+ pad_out ls = '0':'x':ls
+
+instance Eq StackSnapshot where
+ (StackSnapshot s1#) == (StackSnapshot s2#) = (W# (eqStacks# s1# s2#)) > 0
+
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# #)
foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #)
+foreign import prim "eqStackszh" eqStacks# :: StackSnapshot# -> StackSnapshot# -> Word#
+
{-
Note [Stack Cloning]
~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/cbits/StackCloningDecoding.cmm
=====================================
@@ -24,3 +24,7 @@ stg_decodeStackzh (gcptr stgStack) {
return (stackEntries);
}
+
+eqStackszh(P_ stack1, P_ stack2) {
+ return (stack1 == stack2);
+}
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,6 +7,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+{-# LANGUAGE RecordWildCards #-}
+#endif
{-# LANGUAGE UnliftedFFITypes #-}
{-|
@@ -27,6 +30,7 @@ module GHC.Exts.Heap (
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
+ , RetFunType(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
, getClosureDataFromHeapRep
@@ -50,6 +54,7 @@ module GHC.Exts.Heap (
-- * Closure inspection
, getBoxedClosureData
, allClosures
+ , closureSize
-- * Boxes
, Box(..)
@@ -60,22 +65,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.Heap.Decode
-import Data.Bits
-import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+import GHC.Stack.CloneStack
+import GHC.Exts.Stack.Decode
+import GHC.Exts.Stack.Constants
+import Data.Functor
+import Debug.Trace
+#endif
+
#include "ghcconfig.h"
@@ -130,6 +138,11 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
+#if MIN_TOOL_VERSION_ghc(9,7,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
@@ -163,223 +176,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,7,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_TOOL_VERSION_ghc(9,7,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,16 @@ module GHC.Exts.Heap.Closures (
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
+ , RetFunType(..)
, allClosures
- , closureSize
-- * Boxes
, Box(..)
, areBoxesEqual
, asBox
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+ , StackFrameIter(..)
+#endif
) where
import Prelude -- See note [Why do we import Prelude here?]
@@ -48,6 +51,11 @@ import GHC.Exts
import GHC.Generics
import Numeric
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+import GHC.Stack.CloneStack (StackSnapshot(..), stackSnapshotToString)
+import GHC.Exts.Stack.Constants
+#endif
+
------------------------------------------------------------------------
-- Boxes
@@ -56,11 +64,63 @@ foreign import prim "aToWordzh" aToWord# :: Any -> Word#
foreign import prim "reallyUnsafePtrEqualityUpToTag"
reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+-- | Iterator state for stack decoding
+data StackFrameIter =
+ -- | Represents a `StackClosure` / @StgStack@
+ SfiStackClosure
+ { stackSnapshot# :: !StackSnapshot# }
+ -- | Represents a closure on the stack
+ | SfiClosure
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset
+ }
+ -- | Represents a primitive word on the stack
+ | SfiPrimitive
+ { stackSnapshot# :: !StackSnapshot#,
+ index :: !WordOffset
+ }
+
+instance Eq StackFrameIter where
+ (SfiStackClosure s1#) == (SfiStackClosure s2#) =
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ (SfiClosure s1# i1) == (SfiClosure s2# i2) =
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ && i1 == i2
+ (SfiPrimitive s1# i1) == (SfiPrimitive s2# i2) =
+ (StackSnapshot s1#) == (StackSnapshot s2#)
+ && i1 == i2
+ _ == _ = False
+
+instance Show StackFrameIter where
+ showsPrec _ (SfiStackClosure s#) rs =
+ "SfiStackClosure { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ "}" ++ rs
+ showsPrec _ (SfiClosure s# i ) rs =
+ "SfiClosure { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ show i ++ ", " ++ "}" ++ rs
+ showsPrec _ (SfiPrimitive s# i ) rs =
+ "SfiPrimitive { stackSnapshot# = " ++ stackSnapshotToString (StackSnapshot s#) ++ show i ++ ", " ++ "}" ++ rs
+
+-- | 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.
+--
+-- `Box`es can be used to increase (and enforce) laziness: In a graph of
+-- closures they can act as a barrier of evaluation. `Closure` is an example for
+-- this.
+data Box =
+ -- | A heap located closure.
+ Box Any
+ -- | A value or reference to a value on the stack.
+ | StackFrameBox StackFrameIter
+#else
-- | 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.
data Box = Box Any
+#endif
instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
@@ -72,6 +132,22 @@ 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_TOOL_VERSION_ghc(9,7,0)
+ showsPrec _ (StackFrameBox sfi) rs =
+ "(StackFrameBox " ++ 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.
+areBoxesEqual :: Box -> Box -> IO Bool
+areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
+ 0# -> pure False
+ _ -> pure True
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+areBoxesEqual (StackFrameBox sfi1) (StackFrameBox sfi2) =
+ pure $ sfi1 == sfi2
+areBoxesEqual _ _ = pure False
+#endif
-- |This takes an arbitrary value and puts it into a box.
-- Note that calls like
@@ -85,14 +161,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 +369,74 @@ 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,7,0)
+ | UpdateFrame
+ { info :: !StgInfoTable
+ , 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
+ }
+
+ | UnderflowFrame
+ { info :: !StgInfoTable
+ , nextChunk :: !b
+ }
+
+ | StopFrame
+ { info :: !StgInfoTable }
+
+ | RetSmall
+ { info :: !StgInfoTable
+ , payload :: ![b]
+ }
+
+ | RetBig
+ { info :: !StgInfoTable
+ , payload :: ![b]
+ }
+
+ | RetFun
+ { info :: !StgInfoTable
+ , retFunType :: RetFunType
+ , retFunSize :: Word
+ , retFunFun :: !b
+ , retFunPayload :: ![b]
+ }
+
+ | RetBCO
+ { info :: !StgInfoTable
+ , bco :: !b -- must be a BCOClosure
+ , bcoArgs :: ![b]
+ }
+#endif
------------------------------------------------------------
-- Unboxed unlifted closures
@@ -354,8 +488,42 @@ data GenClosure b
| UnsupportedClosure
{ info :: !StgInfoTable
}
- deriving (Show, Generic, Functor, Foldable, Traversable)
+ | UnknownTypeWordSizedPrimitive
+ { wordVal :: !Word }
+ deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+
+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 +592,16 @@ 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,7,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/Decode.hs
=====================================
@@ -0,0 +1,244 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module GHC.Exts.Heap.Decode 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/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/Stack/Constants.hsc
=====================================
@@ -0,0 +1,130 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module GHC.Exts.Stack.Constants where
+
+#if MIN_TOOL_VERSION_ghc(9,7,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/GHC/Exts/Stack/Decode.hs
=====================================
@@ -0,0 +1,461 @@
+{-# LANGUAGE CPP #-}
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module GHC.Exts.Stack.Decode
+ ( decodeStack,
+ unpackStackFrameIter,
+ )
+where
+
+import Data.Array.Byte
+import Data.Bits
+import Data.Maybe
+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.Stack.Constants
+import GHC.IO (IO (..))
+import GHC.Stack.CloneStack
+import GHC.Word
+import Prelude
+
+{- 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 iterator (StackFrameIter) deals with the mentioned challenges
+regarding garbage collected memory. It consists of the StgStack itself and the
+mentioned offset (or index) where needed.
+
+It has three constructors:
+
+- SfiStackClosure: Represents the StgStack closure itself. As stacks are chained
+ by underflow frames, there can be multiple StgStack closures per logical
+ stack.
+
+- SfiClosure: Represents a closure on the stack. The location on the stack is
+ defined by the StgStack itself and an index into it.
+
+- SfiPrimitive: Is structurally equivalent to SfiClosure, but represents a data
+ Word on the stack. These appear as payloads to closures with bitmap layout.
+ From the RTS-perspective, there's no information about the concrete type of
+ the Word. So, it's just handled as Word in further processing.
+
+The `stackSnapshot# :: !StackSnapshot#` field represents a StgStack closure. It
+is updated by the garbage collector when the stack closure is moved.
+
+The relative offset (index) describes the location of a stack frame on the
+stack. 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 (index) 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.)
+
+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 (StackFrameIter).
+
+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 "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
+
+getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
+getUnderflowFrameNextChunk (SfiClosure {..}) = IO $ \s ->
+ case getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, stack# #) -> (# s1, StackSnapshot stack# #)
+getUnderflowFrameNextChunk sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+getWord :: StackFrameIter -> WordOffset -> IO Word
+getWord (SfiPrimitive {..}) relativeOffset = IO $ \s ->
+ case getWord#
+ stackSnapshot#
+ (wordOffsetToWord# index)
+ (wordOffsetToWord# relativeOffset)
+ s of
+ (# s1, w# #) -> (# s1, W# w# #)
+getWord (SfiClosure {..}) relativeOffset = IO $ \s ->
+ case getWord#
+ stackSnapshot#
+ (wordOffsetToWord# index)
+ (wordOffsetToWord# relativeOffset)
+ s of
+ (# s1, w# #) -> (# s1, W# w# #)
+getWord sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+type WordGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
+foreign import prim "getRetFunTypezh" getRetFunType# :: WordGetter
+
+getRetFunType :: StackFrameIter -> IO RetFunType
+getRetFunType (SfiClosure {..}) =
+ toEnum . fromInteger . toInteger
+ <$> IO
+ ( \s ->
+ case getRetFunType#
+ stackSnapshot#
+ (wordOffsetToWord# index)
+ s of
+ (# s1, rft# #) -> (# s1, W# rft# #)
+ )
+getRetFunType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
+
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter
+
+type SmallBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
+
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
+
+foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
+
+foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#
+
+foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
+
+getInfoTable :: StackFrameIter -> IO StgInfoTable
+getInfoTable SfiClosure {..} =
+ let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
+ in peekItbl infoTablePtr
+getInfoTable SfiStackClosure {..} =
+ peekItbl $
+ Ptr (getStackInfoTableAddr# stackSnapshot#)
+getInfoTable _ = 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 SfiStackClosure {..} = IO $ \s ->
+ case getStackFields# stackSnapshot# s of
+ (# s1, sSize#, sDirty#, sMarking# #) ->
+ (# s1, (W32# sSize#, W8# sDirty#, W8# sMarking#) #)
+getStackFields sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+-- | Get an interator starting with the top-most stack frame
+stackHead :: StackSnapshot -> StackFrameIter
+stackHead (StackSnapshot s) = SfiClosure s 0 -- GHC stacks are never empty
+
+-- | Advance to the next stack frame (if any)
+--
+-- The last `Int#` in the result tuple is meant to be treated as bool
+-- (has_next).
+foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
+-- | Advance iterator to the next stack frame (if any)
+advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
+advanceStackFrameIter (SfiClosure {..}) =
+ let !(# s', i', hasNext #) = advanceStackFrameIter# stackSnapshot# (wordOffsetToWord# index)
+ in if I# hasNext > 0
+ then Just $ SfiClosure s' (primWordToWordOffset i')
+ else Nothing
+ where
+ primWordToWordOffset :: Word# -> WordOffset
+ primWordToWordOffset w# = fromIntegral (W# w#)
+advanceStackFrameIter sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+getClosure :: StackFrameIter -> WordOffset -> IO Box
+getClosure SfiClosure {..} relativeOffset =
+ IO $ \s ->
+ case getBoxedClosure#
+ stackSnapshot#
+ (wordOffsetToWord# (index + relativeOffset))
+ s of
+ (# s1, ptr #) ->
+ (# s1, Box ptr #)
+getClosure sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+decodeLargeBitmap :: LargeBitmapGetter -> StackFrameIter -> WordOffset -> IO [Box]
+decodeLargeBitmap getterFun# sfi@(SfiClosure {..}) 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
+ where
+ 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)
+
+ sizeofByteArray :: ByteArray# -> Int
+ sizeofByteArray arr# = I# (sizeofByteArray# arr#)
+decodeLargeBitmap _ sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
+decodeBitmaps (SfiClosure {..}) relativePayloadOffset bitmapWords size =
+ let bes = wordsToBitmapEntries (index + relativePayloadOffset) bitmapWords size
+ in mapM toBitmapPayload bes
+ where
+ toBitmapPayload :: StackFrameIter -> IO Box
+ toBitmapPayload sfi at SfiPrimitive {} = pure (StackFrameBox sfi)
+ toBitmapPayload sfi at SfiClosure {} = getClosure sfi 0
+ toBitmapPayload sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+ wordsToBitmapEntries :: WordOffset -> [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 index' (b : bs) bitmapSize =
+ let entries = toBitmapEntries index' b (min bitmapSize (fromIntegral wORD_SIZE_IN_BITS))
+ mbLastFrame = (listToMaybe . reverse) entries
+ in case mbLastFrame of
+ Just sfi' ->
+ entries
+ ++ wordsToBitmapEntries
+ ((getIndex sfi') + 1)
+ bs
+ subtractDecodedBitmapWord
+ _ -> error "This should never happen! Recursion ended not in base case."
+ where
+ subtractDecodedBitmapWord :: Word
+ subtractDecodedBitmapWord =
+ fromIntegral $
+ max 0 (fromIntegral bitmapSize - wORD_SIZE_IN_BITS)
+
+ toBitmapEntries :: WordOffset -> Word -> Word -> [StackFrameIter]
+ toBitmapEntries _ _ 0 = []
+ toBitmapEntries i bitmapWord bSize =
+ ( if (bitmapWord .&. 1) /= 0
+ then SfiPrimitive stackSnapshot# i
+ else SfiClosure stackSnapshot# i
+ )
+ : toBitmapEntries
+ (i + 1)
+ (bitmapWord `shiftR` 1)
+ (bSize - 1)
+
+ getIndex :: StackFrameIter -> WordOffset
+ getIndex (SfiClosure _ i) = i
+ getIndex (SfiPrimitive _ i) = i
+ getIndex sfi' = error $ "Has no index : " ++ show sfi'
+decodeBitmaps sfi _ _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+decodeSmallBitmap :: SmallBitmapGetter -> StackFrameIter -> WordOffset -> IO [Box]
+decodeSmallBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset =
+ do
+ (bitmap, size) <- IO $ \s ->
+ case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
+ (# s1, b#, s# #) -> (# s1, (W# b#, W# s#) #)
+ let bitmapWords = [bitmap | size > 0]
+ decodeBitmaps sfi relativePayloadOffset bitmapWords size
+decodeSmallBitmap _ sfi _ =
+ error $
+ "Unexpected StackFrameIter type: " ++ show sfi
+
+-- | Decode `StackFrameIter` to `Closure`
+unpackStackFrameIter :: StackFrameIter -> IO Closure
+unpackStackFrameIter sfi@(SfiPrimitive {}) =
+ UnknownTypeWordSizedPrimitive
+ <$> getWord sfi 0
+unpackStackFrameIter sfi@(SfiStackClosure {..}) = do
+ info <- getInfoTable sfi
+ (stack_size', stack_dirty', stack_marking') <- getStackFields sfi
+ case tipe info of
+ STACK -> do
+ let stack' = decodeStackToBoxes (StackSnapshot stackSnapshot#)
+ 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
+ where
+ decodeStackToBoxes :: StackSnapshot -> [Box]
+ decodeStackToBoxes s =
+ StackFrameBox (stackHead s)
+ : go (advanceStackFrameIter (stackHead s))
+ where
+ go :: Maybe StackFrameIter -> [Box]
+ go Nothing = []
+ go (Just sfi') = StackFrameBox sfi' : go (advanceStackFrameIter sfi')
+unpackStackFrameIter sfi@(SfiClosure {}) = do
+ info <- getInfoTable sfi
+ unpackStackFrameIter' info
+ 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 -> do
+ payload' <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ pure $
+ RetSmall
+ { info = info,
+ 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
+ pure $
+ UpdateFrame
+ { info = info,
+ 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 $ SfiStackClosure nextChunk'
+ }
+ 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
+
+-- | Unbox 'Int#' from 'Int'
+toInt# :: Int -> Int#
+toInt# (I# i) = i
+
+-- | Convert `Int` to `Word#`
+intToWord# :: Int -> Word#
+intToWord# i = int2Word# (toInt# i)
+
+wordOffsetToWord# :: WordOffset -> Word#
+wordOffsetToWord# wo = intToWord# (fromIntegral wo)
+
+-- | Decode `StackSnapshot` to a Closure
+--
+-- Due to the use of `Box` this decoding is lazy. The first decoded closure is
+-- the representation of the @StgStack@ itself.
+decodeStack :: StackSnapshot -> IO Closure
+decodeStack (StackSnapshot stack#) =
+ unpackStackFrameIter $
+ SfiStackClosure stack#
+
+#else
+module GHC.Exts.Stack.Decode where
+#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -0,0 +1,172 @@
+#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));
+ return get_itbl(closure);
+};
+
+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));
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+
+ 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);
+}
+
+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;
+}
+
+StgClosure *getBoxedClosure(StgClosure **c) { return *c; }
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -0,0 +1,179 @@
+// Uncomment to enable assertions during development
+// #define DEBUG 1
+
+#include "Cmm.h"
+
+// StgStack_marking was not available in the Stage0 compiler at the time of
+// writing. Because, it has been added to derivedConstants when Stack.cmm was
+// developed.
+#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);
+}
+
+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);
+}
+
+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);
+}
+
+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];
+ 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);
+}
+
+getBoxedClosurezh(P_ stack, W_ offsetWords){
+ P_ ptr;
+ ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+ P_ box;
+ (box) = ccall getBoxedClosure(ptr);
+ return (box);
+}
+
+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,7 @@ library
GHC.Exts.Heap.Closures
GHC.Exts.Heap.ClosureTypes
GHC.Exts.Heap.Constants
+ GHC.Exts.Heap.Decode
GHC.Exts.Heap.InfoTable
GHC.Exts.Heap.InfoTable.Types
GHC.Exts.Heap.InfoTableProf
@@ -48,3 +51,5 @@ library
GHC.Exts.Heap.ProfInfo.PeekProfInfo
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+ GHC.Exts.Stack.Constants
+ GHC.Exts.Stack.Decode
=====================================
libraries/ghc-heap/tests/ClosureSizeUtils.hs
=====================================
@@ -11,6 +11,7 @@ module ClosureSizeUtils (assertSize, assertSizeUnlifted) where
import Control.Monad
import GHC.Exts
+import GHC.Exts.Heap
import GHC.Exts.Heap.Closures
import GHC.Stack
import Type.Reflection
@@ -45,7 +46,7 @@ assertSizeBox
-> Int -- ^ expected size in words
-> IO ()
assertSizeBox x ty expected = do
- let !size = closureSize x
+ !size <- closureSize x
when (size /= expected') $ do
putStrLn $ "closureSize ("++show ty++") == "++show size++", expected "++show expected'
putStrLn $ prettyCallStack callStack
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -1,7 +1,54 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
-module TestUtils where
+{-# 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.Heap
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Decode
+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 =
+ 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
=====================================
@@ -56,3 +56,48 @@ test('parse_tso_flags',
test('T21622',
only_ways(['normal']),
compile_and_run, [''])
+
+test('stack_big_ret',
+ [
+ extra_files(['TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run,
+ [''])
+
+# 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,
+ [''])
+
+test('stack_stm_frames',
+ [
+ extra_files(['TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run,
+ [''])
+
+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' # Debug RTS to use checkSTACK() (Sanity.c)
+ ])
=====================================
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.Heap
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
+import GHC.IO.Unsafe
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import System.IO (hPutStrLn, stderr)
+import System.Mem
+import TestUtils
+
+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,543 @@
+{-# 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
+
+import Data.Functor
+import Debug.Trace
+import GHC.Exts
+import GHC.Exts.Heap
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Decode
+import GHC.IO (IO (..))
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack (StackSnapshot (..))
+import System.Info
+import System.Mem
+import TestUtils
+import Unsafe.Coerce (unsafeCoerce)
+
+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_frame# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_gen_framezh" any_ret_fun_arg_gen_frame# :: SetupFunction
+
+foreign import prim "any_ret_fun_arg_gen_big_framezh" any_ret_fun_arg_gen_big_frame# :: 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 "bitsInWord" bitsInWord :: Word
+
+{- Test stategy
+ ~~~~~~~~~~~~
+
+- Create @StgStack at s in C that contain two 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. 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.) To find subtle garbage collection related
+bugs, the GC is triggered several times.
+
+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.)
+
+- Due to the implementation details of the test framework, the Debug.Trace calls
+are only shown when the test fails. They are used as markers to see where the
+test fails on e.g. a segfault (where the HasCallStack constraint isn't helpful.)
+-}
+main :: HasCallStack => IO ()
+main = do
+ traceM "Test 1"
+ test any_update_frame# $
+ \case
+ UpdateFrame {..} -> do
+ assertEqual (tipe info) UPDATE_FRAME
+ 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 2 =<< getBoxedClosureData first_code
+ assertConstrClosure 3 =<< 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
+ traceM "Test 11"
+ test any_ret_small_prim_frame# $
+ \case
+ RetSmall {..} -> do
+ assertEqual (tipe info) RET_SMALL
+ 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
+ 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
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) maxSmallBitmapBits
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. maxSmallBitmapBits]
+ 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
+ pCs <- mapM getBoxedClosureData payload
+ assertEqual (length pCs) maxSmallBitmapBits
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1 .. maxSmallBitmapBits]
+ 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) minBigBitmapBits
+ let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
+ assertEqual wds [1 .. minBigBitmapBits]
+ 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) minBigBitmapBits
+ let wds = map getWordFromConstr01 pCs
+ assertEqual wds [1 .. minBigBitmapBits]
+ 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 = fromIntegral $ bitsInWord + 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# (fromIntegral bitsInWord + 1 + 1)
+ traceM "Test 25"
+ test any_ret_fun_arg_n_prim_frame# $
+ \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_frame# $
+ \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
+ -- Darwin seems to have a slightly different layout regarding
+ -- function `argGenFun`
+ assertEqual (null ptrArgs) (os /= "darwin")
+ 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_frame# (3 + 9)
+ traceM "Test 28"
+ test any_ret_fun_arg_gen_big_frame# $
+ \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_frame# (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
+ assertEqual size 7
+ 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
+ sn@(StackSnapshot sn#) <- getStackSnapshot setup
+ performGC
+ traceM $ "entertainGC - " ++ entertainGC 100
+ -- 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
+ stackClosure <- getClosureData sn#
+ performGC
+ 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
+ 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 + maxSmallBitmapBits
+
+maxSmallBitmapBits :: Num a => a
+maxSmallBitmapBits = 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,357 @@
+#include "Rts.h"
+
+// 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 = (StgInd *)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);
+ catchF->code = payload1;
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
+ catchF->handler = payload2;
+}
+
+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);
+ catchRF->running_alt_code = w++;
+ StgClosure *payload1 = rts_mkWord(cap, w++);
+ catchRF->first_code = payload1;
+ StgClosure *payload2 = rts_mkWord(cap, w);
+ 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);
+ aF->code = payload1;
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
+ 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; }
+
+StgWord bitsInWord() { return BITS_IN(W_); }
+
+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 = (StgBCO *)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 =
+ (StgMutArrPtrs *)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 - This implies that the test must be run with debug RTS
+// only!
+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);
+}
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -0,0 +1,231 @@
+#include "Cmm.h"
+
+any_update_framezh() {
+ P_ stack;
+ (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 machine 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.Heap
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
+import GHC.Stack.CloneStack
+import TestUtils
+
+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,46 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Monad
+import Data.Bool (Bool (True))
+import GHC.Exts.Heap
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
+import GHC.Stack (HasCallStack)
+import GHC.Stack.CloneStack
+import TestUtils
+
+main = loop 128
+
+{-# NOINLINE loop #-}
+loop 0 = Control.Monad.void getStack
+loop n = print "x" >> loop (n - 1) >> print "x"
+
+getStack :: HasCallStack => IO ()
+getStack = do
+ (s, decodedStack) <- getDecodedStack
+ 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 <- mapM (mapM getBoxedClosureData) stackBoxes
+ assertThat
+ "No empty stack chunks"
+ (== True)
+ ( not (any null framesOfChunks)
+ )
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -471,6 +471,10 @@ instance Binary Heap.WhyBlocked
instance Binary Heap.TsoFlags
#endif
+#if MIN_VERSION_base(4,17,0)
+instance Binary Heap.RetFunType
+#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,10 @@ 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)
+ r -> error $ "Unsupported Box: " ++ show r
+ ) clos
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
_other -> error "GHCi.Run.run"
=====================================
rts/Printer.c
=====================================
@@ -664,17 +664,17 @@ 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,
+ 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;
=====================================
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 );
@@ -713,7 +712,7 @@ checkCompactObjects(bdescr *bd)
}
}
-static void
+void
checkSTACK (StgStack *stack)
{
StgPtr sp = stack->sp;
@@ -1325,5 +1324,4 @@ memInventory (bool show)
}
-
#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/531ca427031471ed78952a8770dbcc8ae19a9ac7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/531ca427031471ed78952a8770dbcc8ae19a9ac7
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/20230226/5a5106c3/attachment-0001.html>
More information about the ghc-commits
mailing list