[Git][ghc/ghc][wip/decode_cloned_stack] 6 commits: Un-IO getWord
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Apr 23 10:08:48 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
75039a7b by Sven Tennie at 2023-04-23T09:34:42+00:00
Un-IO getWord
- - - - -
df9f0b2e by Sven Tennie at 2023-04-23T09:38:14+00:00
Un-IO getUnderflowFrameNextChunk
- - - - -
7c26cb2c by Sven Tennie at 2023-04-23T09:44:38+00:00
Un-IO getRetFunType
- - - - -
f3230b9d by Sven Tennie at 2023-04-23T09:49:20+00:00
Un-IO LargeBitmapGetter
- - - - -
c4205b02 by Sven Tennie at 2023-04-23T09:53:15+00:00
Un-IO SmallBitmapGetter
- - - - -
dc135403 by Sven Tennie at 2023-04-23T10:08:26+00:00
Formatting and one comment
- - - - -
1 changed file:
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -117,47 +117,32 @@ Technical details
foreign import prim "getUnderflowFrameNextChunkzh"
getUnderflowFrameNextChunk# ::
- StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
+ StackSnapshot# -> Word# -> StackSnapshot#
-getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> IO StackSnapshot
-getUnderflowFrameNextChunk stackSnapshot# index = IO $ \s ->
- case getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index) s of
- (# s1, stack# #) -> (# s1, StackSnapshot stack# #)
+getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot
+getUnderflowFrameNextChunk stackSnapshot# index =
+ StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index))
foreign import prim "getWordzh"
getWord# ::
- StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+ StackSnapshot# -> Word# -> Word#
-getWord :: StackSnapshot# -> WordOffset -> IO Word
-getWord stackSnapshot# index = IO $ \s ->
- case getWord#
- stackSnapshot#
- (wordOffsetToWord# index)
- s of
- (# s1, w# #) -> (# s1, W# w# #)
-
-type WordGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+getWord :: StackSnapshot# -> WordOffset -> Word
+getWord stackSnapshot# index =
+ W# (getWord# stackSnapshot# (wordOffsetToWord# index))
-foreign import prim "getRetFunTypezh" getRetFunType# :: WordGetter
+foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
-getRetFunType :: StackSnapshot# -> WordOffset -> IO RetFunType
+getRetFunType :: StackSnapshot# -> WordOffset -> RetFunType
getRetFunType stackSnapshot# index =
- toEnum . fromInteger . toInteger
- <$> IO
- ( \s ->
- case getRetFunType#
- stackSnapshot#
- (wordOffsetToWord# index)
- s of
- (# s1, rft# #) -> (# s1, W# rft# #)
- )
+ toEnum . fromInteger . toInteger $
+ W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index))
-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@)
--
-- The first two arguments identify the location of the frame on the stack.
--- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. The
--- `RealWorld` token is used to run this in an `IO` context.
-type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
+-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size.
+type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #)
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
@@ -168,9 +153,8 @@ foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitma
-- | 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. The `RealWorld` token is used to run
--- this in an `IO` context.
-type SmallBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
+-- Returned is the bitmap and it's size.
+type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #)
foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
@@ -196,13 +180,13 @@ foreign import prim "getStackClosurezh"
foreign import prim "getStackFieldszh"
getStackFields# ::
- StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Word32#, Word8#, Word8# #)
+ StackSnapshot# -> (# Word32#, Word8#, Word8# #)
-getStackFields :: StackSnapshot# -> IO (Word32, Word8, Word8)
-getStackFields stackSnapshot# = IO $ \s ->
- case getStackFields# stackSnapshot# s of
- (# s1, sSize#, sDirty#, sMarking# #) ->
- (# s1, (W32# sSize#, W8# sDirty#, W8# sMarking#) #)
+getStackFields :: StackSnapshot# -> (Word32, Word8, Word8)
+getStackFields stackSnapshot# =
+ case getStackFields# stackSnapshot# of
+ (# sSize#, sDirty#, sMarking# #) ->
+ (W32# sSize#, W8# sDirty#, W8# sMarking#)
-- | `StackFrameLocation` of the top-most stack frame
stackHead :: StackSnapshot# -> StackFrameLocation
@@ -229,6 +213,9 @@ advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
getClosure :: StackSnapshot# -> WordOffset -> IO Closure
getClosure stackSnapshot# index =
+ -- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage
+ -- collector might move the referenced closure, without updating our reference
+ -- (pointer) to it.
( IO $ \s ->
case getStackClosure#
stackSnapshot#
@@ -251,9 +238,8 @@ data Pointerness = Pointer | NonPointer
decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
- largeBitmap <- IO $ \s ->
- case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
- (# s1, wordsAddr#, size# #) -> (# s1, LargeBitmap (W# size#) (Ptr wordsAddr#) #)
+ let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
+ (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#)
bitmapWords <- largeBitmapToList largeBitmap
decodeBitmaps
stackSnapshot#
@@ -296,21 +282,18 @@ decodeBitmaps stack# index ps =
where
toPayload :: Pointerness -> WordOffset -> IO Closure
toPayload p i = case p of
- NonPointer -> do
- w <- getWord stack# i
- pure $ UnknownTypeWordSizedPrimitive w
+ NonPointer ->
+ pure $ UnknownTypeWordSizedPrimitive (getWord stack# i)
Pointer -> getClosure stack# i
decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
- do
- (bitmap, size) <- IO $ \s ->
- case getterFun# stackSnapshot# (wordOffsetToWord# index) s of
- (# s1, b#, s# #) -> (# s1, (W# b#, W# s#) #)
- decodeBitmaps
- stackSnapshot#
- (index + relativePayloadOffset)
- (bitmapWordPointerness size bitmap)
+ 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
@@ -345,8 +328,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
stack_payload = payload'
}
RET_FUN -> do
- retFunType' <- getRetFunType stackSnapshot# index
- retFunSize' <- getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
+ let retFunType' = getRetFunType stackSnapshot# index
+ retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
retFunFun' <- getClosure stackSnapshot# (index + offsetStgRetFunFrameFun)
retFunPayload' <-
if retFunType' == ARG_GEN_BIG
@@ -368,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
updatee = updatee'
}
CATCH_FRAME -> do
- exceptions_blocked' <- getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked)
+ let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked)
handler' <- getClosure stackSnapshot# (index + offsetStgCatchFrameHandler)
pure $
CatchFrame
@@ -377,7 +360,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
handler = handler'
}
UNDERFLOW_FRAME -> do
- nextChunk' <- getUnderflowFrameNextChunk stackSnapshot# index
+ let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
stackClosure <- decodeStack nextChunk'
pure $
UnderflowFrame
@@ -395,7 +378,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
result = result'
}
CATCH_RETRY_FRAME -> do
- running_alt_code' <- getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
+ let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
first_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
alt_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
pure $
@@ -441,10 +424,10 @@ type StackFrameLocation = (StackSnapshot, WordOffset)
decodeStack :: StackSnapshot -> IO StgStackClosure
decodeStack (StackSnapshot stack#) = do
info <- getInfoTableForStack stack#
- (stack_size', stack_dirty', stack_marking') <- getStackFields stack#
case tipe info of
STACK -> do
- let sfls = stackFrameLocations stack#
+ let (stack_size', stack_dirty', stack_marking') = getStackFields stack#
+ sfls = stackFrameLocations stack#
stack' <- mapM unpackStackFrame sfls
pure $
StgStackClosure
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e071fa31da7c5e9264685bf17ca582bde756d00f...dc135403e75c95c697d48afc7b085ae757560ca5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e071fa31da7c5e9264685bf17ca582bde756d00f...dc135403e75c95c697d48afc7b085ae757560ca5
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/20230423/901360e1/attachment-0001.html>
More information about the ghc-commits
mailing list