[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Add Atomically assertion
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Dec 9 19:40:34 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
67a64bae by Sven Tennie at 2022-12-03T16:13:00+00:00
Add Atomically assertion
- - - - -
a8a4bb66 by Sven Tennie at 2022-12-09T19:39:32+00:00
Make stack frame closure types heap closures types
- - - - -
7 changed files:
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/stack_stm_frames.hs
- libraries/ghci/GHCi/Message.hs
Changes:
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -26,16 +26,26 @@ import Control.Concurrent.MVar
import Data.Maybe (catMaybes)
import Foreign
import GHC.Conc.Sync
-import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#)
+import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#, Word#, unsafeCoerce#, eqWord#, isTrue#)
import GHC.IO (IO (..))
import GHC.Stack.CCS (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv)
import GHC.Stable
+import qualified GHC.Generics
-- | A frozen snapshot of the state of an execution stack.
--
-- @since 2.16.0.0
data StackSnapshot = StackSnapshot !StackSnapshot#
+
+-- TODO: Cast to Addr representation instead?
+instance Eq StackSnapshot where
+ (StackSnapshot s1#) == (StackSnapshot s2#) = isTrue# (((unsafeCoerce# s1#) :: Word#) `eqWord#` ((unsafeCoerce# s2#) :: Word#))
+
+-- TODO: Show and Eq instances are mainly here to fulfill Closure deriving requirements
+instance Show StackSnapshot where
+ show _ = "StackSnapshot"
+
foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #)
foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -16,8 +16,6 @@
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack (
- StackFrame(..),
- BitmapPayload(..),
decodeStack
) where
@@ -28,12 +26,12 @@ import Data.Bits
import Foreign
import Prelude
import GHC.Stack.CloneStack
-import GHC.Exts.Heap hiding (bitmap, size)
-- TODO: Remove before releasing
import Debug.Trace
import GHC.Exts
-import qualified GHC.Exts.Heap.Closures as CL
-
+import GHC.Exts.Heap.Closures as CL
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.DecodeHeap
type StackFrameIter# = (#
-- | StgStack
@@ -48,9 +46,6 @@ data StackFrameIter = StackFrameIter StackFrameIter#
instance Show StackFrameIter where
show (StackFrameIter (# _, i# #)) = "StackFrameIter " ++ "(StackSnapshot _" ++ " " ++ show (W# i#)
-instance Show StackSnapshot where
- show _ = "StackSnapshot _"
-
-- | Get an interator starting with the top-most stack frame
stackHead :: StackSnapshot -> StackFrameIter
stackHead (StackSnapshot s) = StackFrameIter (# s , 0## #) -- GHC stacks are never empty
@@ -106,30 +101,31 @@ toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmap bSize = BitmapEntry {
isPrimitive = (bitmap .&. 1) /= 0
} : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (bSize - 1)
-toBitmapPayload :: BitmapEntry -> IO BitmapPayload
-toBitmapPayload e | isPrimitive e = pure $ Primitive . toWord . closureFrame $ e
+toBitmapPayload :: BitmapEntry -> IO Box
+toBitmapPayload e | isPrimitive e = pure $ asBox . CL.UnknownTypeWordSizedPrimitive . toWord . closureFrame $ e
where
toWord (StackFrameIter (# s#, i# #)) = W# (derefStackWord# s# i#)
-toBitmapPayload e = Closure <$> toClosure unpackClosureFromStackFrame# (closureFrame e)
+toBitmapPayload e = toClosure unpackClosureFromStackFrame# (closureFrame e)
-- TODO: Negative offsets won't work! Consider using Word
-getClosure :: StackFrameIter -> Int -> IO CL.Closure
+getClosure :: StackFrameIter -> Int -> IO Box
getClosure sfi relativeOffset = toClosure (unpackClosureReferencedByFrame# (intToWord# relativeOffset)) sfi
-toClosure :: (StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO CL.Closure
+toClosure :: (StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO Box
toClosure f# (StackFrameIter (# s#, i# #)) =
case f# s# i# of
(# infoTableAddr, heapRep, pointersArray #) -> do
let infoTablePtr = Ptr infoTableAddr
ptrList = [case indexArray# pointersArray i of
- (# ptr #) -> Box ptr
+ (# ptr #) -> CL.Box ptr
| I# i <- [0..I# (sizeofArray# pointersArray) - 1]
]
- getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+ c <- (getClosureDataFromHeapRep heapRep infoTablePtr ptrList)
+ pure $ asBox c
-- TODO: Make function more readable: No IO in let bindings
-decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> Word# -> IO [BitmapPayload]
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> Word# -> IO [Box]
decodeLargeBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #)) relativePayloadOffset# =
let !(# bitmapArray#, size# #) = getterFun# stackFrame# closureOffset#
bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
@@ -139,7 +135,7 @@ decodeLargeBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #))
payloads
-- TODO: Make function more readable: No IO in let bindings
-decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> Word# -> IO [BitmapPayload]
+decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> Word# -> IO [Box]
decodeSmallBitmap getterFun# (StackFrameIter (# stackFrame#, closureOffset# #)) relativePayloadOffset# =
let !(# bitmap#, size# #) = getterFun# stackFrame# closureOffset#
bes = toBitmapEntries (StackFrameIter (# stackFrame#, plusWord# closureOffset# relativePayloadOffset# #))(W# bitmap#) (W# size#)
@@ -155,7 +151,7 @@ getHalfWord (StackFrameIter (# s#, i# #)) relativeOffset = W# (getHalfWord# s# i
getWord :: StackFrameIter -> Int -> Word
getWord (StackFrameIter (# s#, i# #)) relativeOffset = W# (getWord# s# i# (intToWord# relativeOffset))
-unpackStackFrameIter :: StackFrameIter -> IO StackFrame
+unpackStackFrameIter :: StackFrameIter -> IO CL.Closure
unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... " ++ show @ClosureType ((toEnum . fromIntegral) (W# (getInfoTableType# s# i#))) ++ "\n") $
case (toEnum . fromIntegral) (W# (getInfoTableType# s# i#)) of
RET_BCO -> do
@@ -165,54 +161,54 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
let arity' = getHalfWord sfi offsetStgRetBCOFrameArity
size' = getHalfWord sfi offsetStgRetBCOFrameSize
payload' <- decodeLargeBitmap getBCOLargeBitmap# sfi 2##
- pure $ RetBCO {
- instrs = instrs',
- literals = literals',
- ptrs = ptrs',
- arity = arity',
- size = size',
- payload = payload'
+ pure $ CL.RetBCO {
+ bcoInstrs = instrs',
+ bcoLiterals = literals',
+ bcoPtrs = ptrs',
+ bcoArity = arity',
+ bcoSize = size',
+ bcoPayload = payload'
}
RET_SMALL -> do
payloads <- decodeSmallBitmap getSmallBitmap# sfi 1##
let special# = getRetSmallSpecialType# s# i#
special = (toEnum . fromInteger . toInteger) (W# special#)
- pure $ RetSmall special payloads
- RET_BIG -> RetBig <$> decodeLargeBitmap getLargeBitmap# sfi 1##
+ pure $ CL.RetSmall special payloads
+ RET_BIG -> CL.RetBig <$> decodeLargeBitmap getLargeBitmap# sfi 1##
RET_FUN -> do
let t = (toEnum . fromInteger . toInteger) (W# (getRetFunType# s# i#))
size' = getWord sfi offsetStgRetFunFrameSize
fun' <- getClosure sfi offsetStgRetFunFrameFun
payload' <-
- if t == ARG_GEN_BIG then
+ if t == CL.ARG_GEN_BIG then
decodeLargeBitmap getRetFunLargeBitmap# sfi 2##
else
decodeSmallBitmap getRetFunSmallBitmap# sfi 2##
- pure $ RetFun t size' fun' payload'
+ pure $ CL.RetFun t size' fun' payload'
-- TODO: Decode update frame type
UPDATE_FRAME -> let
!t = (toEnum . fromInteger . toInteger) (W# (getUpdateFrameType# s# i#))
in
- UpdateFrame t <$> getClosure sfi offsetStgUpdateFrameUpdatee
+ CL.UpdateFrame t <$> getClosure sfi offsetStgUpdateFrameUpdatee
CATCH_FRAME -> do
-- TODO: Replace with getWord# expression
let exceptionsBlocked = W# (getCatchFrameExceptionsBlocked# s# i#)
c <- getClosure sfi offsetStgCatchFrameHandler
- pure $ CatchFrame exceptionsBlocked c
+ pure $ CL.CatchFrame exceptionsBlocked c
UNDERFLOW_FRAME -> let
nextChunk# = getUnderflowFrameNextChunk# s# i#
in
- pure $ UnderflowFrame (StackSnapshot nextChunk#)
- STOP_FRAME -> pure StopFrame
- ATOMICALLY_FRAME -> AtomicallyFrame
+ pure $ CL.UnderflowFrame (StackSnapshot nextChunk#)
+ STOP_FRAME -> pure CL.StopFrame
+ ATOMICALLY_FRAME -> CL.AtomicallyFrame
<$> getClosure sfi offsetStgAtomicallyFrameCode
<*> getClosure sfi offsetStgAtomicallyFrameResult
CATCH_RETRY_FRAME -> do
let running_alt_code' = getWord sfi offsetStgCatchRetryFrameRunningAltCode
first_code' <- getClosure sfi offsetStgCatchRetryFrameRunningFirstCode
alt_code' <- getClosure sfi offsetStgCatchRetryFrameRunningAltCode
- pure $ CatchRetryFrame running_alt_code' first_code' alt_code'
- CATCH_STM_FRAME -> CatchStmFrame
+ pure $ CL.CatchRetryFrame running_alt_code' first_code' alt_code'
+ CATCH_STM_FRAME -> CL.CatchStmFrame
<$> getClosure sfi offsetStgCatchSTMFrameCode
<*> getClosure sfi offsetStgCatchSTMFrameHandler
x -> error $ "Unexpected closure type on stack: " ++ show x
@@ -262,98 +258,6 @@ foreign import prim "getHalfWordzh" getHalfWord# :: StackSnapshot# -> Word# ->
foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
-data BitmapPayload = Closure CL.Closure | Primitive Word
-
-instance Show BitmapPayload where
- show (Primitive w) = "Primitive " ++ show w
- show (Closure ptr) = "Closure " ++ show ptr -- showAddr# addr#
-
--- TODO There are likely more. See MiscClosures.h
-data SpecialRetSmall =
- -- TODO: Shoudn't `None` be better `Maybe ...`?
- None |
- ApV |
- ApF |
- ApD |
- ApL |
- ApN |
- ApP |
- ApPP |
- ApPPP |
- ApPPPP |
- ApPPPPP |
- ApPPPPPP |
- RetV |
- RetP |
- RetN |
- RetF |
- RetD |
- RetL |
- RestoreCCCS |
- RestoreCCCSEval
- deriving (Enum, Eq, Show)
-
-data UpdateFrameType =
- NormalUpdateFrame |
- BhUpdateFrame |
- MarkedUpdateFrame
- deriving (Enum, Eq, Show)
-
-data StackFrame =
- UpdateFrame { knownUpdateFrameType :: UpdateFrameType, updatee :: CL.Closure } |
- CatchFrame { exceptions_blocked :: Word, handler :: CL.Closure } |
- CatchStmFrame { code :: CL.Closure, handler :: CL.Closure } |
- CatchRetryFrame {running_alt_code :: Word, first_code :: CL.Closure, alt_code :: CL.Closure} |
- AtomicallyFrame { code :: CL.Closure, result :: CL.Closure} |
- -- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
- UnderflowFrame { nextChunk:: StackSnapshot } |
- StopFrame |
- RetSmall { knownRetSmallType :: SpecialRetSmall, payload :: [BitmapPayload]} |
- RetBig { payload :: [BitmapPayload] } |
- RetFun { retFunType :: RetFunType, size :: Word, fun :: CL.Closure, payload :: [BitmapPayload]} |
- RetBCO {
- -- TODO: Add pre-defined BCO closures (like knownUpdateFrameType)
- instrs :: CL.Closure,
- literals :: CL.Closure,
- ptrs :: CL.Closure,
- arity :: Word,
- size :: Word,
- payload :: [BitmapPayload]
- }
- deriving (Show)
-
-data RetFunType =
- ARG_GEN |
- ARG_GEN_BIG |
- ARG_BCO |
- ARG_NONE |
- ARG_N |
- ARG_P |
- ARG_F |
- ARG_D |
- ARG_L |
- ARG_V16 |
- ARG_V32 |
- ARG_V64 |
- ARG_NN |
- ARG_NP |
- ARG_PN |
- ARG_PP |
- ARG_NNN |
- ARG_NNP |
- ARG_NPN |
- ARG_NPP |
- ARG_PNN |
- ARG_PNP |
- ARG_PPN |
- ARG_PPP |
- ARG_PPPP |
- ARG_PPPPP |
- ARG_PPPPPP |
- ARG_PPPPPPP |
- ARG_PPPPPPPP
- deriving (Show, Eq, Enum)
-
#if defined(DEBUG)
foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
@@ -361,17 +265,17 @@ belchStack :: StackSnapshot -> IO ()
belchStack (StackSnapshot s#) = belchStack# s#
#endif
-decodeStack :: StackSnapshot -> IO [StackFrame]
+decodeStack :: StackSnapshot -> IO CL.Closure
decodeStack s = do
#if defined(DEBUG)
belchStack s
#endif
- decodeStack' s
+ SimpleStack . (map asBox) <$> decodeStack' s
-decodeStack' :: StackSnapshot -> IO [StackFrame]
+decodeStack' :: StackSnapshot -> IO [CL.Closure]
decodeStack' s = unpackStackFrameIter (stackHead s) >>= \frame -> (frame :) <$> go (advanceStackFrameIter (stackHead s))
where
- go :: Maybe StackFrameIter -> IO [StackFrame]
+ go :: Maybe StackFrameIter -> IO [CL.Closure]
go Nothing = pure []
go (Just sfi) = (trace "decode\n" (unpackStackFrameIter sfi)) >>= \frame -> (frame :) <$> go (advanceStackFrameIter sfi)
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -27,6 +27,9 @@ module GHC.Exts.Heap (
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
+ , UpdateFrameType(..)
+ , SpecialRetSmall(..)
+ , RetFunType(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
, getClosureDataFromHeapRep
@@ -60,23 +63,22 @@ module GHC.Exts.Heap (
import Prelude
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.ClosureTypes
-import GHC.Exts.Heap.Constants
import GHC.Exts.Heap.ProfInfo.Types
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
-import GHC.Exts.Heap.Utils
-import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
-import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
+import GHC.Exts.DecodeHeap
-import Control.Monad
-import Data.Bits
-import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
+#if MIN_VERSION_base(4,17,0)
+import GHC.Stack.CloneStack
+import GHC.Exts.DecodeStack
+#endif
+
#include "ghcconfig.h"
@@ -131,6 +133,11 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
+#if MIN_VERSION_base(4,17,0)
+instance HasHeapRep StackSnapshot# where
+ getClosureData s# = decodeStack (StackSnapshot s#)
+#endif
+
-- | Get the heap representation of a closure _at this moment_, even if it is
-- unevaluated or an indirection or other exotic stuff. Beware when passing
-- something to this function, the same caveats as for
@@ -164,235 +171,6 @@ getClosureDataFromHeapObject x = do
STACK -> pure $ UnsupportedClosure infoTable
_ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
-
--- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
--- function can be generated from a heap object using `unpackClosure#`.
-getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
-getClosureDataFromHeapRep heapRep infoTablePtr pts = do
- itbl <- peekItbl infoTablePtr
- getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts
-
-getClosureDataFromHeapRepPrim
- :: IO (String, String, String)
- -- ^ A continuation used to decode the constructor description field,
- -- in ghc-debug this code can lead to segfaults because dataConNames
- -- will dereference a random part of memory.
- -> (Ptr a -> IO (Maybe CostCentreStack))
- -- ^ A continuation which is used to decode a cost centre stack
- -- In ghc-debug, this code will need to call back into the debuggee to
- -- fetch the representation of the CCS before decoding it. Using
- -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as
- -- the CCS argument will point outside the copied closure.
- -> StgInfoTable
- -- ^ The `StgInfoTable` of the closure, extracted from the heap
- -- representation.
- -> ByteArray#
- -- ^ Heap representation of the closure as returned by `unpackClosure#`.
- -- This includes all of the object including the header, info table
- -- pointer, pointer data, and non-pointer data. The ByteArray# may be
- -- pinned or unpinned.
- -> [b]
- -- ^ Pointers in the payload of the closure, extracted from the heap
- -- representation as returned by `collect_pointers()` in `Heap.c`. The type
- -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
- -> IO (GenClosure b)
- -- ^ Heap representation of the closure.
-getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
- let -- heapRep as a list of words.
- rawHeapWords :: [Word]
- rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
- where
- nelems = I# (sizeofByteArray# heapRep) `div` wORD_SIZE
- end = fromIntegral nelems - 1
-
- -- Just the payload of rawHeapWords (no header).
- payloadWords :: [Word]
- payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords
-
- -- The non-pointer words in the payload. Only valid for closures with a
- -- "pointers first" layout. Not valid for bit field layout.
- npts :: [Word]
- npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords
- case tipe itbl of
- t | t >= CONSTR && t <= CONSTR_NOCAF -> do
- (p, m, n) <- getConDesc
- pure $ ConstrClosure itbl pts npts p m n
-
- t | t >= THUNK && t <= THUNK_STATIC -> do
- pure $ ThunkClosure itbl pts npts
-
- THUNK_SELECTOR -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
- pure $ SelectorClosure itbl (head pts)
-
- t | t >= FUN && t <= FUN_STATIC -> do
- pure $ FunClosure itbl pts npts
-
- AP -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to AP"
- -- We expect at least the arity, n_args, and fun fields
- unless (length payloadWords >= 2) $
- fail "Expected at least 2 raw words to AP"
- let splitWord = payloadWords !! 0
- pure $ APClosure itbl
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- (head pts) (tail pts)
-
- PAP -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to PAP"
- -- We expect at least the arity, n_args, and fun fields
- unless (length payloadWords >= 2) $
- fail "Expected at least 2 raw words to PAP"
- let splitWord = payloadWords !! 0
- pure $ PAPClosure itbl
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- (head pts) (tail pts)
-
- AP_STACK -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to AP_STACK"
- pure $ APStackClosure itbl (head pts) (tail pts)
-
- IND -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to IND"
- pure $ IndClosure itbl (head pts)
-
- IND_STATIC -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to IND_STATIC"
- pure $ IndClosure itbl (head pts)
-
- BLACKHOLE -> do
- unless (length pts >= 1) $
- fail "Expected at least 1 ptr argument to BLACKHOLE"
- pure $ BlackholeClosure itbl (head pts)
-
- BCO -> do
- unless (length pts >= 3) $
- fail $ "Expected at least 3 ptr argument to BCO, found "
- ++ show (length pts)
- unless (length payloadWords >= 4) $
- fail $ "Expected at least 4 words to BCO, found "
- ++ show (length payloadWords)
- let splitWord = payloadWords !! 3
- pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- (drop 4 payloadWords)
-
- ARR_WORDS -> do
- unless (length payloadWords >= 1) $
- fail $ "Expected at least 1 words to ARR_WORDS, found "
- ++ show (length payloadWords)
- pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
-
- t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length payloadWords >= 2) $
- fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
- pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
-
- t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
- unless (length payloadWords >= 1) $
- fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
- pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
-
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
- unless (length pts >= 1) $
- fail $ "Expected at least 1 words to MUT_VAR, found "
- ++ show (length pts)
- pure $ MutVarClosure itbl (head pts)
-
- t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
- unless (length pts >= 3) $
- fail $ "Expected at least 3 ptrs to MVAR, found "
- ++ show (length pts)
- pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
-
- BLOCKING_QUEUE ->
- pure $ OtherClosure itbl pts rawHeapWords
- -- pure $ BlockingQueueClosure itbl
- -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
-
- -- pure $ OtherClosure itbl pts rawHeapWords
- --
- WEAK -> do
- pure $ WeakClosure
- { info = itbl
- , cfinalizers = pts !! 0
- , key = pts !! 1
- , value = pts !! 2
- , finalizer = pts !! 3
- , weakLink = case drop 4 pts of
- [] -> Nothing
- [p] -> Just p
- _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
- }
- TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
- -> withArray rawHeapWords (\ptr -> do
- fields <- FFIClosures.peekTSOFields decodeCCS ptr
- pure $ TSOClosure
- { info = itbl
- , link = u_lnk
- , global_link = u_gbl_lnk
- , tsoStack = tso_stack
- , trec = u_trec
- , blocked_exceptions = u_blk_ex
- , bq = u_bq
- , what_next = FFIClosures.tso_what_next fields
- , why_blocked = FFIClosures.tso_why_blocked fields
- , flags = FFIClosures.tso_flags fields
- , threadId = FFIClosures.tso_threadId fields
- , saved_errno = FFIClosures.tso_saved_errno fields
- , tso_dirty = FFIClosures.tso_dirty fields
- , alloc_limit = FFIClosures.tso_alloc_limit fields
- , tot_stack_size = FFIClosures.tso_tot_stack_size fields
- , prof = FFIClosures.tso_prof fields
- })
- | otherwise
- -> fail $ "Expected 6 ptr arguments to TSO, found "
- ++ show (length pts)
- STACK
- | [] <- pts
- -> withArray rawHeapWords (\ptr -> do
- fields <- FFIClosures.peekStackFields ptr
- pure $ StackClosure
- { info = itbl
- , stack_size = FFIClosures.stack_size fields
- , stack_dirty = FFIClosures.stack_dirty fields
-#if __GLASGOW_HASKELL__ >= 811
- , stack_marking = FFIClosures.stack_marking fields
-#endif
- })
- | otherwise
- -> fail $ "Expected 0 ptr argument to STACK, found "
- ++ show (length pts)
-
- _ ->
- pure $ UnsupportedClosure itbl
-
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -15,8 +15,12 @@ module GHC.Exts.Heap.Closures (
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
+ , UpdateFrameType(..)
+ , SpecialRetSmall(..)
+ , RetFunType(..)
, allClosures
, closureSize
+ , RetFunType(..)
-- * Boxes
, Box(..)
@@ -48,6 +52,10 @@ import GHC.Exts
import GHC.Generics
import Numeric
+#if MIN_VERSION_base(4,17,0)
+import GHC.Stack.CloneStack (StackSnapshot(..))
+#endif
+
------------------------------------------------------------------------
-- Boxes
@@ -302,6 +310,70 @@ data GenClosure b
#endif
}
+#if MIN_VERSION_base(4,17,0)
+ -- TODO: I could model stack chunks here (much better). However, I need the
+ -- code to typecheck, now.
+ | SimpleStack {
+ stackClosures :: ![b]
+ }
+ -- TODO: Add `info :: !StgInfoTable` fields
+ | UpdateFrame
+ { knownUpdateFrameType :: !UpdateFrameType
+ , updatee :: !b
+ }
+
+ | CatchFrame
+ { exceptions_blocked :: Word
+ , handler :: !b
+ }
+
+ | CatchStmFrame
+ { catchFrameCode :: !b
+ , handler :: !b
+ }
+
+ | CatchRetryFrame
+ { running_alt_code :: !Word
+ , first_code :: !b
+ , alt_code :: !b
+ }
+
+ | AtomicallyFrame
+ { atomicallyFrameCode :: !b
+ , result :: !b
+ }
+
+ -- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
+ | UnderflowFrame
+ { nextChunk:: !StackSnapshot }
+
+ | StopFrame
+
+ | RetSmall
+ { knownRetSmallType :: !SpecialRetSmall
+ , payload :: ![b]
+ }
+
+ | RetBig
+ { payload :: ![b] }
+
+ | RetFun
+ { retFunType :: RetFunType
+ , retFunSize :: Word
+ , retFunFun :: !b
+ , retFunPayload :: ![b]
+ }
+
+ | RetBCO
+ -- TODO: Add pre-defined BCO closures (like knownUpdateFrameType)
+ { bcoInstrs :: !b
+ , bcoLiterals :: !b
+ , bcoPtrs :: !b
+ , bcoArity :: !Word
+ , bcoSize :: !Word
+ , bcoPayload :: ![b]
+ }
+#endif
------------------------------------------------------------
-- Unboxed unlifted closures
@@ -353,8 +425,73 @@ data GenClosure b
| UnsupportedClosure
{ info :: !StgInfoTable
}
+
+ | UnknownTypeWordSizedPrimitive
+ { wordVal :: !Word }
deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
+-- TODO There are likely more. See MiscClosures.h
+data SpecialRetSmall =
+ -- TODO: Shoudn't `None` be better `Maybe ...`?
+ None |
+ ApV |
+ ApF |
+ ApD |
+ ApL |
+ ApN |
+ ApP |
+ ApPP |
+ ApPPP |
+ ApPPPP |
+ ApPPPPP |
+ ApPPPPPP |
+ RetV |
+ RetP |
+ RetN |
+ RetF |
+ RetD |
+ RetL |
+ RestoreCCCS |
+ RestoreCCCSEval
+ deriving (Enum, Eq, Show, Generic)
+
+data UpdateFrameType =
+ NormalUpdateFrame |
+ BhUpdateFrame |
+ MarkedUpdateFrame
+ deriving (Enum, Eq, Show, Generic, Ord)
+
+data RetFunType =
+ ARG_GEN |
+ ARG_GEN_BIG |
+ ARG_BCO |
+ ARG_NONE |
+ ARG_N |
+ ARG_P |
+ ARG_F |
+ ARG_D |
+ ARG_L |
+ ARG_V16 |
+ ARG_V32 |
+ ARG_V64 |
+ ARG_NN |
+ ARG_NP |
+ ARG_PN |
+ ARG_PP |
+ ARG_NNN |
+ ARG_NNP |
+ ARG_NPN |
+ ARG_NPP |
+ ARG_PNN |
+ ARG_PNP |
+ ARG_PPN |
+ ARG_PPP |
+ ARG_PPPP |
+ ARG_PPPPP |
+ ARG_PPPPPP |
+ ARG_PPPPPPP |
+ ARG_PPPPPPPP
+ deriving (Show, Eq, Enum, Generic)
data PrimType
= PInt
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.Exts.Heap.Closures
GHC.Exts.Heap.ClosureTypes
GHC.Exts.Heap.Constants
+ GHC.Exts.DecodeHeap
GHC.Exts.DecodeStack
GHC.Exts.Heap.InfoTable
GHC.Exts.Heap.InfoTable.Types
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -18,6 +18,10 @@ main = do
"Stack contains one catch stm frame"
(== 1)
(length $ filter isCatchStmFrame decodedStack)
+ assertThat
+ "Stack contains one atomically frame"
+ (== 1)
+ (length $ filter isAtomicallyFrame decodedStack)
getDecodedStack :: IO (StackSnapshot, [StackFrame])
getDecodedStack = do
@@ -28,3 +32,7 @@ getDecodedStack = do
isCatchStmFrame :: StackFrame -> Bool
isCatchStmFrame (CatchStmFrame _ _) = True
isCatchStmFrame _ = False
+
+isAtomicallyFrame :: StackFrame -> Bool
+isAtomicallyFrame (AtomicallyFrame _ _) = True
+isAtomicallyFrame _ = False
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
- CPP #-}
+ CPP, MagicHash, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
-- |
@@ -53,7 +53,11 @@ import qualified Language.Haskell.TH.Syntax as TH
import System.Exit
import System.IO
import System.IO.Error
-
+#if MIN_VERSION_base(4,17,0)
+import GHC.Stack.CloneStack
+import GHC.Word (Word(W#))
+import GHC.Exts (Word#, unsafeCoerce#, StackSnapshot#)
+#endif
-- -----------------------------------------------------------------------------
-- The RPC protocol between GHC and the interactive server
@@ -471,6 +475,21 @@ instance Binary Heap.WhyBlocked
instance Binary Heap.TsoFlags
#endif
+#if MIN_VERSION_base(4,17,0)
+instance Binary Heap.SpecialRetSmall
+instance Binary Heap.UpdateFrameType
+instance Binary Heap.RetFunType
+-- TODO: Revisit this. This instance is pretty hacky (unsafeCoerce# ...)
+instance Binary StackSnapshot where
+ get = do
+ v <- get @Word
+ pure $ StackSnapshot (toPrim v)
+ where
+ toPrim :: Word -> StackSnapshot#
+ toPrim (W# w#) = unsafeCoerce# w#
+ put (StackSnapshot s#) = put (W# ((unsafeCoerce# s#) :: Word#))
+#endif
+
instance Binary Heap.StgInfoTable
instance Binary Heap.ClosureType
instance Binary Heap.PrimType
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989cebf1929949435251e4c22986e6fb512d7f3a...a8a4bb669eecd5ec3d2472a91828174f1f4b8cdb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989cebf1929949435251e4c22986e6fb512d7f3a...a8a4bb669eecd5ec3d2472a91828174f1f4b8cdb
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221209/749b1922/attachment-0001.html>
More information about the ghc-commits
mailing list