diff --git a/GHC/Exts/Heap.hs b/GHC/Exts/Heap.hs --- a/GHC/Exts/Heap.hs +++ b/GHC/Exts/Heap.hs @@ -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 " diff --git a/GHC/Exts/Heap/ClosureTypes.hs b/GHC/Exts/Heap/ClosureTypes.hs --- a/GHC/Exts/Heap/ClosureTypes.hs +++ b/GHC/Exts/Heap/ClosureTypes.hs @@ -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 diff --git a/GHC/Exts/Heap/Closures.hs b/GHC/Exts/Heap/Closures.hs --- a/GHC/Exts/Heap/Closures.hs +++ b/GHC/Exts/Heap/Closures.hs @@ -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 --- --- --- 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 --- --- 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 diff --git a/GHC/Exts/Heap/Constants.hs b/GHC/Exts/Heap/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/Constants.hs @@ -0,0 +1,7 @@ +module GHC.Exts.Heap.Constants + ( wORD_SIZE + , tAG_MASK + , wORD_SIZE_IN_BITS + ) where + +import GHC.Internal.Heap.Constants diff --git a/GHC/Exts/Heap/Constants.hsc b/GHC/Exts/Heap/Constants.hsc deleted file mode 100644 --- a/GHC/Exts/Heap/Constants.hsc +++ /dev/null @@ -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 diff --git a/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc --- a/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc +++ b/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc @@ -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' } - diff --git a/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc --- a/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc +++ b/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc @@ -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' } diff --git a/GHC/Exts/Heap/InfoTable.hs b/GHC/Exts/Heap/InfoTable.hs new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/InfoTable.hs @@ -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 diff --git a/GHC/Exts/Heap/InfoTable.hsc b/GHC/Exts/Heap/InfoTable.hsc deleted file mode 100644 --- a/GHC/Exts/Heap/InfoTable.hsc +++ /dev/null @@ -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_) diff --git a/GHC/Exts/Heap/InfoTable/Types.hs b/GHC/Exts/Heap/InfoTable/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/InfoTable/Types.hs @@ -0,0 +1,8 @@ +module GHC.Exts.Heap.InfoTable.Types + ( StgInfoTable(..) + , EntryFunPtr + , HalfWord(..) + , ItblCodes + ) where + +import GHC.Internal.Heap.InfoTable.Types diff --git a/GHC/Exts/Heap/InfoTable/Types.hsc b/GHC/Exts/Heap/InfoTable/Types.hsc deleted file mode 100644 --- a/GHC/Exts/Heap/InfoTable/Types.hsc +++ /dev/null @@ -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 --- --- 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) diff --git a/GHC/Exts/Heap/InfoTableProf.hs b/GHC/Exts/Heap/InfoTableProf.hs new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/InfoTableProf.hs @@ -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 diff --git a/GHC/Exts/Heap/InfoTableProf.hsc b/GHC/Exts/Heap/InfoTableProf.hsc deleted file mode 100644 --- a/GHC/Exts/Heap/InfoTableProf.hsc +++ /dev/null @@ -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_) diff --git a/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc --- a/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc +++ b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc @@ -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 diff --git a/GHC/Exts/Heap/ProfInfo/Types.hs b/GHC/Exts/Heap/ProfInfo/Types.hs --- a/GHC/Exts/Heap/ProfInfo/Types.hs +++ b/GHC/Exts/Heap/ProfInfo/Types.hs @@ -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 --- --- 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 --- --- 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 --- --- 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 --- --- 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 diff --git a/GHC/Exts/Heap/Utils.hsc b/GHC/Exts/Heap/Utils.hsc --- a/GHC/Exts/Heap/Utils.hsc +++ b/GHC/Exts/Heap/Utils.hsc @@ -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 diff --git a/GHC/Exts/Stack.hs b/GHC/Exts/Stack.hs --- a/GHC/Exts/Stack.hs +++ b/GHC/Exts/Stack.hs @@ -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 diff --git a/GHC/Exts/Stack/Constants.hs b/GHC/Exts/Stack/Constants.hs new file mode 100644 --- /dev/null +++ b/GHC/Exts/Stack/Constants.hs @@ -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 diff --git a/GHC/Exts/Stack/Constants.hsc b/GHC/Exts/Stack/Constants.hsc deleted file mode 100644 --- a/GHC/Exts/Stack/Constants.hsc +++ /dev/null @@ -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 diff --git a/GHC/Exts/Stack/Decode.hs b/GHC/Exts/Stack/Decode.hs --- a/GHC/Exts/Stack/Decode.hs +++ b/GHC/Exts/Stack/Decode.hs @@ -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 diff --git a/cbits/HeapPrim.cmm b/cbits/HeapPrim.cmm deleted file mode 100644 --- a/cbits/HeapPrim.cmm +++ /dev/null @@ -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); -} diff --git a/cbits/Stack.cmm b/cbits/Stack.cmm deleted file mode 100644 --- a/cbits/Stack.cmm +++ /dev/null @@ -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 diff --git a/cbits/Stack_c.c b/cbits/Stack_c.c deleted file mode 100644 --- a/cbits/Stack_c.c +++ /dev/null @@ -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; } diff --git a/ghc-heap.cabal b/ghc-heap.cabal --- a/ghc-heap.cabal +++ b/ghc-heap.cabal @@ -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