[Git][ghc/ghc][wip/decode_cloned_stack] 6 commits: Serialize CmmRetInfo in .rodata
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Mon May 8 18:31:43 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
208f181d by Sven Tennie at 2023-05-08T18:10:03+00:00
Serialize CmmRetInfo in .rodata
The handling of case was missing.
- - - - -
715eebf6 by Sven Tennie at 2023-05-08T18:12:35+00:00
Reference StgRetFun payload by its struct field address
This is easier to grasp than relative pointer offsets.
- - - - -
b529e7cf by Sven Tennie at 2023-05-08T18:21:14+00:00
Better variable name: u -> frame
The 'u' was likely introduced by copy'n'paste.
- - - - -
eefa9f12 by Sven Tennie at 2023-05-08T18:22:59+00:00
Make checkSTACK() public
Such that it can also be used in tests.
- - - - -
2c9f1a36 by Sven Tennie at 2023-05-08T18:26:07+00:00
Publish stack related fields in DerivedConstants.h
These will be used in ghc-heap to decode these parts of the stack.
- - - - -
e778d832 by Sven Tennie at 2023-05-08T18:29:32+00:00
ghc-heap: Decode StgStack and its stack frames
Previously, ghc-heap could only decode heap closures.
The approach is explained in detail in note
[Decoding the stack].
- - - - -
22 changed files:
- compiler/GHC/Cmm/CLabel.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
- + libraries/ghc-heap/GHC/Exts/Stack.hs
- + 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/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
- 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
=====================================
@@ -797,6 +797,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/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -15,9 +15,18 @@ module GHC.Exts.Heap.Closures (
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
+ , RetFunType(..)
, allClosures
, closureSize
+ -- * Stack
+ , StgStackClosure
+ , GenStgStackClosure(..)
+ , StackFrame
+ , GenStackFrame(..)
+ , StackField
+ , GenStackField(..)
+
-- * Boxes
, Box(..)
, areBoxesEqual
@@ -95,7 +104,6 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
------------------------------------------------------------------------
-- Closures
-
type Closure = GenClosure Box
-- | This is the representation of a Haskell value on the heap. It reflects
@@ -354,8 +362,148 @@ data GenClosure b
| UnsupportedClosure
{ info :: !StgInfoTable
}
+
+ -- | A primitive word from a bitmap encoded stack frame payload
+ --
+ -- The type itself cannot be restored (i.e. it might represent a Word8#
+ -- or an Int#).
+ | UnknownTypeWordSizedPrimitive
+ { wordVal :: !Word }
deriving (Show, Generic, Functor, Foldable, Traversable)
+type StgStackClosure = GenStgStackClosure Box
+
+-- | A decoded @StgStack@ with `StackFrame`s
+--
+-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,
+-- `GenStackFrame`) are defined separately from `GenClosure` as their related
+-- functions are very different. Though, both are closures in the sense of RTS
+-- structures, their decoding logic differs: While it's safe to keep a reference
+-- to a heap closure, the garbage collector does not update references to stack
+-- located closures.
+--
+-- Additionally, stack frames don't appear outside of the stack. Thus, keeping
+-- `GenStackFrame` and `GenClosure` separated, makes these types more precise
+-- (in the sense what values to expect.)
+data GenStgStackClosure b = GenStgStackClosure
+ { ssc_info :: !StgInfoTable
+ , ssc_stack_size :: !Word32 -- ^ stack size in *words*
+ , ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty
+ , ssc_stack_marking :: !Word8
+ , ssc_stack :: ![GenStackFrame b]
+ }
+ deriving (Foldable, Functor, Generic, Show, Traversable)
+
+type StackField = GenStackField Box
+
+-- | Bitmap-encoded payload on the stack
+data GenStackField b
+ -- | A non-pointer field
+ = StackWord !Word
+ -- | A pointer field
+ | StackBox !b
+ deriving (Foldable, Functor, Generic, Show, Traversable)
+
+type StackFrame = GenStackFrame Box
+
+-- | A single stack frame
+data GenStackFrame b =
+ UpdateFrame
+ { info_tbl :: !StgInfoTable
+ , updatee :: !b
+ }
+
+ | CatchFrame
+ { info_tbl :: !StgInfoTable
+ , exceptions_blocked :: !Word
+ , handler :: !b
+ }
+
+ | CatchStmFrame
+ { info_tbl :: !StgInfoTable
+ , catchFrameCode :: !b
+ , handler :: !b
+ }
+
+ | CatchRetryFrame
+ { info_tbl :: !StgInfoTable
+ , running_alt_code :: !Word
+ , first_code :: !b
+ , alt_code :: !b
+ }
+
+ | AtomicallyFrame
+ { info_tbl :: !StgInfoTable
+ , atomicallyFrameCode :: !b
+ , result :: !b
+ }
+
+ | UnderflowFrame
+ { info_tbl :: !StgInfoTable
+ , nextChunk :: !(GenStgStackClosure b)
+ }
+
+ | StopFrame
+ { info_tbl :: !StgInfoTable }
+
+ | RetSmall
+ { info_tbl :: !StgInfoTable
+ , stack_payload :: ![GenStackField b]
+ }
+
+ | RetBig
+ { info_tbl :: !StgInfoTable
+ , stack_payload :: ![GenStackField b]
+ }
+
+ | RetFun
+ { info_tbl :: !StgInfoTable
+ , retFunType :: !RetFunType
+ , retFunSize :: !Word
+ , retFunFun :: !b
+ , retFunPayload :: ![GenStackField b]
+ }
+
+ | RetBCO
+ { info_tbl :: !StgInfoTable
+ , bco :: !b -- ^ always a BCOClosure
+ , bcoArgs :: ![GenStackField b]
+ }
+ deriving (Foldable, Functor, Generic, Show, Traversable)
+
+-- | Fun types according to @FunTypes.h@
+-- This `Enum` must be aligned with the values in @FunTypes.h at .
+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
=====================================
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.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+{-# LANGUAGE RecordWildCards #-}
+
+module GHC.Exts.Stack
+ ( -- * Stack inspection
+ decodeStack,
+ stackFrameSize,
+ )
+where
+
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Constants
+import GHC.Exts.Stack.Decode
+import Prelude
+
+-- | Get the size of the `StackFrame` in words.
+--
+-- Includes header and payload. Does not follow pointers.
+stackFrameSize :: StackFrame -> Int
+stackFrameSize (UpdateFrame {}) = sizeStgUpdateFrame
+stackFrameSize (CatchFrame {}) = sizeStgCatchFrame
+stackFrameSize (CatchStmFrame {}) = sizeStgCatchSTMFrame
+stackFrameSize (CatchRetryFrame {}) = sizeStgCatchRetryFrame
+stackFrameSize (AtomicallyFrame {}) = sizeStgAtomicallyFrame
+stackFrameSize (RetSmall {..}) = sizeStgClosure + length stack_payload
+stackFrameSize (RetBig {..}) = sizeStgClosure + length stack_payload
+stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload
+-- The one additional word is a pointer to the StgBCO in the closure's payload
+stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs
+-- The one additional word is a pointer to the next stack chunk
+stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1
+stackFrameSize _ = error "Unexpected stack frame type"
+
+#else
+module GHC.Exts.Stack where
+#endif
=====================================
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,444 @@
+{-# 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,
+ )
+where
+
+import Control.Monad
+import Data.Bits
+import Data.Maybe
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap (Box (..))
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Closures
+ ( RetFunType (..),
+ StackFrame,
+ GenStackFrame (..),
+ StgStackClosure,
+ GenStgStackClosure (..),
+ StackField,
+ GenStackField(..)
+ )
+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 by the garbage collector.
+
+As the StgStack closure is moved as whole, the relative offsets inside it stay
+the same. (Though, the absolute addresses change!)
+
+Decoding
+========
+
+Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and
+their relative offset. This tuple is described by `StackFrameLocation`.
+
+`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we
+have to deal with three cases:
+
+- If the payload can only be a closure, we put it in a `Box` for later decoding
+ by the heap closure functions.
+
+- If the payload can either be a closure or a word-sized value (this happens for
+ bitmap-encoded payloads), we use a `StackField` which is a sum type to
+ represent either a `Word` or a `Box`.
+
+- Fields that are just simple (i.e. non-closure) values are decoded as such.
+
+The decoding happens in two phases:
+
+1. The whole stack is decoded into `StackFrameLocation`s.
+
+2. All `StackFrameLocation`s are decoded into `StackFrame`s.
+
+`StackSnapshot#` parameters are updated by the garbage collector and thus safe
+to hand around.
+
+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.)
+
+IO
+==
+
+Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames`
+also being decoded in `IO`, due to references to `Closure`s.
+
+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# -> StackSnapshot#
+
+getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot
+getUnderflowFrameNextChunk stackSnapshot# index =
+ StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index))
+
+foreign import prim "getWordzh"
+ getWord# ::
+ StackSnapshot# -> Word# -> Word#
+
+getWord :: StackSnapshot# -> WordOffset -> Word
+getWord stackSnapshot# index =
+ W# (getWord# stackSnapshot# (wordOffsetToWord# index))
+
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
+
+getRetFunType :: StackSnapshot# -> WordOffset -> RetFunType
+getRetFunType stackSnapshot# index =
+ toEnum . fromInteger . toInteger $
+ W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index))
+
+-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size.
+type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #)
+
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter
+
+-- | Gets contents of a small bitmap (fitting in one @StgWord@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the bitmap and it's size.
+type SmallBitmapGetter = StackSnapshot# -> Word# -> (# 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#
+
+getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable
+getInfoTableOnStack stackSnapshot# index =
+ let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index))
+ in peekItbl infoTablePtr
+
+getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
+getInfoTableForStack stackSnapshot# =
+ peekItbl $
+ Ptr (getStackInfoTableAddr# stackSnapshot#)
+
+foreign import prim "getStackClosurezh"
+ getStackClosure# ::
+ StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #)
+
+foreign import prim "getStackFieldszh"
+ getStackFields# ::
+ StackSnapshot# -> (# Word32#, Word8#, Word8# #)
+
+getStackFields :: StackSnapshot# -> (Word32, Word8, Word8)
+getStackFields stackSnapshot# =
+ case getStackFields# stackSnapshot# of
+ (# sSize#, sDirty#, sMarking# #) ->
+ (W32# sSize#, W8# sDirty#, W8# sMarking#)
+
+-- | `StackFrameLocation` of the top-most stack frame
+stackHead :: StackSnapshot# -> StackFrameLocation
+stackHead s# = (StackSnapshot 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 "advanceStackFrameLocationzh"
+ advanceStackFrameLocation# ::
+ StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
+-- | Advance to the next stack frame (if any)
+advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
+advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
+ let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)
+ in if I# hasNext > 0
+ then Just (StackSnapshot s', primWordToWordOffset i')
+ else Nothing
+ where
+ primWordToWordOffset :: Word# -> WordOffset
+ primWordToWordOffset w# = fromIntegral (W# w#)
+
+getClosureBox :: StackSnapshot# -> WordOffset -> IO Box
+getClosureBox stackSnapshot# index =
+ -- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage
+ -- collector might move the referenced closure, without updating our reference
+ -- (pointer) to it.
+ IO $ \s ->
+ case getStackClosure#
+ stackSnapshot#
+ (wordOffsetToWord# index)
+ s of
+ (# s1, ptr #) ->
+ (# s1, Box ptr #)
+
+-- | Representation of @StgLargeBitmap@ (RTS)
+data LargeBitmap = LargeBitmap
+ { largeBitmapSize :: Word,
+ largebitmapWords :: Ptr Word
+ }
+
+-- | Is a bitmap entry a closure pointer or a primitive non-pointer?
+data Pointerness = Pointer | NonPointer
+ deriving (Show)
+
+decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
+decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
+ let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
+ (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#)
+ bitmapWords <- largeBitmapToList largeBitmap
+ decodeBitmaps
+ stackSnapshot#
+ (index + relativePayloadOffset)
+ (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords)
+ where
+ largeBitmapToList :: LargeBitmap -> IO [Word]
+ largeBitmapToList LargeBitmap {..} =
+ cWordArrayToList largebitmapWords $
+ (usedBitmapWords . fromIntegral) largeBitmapSize
+
+ cWordArrayToList :: Ptr Word -> Int -> IO [Word]
+ cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)]
+
+ usedBitmapWords :: Int -> Int
+ usedBitmapWords 0 = error "Invalid large bitmap size 0."
+ usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1
+
+ bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
+ bitmapWordsPointerness size _ | size <= 0 = []
+ bitmapWordsPointerness _ [] = []
+ bitmapWordsPointerness size (w : wds) =
+ bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w
+ ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds
+
+bitmapWordPointerness :: Word -> Word -> [Pointerness]
+bitmapWordPointerness 0 _ = []
+bitmapWordPointerness bSize bitmapWord =
+ ( if (bitmapWord .&. 1) /= 0
+ then NonPointer
+ else Pointer
+ )
+ : bitmapWordPointerness
+ (bSize - 1)
+ (bitmapWord `shiftR` 1)
+
+decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [StackField]
+decodeBitmaps stack# index ps =
+ zipWithM toPayload ps [index ..]
+ where
+ toPayload :: Pointerness -> WordOffset -> IO StackField
+ toPayload p i = case p of
+ NonPointer ->
+ pure $ StackWord (getWord stack# i)
+ Pointer -> StackBox <$> getClosureBox stack# i
+
+decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
+decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
+ let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
+ (# b#, s# #) -> (W# b#, W# s#)
+ in decodeBitmaps
+ stackSnapshot#
+ (index + relativePayloadOffset)
+ (bitmapWordPointerness size bitmap)
+
+unpackStackFrame :: StackFrameLocation -> IO StackFrame
+unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
+ info <- getInfoTableOnStack stackSnapshot# index
+ unpackStackFrame' info
+ where
+ unpackStackFrame' :: StgInfoTable -> IO StackFrame
+ unpackStackFrame' info =
+ case tipe info of
+ RET_BCO -> do
+ bco' <- getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
+ -- The arguments begin directly after the payload's one element
+ bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
+ pure
+ RetBCO
+ { info_tbl = info,
+ bco = bco',
+ bcoArgs = bcoArgs'
+ }
+ RET_SMALL -> do
+ payload' <- decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
+ pure $
+ RetSmall
+ { info_tbl = info,
+ stack_payload = payload'
+ }
+ RET_BIG -> do
+ payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
+ pure $
+ RetBig
+ { info_tbl = info,
+ stack_payload = payload'
+ }
+ RET_FUN -> do
+ let retFunType' = getRetFunType stackSnapshot# index
+ retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
+ retFunFun' <- getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)
+ retFunPayload' <-
+ if retFunType' == ARG_GEN_BIG
+ then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
+ else decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
+ pure $
+ RetFun
+ { info_tbl = info,
+ retFunType = retFunType',
+ retFunSize = retFunSize',
+ retFunFun = retFunFun',
+ retFunPayload = retFunPayload'
+ }
+ UPDATE_FRAME -> do
+ updatee' <- getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
+ pure $
+ UpdateFrame
+ { info_tbl = info,
+ updatee = updatee'
+ }
+ CATCH_FRAME -> do
+ let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked)
+ handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
+ pure $
+ CatchFrame
+ { info_tbl = info,
+ exceptions_blocked = exceptions_blocked',
+ handler = handler'
+ }
+ UNDERFLOW_FRAME -> do
+ let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
+ stackClosure <- decodeStack nextChunk'
+ pure $
+ UnderflowFrame
+ { info_tbl = info,
+ nextChunk = stackClosure
+ }
+ STOP_FRAME -> pure $ StopFrame {info_tbl = info}
+ ATOMICALLY_FRAME -> do
+ atomicallyFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
+ result' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
+ pure $
+ AtomicallyFrame
+ { info_tbl = info,
+ atomicallyFrameCode = atomicallyFrameCode',
+ result = result'
+ }
+ CATCH_RETRY_FRAME -> do
+ let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
+ first_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
+ alt_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
+ pure $
+ CatchRetryFrame
+ { info_tbl = info,
+ running_alt_code = running_alt_code',
+ first_code = first_code',
+ alt_code = alt_code'
+ }
+ CATCH_STM_FRAME -> do
+ catchFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
+ handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
+ pure $
+ CatchStmFrame
+ { info_tbl = 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)
+
+-- | Location of a stackframe on the stack
+--
+-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
+-- of the stack.
+type StackFrameLocation = (StackSnapshot, WordOffset)
+
+-- | Decode `StackSnapshot` to a `StgStackClosure`
+--
+-- The return value is the representation of the @StgStack@ itself.
+--
+-- See /Note [Decoding the stack]/.
+decodeStack :: StackSnapshot -> IO StgStackClosure
+decodeStack (StackSnapshot stack#) = do
+ info <- getInfoTableForStack stack#
+ case tipe info of
+ STACK -> do
+ let (stack_size', stack_dirty', stack_marking') = getStackFields stack#
+ sfls = stackFrameLocations stack#
+ stack' <- mapM unpackStackFrame sfls
+ pure $
+ GenStgStackClosure
+ { ssc_info = info,
+ ssc_stack_size = stack_size',
+ ssc_stack_dirty = stack_dirty',
+ ssc_stack_marking = stack_marking',
+ ssc_stack = stack'
+ }
+ _ -> error $ "Expected STACK closure, got " ++ show info
+ where
+ stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
+ stackFrameLocations s# =
+ stackHead s#
+ : go (advanceStackFrameLocation (stackHead s#))
+ where
+ go :: Maybe StackFrameLocation -> [StackFrameLocation]
+ go Nothing = []
+ go (Just r) = r : go (advanceStackFrameLocation r)
+
+#else
+module GHC.Exts.Stack.Decode where
+#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -0,0 +1,150 @@
+#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);
+}
+
+StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+ const StgInfoTable *info = get_itbl(c);
+ StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+
+ return bitmap->bitmap;
+}
+
+StgWord *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 bitmap->bitmap;
+}
+
+StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ StgBCO *bco = (StgBCO *)*c->payload;
+ StgLargeBitmap *bitmap = BCO_BITMAP(bco);
+
+ return bitmap->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 *getStackClosure(StgClosure **c) { return *c; }
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -0,0 +1,187 @@
+// 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)
+
+// Returns the next stackframe's StgStack* and offset in it. And, an indicator
+// if this frame is the last one (`hasNext` bit.)
+// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
+advanceStackFrameLocationzh (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);
+}
+
+// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+getSmallBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ W_ bitmap, size;
+ (bitmap) = ccall getBitmapWord(c);
+ (size) = ccall getBitmapSize(c);
+
+ return (bitmap, size);
+}
+
+
+// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+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);
+}
+
+// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getLargeBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c, words;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (words) = ccall getLargeBitmap(MyCapability(), c);
+ (size) = ccall getLargeBitmapSize(c);
+
+ return (words, size);
+}
+
+// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c, words;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (words) = ccall getBCOLargeBitmap(MyCapability(), c);
+ (size) = ccall getBCOLargeBitmapSize(c);
+
+ return (words, size);
+}
+
+// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {
+ P_ c, words;
+ W_ size;
+ c = StgStack_sp(stack) + WDS(offsetWords);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+ (words) = ccall getRetFunLargeBitmap(MyCapability(), c);
+ (size) = ccall getRetFunSize(c);
+
+ return (words, size);
+}
+
+// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)
+getWordzh(P_ stack, W_ offsetWords) {
+ P_ wordAddr;
+ wordAddr = (StgStack_sp(stack) + WDS(offsetWords));
+ return (W_[wordAddr]);
+}
+
+// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)
+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);
+}
+
+// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)
+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);
+}
+
+// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords)
+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);
+}
+
+// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
+getStackInfoTableAddrzh(P_ stack) {
+ P_ info;
+ info = %GET_STD_INFO(UNTAG(stack));
+ return (info);
+}
+
+// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
+getStackClosurezh(P_ stack, W_ offsetWords) {
+ P_ ptr;
+ ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+ P_ closure;
+ (closure) = ccall getStackClosure(ptr);
+ return (closure);
+}
+
+// (bits32, bits8, bits8) getStackFieldszh(StgStack* stack)
+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
@@ -48,3 +50,6 @@ 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
+ GHC.Exts.Stack.Decode
=====================================
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, [StackFrame])
+getDecodedStack = do
+ stack <- cloneMyStack
+ stackClosure <- decodeStack stack
+
+ pure (stack, ssc_stack stackClosure)
+
+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) => [StackFrame] -> m ()
+assertStackInvariants 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
=====================================
@@ -57,3 +57,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,142 @@
+{-# 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 = fromJust mbStackSnapshot
+ stackClosure <- decodeStack stackSnapshot
+ let stackFrames = ssc_stack stackClosure
+
+ assertStackInvariants stackFrames
+ assertThat
+ "Stack contains one big return frame"
+ (== 1)
+ (length $ filter isBigReturnFrame stackFrames)
+ let cs = (stack_payload . head) $ filter isBigReturnFrame stackFrames
+ let xs = zip [1 ..] cs
+ mapM_ (uncurry checkArg) xs
+
+checkArg :: Word -> StackField -> IO ()
+checkArg w sf =
+ case sf of
+ StackWord _ -> error "Unexpected payload type from bitmap."
+ StackBox b -> do
+ c <- getBoxedClosureData b
+ 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 :: StackFrame -> Bool
+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,526 @@
+{-# 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 (getBoxedClosureData)
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.Closures (GenStackFrame (retFunFun), StackField)
+import GHC.Exts.Stack
+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_tbl) UPDATE_FRAME
+ assertEqual 1 =<< getWordFromBlackhole 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_tbl) CATCH_FRAME
+ assertEqual exceptions_blocked 1
+ assertConstrClosure 1 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_tbl) CATCH_STM_FRAME
+ assertConstrClosure 1 catchFrameCode
+ assertConstrClosure 2 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_tbl) CATCH_RETRY_FRAME
+ assertEqual running_alt_code 1
+ assertConstrClosure 2 first_code
+ assertConstrClosure 3 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_tbl) ATOMICALLY_FRAME
+ assertConstrClosure 1 atomicallyFrameCode
+ assertConstrClosure 2 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_tbl) RET_SMALL
+ assertEqual (length stack_payload) 1
+ assertUnknownTypeWordSizedPrimitive 1 (head stack_payload)
+ 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_tbl) RET_SMALL
+ assertEqual (length stack_payload) 1
+ assertConstrClosure 1 $ (stackFieldClosure . head) stack_payload
+ 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_tbl) RET_SMALL
+ assertEqual (length stack_payload) maxSmallBitmapBits
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload
+ 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_tbl) RET_SMALL
+ assertEqual (length stack_payload) maxSmallBitmapBits
+ let wds = map stackFieldWord stack_payload
+ 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_tbl) RET_BIG
+ assertEqual (length stack_payload) minBigBitmapBits
+ let wds = map stackFieldWord stack_payload
+ 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_tbl) RET_BIG
+ assertEqual (length stack_payload) minBigBitmapBits
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload
+ 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_tbl) RET_BIG
+ let closureCount = fromIntegral $ bitsInWord + 1
+ assertEqual (length stack_payload) closureCount
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload
+ 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_tbl) RET_FUN
+ assertEqual retFunType ARG_N
+ assertEqual retFunSize 1
+ assertFun01Closure 1 retFunFun
+ assertEqual (length retFunPayload) 1
+ let wds = map stackFieldWord retFunPayload
+ 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_tbl) RET_FUN
+ assertEqual retFunType ARG_GEN
+ assertEqual retFunSize 9
+ retFunFun' <- getBoxedClosureData retFunFun
+ case retFunFun' 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
+ assertEqual (length retFunPayload) 9
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) retFunPayload
+ 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_tbl) RET_FUN
+ assertEqual retFunType ARG_GEN_BIG
+ assertEqual retFunSize 59
+ retFunFun' <- getBoxedClosureData retFunFun
+ case retFunFun' of
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_STATIC
+ assertEqual (null dataArgs) True
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+ assertEqual (length retFunPayload) 59
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) retFunPayload
+ 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_tbl) RET_BCO
+ assertEqual (length bcoArgs) 1
+ wds <- mapM (getWordFromConstr01 . stackFieldClosure) bcoArgs
+ assertEqual wds [3]
+ bco' <- getBoxedClosureData bco
+ case bco' of
+ BCOClosure {..} -> do
+ assertEqual (tipe info) BCO
+ assertEqual arity 3
+ assertEqual size 7
+ assertArrWordsClosure [1] instrs
+ assertArrWordsClosure [2] literals
+ assertMutArrClosure [3] 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_tbl) UNDERFLOW_FRAME
+ assertEqual (tipe (ssc_info nextChunk)) STACK
+ assertEqual (ssc_stack_size nextChunk) 27
+ assertEqual (ssc_stack_dirty nextChunk) 0
+ assertEqual (ssc_stack_marking nextChunk) 0
+ assertEqual (length (ssc_stack nextChunk)) 2
+ case head (ssc_stack nextChunk) of
+ RetSmall {..} ->
+ assertEqual (tipe info_tbl) RET_SMALL
+ e -> error $ "Wrong closure type: " ++ show e
+ case last (ssc_stack nextChunk) of
+ StopFrame {..} ->
+ assertEqual (tipe info_tbl) STOP_FRAME
+ 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 -> (StackFrame -> IO ()) -> IO ()
+test setup assertion = do
+ stackSnapshot <- 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 <- decodeStack stackSnapshot
+ performGC
+ let stack = ssc_stack stackClosure
+ performGC
+ assert stack
+ where
+ assert :: [StackFrame] -> IO ()
+ assert stack = do
+ assertStackInvariants 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 <- getStackSnapshot setup
+ stackClosure <- decodeStack stackSnapshot
+ assertEqual expectedSize $ (stackFrameSize . head . ssc_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 -> Box -> IO ()
+assertConstrClosure w c =
+ getBoxedClosureData c >>= \case
+ 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] -> Box -> IO ()
+assertArrWordsClosure wds c =
+ getBoxedClosureData c >>= \case
+ ArrWordsClosure {..} -> do
+ assertEqual (tipe info) ARR_WORDS
+ assertEqual arrWords wds
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertMutArrClosure :: HasCallStack => [Word] -> Box -> IO ()
+assertMutArrClosure wds c =
+ getBoxedClosureData c >>= \case
+ MutArrClosure {..} -> do
+ assertEqual (tipe info) MUT_ARR_PTRS_FROZEN_CLEAN
+ assertEqual wds =<< mapM getWordFromConstr01 mccPayload
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertFun01Closure :: HasCallStack => Word -> Box -> IO ()
+assertFun01Closure w c =
+ getBoxedClosureData c >>= \case
+ FunClosure {..} -> do
+ assertEqual (tipe info) FUN_0_1
+ assertEqual dataArgs [w]
+ assertEqual (null ptrArgs) True
+ e -> error $ "Wrong closure type: " ++ show e
+
+getWordFromConstr01 :: HasCallStack => Box -> IO Word
+getWordFromConstr01 c =
+ getBoxedClosureData c >>= \case
+ ConstrClosure {..} -> pure $ head dataArgs
+ e -> error $ "Wrong closure type: " ++ show e
+
+getWordFromBlackhole :: HasCallStack => Box -> IO Word
+getWordFromBlackhole c =
+ getBoxedClosureData c >>= \case
+ BlackholeClosure {..} -> getWordFromConstr01 indirectee
+ -- For test stability reasons: Expect that the blackhole might have been
+ -- resolved.
+ ConstrClosure {..} -> pure $ head dataArgs
+ e -> error $ "Wrong closure type: " ++ show e
+
+assertUnknownTypeWordSizedPrimitive :: HasCallStack => Word -> StackField -> IO ()
+assertUnknownTypeWordSizedPrimitive w stackField =
+ assertEqual (stackFieldWord stackField) w
+
+unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
+unboxSingletonTuple (# s# #) = s#
+
+minBigBitmapBits :: Num a => a
+minBigBitmapBits = 1 + maxSmallBitmapBits
+
+maxSmallBitmapBits :: Num a => a
+maxSmallBitmapBits = fromIntegral maxSmallBitmapBits_c
+
+stackFieldClosure :: HasCallStack => StackField -> Box
+stackFieldClosure (StackBox b) = b
+stackFieldClosure w = error $ "Expected closure in a Box, got: " ++ show w
+
+stackFieldWord :: HasCallStack => StackField -> Word
+stackFieldWord (StackWord w) = w
+stackFieldWord c = error $ "Expected word, got: " ++ show 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 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 :: StackFrame -> Bool
+isCatchStmFrame (CatchStmFrame {..}) = tipe info_tbl == CATCH_STM_FRAME
+isCatchStmFrame _ = False
+
+isAtomicallyFrame :: StackFrame -> Bool
+isAtomicallyFrame (AtomicallyFrame {..}) = tipe info_tbl == ATOMICALLY_FRAME
+isAtomicallyFrame _ = False
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -0,0 +1,49 @@
+{-# 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 256
+
+{-# 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 decodedStack
+ assertThat
+ "Stack contains underflow frames"
+ (== True)
+ (any isUnderflowFrame decodedStack)
+ assertStackChunksAreDecodable decodedStack
+ return ()
+
+isUnderflowFrame :: StackFrame -> Bool
+isUnderflowFrame (UnderflowFrame {..}) = tipe info_tbl == UNDERFLOW_FRAME
+isUnderflowFrame _ = False
+
+assertStackChunksAreDecodable :: HasCallStack => [StackFrame] -> IO ()
+assertStackChunksAreDecodable s = do
+ let underflowFrames = filter isUnderflowFrame s
+ assertThat
+ ("Expect some underflow frames. Got " ++ show (length underflowFrames))
+ (>= 2)
+ (length underflowFrames)
+ let stackFrames = map (ssc_stack . nextChunk) underflowFrames
+ assertThat
+ "No empty stack chunks"
+ (== True)
+ ( not (any null stackFrames)
+ )
=====================================
rts/Printer.c
=====================================
@@ -259,79 +259,79 @@ printClosure( const StgClosure *obj )
case UPDATE_FRAME:
{
- StgUpdateFrame* u = (StgUpdateFrame*)obj;
+ StgUpdateFrame* frame = (StgUpdateFrame*)obj;
debugBelch("%s(", info_update_frame(obj));
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(",");
- printPtr((StgPtr)u->updatee);
+ printPtr((StgPtr)frame->updatee);
debugBelch(")\n");
break;
}
case CATCH_FRAME:
{
- StgCatchFrame* u = (StgCatchFrame*)obj;
+ StgCatchFrame* frame = (StgCatchFrame*)obj;
debugBelch("CATCH_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(",");
- printPtr((StgPtr)u->handler);
+ printPtr((StgPtr)frame->handler);
debugBelch(")\n");
break;
}
case UNDERFLOW_FRAME:
{
- StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
+ StgUnderflowFrame* frame = (StgUnderflowFrame*)obj;
debugBelch("UNDERFLOW_FRAME(");
- printPtr((StgPtr)u->next_chunk);
+ printPtr((StgPtr)frame->next_chunk);
debugBelch(")\n");
break;
}
case STOP_FRAME:
{
- StgStopFrame* u = (StgStopFrame*)obj;
+ StgStopFrame* frame = (StgStopFrame*)obj;
debugBelch("STOP_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(")\n");
break;
}
case ATOMICALLY_FRAME:
{
- StgAtomicallyFrame* u = (StgAtomicallyFrame*)obj;
+ StgAtomicallyFrame* frame = (StgAtomicallyFrame*)obj;
debugBelch("ATOMICALLY_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(",");
- printPtr((StgPtr)u->code);
+ printPtr((StgPtr)frame->code);
debugBelch(",");
- printPtr((StgPtr)u->result);
+ printPtr((StgPtr)frame->result);
debugBelch(")\n");
break;
}
case CATCH_RETRY_FRAME:
{
- StgCatchRetryFrame* u = (StgCatchRetryFrame*)obj;
+ StgCatchRetryFrame* frame = (StgCatchRetryFrame*)obj;
debugBelch("CATCH_RETRY_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(",");
- printPtr((StgPtr)u->first_code);
+ printPtr((StgPtr)frame->first_code);
debugBelch(",");
- printPtr((StgPtr)u->alt_code);
+ printPtr((StgPtr)frame->alt_code);
debugBelch(")\n");
break;
}
case CATCH_STM_FRAME:
{
- StgCatchSTMFrame* u = (StgCatchSTMFrame*)obj;
+ StgCatchSTMFrame* frame = (StgCatchSTMFrame*)obj;
debugBelch("CATCH_STM_FRAME(");
- printPtr((StgPtr)GET_INFO((StgClosure *)u));
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
debugBelch(",");
- printPtr((StgPtr)u->code);
+ printPtr((StgPtr)frame->code);
debugBelch(",");
- printPtr((StgPtr)u->handler);
+ printPtr((StgPtr)frame->handler);
debugBelch(")\n");
break;
}
@@ -715,17 +715,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, (StgPtr) &ret_fun->payload,
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, (StgPtr) &ret_fun->payload,
GET_FUN_LARGE_BITMAP(fun_info),
GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
- printSmallBitmap(spBottom, sp+2,
+ printSmallBitmap(spBottom, (StgPtr) &ret_fun->payload,
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 void checkCompactObjects (bdescr *bd);
@@ -725,7 +724,7 @@ checkCompactObjects(bdescr *bd)
}
}
-static void
+void
checkSTACK (StgStack *stack)
{
StgPtr sp = stack->sp;
@@ -1341,5 +1340,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
=====================================
@@ -475,6 +475,7 @@ wanteds os = concat
,closureFieldOffset Both "StgStack" "stack"
,closureField C "StgStack" "stack_size"
,closureField C "StgStack" "dirty"
+ ,closureField C "StgStack" "marking"
,structSize C "StgTSOProfInfo"
@@ -483,6 +484,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/-/compare/a661ec564e5bab4c0cadb1af9ba2566b9b610df3...e778d8320606726a820f7f351b87f94e0f5a9888
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a661ec564e5bab4c0cadb1af9ba2566b9b610df3...e778d8320606726a820f7f351b87f94e0f5a9888
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/20230508/d2e259a7/attachment-0001.html>
More information about the ghc-commits
mailing list