[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Cleanup
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Oct 8 07:38:51 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
a342ceb8 by Sven Tennie at 2022-10-08T07:32:48+00:00
Cleanup
- - - - -
8e623557 by Sven Tennie at 2022-10-08T07:38:31+00:00
Fix some warnings
- - - - -
1 changed file:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -13,16 +13,16 @@
-- TODO: Find better place than top level. Re-export from top-level?
module GHC.Exts.DecodeStack where
-import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
#if MIN_VERSION_base(4,17,0)
+import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
import Data.Maybe
import Data.Bits
import Foreign
import System.IO.Unsafe
import Prelude
import GHC.Stack.CloneStack
-import GHC.Exts.Heap
+import GHC.Exts.Heap hiding (bitmap, size)
import Debug.Trace
import GHC.Exts
import qualified GHC.Exts.Heap.Closures as CL
@@ -206,13 +206,16 @@ data StackFrame =
deriving (Show)
#if defined(DEBUG)
-foreign import ccall "belchStack" belchStack :: StackSnapshot# -> IO ()
+foreign import ccall "belchStack" belchStack# :: StackSnapshot# -> IO ()
+
+belchStack :: StackSnapshot -> IO ()
+belchStack (StackSnapshot s#) = belchStack s#
#endif
decodeStack :: StackSnapshot -> IO [StackFrame]
-decodeStack s@(StackSnapshot s#) = do
+decodeStack s = do
#if defined(DEBUG)
- belchStack s#
+ belchStack s
#endif
pure $ decodeStack' s
@@ -223,236 +226,4 @@ decodeStack' s = unpackStackFrameIter (stackHead s) : go (advanceStackFrameIter
go Nothing = []
go (Just sfi) = unpackStackFrameIter sfi : go (advanceStackFrameIter sfi)
-
--- foreign import ccall "stackFrameSizeW" stackFrameSizeW :: Addr# -> Word
--- foreign import ccall "getItbl" getItbl :: Addr# -> Ptr StgInfoTable
--- foreign import ccall "getSpecialRetSmall" getSpecialRetSmall :: Addr# -> Word
--- foreign import ccall "getBitmapSize" getBitmapSize :: Ptr StgInfoTable -> Word
--- foreign import ccall "getBitmapWord" getBitmapWord :: Ptr StgInfoTable -> Word
--- foreign import prim "stg_unpackClosurezh" unpackClosure_prim# :: Word# -> (# Addr#, ByteArray#, Array# b #)
--- foreign import ccall "getLargeBitmapPtr" getLargeBitmapPtr :: Ptr StgInfoTable -> Ptr LargeBitmap
--- #if defined(DEBUG)
--- foreign import ccall "belchStack" belchStack :: StackSnapshot# -> IO ()
--- #endif
---
--- decodeStack :: StackSnapshot -> IO [StackFrame]
--- decodeStack (StackSnapshot stack) = do
--- #if defined(DEBUG)
--- performMajorGC
--- belchStack stack
--- #endif
--- let (stgStackPtr :: Ptr FFIClosures.StackFields) = Ptr (unsafeCoerce# stack)
--- stgStack <- FFIClosures.peekStackFields stgStackPtr
--- traceM $ "stack_dirty " ++ show (FFIClosures.stack_dirty stgStack)
--- traceM $ "stack_marking " ++ show (FFIClosures.stack_marking stgStack)
--- traceM $ "stack_size " ++ show (FFIClosures.stack_size stgStack)
--- traceM $ "stack_sp " ++ showAddr# (FFIClosures.stack_sp stgStack)
--- decodeStackChunks stgStack
---
--- decodeStackChunks :: FFIClosures.StackFields -> IO [StackFrame]
--- decodeStackChunks stgStack =
--- let
--- -- TODO: Use word size here, not just 8
--- stackSize = 8 * (FFIClosures.stack_size stgStack)
--- buttom = plusAddr# (FFIClosures.stack_stack stgStack) (integralToInt# stackSize)
--- in
--- decodeStackFrame buttom (FFIClosures.stack_sp stgStack)
---
--- decodeStackFrame :: Addr# -> Addr# -> IO [StackFrame]
--- -- TODO: Use ltAddr# ? (Does it even work?)
--- decodeStackFrame buttom sp | (addrToInt sp) >= (addrToInt buttom) = do
--- traceM $ "decodeStackFrame - buttom " ++ showAddr# buttom
--- traceM $ "decodeStackFrame - sp " ++ showAddr# sp
--- traceM "buttom reached"
--- pure []
--- decodeStackFrame buttom sp = do
--- -- traceM $ "decodeStackFrame - (addrToInt sp) >= (addrToInt buttom)" ++ show ((addrToInt sp) >= (addrToInt buttom))
--- -- traceM $ "decodeStackFrame - buttom " ++ showAddr# buttom
--- traceM $ "decodeStackFrame - sp " ++ showAddr# sp
--- frame <- toStackFrame sp
--- traceM $ "decodeStackFrame - frame " ++ show frame
--- -- TODO: This is probably not lazy and pretty ugly.
--- -- TODO: Use word size instead of 8
--- let
--- closureSize = stackFrameSizeW sp
--- closureSizeInBytes = 8 * closureSize
--- nextSp = plusAddr# sp (integralToInt# closureSizeInBytes)
---
--- traceM $ "decodeStackFrame - closureSize " ++ show closureSize ++ " sp " ++ showAddr# sp
--- traceM $ "decodeStackFrame - nextSp " ++ showAddr# nextSp
--- otherFrames <- decodeStackFrame buttom nextSp
--- return $ frame : otherFrames
---
--- toStackFrame :: Addr# -> IO StackFrame
--- toStackFrame sp = do
--- let itblPtr = getItbl sp
--- itbl <- peekItbl itblPtr
--- traceM $ "itbl " ++ show itbl
--- case tipe itbl of
--- RET_BCO -> pure RetBCO
--- RET_SMALL ->
--- let special = ((toEnum . fromInteger . toInteger) (getSpecialRetSmall sp))
--- -- TODO: Use word size here, not just 8
--- payloadAddr# = plusAddr# sp (toInt# 8)
--- bSize = getBitmapSize itblPtr
--- bWord = getBitmapWord itblPtr
--- in
--- do
--- payloads <- peekBitmapPayloadArray bSize bWord (Ptr payloadAddr#)
--- pure $ RetSmall special payloads
--- RET_BIG -> do
--- let pPtr = payloadPtr (Ptr sp)
--- traceM $ "toStackFrame - BIG_RET - pPtr " ++ show pPtr
--- let largeBitmapPtr = getLargeBitmapPtr itblPtr
--- largeBitmap <- peekStgLargeBitmap largeBitmapPtr
--- traceM $ "toStackFrame - BIG_RET - largeBitmap " ++ show largeBitmap
--- let entries = bitmapEntries pPtr largeBitmap
--- traceM $ "toStackFrame - BIG_RET - entries " ++ show entries
--- payloads <- mapM toClosure $ bitmapEntries pPtr largeBitmap
--- pure $ RetBig payloads
--- RET_FUN -> pure RetFun
--- UPDATE_FRAME -> pure UpdateFrame
--- CATCH_FRAME -> pure CatchFrame
--- UNDERFLOW_FRAME -> pure UnderflowFrame
--- STOP_FRAME -> pure StopFrame
--- ATOMICALLY_FRAME -> pure AtomicallyFrame
--- CATCH_RETRY_FRAME -> pure CatchRetryFrame
--- CATCH_STM_FRAME -> pure CatchStmFrame
--- _ -> error $ "Unexpected closure type on stack: " ++ show (tipe itbl)
---
--- toClosure :: BitmapEntry -> IO BitmapPayload
--- toClosure (BitmapEntry ptr isPrimitive) = if isPrimitive then
--- do
--- -- TODO: duplicated line with else branch
--- e <- peek ptr
--- pure $ Primitive e
--- else
--- do
--- e <- peek ptr
--- c <- getClosureDataFromHeapObject' (toWord# e)
--- pure $ Closure c
---
--- -- Idea:
--- -- 1. convert to list of (significant) bits
--- -- Convert to tupe (Ptr addr, closure type)
--- -- This is pure! And, should be easy to decode, debug and reuse.
--- data BitmapEntry = BitmapEntry {
--- closurePtr :: Ptr Word,
--- isPrimitive :: Bool
--- } deriving (Show)
---
--- bitmapEntries :: Ptr Word -> LargeBitmap -> [BitmapEntry]
--- bitmapEntries payloadPtr (LargeBitmap size ws) =
--- map toBitmapEntry $ zip (bits size ws) [0..]
--- where
--- toBitmapEntry :: (Bool, Int) -> BitmapEntry
--- toBitmapEntry (b,i) = BitmapEntry {
--- closurePtr = plusPtr payloadPtr (i * (fromIntegral bytesInWord)),
--- isPrimitive = b
--- }
---
--- bits :: Word -> [Word] -> [Bool]
--- bits size ws = take (fromIntegral size) $ concat (map toBits ws)
---
--- toBits :: Word -> [Bool]
--- toBits w = go 0
--- where
--- go :: Int -> [Bool]
--- go b | b == (fromIntegral bitsInWord) = []
--- go b = (w .&. (1 `shiftL` b) == 1) : go (b + 1)
---
--- peekLargeBitmap :: Word -> [Word] -> Ptr Word -> IO [BitmapPayload]
--- peekLargeBitmap 0 _ _ = pure []
--- peekLargeBitmap _ [] _ = pure []
--- peekLargeBitmap bSize (w:ws) pPtr = do
--- payloads <- peekPayloadsFromLargeBitmapWord bSize w pPtr
--- -- TODO: Not tail-recursive, breaks lazyness
--- rest <- peekLargeBitmap remainingBitmapSize ws pPtr
--- pure $ payloads ++ rest
--- where
--- remainingBitmapSize = max 0 (bSize - bitsInWord)
---
--- peekPayloadsFromLargeBitmapWord :: Word -> Word -> Ptr Word -> IO [BitmapPayload]
--- peekPayloadsFromLargeBitmapWord bSize bWord ptr = go 0 []
--- where
--- go :: Word -> [BitmapPayload] -> IO [BitmapPayload]
--- go index acc | index >= bitsUsed = pure acc
--- go index acc = do
--- e <- peekBitmapPayload ptr index bWord
--- go (index + 1) (e:acc)
--- bitsUsed = min bitsInWord bSize
---
--- -- TODO: Use Ptr instead of Addr# (in all possible places)?
--- peekBitmapPayloadArray :: Word -> Word -> Ptr Word -> IO [BitmapPayload]
--- peekBitmapPayloadArray bSize bWord ptr = go 0 []
--- where
--- go :: Word -> [BitmapPayload] -> IO [BitmapPayload]
--- go index acc | index >= bSize = pure acc
--- go index acc = do
--- e <- peekBitmapPayload ptr index bWord
--- go (index + 1) (e:acc)
---
--- -- | Fetch a single closure payload
--- -- As the decission about the value to marshall
--- -- to depends on the bitmap, only a `Word` is peeked.
--- peekBitmapPayload :: Ptr Word -> Word -> Word -> IO BitmapPayload
--- peekBitmapPayload ptr index bitmapWord = do
--- traceM $ "peekBitmapPayload - ptr " ++ show ptr
--- traceM $ "peekBitmapPayload - index " ++ show index
--- e <- (peekElemOff ptr i :: IO Word)
--- if isClosure then
--- do
--- c <- getClosureDataFromHeapObject' (toWord# e)
--- pure $ Closure c
--- else
--- pure $ Primitive e
--- where
--- isClosure :: Bool
--- isClosure = (bitmapWord .&. mask) == 0
--- mask :: Word
--- mask = 1 `shiftL` i
--- i :: Int
--- i = (fromInteger.toInteger) index
---
--- getClosureDataFromHeapObject'
--- :: Word#
--- -- ^ Heap object to decode.
--- -> IO Closure
--- -- ^ Heap representation of the closure.
--- getClosureDataFromHeapObject' x = do
--- case unpackClosure_prim# x of
--- (# infoTableAddr, heapRep, pointersArray #) -> do
--- let infoTablePtr = Ptr infoTableAddr
--- ptrList = [case indexArray# pointersArray i of
--- (# ptr #) -> Box ptr
--- | I# i <- [0..I# (sizeofArray# pointersArray) - 1]
--- ]
---
--- infoTable <- peekItbl infoTablePtr
--- case tipe infoTable of
--- TSO -> pure $ UnsupportedClosure infoTable
--- STACK -> pure $ UnsupportedClosure infoTable
--- _ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
---
---
--- -- | Converts to 'Int#'
--- -- An 'Integral' can be bigger than the domain of 'Int#'. This function drops
--- -- the additional bits. So, the caller should better make sure that this
--- -- conversion fits.
--- integralToInt# :: Integral a => a -> Int#
--- integralToInt# w = toInt# $ (fromInteger . toInteger) w
---
--- -- | Unbox 'Int#' from 'Int'
--- toInt# :: Int -> Int#
--- toInt# (I# i) = i
---
--- toWord# :: Word -> Word#
--- toWord# (W# w#) = w#
---
--- showAddr# :: Addr# -> String
--- showAddr# addr# = showHex (addrToInt addr#) ""
---
--- addrToInt:: Addr# -> Int
--- addrToInt addr# = I# (addr2Int# addr#)
---
#endif
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/18f594e85854d5401a31a86fc1bafc431773d08a...8e623557539cbe4d907852920402724ac28a67bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/18f594e85854d5401a31a86fc1bafc431773d08a...8e623557539cbe4d907852920402724ac28a67bc
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/20221008/dcba623d/attachment-0001.html>
More information about the ghc-commits
mailing list