[Git][ghc/ghc][wip/decode_cloned_stack] Use `Box Any` for lazy closures
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Mon Jan 23 17:30:06 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
50dc463b by Sven Tennie at 2023-01-23T17:23:53+00:00
Use `Box Any` for lazy closures
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/stack_big_ret.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -61,6 +61,8 @@ getUnderflowFrameNextChunk (StackFrameIter {..}) = StackSnapshot s#
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+foreign import prim "getAddrzh" getAddr# :: StackSnapshot# -> Word# -> Addr#
+
getWord :: StackFrameIter -> WordOffset -> Word
getWord (StackFrameIter {..}) relativeOffset = W# (getWord# stackSnapshot# (wordOffsetToWord# index) (wordOffsetToWord# relativeOffset))
@@ -145,40 +147,32 @@ toBitmapEntries sfi@(StackFrameIter {..}) bitmapWord bSize = BitmapEntry {
isPrimitive = (bitmapWord .&. 1) /= 0
} : toBitmapEntries (StackFrameIter stackSnapshot# (index + 1)) (bitmapWord `shiftR` 1) (bSize - 1)
-toBitmapPayload :: BitmapEntry -> IO Box
-toBitmapPayload e | isPrimitive e = pure $ DecodedClosureBox. CL.UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame $ e
-toBitmapPayload e = toClosure (unpackClosureReferencedByFrame 0) (closureFrame e)
-
-getClosure :: StackFrameIter -> WordOffset-> IO Box
-getClosure sfi relativeOffset = toClosure (unpackClosureReferencedByFrame relativeOffset) sfi
-
-toClosure :: (StackSnapshot# -> WordOffset -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO Box
-toClosure f# (StackFrameIter {..}) =
- case f# stackSnapshot# index of
- (# infoTableAddr, heapRep, pointersArray #) ->
- let infoTablePtr = Ptr infoTableAddr
- ptrList = [case indexArray# pointersArray i of
- (# ptr #) -> CL.Box ptr
- | I# i <- [0..I# (sizeofArray# pointersArray) - 1]
- ]
- in
- DecodedClosureBox <$> (getClosureDataFromHeapRep heapRep infoTablePtr ptrList)
+toBitmapPayload :: BitmapEntry -> Box
+toBitmapPayload e | isPrimitive e = DecodedClosureBox $ (CL.UnknownTypeWordSizedPrimitive . derefStackWord . closureFrame) e
+toBitmapPayload e = getClosure (closureFrame e) 0
+
+getClosure :: StackFrameIter -> WordOffset-> Box
+getClosure StackFrameIter {..} relativeOffset =
+ let offset = wordOffsetToWord# (index + relativeOffset)
+ !ptr = (getAddr# stackSnapshot# offset)
+ !a :: Any = unsafeCoerce# ptr
+ in Box a
-decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> WordOffset -> [Box]
decodeLargeBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
let !(# bitmapArray#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
bitmapWords :: [Word] = byteArrayToList bitmapArray#
in
decodeBitmaps sfi relativePayloadOffset bitmapWords (W# size#)
-decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
+decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> [Box]
decodeBitmaps (StackFrameIter {..}) relativePayloadOffset bitmapWords size =
let
bes = wordsToBitmapEntries (StackFrameIter stackSnapshot# (index + relativePayloadOffset)) bitmapWords size
in
- mapM toBitmapPayload bes
+ map toBitmapPayload bes
-decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> WordOffset -> IO [Box]
+decodeSmallBitmap :: (StackSnapshot# -> Word# -> (# Word#, Word# #)) -> StackFrameIter -> WordOffset -> [Box]
decodeSmallBitmap getterFun# sfi@(StackFrameIter {..}) relativePayloadOffset =
let !(# bitmap#, size# #) = getterFun# stackSnapshot# (wordOffsetToWord# index)
size = W# size#
@@ -200,54 +194,59 @@ wordOffsetToWord# wo = intToWord# (fromIntegral wo)
unpackStackFrameIter :: StackFrameIter -> IO CL.Closure
unpackStackFrameIter sfi = do
info <- getInfoTable sfi
- case tipe info of
- RET_BCO -> do
- bco' <- getClosure sfi offsetStgClosurePayload
- -- The arguments begin directly after the payload's one element
- args' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
- pure $ CL.RetBCO info bco' args'
- RET_SMALL -> do
- payloads <- decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
- let special = getRetSmallSpecialType sfi
- pure $ CL.RetSmall info special payloads
- RET_BIG -> CL.RetBig info <$> decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
- RET_FUN -> do
- let t = getRetFunType sfi
- size' = getWord sfi offsetStgRetFunFrameSize
- fun' <- getClosure sfi offsetStgRetFunFrameFun
- payload' <-
- if t == CL.ARG_GEN_BIG then
- decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
- else
- decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
- pure $ CL.RetFun info t size' fun' payload'
- -- TODO: Decode update frame type
- UPDATE_FRAME -> let
- !t = getUpdateFrameType sfi
- c = getClosure sfi offsetStgUpdateFrameUpdatee
- in
- (CL.UpdateFrame info t ) <$> c
- CATCH_FRAME -> do
- let exceptionsBlocked = getWord sfi offsetStgCatchFrameExceptionsBlocked
- c <- getClosure sfi offsetStgCatchFrameHandler
- pure $ CL.CatchFrame info exceptionsBlocked c
- UNDERFLOW_FRAME -> let
- nextChunk = getUnderflowFrameNextChunk sfi
- in
- pure $ CL.UnderflowFrame info nextChunk
- STOP_FRAME -> pure $ CL.StopFrame info
- ATOMICALLY_FRAME -> CL.AtomicallyFrame info
- <$> 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 offsetStgCatchRetryFrameAltCode
- pure $ CL.CatchRetryFrame info running_alt_code' first_code' alt_code'
- CATCH_STM_FRAME -> CL.CatchStmFrame info
- <$> getClosure sfi offsetStgCatchSTMFrameCode
- <*> getClosure sfi offsetStgCatchSTMFrameHandler
- x -> error $ "Unexpected closure type on stack: " ++ show x
+ pure $ unpackStackFrameIter' info
+ where
+ -- TODO: Check all (missing?) bang patterns
+ unpackStackFrameIter' :: StgInfoTable -> CL.Closure
+ unpackStackFrameIter' info = do
+ case tipe info of
+ RET_BCO -> do
+ let !bco' = getClosure sfi offsetStgClosurePayload
+ -- The arguments begin directly after the payload's one element
+ !args' = decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
+ CL.RetBCO info bco' args'
+ RET_SMALL -> do
+ let !special = getRetSmallSpecialType sfi
+ !payloads = decodeSmallBitmap getSmallBitmap# sfi offsetStgClosurePayload
+ CL.RetSmall info special payloads
+ RET_BIG -> CL.RetBig info $ decodeLargeBitmap getLargeBitmap# sfi offsetStgClosurePayload
+ RET_FUN -> do
+ let t = getRetFunType sfi
+ size' = getWord sfi offsetStgRetFunFrameSize
+ fun' = getClosure sfi offsetStgRetFunFrameFun
+ payload' =
+ if t == CL.ARG_GEN_BIG then
+ decodeLargeBitmap getRetFunLargeBitmap# sfi offsetStgRetFunFramePayload
+ else
+ decodeSmallBitmap getRetFunSmallBitmap# sfi offsetStgRetFunFramePayload
+ CL.RetFun info t size' fun' payload'
+ -- TODO: Decode update frame type
+ UPDATE_FRAME -> let
+ !t = getUpdateFrameType sfi
+ c = getClosure sfi offsetStgUpdateFrameUpdatee
+ in
+ CL.UpdateFrame info t c
+ CATCH_FRAME -> do
+ let exceptionsBlocked = getWord sfi offsetStgCatchFrameExceptionsBlocked
+ c = getClosure sfi offsetStgCatchFrameHandler
+ CL.CatchFrame info exceptionsBlocked c
+ UNDERFLOW_FRAME -> let
+ nextChunk = getUnderflowFrameNextChunk sfi
+ in
+ CL.UnderflowFrame info nextChunk
+ STOP_FRAME -> CL.StopFrame info
+ ATOMICALLY_FRAME -> CL.AtomicallyFrame info
+ (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 offsetStgCatchRetryFrameAltCode
+ CL.CatchRetryFrame info running_alt_code' first_code' alt_code'
+ CATCH_STM_FRAME -> CL.CatchStmFrame info
+ (getClosure sfi offsetStgCatchSTMFrameCode)
+ (getClosure sfi offsetStgCatchSTMFrameHandler)
+ x -> error $ "Unexpected closure type on stack: " ++ show x
-- | Size of the byte array in bytes.
-- Copied from `primitive`
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -144,6 +144,15 @@ getWordzh(P_ stack, W_ offsetWords, W_ offsetBytes){
return (W_[wordAddr]);
}
+getAddrzh(P_ stack, W_ offsetWords){
+ P_ addr;
+ addr = (StgStack_sp(stack) + WDS(offsetWords));
+ P_ ptr;
+ ptr = P_[addr];
+// ccall printObj(ptr);
+ return (ptr);
+}
+
getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords){
P_ closurePtr;
closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -22,6 +22,9 @@ import GHC.Records
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
import Unsafe.Coerce (unsafeCoerce)
+import Debug.Trace
+import Data.Foldable
+import Control.Monad.IO.Class
assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m ()
assertEqual a b
@@ -31,7 +34,7 @@ assertEqual a b
assertThat :: (HasCallStack, Monad m) => String -> (a -> Bool) -> a -> m ()
assertThat s f a = if f a then pure () else error s
-assertStackInvariants :: (HasCallStack, Monad m) => StackSnapshot -> [Closure] -> m ()
+assertStackInvariants :: (HasCallStack, MonadIO m) => StackSnapshot -> [Closure] -> m ()
assertStackInvariants stack decodedStack = do
assertThat
"Last frame is stop frame"
@@ -40,21 +43,21 @@ assertStackInvariants stack decodedStack = do
_ -> False
)
(last decodedStack)
- assertEqual
- (toClosureTypes decodedStack)
- (toClosureTypes stack)
+ ts1 <- liftIO $ toClosureTypes decodedStack
+ ts2 <- liftIO $ toClosureTypes stack
+ assertEqual ts1 ts2
class ToClosureTypes a where
- toClosureTypes :: a -> [ClosureType]
+ toClosureTypes :: a -> IO [ClosureType]
instance ToClosureTypes StackSnapshot where
- toClosureTypes = stackSnapshotToClosureTypes . foldStackToArrayClosure
+ toClosureTypes = pure . stackSnapshotToClosureTypes . foldStackToArrayClosure
instance ToClosureTypes Closure where
toClosureTypes = stackFrameToClosureTypes
instance ToClosureTypes a => ToClosureTypes [a] where
- toClosureTypes = concatMap toClosureTypes
+ toClosureTypes cs = concat <$> mapM toClosureTypes cs
foreign import ccall "foldStackToArrayClosure" foldStackToArrayClosure# :: StackSnapshot# -> ByteArray#
@@ -86,59 +89,95 @@ toInt# :: Int -> Int#
toInt# (I# i#) = i#
-- TODO: Can probably be simplified once all stack closures have into tables attached.
-stackFrameToClosureTypes :: Closure -> [ClosureType]
+stackFrameToClosureTypes :: Closure -> IO [ClosureType]
stackFrameToClosureTypes = getClosureTypes
where
- getClosureTypes :: Closure -> [ClosureType]
+ getClosureTypes :: Closure -> IO [ClosureType]
-- Stack frame closures
- getClosureTypes (UpdateFrame {info, updatee, ..}) = tipe info : getClosureTypes (unbox updatee)
- getClosureTypes (CatchFrame {info, handler, ..}) = tipe info : getClosureTypes (unbox handler)
- getClosureTypes (CatchStmFrame {info, catchFrameCode, handler}) = tipe info : getClosureTypes (unbox catchFrameCode) ++ getClosureTypes (unbox handler)
- getClosureTypes (CatchRetryFrame {info, first_code, alt_code, ..}) = tipe info : getClosureTypes (unbox first_code) ++ getClosureTypes (unbox alt_code)
- getClosureTypes (AtomicallyFrame {info, atomicallyFrameCode, result}) = tipe info : getClosureTypes (unbox atomicallyFrameCode) ++ getClosureTypes (unbox result)
- getClosureTypes (UnderflowFrame {..}) = [tipe info]
- getClosureTypes (StopFrame info) = [tipe info]
- getClosureTypes (RetSmall {info, payload, ..}) = tipe info : getBitmapClosureTypes payload
- getClosureTypes (RetBig {info, payload}) = tipe info : getBitmapClosureTypes payload
- getClosureTypes (RetFun {info, retFunFun, retFunPayload, ..}) = tipe info : getClosureTypes (unbox retFunFun) ++ getBitmapClosureTypes retFunPayload
- getClosureTypes (RetBCO {info, bco, bcoArgs, ..}) =
- tipe info : getClosureTypes (unbox bco) ++ getBitmapClosureTypes bcoArgs
+ getClosureTypes (UpdateFrame {info, updatee, ..}) = do
+ u <- unbox updatee
+ ts <- getClosureTypes u
+ pure $ tipe info : ts
+ getClosureTypes (CatchFrame {info, handler, ..}) = do
+ h <- unbox handler
+ ts <- getClosureTypes h
+ pure $ tipe info : ts
+ getClosureTypes (CatchStmFrame {info, catchFrameCode, handler}) = do
+ c <- unbox catchFrameCode
+ h <- unbox handler
+ ts1 <- getClosureTypes c
+ ts2 <- getClosureTypes h
+ pure $ tipe info : ts1 ++ ts2
+ getClosureTypes (CatchRetryFrame {info, first_code, alt_code, ..}) = do
+ a <- unbox alt_code
+ f <- unbox first_code
+ ts1 <- getClosureTypes f
+ ts2 <- getClosureTypes a
+ pure $ tipe info : ts1 ++ ts2
+ getClosureTypes (AtomicallyFrame {info, atomicallyFrameCode, result}) = do
+ r <- unbox result
+ a <- unbox atomicallyFrameCode
+ ts1 <- getClosureTypes a
+ ts2 <- getClosureTypes r
+ pure $ tipe info : ts1 ++ ts2
+ getClosureTypes (UnderflowFrame {..}) = pure [tipe info]
+ getClosureTypes (StopFrame info) = pure [tipe info]
+ getClosureTypes (RetSmall {info, payload, ..}) = do
+ ts <- getBitmapClosureTypes payload
+ pure $ tipe info : ts
+ getClosureTypes (RetBig {info, payload}) = do
+ ts <- getBitmapClosureTypes payload
+ pure $ tipe info : ts
+ getClosureTypes (RetFun {info, retFunFun, retFunPayload, ..}) = do
+ rf <- unbox retFunFun
+ ts1 <- getClosureTypes rf
+ ts2 <- getBitmapClosureTypes retFunPayload
+ pure $ tipe info : ts1 ++ ts2
+ getClosureTypes (RetBCO {info, bco, bcoArgs, ..}) = do
+ bco <- unbox bco
+ bcoCls <- getClosureTypes bco
+ bcoArgsCls <- getBitmapClosureTypes bcoArgs
+ pure $ tipe info : bcoCls ++ bcoArgsCls
-- Other closures
- getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
- getClosureTypes (FunClosure {info, ..}) = [tipe info]
- getClosureTypes (ThunkClosure {info, ..}) = [tipe info]
- getClosureTypes (SelectorClosure {info, ..}) = [tipe info]
- getClosureTypes (PAPClosure {info, ..}) = [tipe info]
- getClosureTypes (APClosure {info, ..}) = [tipe info]
- getClosureTypes (APStackClosure {info, ..}) = [tipe info]
- getClosureTypes (IndClosure {info, ..}) = [tipe info]
- getClosureTypes (BCOClosure {info, ..}) = [tipe info]
- getClosureTypes (BlackholeClosure {info, ..}) = [tipe info]
- getClosureTypes (ArrWordsClosure {info, ..}) = [tipe info]
- getClosureTypes (MutArrClosure {info, ..}) = [tipe info]
- getClosureTypes (SmallMutArrClosure {info, ..}) = [tipe info]
- getClosureTypes (MVarClosure {info, ..}) = [tipe info]
- getClosureTypes (IOPortClosure {info, ..}) = [tipe info]
- getClosureTypes (MutVarClosure {info, ..}) = [tipe info]
- getClosureTypes (BlockingQueueClosure {info, ..}) = [tipe info]
- getClosureTypes (WeakClosure {info, ..}) = [tipe info]
- getClosureTypes (TSOClosure {info, ..}) = [tipe info]
- getClosureTypes (StackClosure {info, ..}) = [tipe info]
- getClosureTypes (OtherClosure {info, ..}) = [tipe info]
- getClosureTypes (UnsupportedClosure {info, ..}) = [tipe info]
- getClosureTypes _ = []
-
- getBitmapClosureTypes :: [Box] -> [ClosureType]
+ getClosureTypes (ConstrClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (FunClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (ThunkClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (SelectorClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (PAPClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (APClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (APStackClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (IndClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (BCOClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (BlackholeClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (ArrWordsClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (MutArrClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (SmallMutArrClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (MVarClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (IOPortClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (MutVarClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (BlockingQueueClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (WeakClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (TSOClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (StackClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (OtherClosure {info, ..}) = pure [tipe info]
+ getClosureTypes (UnsupportedClosure {info, ..}) = pure [tipe info]
+ getClosureTypes _ = pure []
+
+ getBitmapClosureTypes :: [Box] -> IO [ClosureType]
getBitmapClosureTypes bps =
- reverse $
- foldl
- ( \acc p -> case unbox p of
- UnknownTypeWordSizedPrimitive _ -> acc
- c -> getClosureTypes c ++ acc
+ reverse <$>
+ foldlM
+ ( \acc p -> do
+ c <- unbox p
+ case c of
+ UnknownTypeWordSizedPrimitive _ -> pure acc
+ c -> do
+ cls <- getClosureTypes c
+ pure $ cls ++ acc
)
[]
bps
-unbox :: Box -> Closure
-unbox (Box c) = unsafeCoerce c
-unbox (DecodedClosureBox c) = c
+unbox :: Box -> IO Closure
+unbox (DecodedClosureBox c) = pure c
+unbox box = getBoxedClosureData box
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -43,7 +43,8 @@ main = do
"Stack contains one big return frame"
(== 1)
(length $ filter isBigReturnFrame decodedStack)
- let xs = zip [1 ..] $ (map unbox . payload . head) $ filter isBigReturnFrame decodedStack
+ cs <- (mapM unbox . payload . head) $ filter isBigReturnFrame decodedStack
+ let xs = zip [1 ..] cs
mapM_ (uncurry checkArg) xs
checkArg :: Word -> Closure -> IO ()
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -282,6 +282,7 @@ test setup assertion = do
-- Better fail early, here.
performGC
stack <- decodeStack' sn
+ performGC
assert sn stack
-- The result of HasHeapRep should be similar (wrapped in the closure for
-- StgStack itself.)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50dc463b7a269a3e0ee8cb1d5ff8d2bbcb50792f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50dc463b7a269a3e0ee8cb1d5ff8d2bbcb50792f
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/20230123/29041ac0/attachment-0001.html>
More information about the ghc-commits
mailing list