ghc-heap 9.12.4 → 9.14.1

raw patch · 24 files changed

+117/−1800 lines, 24 filesdep −ghc-primdep ~containersdep ~ghc-internalPVP ok

version bump matches the API change (PVP)

Dependencies removed: ghc-prim

Dependency ranges changed: containers, ghc-internal

API changes (from Hackage documentation)

Files

• GHC/Exts/Heap.hs +20/−10
• GHC/Exts/Heap/ClosureTypes.hs +0/−79
• GHC/Exts/Heap/Closures.hs +7/−518
• GHC/Exts/Heap/Constants.hs +7/−0
• GHC/Exts/Heap/Constants.hsc +0/−17
• GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc +4/−7
• GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc +4/−6
• GHC/Exts/Heap/InfoTable.hs +9/−0
• GHC/Exts/Heap/InfoTable.hsc +0/−73
• GHC/Exts/Heap/InfoTable/Types.hs +8/−0
• GHC/Exts/Heap/InfoTable/Types.hsc +0/−46
• GHC/Exts/Heap/InfoTableProf.hs +9/−0
• GHC/Exts/Heap/InfoTableProf.hsc +0/−66
• GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc +0/−14
• GHC/Exts/Heap/ProfInfo/Types.hs +8/−55
• GHC/Exts/Heap/Utils.hsc +0/−1
• GHC/Exts/Stack.hs +2/−1
• GHC/Exts/Stack/Constants.hs +35/−0
• GHC/Exts/Stack/Constants.hsc +0/−126
• GHC/Exts/Stack/Decode.hs +1/−426
• cbits/HeapPrim.cmm +0/−13
• cbits/Stack.cmm +0/−182
• cbits/Stack_c.c +0/−151
• ghc-heap.cabal +3/−9

@@ -29,6 +29,10 @@     , WhyBlocked(..)     , TsoFlags(..)     , HasHeapRep(getClosureData)+    , getClosureInfoTbl+    , getClosureInfoTbl_maybe+    , getClosurePtrArgs+    , getClosurePtrArgs_maybe     , getClosureDataFromHeapRep     , getClosureDataFromHeapRepPrim @@ -63,10 +67,26 @@ import GHC.Exts.Heap.Constants import GHC.Exts.Heap.ProfInfo.Types #if defined(PROFILING)+import GHC.Exts.Heap.InfoTable () -- See Note [No way-dependent imports] import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable+import GHC.Exts.Heap.InfoTableProf () -- See Note [No way-dependent imports]++{-+Note [No way-dependent imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`ghc -M` currently assumes that the imports for a module are the same+in every way.  This is arguably a bug, but breaking this assumption by+importing different things in different ways can cause trouble.  For+example, this module in the profiling way imports and uses+GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the+vanilla way, there were intermittent build failures due to this module+being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf+in the profiling way. (#15197)+-} #endif+ import GHC.Exts.Heap.Utils import qualified GHC.Exts.Heap.FFIClosures as FFIClosures import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI@@ -88,18 +108,10 @@         -> IO Closure         -- ^ Heap representation of the closure. -#if __GLASGOW_HASKELL__ >= 901 instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where-#else-instance HasHeapRep (a :: TYPE 'LiftedRep) where-#endif     getClosureData = getClosureDataFromHeapObject -#if __GLASGOW_HASKELL__ >= 901 instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where-#else-instance HasHeapRep (a :: TYPE 'UnliftedRep) where-#endif     getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x)  instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where@@ -370,9 +382,7 @@                                 { info = itbl                                 , stack_size = FFIClosures.stack_size fields                                 , stack_dirty = FFIClosures.stack_dirty fields-#if __GLASGOW_HASKELL__ >= 811                                 , stack_marking = FFIClosures.stack_marking fields-#endif                                 })             | otherwise                 -> fail $ "Expected 0 ptr argument to STACK, found "

@@ -7,86 +7,7 @@     ) where  import Prelude -- See note [Why do we import Prelude here?]-#if __GLASGOW_HASKELL__ >= 909 import GHC.Internal.ClosureTypes-#else-import GHC.Generics--{- ------------------------------------------------ Enum representing closure types--- This is a mirror of:--- rts/include/rts/storage/ClosureTypes.h--- ---------------------------------------------}--data ClosureType-    = INVALID_OBJECT-    | CONSTR-    | CONSTR_1_0-    | CONSTR_0_1-    | CONSTR_2_0-    | CONSTR_1_1-    | CONSTR_0_2-    | CONSTR_NOCAF-    | FUN-    | FUN_1_0-    | FUN_0_1-    | FUN_2_0-    | FUN_1_1-    | FUN_0_2-    | FUN_STATIC-    | THUNK-    | THUNK_1_0-    | THUNK_0_1-    | THUNK_2_0-    | THUNK_1_1-    | THUNK_0_2-    | THUNK_STATIC-    | THUNK_SELECTOR-    | BCO-    | AP-    | PAP-    | AP_STACK-    | IND-    | IND_STATIC-    | RET_BCO-    | RET_SMALL-    | RET_BIG-    | RET_FUN-    | UPDATE_FRAME-    | CATCH_FRAME-    | UNDERFLOW_FRAME-    | STOP_FRAME-    | BLOCKING_QUEUE-    | BLACKHOLE-    | MVAR_CLEAN-    | MVAR_DIRTY-    | TVAR-    | ARR_WORDS-    | MUT_ARR_PTRS_CLEAN-    | MUT_ARR_PTRS_DIRTY-    | MUT_ARR_PTRS_FROZEN_DIRTY-    | MUT_ARR_PTRS_FROZEN_CLEAN-    | MUT_VAR_CLEAN-    | MUT_VAR_DIRTY-    | WEAK-    | PRIM-    | MUT_PRIM-    | TSO-    | STACK-    | TREC_CHUNK-    | ATOMICALLY_FRAME-    | CATCH_RETRY_FRAME-    | CATCH_STM_FRAME-    | WHITEHOLE-    | SMALL_MUT_ARR_PTRS_CLEAN-    | SMALL_MUT_ARR_PTRS_DIRTY-    | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY-    | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN-    | COMPACT_NFDATA-    | CONTINUATION-    | N_CLOSURE_TYPES- deriving (Enum, Eq, Ord, Show, Generic)-#endif  -- | Return the size of the closures header in words closureTypeHeaderSize :: ClosureType -> Int

@@ -8,12 +8,18 @@ {-# LANGUAGE DeriveTraversable #-} -- Late cost centres introduce a thunk in the asBox function, which leads to -- an additional wrapper being added to any value placed inside a box.+-- This can be removed once our boot compiler is no longer affected by #25212 {-# OPTIONS_GHC -fno-prof-late  #-}+{-# LANGUAGE NamedFieldPuns #-}  module GHC.Exts.Heap.Closures (     -- * Closures       Closure     , GenClosure(..)+    , getClosureInfoTbl+    , getClosureInfoTbl_maybe+    , getClosurePtrArgs+    , getClosurePtrArgs_maybe     , PrimType(..)     , WhatNext(..)     , WhyBlocked(..)@@ -35,521 +41,4 @@     , asBox     ) where -import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.Constants-#if defined(PROFILING)-import GHC.Exts.Heap.InfoTable () -- see Note [No way-dependent imports]-import GHC.Exts.Heap.InfoTableProf-#else-import GHC.Exts.Heap.InfoTable-import GHC.Exts.Heap.InfoTableProf () -- see Note [No way-dependent imports]--{--Note [No way-dependent imports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-`ghc -M` currently assumes that the imports for a module are the same-in every way.  This is arguably a bug, but breaking this assumption by-importing different things in different ways can cause trouble.  For-example, this module in the profiling way imports and uses-GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the-vanilla way, there were intermittent build failures due to this module-being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf-in the profiling way. (#15197)--}-#endif--import GHC.Exts.Heap.ProfInfo.Types--import Data.Bits-import Data.Foldable (toList)-import Data.Int-import Data.Word-import GHC.Exts-import GHC.Generics-import Numeric----------------------------------------------------------------------------- Boxes--foreign import prim "aToWordzh" aToWord# :: Any -> Word#--foreign import prim "reallyUnsafePtrEqualityUpToTag"-    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#---- | 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--instance Show Box where--- From libraries/base/GHC/Ptr.lhs-   showsPrec _ (Box a) rs =-    -- unsafePerformIO (print "↓" >> pClosure a) `seq`-    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs-     where-       ptr  = W# (aToWord# a)-       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)-       addr = ptr - tag-       pad_out ls = '0':'x':ls---- |This takes an arbitrary value and puts it into a box.--- Note that calls like------ > asBox (head list)------ will put the thunk \"head list\" into the box, /not/ the element at the head--- of the list. For that, use careful case expressions:------ > case list of x:_ -> asBox x-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-type Closure = GenClosure Box---- | This is the representation of a Haskell value on the heap. It reflects--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closures.h>------ The data type is parametrized by `b`: the type to store references in.--- Usually this is a 'Box' with the type synonym 'Closure'.------ All Heap objects have the same basic layout. A header containing a pointer to--- the info table and a payload with various fields. The @info@ field below--- always refers to the info table pointed to by the header. The remaining--- fields are the payload.------ See--- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>--- for more information.-data GenClosure b-  = -- | A data constructor-    ConstrClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        , pkg        :: !String         -- ^ Package name-        , modl       :: !String         -- ^ Module name-        , name       :: !String         -- ^ Constructor name-        }--    -- | A function-  | FunClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        }--    -- | A thunk, an expression not obviously in head normal form-  | ThunkClosure-        { info       :: !StgInfoTable-        , ptrArgs    :: ![b]            -- ^ Pointer arguments-        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments-        }--    -- | A thunk which performs a simple selection operation-  | SelectorClosure-        { info       :: !StgInfoTable-        , selectee   :: !b              -- ^ Pointer to the object being-                                        --   selected from-        }--    -- | An unsaturated function application-  | PAPClosure-        { info       :: !StgInfoTable-        , arity      :: !HalfWord       -- ^ Arity of the partial application-        , n_args     :: !HalfWord       -- ^ Size of the payload in words-        , fun        :: !b              -- ^ Pointer to a 'FunClosure'-        , payload    :: ![b]            -- ^ Sequence of already applied-                                        --   arguments-        }--    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported-    -- functions fun actually find the name here.-    -- At least the other direction works via "lookupSymbol-    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)-    -- | A function application-  | APClosure-        { info       :: !StgInfoTable-        , arity      :: !HalfWord       -- ^ Always 0-        , n_args     :: !HalfWord       -- ^ Size of payload in words-        , fun        :: !b              -- ^ Pointer to a 'FunClosure'-        , payload    :: ![b]            -- ^ Sequence of already applied-                                        --   arguments-        }--    -- | A suspended thunk evaluation-  | APStackClosure-        { info       :: !StgInfoTable-        , fun        :: !b              -- ^ Function closure-        , payload    :: ![b]            -- ^ Stack right before suspension-        }--    -- | A pointer to another closure, introduced when a thunk is updated-    -- to point at its value-  | IndClosure-        { info       :: !StgInfoTable-        , indirectee :: !b              -- ^ Target closure-        }--   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code-   -- interpreter (e.g. as used by GHCi)-  | BCOClosure-        { info       :: !StgInfoTable-        , instrs     :: !b              -- ^ A pointer to an ArrWords-                                        --   of instructions-        , literals   :: !b              -- ^ A pointer to an ArrWords-                                        --   of literals-        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords-                                        --   of byte code objects-        , arity      :: !HalfWord       -- ^ The arity of this BCO-        , size       :: !HalfWord       -- ^ The size of this BCO in words-        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the-                                        --   pointerhood of its args/free vars-        }--    -- | A thunk under evaluation by another thread-  | BlackholeClosure-        { info       :: !StgInfoTable-        , indirectee :: !b              -- ^ The target closure-        }--    -- | A @ByteArray#@-  | ArrWordsClosure-        { info       :: !StgInfoTable-        , bytes      :: !Word           -- ^ Size of array in bytes-        , arrWords   :: ![Word]         -- ^ Array payload-        }--    -- | A @MutableByteArray#@-  | MutArrClosure-        { info       :: !StgInfoTable-        , mccPtrs    :: !Word           -- ^ Number of pointers-        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h-        , mccPayload :: ![b]            -- ^ Array payload-        -- Card table ignored-        }--    -- | A @SmallMutableArray#@-    ---    -- @since 8.10.1-  | SmallMutArrClosure-        { info       :: !StgInfoTable-        , mccPtrs    :: !Word           -- ^ Number of pointers-        , mccPayload :: ![b]            -- ^ Array payload-        }--  -- | An @MVar#@, with a queue of thread state objects blocking on them-  | MVarClosure-    { info       :: !StgInfoTable-    , queueHead  :: !b              -- ^ Pointer to head of queue-    , queueTail  :: !b              -- ^ Pointer to tail of queue-    , value      :: !b              -- ^ Pointer to closure-    }--    -- | An @IOPort#@, with a queue of thread state objects blocking on them-  | IOPortClosure-        { info       :: !StgInfoTable-        , queueHead  :: !b              -- ^ Pointer to head of queue-        , queueTail  :: !b              -- ^ Pointer to tail of queue-        , value      :: !b              -- ^ Pointer to closure-        }--    -- | A @MutVar#@-  | MutVarClosure-        { info       :: !StgInfoTable-        , var        :: !b              -- ^ Pointer to contents-        }--    -- | An STM blocking queue.-  | BlockingQueueClosure-        { info       :: !StgInfoTable-        , link       :: !b              -- ^ ?? Here so it looks like an IND-        , blackHole  :: !b              -- ^ The blackhole closure-        , owner      :: !b              -- ^ The owning thread state object-        , queue      :: !b              -- ^ ??-        }--  | WeakClosure-        { info        :: !StgInfoTable-        , cfinalizers :: !b-        , key         :: !b-        , value       :: !b-        , finalizer   :: !b-        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability-        }--  -- | Representation of StgTSO: A Thread State Object. The values for-  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.-  | TSOClosure-      { info                :: !StgInfoTable-      -- pointers-      , link                :: !b-      , global_link         :: !b-      , tsoStack            :: !b -- ^ stackobj from StgTSO-      , trec                :: !b-      , blocked_exceptions  :: !b-      , bq                  :: !b-      , thread_label        :: !(Maybe b)-      -- values-      , what_next           :: !WhatNext-      , why_blocked         :: !WhyBlocked-      , flags               :: ![TsoFlags]-      , threadId            :: !Word64-      , saved_errno         :: !Word32-      , tso_dirty           :: !Word32 -- ^ non-zero => dirty-      , alloc_limit         :: !Int64-      , tot_stack_size      :: !Word32-      , prof                :: !(Maybe StgTSOProfInfo)-      }--  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.-  | StackClosure-      { info            :: !StgInfoTable-      , stack_size      :: !Word32 -- ^ stack size in *words*-      , stack_dirty     :: !Word8 -- ^ non-zero => dirty-#if __GLASGOW_HASKELL__ >= 811-      , stack_marking   :: !Word8-#endif-      }--    -------------------------------------------------------------    -- Unboxed unlifted closures--    -- | Primitive Int-  | IntClosure-        { ptipe      :: PrimType-        , intVal     :: !Int }--    -- | Primitive Word-  | WordClosure-        { ptipe      :: PrimType-        , wordVal    :: !Word }--    -- | Primitive Int64-  | Int64Closure-        { ptipe      :: PrimType-        , int64Val   :: !Int64 }--    -- | Primitive Word64-  | Word64Closure-        { ptipe      :: PrimType-        , word64Val  :: !Word64 }--    -- | Primitive Addr-  | AddrClosure-        { ptipe      :: PrimType-        , addrVal    :: !(Ptr ()) }--    -- | Primitive Float-  | FloatClosure-        { ptipe      :: PrimType-        , floatVal   :: !Float }--    -- | Primitive Double-  | DoubleClosure-        { ptipe      :: PrimType-        , doubleVal  :: !Double }--    ------------------------------------------------------------    -- Anything else--    -- | Another kind of closure-  | OtherClosure-        { info       :: !StgInfoTable-        , hvalues    :: ![b]-        , rawWords   :: ![Word]-        }--  | 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           :: ![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-      , 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-      , 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)--data PrimType-  = PInt-  | PWord-  | PInt64-  | PWord64-  | PAddr-  | PFloat-  | PDouble-  deriving (Eq, Show, Generic, Ord)--data WhatNext-  = ThreadRunGHC-  | ThreadInterpret-  | ThreadKilled-  | ThreadComplete-  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)--data WhyBlocked-  = NotBlocked-  | BlockedOnMVar-  | BlockedOnMVarRead-  | BlockedOnBlackHole-  | BlockedOnRead-  | BlockedOnWrite-  | BlockedOnDelay-  | BlockedOnSTM-  | BlockedOnDoProc-  | BlockedOnCCall-  | BlockedOnCCall_Interruptible-  | BlockedOnMsgThrowTo-  | ThreadMigrating-  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)--data TsoFlags-  = TsoLocked-  | TsoBlockx-  | TsoInterruptible-  | TsoStoppedOnBreakpoint-  | TsoMarked-  | TsoSqueezed-  | TsoAllocLimit-  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug-  deriving (Eq, Show, Generic, Ord)---- | For generic code, this function returns all referenced closures.-allClosures :: GenClosure b -> [b]-allClosures (ConstrClosure {..}) = ptrArgs-allClosures (ThunkClosure {..}) = ptrArgs-allClosures (SelectorClosure {..}) = [selectee]-allClosures (IndClosure {..}) = [indirectee]-allClosures (BlackholeClosure {..}) = [indirectee]-allClosures (APClosure {..}) = fun:payload-allClosures (PAPClosure {..}) = fun:payload-allClosures (APStackClosure {..}) = fun:payload-allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]-allClosures (ArrWordsClosure {}) = []-allClosures (MutArrClosure {..}) = mccPayload-allClosures (SmallMutArrClosure {..}) = mccPayload-allClosures (MutVarClosure {..}) = [var]-allClosures (MVarClosure {..}) = [queueHead,queueTail,value]-allClosures (IOPortClosure {..}) = [queueHead,queueTail,value]-allClosures (FunClosure {..}) = ptrArgs-allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]-allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink-allClosures (OtherClosure {..}) = hvalues-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)+import GHC.Internal.Heap.Closures

@@ -0,0 +1,7 @@+module GHC.Exts.Heap.Constants+    ( wORD_SIZE+    , tAG_MASK+    , wORD_SIZE_IN_BITS+    ) where++import GHC.Internal.Heap.Constants

@@ -1,17 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Exts.Heap.Constants-    ( wORD_SIZE-    , tAG_MASK-    , wORD_SIZE_IN_BITS-    ) where--#include "MachDeps.h"--import Prelude -- See note [Why do we import Prelude here?]-import Data.Bits--wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int-wORD_SIZE = #const SIZEOF_HSWORD-wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS-tAG_MASK = (1 `shift` #const TAG_BITS) - 1

@@ -87,6 +87,10 @@                 | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)                 | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)                 | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)+#if __GLASGOW_HASKELL__ >= 913+                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)+                | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)+#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] @@ -99,9 +103,7 @@ data StackFields = StackFields {     stack_size :: Word32,     stack_dirty :: Word8,-#if __GLASGOW_HASKELL__ >= 811     stack_marking :: Word8,-#endif     stack_sp :: Addr## } @@ -110,9 +112,7 @@ peekStackFields ptr = do     stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32     dirty' <- (#peek struct StgStack_, dirty) ptr-#if __GLASGOW_HASKELL__ >= 811     marking' <- (#peek struct StgStack_, marking) ptr-#endif     Ptr sp' <- (#peek struct StgStack_, sp) ptr      -- TODO decode the stack.@@ -120,9 +120,6 @@     return StackFields {         stack_size = stack_size',         stack_dirty = dirty',-#if __GLASGOW_HASKELL__ >= 811         stack_marking = marking',-#endif         stack_sp = sp'     }-

@@ -87,6 +87,10 @@                 | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)                 | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)                 | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)+#if __GLASGOW_HASKELL__ >= 913+                | isSet (#const TSO_STOP_NEXT_BREAKPOINT) w = TsoStopNextBreakpoint : parseTsoFlags (unset (#const TSO_STOP_NEXT_BREAKPOINT) w)+                | isSet (#const TSO_STOP_AFTER_RETURN) w = TsoStopAfterReturn : parseTsoFlags (unset (#const TSO_STOP_AFTER_RETURN) w)+#endif parseTsoFlags 0 = [] parseTsoFlags w = [TsoFlagsUnknownValue w] @@ -99,9 +103,7 @@ data StackFields = StackFields {     stack_size :: Word32,     stack_dirty :: Word8,-#if __GLASGOW_HASKELL__ >= 811     stack_marking :: Word8,-#endif     stack_sp :: Addr## } @@ -110,9 +112,7 @@ peekStackFields ptr = do     stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32     dirty' <- (#peek struct StgStack_, dirty) ptr-#if __GLASGOW_HASKELL__ >= 811     marking' <- (#peek struct StgStack_, marking) ptr-#endif     Ptr sp' <- (#peek struct StgStack_, sp) ptr      -- TODO decode the stack.@@ -120,8 +120,6 @@     return StackFields {         stack_size = stack_size',         stack_dirty = dirty',-#if __GLASGOW_HASKELL__ >= 811         stack_marking = marking',-#endif         stack_sp = sp'     }

@@ -0,0 +1,9 @@+module GHC.Exts.Heap.InfoTable+    ( module GHC.Exts.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++import GHC.Exts.Heap.InfoTable.Types+import GHC.Internal.Heap.InfoTable

@@ -1,73 +0,0 @@-module GHC.Exts.Heap.InfoTable-    ( module GHC.Exts.Heap.InfoTable.Types-    , itblSize-    , peekItbl-    , pokeItbl-    ) where--#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.InfoTable.Types-#if !defined(TABLES_NEXT_TO_CODE)-import GHC.Exts.Heap.Constants-import Data.Maybe-#endif-import Foreign------------------------------------------------------------------------------ Profiling specific code------ The functions that follow all rely on PROFILING. They are duplicated in--- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This--- allows hsc2hs to generate values for both profiling and non-profiling builds.---- | Read an InfoTable from the heap into a haskell type.--- WARNING: This code assumes it is passed a pointer to a "standard" info--- table. If tables_next_to_code is enabled, it will look 1 byte before the--- start for the entry field.-peekItbl :: Ptr StgInfoTable -> IO StgInfoTable-peekItbl a0 = do-#if !defined(TABLES_NEXT_TO_CODE)-  let ptr = a0 `plusPtr` (negate wORD_SIZE)-  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr-#else-  let ptr = a0-      entry' = Nothing-#endif-  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr-  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr-  tipe'   <- (#peek struct StgInfoTable_, type) ptr-  srtlen' <- (#peek struct StgInfoTable_, srt) a0-  return StgInfoTable-    { entry  = entry'-    , ptrs   = ptrs'-    , nptrs  = nptrs'-    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))-    , srtlen = srtlen'-    , code   = Nothing-    }--pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()-pokeItbl a0 itbl = do-#if !defined(TABLES_NEXT_TO_CODE)-  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))-#endif-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)-  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))-  (#poke StgInfoTable, srt) a0 (srtlen itbl)-#if defined(TABLES_NEXT_TO_CODE)-  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)-  case code itbl of-    Nothing -> return ()-    Just (Left xs) -> pokeArray code_offset xs-    Just (Right xs) -> pokeArray code_offset xs-#endif-  where-    toHalfWord :: Int -> HalfWord-    toHalfWord i = fromIntegral i---- | Size in bytes of a standard InfoTable-itblSize :: Int-itblSize = (#size struct StgInfoTable_)

@@ -0,0 +1,8 @@+module GHC.Exts.Heap.InfoTable.Types+    ( StgInfoTable(..)+    , EntryFunPtr+    , HalfWord(..)+    , ItblCodes+    ) where++import GHC.Internal.Heap.InfoTable.Types

@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module GHC.Exts.Heap.InfoTable.Types-    ( StgInfoTable(..)-    , EntryFunPtr-    , HalfWord(..)-    , ItblCodes-    ) where--#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Generics-import GHC.Exts.Heap.ClosureTypes-import Foreign--type ItblCodes = Either [Word8] [Word32]--#include "ghcautoconf.h"--- Ultra-minimalist version specially for constructors-#if SIZEOF_VOID_P == 8-type HalfWord' = Word32-#elif SIZEOF_VOID_P == 4-type HalfWord' = Word16-#else-#error Unknown SIZEOF_VOID_P-#endif--newtype HalfWord = HalfWord HalfWord'-    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)--type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))---- | This is a somewhat faithful representation of an info table. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoTables.h>--- for more details on this data structure.-data StgInfoTable = StgInfoTable {-   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE-   ptrs   :: HalfWord,-   nptrs  :: HalfWord,-   tipe   :: ClosureType,-   srtlen :: HalfWord,-   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE-  } deriving (Eq, Show, Generic)

@@ -0,0 +1,9 @@+module GHC.Exts.Heap.InfoTableProf+    ( module GHC.Exts.Heap.InfoTable.Types+    , itblSize+    , peekItbl+    , pokeItbl+    ) where++import GHC.Exts.Heap.InfoTable.Types+import GHC.Internal.Heap.InfoTableProf

@@ -1,66 +0,0 @@-module GHC.Exts.Heap.InfoTableProf-    ( module GHC.Exts.Heap.InfoTable.Types-    , itblSize-    , peekItbl-    , pokeItbl-    ) where---- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.--- Manually defining PROFILING gives the #peek and #poke macros an accurate--- representation of StgInfoTable_ when hsc2hs runs.-#define PROFILING-#include "Rts.h"--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Exts.Heap.InfoTable.Types-#if !defined(TABLES_NEXT_TO_CODE)-import GHC.Exts.Heap.Constants-import Data.Maybe-#endif-import Foreign---- | Read an InfoTable from the heap into a haskell type.--- WARNING: This code assumes it is passed a pointer to a "standard" info--- table. If tables_next_to_code is enabled, it will look 1 byte before the--- start for the entry field.-peekItbl :: Ptr StgInfoTable -> IO StgInfoTable-peekItbl a0 = do-#if !defined(TABLES_NEXT_TO_CODE)-  let ptr = a0 `plusPtr` (negate wORD_SIZE)-  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr-#else-  let ptr = a0-      entry' = Nothing-#endif-  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr-  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr-  tipe'   <- (#peek struct StgInfoTable_, type) ptr-  srtlen' <- (#peek struct StgInfoTable_, srt) a0-  return StgInfoTable-    { entry  = entry'-    , ptrs   = ptrs'-    , nptrs  = nptrs'-    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))-    , srtlen = srtlen'-    , code   = Nothing-    }--pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()-pokeItbl a0 itbl = do-#if !defined(TABLES_NEXT_TO_CODE)-  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))-#endif-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)-  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))-  (#poke StgInfoTable, srt) a0 (srtlen itbl)-#if defined(TABLES_NEXT_TO_CODE)-  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)-  case code itbl of-    Nothing -> return ()-    Just (Left xs) -> pokeArray code_offset xs-    Just (Right xs) -> pokeArray code_offset xs-#endif--itblSize :: Int-itblSize = (#size struct StgInfoTable_)

@@ -6,7 +6,6 @@     , peekTopCCS ) where -#if __GLASGOW_HASKELL__ >= 811  -- See [hsc and CPP workaround] @@ -158,16 +157,3 @@ -- | casts a @Ptr@ to an @Int@ ptrToInt :: Ptr a -> Int ptrToInt (Ptr a##) = I## (addr2Int## a##)--#else-import Prelude-import Foreign--import GHC.Exts.Heap.ProfInfo.Types--peekStgTSOProfInfo :: (Ptr b -> IO (Maybe CostCentreStack)) -> Ptr a -> IO (Maybe StgTSOProfInfo)-peekStgTSOProfInfo _ _ = return Nothing--peekTopCCS :: Ptr a -> IO (Maybe CostCentreStack)-peekTopCCS _ = return Nothing-#endif

@@ -1,56 +1,9 @@-{-# LANGUAGE DeriveGeneric #-}--module GHC.Exts.Heap.ProfInfo.Types where--import Prelude-import Data.Word-import GHC.Generics---- | This is a somewhat faithful representation of StgTSOProfInfo. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h>--- for more details on this data structure.-newtype StgTSOProfInfo = StgTSOProfInfo {-    cccs :: Maybe CostCentreStack-} deriving (Show, Generic, Eq, Ord)---- | This is a somewhat faithful representation of CostCentreStack. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data CostCentreStack = CostCentreStack {-    ccs_ccsID :: Int,-    ccs_cc :: CostCentre,-    ccs_prevStack :: Maybe CostCentreStack,-    ccs_indexTable :: Maybe IndexTable,-    ccs_root :: Maybe CostCentreStack,-    ccs_depth :: Word,-    ccs_scc_count :: Word64,-    ccs_selected :: Word,-    ccs_time_ticks :: Word,-    ccs_mem_alloc :: Word64,-    ccs_inherited_alloc :: Word64,-    ccs_inherited_ticks :: Word-} deriving (Show, Generic, Eq, Ord)---- | This is a somewhat faithful representation of CostCentre. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data CostCentre = CostCentre {-    cc_ccID :: Int,-    cc_label :: String,-    cc_module :: String,-    cc_srcloc :: Maybe String,-    cc_mem_alloc :: Word64,-    cc_time_ticks :: Word,-    cc_is_caf :: Bool,-    cc_link :: Maybe CostCentre-} deriving (Show, Generic, Eq, Ord)+module GHC.Exts.Heap.ProfInfo.Types (+  StgTSOProfInfo(..),+  CostCentreStack(..),+  CostCentre(..),+  IndexTable(..),+)+  where --- | This is a somewhat faithful representation of IndexTable. See--- <https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h>--- for more details on this data structure.-data IndexTable = IndexTable {-    it_cc :: CostCentre,-    it_ccs :: Maybe CostCentreStack,-    it_next :: Maybe IndexTable,-    it_back_edge :: Bool-} deriving (Show, Generic, Eq, Ord)+import GHC.Internal.Heap.ProfInfo.Types

@@ -13,7 +13,6 @@ import Data.Char import Data.List (intercalate) import Foreign-import GHC.CString import GHC.Exts  {- To find the string in the constructor's info table we need to consider

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if MIN_TOOL_VERSION_ghc(9,9,0)+#if MIN_TOOL_VERSION_ghc(9,13,0) {-# LANGUAGE RecordWildCards #-}  module GHC.Exts.Stack@@ -30,6 +30,7 @@ stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs -- The one additional word is a pointer to the next stack chunk stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1+stackFrameSize (AnnFrame {}) = sizeStgAnnFrame stackFrameSize _ = error "Unexpected stack frame type"  #else

@@ -0,0 +1,35 @@+module GHC.Exts.Stack.Constants (+  ByteOffset(..),+  WordOffset(..),+  offsetStgCatchFrameHandler,+  sizeStgCatchFrame,+  offsetStgCatchSTMFrameCode,+  offsetStgCatchSTMFrameHandler,+  sizeStgCatchSTMFrame,+  offsetStgUpdateFrameUpdatee,+  sizeStgUpdateFrame,+  offsetStgAtomicallyFrameCode,+  offsetStgAtomicallyFrameResult,+  sizeStgAtomicallyFrame,+  offsetStgCatchRetryFrameRunningAltCode,+  offsetStgCatchRetryFrameRunningFirstCode,+  offsetStgCatchRetryFrameAltCode,+  sizeStgCatchRetryFrame,+  offsetStgRetFunFrameSize,+  offsetStgRetFunFramePayload,+  sizeStgRetFunFrame,+  sizeStgAnnFrame,+  offsetStgAnnFrameAnn,+  offsetStgBCOFrameInstrs,+  offsetStgBCOFrameLiterals,+  offsetStgBCOFramePtrs,+  offsetStgBCOFrameArity,+  offsetStgBCOFrameSize,+  offsetStgClosurePayload,+  sizeStgClosure,+  byteOffsetToWordOffset,+  bytesToWords,+  bytesInWord,+) where++import GHC.Internal.Stack.Constants

@@ -1,126 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module GHC.Exts.Stack.Constants where--#if MIN_TOOL_VERSION_ghc(9,9,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)--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

@@ -1,431 +1,6 @@-{-# LANGUAGE CPP #-}-#if MIN_TOOL_VERSION_ghc(9,9,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-  ( 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.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 "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int#--isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool-isArgGenBigRetFunType stackSnapshot# index =-  I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0---- | 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# ->  Any--foreign import prim "getStackFieldszh"-  getStackFields# ::-    StackSnapshot# -> Word32#--getStackFields :: StackSnapshot# -> Word32-getStackFields stackSnapshot# =-  case getStackFields# stackSnapshot# of-    sSize# -> W32# sSize#---- | `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 -> Box-getClosureBox stackSnapshot# index =-        case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of-          -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and-          -- will later be decoded as such)-          !c -> Box c---- | 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-  pure $ 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] -> [StackField]-decodeBitmaps stack# index ps =-  zipWith toPayload ps [index ..]-  where-    toPayload :: Pointerness -> WordOffset -> StackField-    toPayload p i = case p of-      NonPointer -> StackWord (getWord stack# i)-      Pointer -> StackBox (getClosureBox stack# i)--decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [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-          let 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 ->-          let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload-          in-            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 retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)-              retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)-          retFunPayload' <--            if isArgGenBigRetFunType stackSnapshot# index == True-              then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload-              else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload-          pure $-            RetFun-              { info_tbl = info,-                retFunSize = retFunSize',-                retFunFun = retFunFun',-                retFunPayload = retFunPayload'-              }-        UPDATE_FRAME ->-          let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)-          in-            pure $-              UpdateFrame-                { info_tbl = info,-                  updatee = updatee'-                }-        CATCH_FRAME -> do-          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)-          pure $-            CatchFrame-              { info_tbl = info,-                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-          let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)-              result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)-          pure $-            AtomicallyFrame-              { info_tbl = info,-                atomicallyFrameCode = atomicallyFrameCode',-                result = result'-              }-        CATCH_RETRY_FRAME ->-          let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)-              first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)-              alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)-          in-            pure $-              CatchRetryFrame-                { info_tbl = info,-                  running_alt_code = running_alt_code',-                  first_code = first_code',-                  alt_code = alt_code'-                }-        CATCH_STM_FRAME ->-          let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)-              handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)-          in-            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' = getStackFields stack#-          sfls = stackFrameLocations stack#-      stack' <- mapM unpackStackFrame sfls-      pure $-        GenStgStackClosure-          { ssc_info = info,-            ssc_stack_size = stack_size',-            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+import GHC.Internal.Stack.Decode

@@ -1,13 +0,0 @@-#include "Cmm.h"--aToWordzh (P_ clos)-{-    return (clos);-}--reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)-{-    clos1 = UNTAG(clos1);-    clos2 = UNTAG(clos2);-    return (clos1 == clos2);-}

@@ -1,182 +0,0 @@-// 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_CLOSURE_PTR(closurePtr));--  P_ next_chunk;-  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);-  ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk));-  return (next_chunk);-}--// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)-isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {-  P_ c;-  c = StgStack_sp(stack) + WDS(offsetWords);-  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));--  W_ type;-  (type) = ccall isArgGenBigRetFunType(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) getStackFieldszh(StgStack* stack)-getStackFieldszh(P_ stack){-  bits32 size;-  size = StgStack_stack_size(stack);-  return (size);-}-#endif

@@ -1,151 +0,0 @@-#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/FunTypes.h"-#include "rts/storage/InfoTables.h"--StgWord stackFrameSize(StgStack *stack, StgWord offset) {-  StgClosure *c = (StgClosure *)stack->sp + offset;-  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));-  return stack_frame_sizeW(c);-}--StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {-  StgClosure *frame = (StgClosure *)stack->sp + offset;-  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 isArgGenBigRetFunType(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 == ARG_GEN_BIG;-}--StgClosure *getStackClosure(StgClosure **c) { return *c; }

@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.12.4+version:        9.14.1 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -23,18 +23,12 @@   default-language: Haskell2010    build-depends:    base             >= 4.9.0 && < 5.0-                  , ghc-prim         > 0.2 && < 0.14                   , rts              == 1.0.*-                  , containers       >= 0.6.2.1 && < 0.8+                  , containers       >= 0.6.2.1 && < 0.9 -  if impl(ghc >= 9.9)-    build-depends:  ghc-internal     >= 9.900 && < 9.1204.99999+  build-depends:  ghc-internal >= 9.1401.0 && < 9.1401.99999    ghc-options:      -Wall-  if !os(ghcjs)-    cmm-sources:      cbits/HeapPrim.cmm-                      cbits/Stack.cmm-  c-sources:        cbits/Stack_c.c    default-extensions: NoImplicitPrelude