Compare revisions

Sven Tennie · Sven Tennie · Sven Tennie · Sven Tennie · Sven Tennie · Sven Tennie
--- a/libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
@@ -3,7 +3,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module GHC.Exts.Stack.Constants where

-- TODO: Better expression to allow is only for the latest (this branch) GHC?
 #if MIN_TOOL_VERSION_ghc(9,7,0)

 import           Prelude
@@ -21,59 +20,74 @@ newtype WordOffset = WordOffset { offsetInWords :: Int }
  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)

 offsetStgCatchFrameHandler :: WordOffset
-offsetStgCatchFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+offsetStgCatchFrameHandler = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)

 offsetStgCatchFrameExceptionsBlocked :: WordOffset
-offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $ (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader)
+offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader)

 sizeStgCatchFrame :: Int
-sizeStgCatchFrame = bytesToWords $ (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
+sizeStgCatchFrame = bytesToWords $
+  (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)

 offsetStgCatchSTMFrameCode :: WordOffset
-offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)

 offsetStgCatchSTMFrameHandler :: WordOffset
-offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)

 sizeStgCatchSTMFrame :: Int
-sizeStgCatchSTMFrame = bytesToWords $ (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
+sizeStgCatchSTMFrame = bytesToWords $
+  (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)

 offsetStgUpdateFrameUpdatee :: WordOffset
-offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $
+  (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)

 sizeStgUpdateFrame :: Int
-sizeStgUpdateFrame = bytesToWords $ (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
+sizeStgUpdateFrame = bytesToWords $
+  (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)

 offsetStgAtomicallyFrameCode :: WordOffset
-offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)

 offsetStgAtomicallyFrameResult :: WordOffset
-offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $
+  (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)

 sizeStgAtomicallyFrame :: Int
-sizeStgAtomicallyFrame = bytesToWords $ (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
+sizeStgAtomicallyFrame = bytesToWords $
+  (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)

 offsetStgCatchRetryFrameRunningAltCode :: WordOffset
-offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)

 offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
-offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)

 offsetStgCatchRetryFrameAltCode :: WordOffset
-offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)

 sizeStgCatchRetryFrame :: Int
-sizeStgCatchRetryFrame = bytesToWords $ (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
+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)
+offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size)

 offsetStgRetFunFrameFun :: WordOffset
-offsetStgRetFunFrameFun = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_fun)
+offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun)

 offsetStgRetFunFramePayload :: WordOffset
-offsetStgRetFunFramePayload = byteOffsetToWordOffset $ (#const OFFSET_StgRetFun_payload)
+offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload)

 sizeStgRetFunFrame :: Int
 sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
@@ -94,7 +108,8 @@ offsetStgBCOFrameSize :: ByteOffset
 offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)

 offsetStgClosurePayload :: WordOffset
-offsetStgClosurePayload = byteOffsetToWordOffset $ (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+offsetStgClosurePayload = byteOffsetToWordOffset $
+  (#const OFFSET_StgClosure_payload) + (#size StgHeader)

 sizeStgClosure :: Int
 sizeStgClosure = bytesToWords (#size StgHeader)

--- a/libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
+++ b/libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
@@ -19,7 +19,6 @@ module GHC.Exts.Stack.Decode
  )
 where

-
 import Data.Array.Byte
 import Data.Bits
 import Data.Maybe
@@ -110,12 +109,6 @@ Technical details
  This keeps the code very portable.
 -}

-type WordGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
-
-type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
-
-type SmallBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
-
 foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :: StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, StackSnapshot# #)

 getUnderflowFrameNextChunk :: StackFrameIter -> IO StackSnapshot
@@ -143,6 +136,8 @@ getWord (SfiClosure {..}) relativeOffset = IO $ \s ->
    (# s1, w# #) -> (# s1, W# w# #)
 getWord sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi

+type WordGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
+
 foreign import prim "getRetFunTypezh" getRetFunType# :: WordGetter

 getRetFunType :: StackFrameIter -> IO RetFunType
@@ -158,18 +153,20 @@ getRetFunType (SfiClosure {..}) =
      )
 getRetFunType sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi

+type LargeBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, ByteArray#, Word# #)
+
 foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter

 foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter

 foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter

+type SmallBitmapGetter = StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Word#, Word# #)
+
 foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter

 foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter

-foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
-
 foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr#

 foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
@@ -198,6 +195,12 @@ getStackFields sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
 stackHead :: StackSnapshot -> StackFrameIter
 stackHead (StackSnapshot s) = SfiClosure 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 "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
 -- | Advance iterator to the next stack frame (if any)
 advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
 advanceStackFrameIter (SfiClosure {..}) =
@@ -205,58 +208,10 @@ advanceStackFrameIter (SfiClosure {..}) =
   in if I# hasNext > 0
        then Just $ SfiClosure s' (primWordToWordOffset i')
        else Nothing
-advanceStackFrameIter sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
-
-primWordToWordOffset :: Word# -> WordOffset
-primWordToWordOffset w# = fromIntegral (W# w#)
-
-wordsToBitmapEntries :: StackFrameIter -> [Word] -> Word -> [StackFrameIter]
-wordsToBitmapEntries _ [] 0 = []
-wordsToBitmapEntries _ [] i = error $ "Invalid state: Empty list, size " ++ show i
-wordsToBitmapEntries _ l 0 = error $ "Invalid state: Size 0, list " ++ show l
-wordsToBitmapEntries sfi (b : bs) bitmapSize =
-  let entries = toBitmapEntries sfi b (min bitmapSize (fromIntegral wORD_SIZE_IN_BITS))
-      mbLastFrame = (listToMaybe . reverse) entries
-   in case mbLastFrame of
-        Just (SfiClosure {..}) ->
-          entries
-            ++ wordsToBitmapEntries
-              ( SfiClosure stackSnapshot# (index + 1)
-              )
-              bs
-              (subtractDecodedBitmapWord bitmapSize)
-        Just (SfiPrimitive {..}) ->
-          entries
-            ++ wordsToBitmapEntries
-              ( SfiClosure stackSnapshot# (index + 1)
-              )
-              bs
-              (subtractDecodedBitmapWord bitmapSize)
-        _ -> error "This should never happen! Recursion ended not in base case."
  where
-    subtractDecodedBitmapWord :: Word -> Word
-    subtractDecodedBitmapWord bSize =
-      fromIntegral $
-        max 0 (fromIntegral bSize - wORD_SIZE_IN_BITS)
-
-toBitmapEntries :: StackFrameIter -> Word -> Word -> [StackFrameIter]
-toBitmapEntries _ _ 0 = []
-toBitmapEntries (SfiClosure {..}) bitmapWord bSize =
-  ( if (bitmapWord .&. 1) /= 0
-      then SfiPrimitive stackSnapshot# index
-      else SfiClosure stackSnapshot# index
-  )
-    : toBitmapEntries
-      ( SfiClosure stackSnapshot# (index + 1)
-      )
-      (bitmapWord `shiftR` 1)
-      (bSize - 1)
-toBitmapEntries sfi _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi
-
-toBitmapPayload :: StackFrameIter -> IO Box
-toBitmapPayload sfi@SfiPrimitive {} = pure (StackFrameBox sfi)
-toBitmapPayload sfi@SfiClosure {} = getClosure sfi 0
-toBitmapPayload sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+    primWordToWordOffset :: Word# -> WordOffset
+    primWordToWordOffset w# = fromIntegral (W# w#)
+advanceStackFrameIter sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi

 getClosure :: StackFrameIter -> WordOffset -> IO Box
 getClosure SfiClosure {..} relativeOffset =
@@ -276,12 +231,66 @@ decodeLargeBitmap getterFun# sfi@(SfiClosure {..}) relativePayloadOffset = do
      (# s1, ba#, s# #) -> (# s1, (ByteArray ba#, W# s#) #)
  let bitmapWords :: [Word] = byteArrayToList bitmapArray
  decodeBitmaps sfi relativePayloadOffset bitmapWords size
+  where
+    byteArrayToList :: ByteArray -> [Word]
+    byteArrayToList (ByteArray bArray) = go 0
+      where
+        go i
+          | i < maxIndex = W# (indexWordArray# bArray (toInt# i)) : go (i + 1)
+          | otherwise = []
+        maxIndex = sizeofByteArray bArray `quot` sizeOf (undefined :: Word)
+
+    sizeofByteArray :: ByteArray# -> Int
+    sizeofByteArray arr# = I# (sizeofByteArray# arr#)
 decodeLargeBitmap _ sfi _ = error $ "Unexpected StackFrameIter type: " ++ show sfi

 decodeBitmaps :: StackFrameIter -> WordOffset -> [Word] -> Word -> IO [Box]
 decodeBitmaps (SfiClosure {..}) relativePayloadOffset bitmapWords size =
-  let bes = wordsToBitmapEntries (SfiClosure stackSnapshot# (index + relativePayloadOffset)) bitmapWords size
+  let bes = wordsToBitmapEntries (index + relativePayloadOffset) bitmapWords size
   in mapM toBitmapPayload bes
+  where
+    toBitmapPayload :: StackFrameIter -> IO Box
+    toBitmapPayload sfi@SfiPrimitive {} = pure (StackFrameBox sfi)
+    toBitmapPayload sfi@SfiClosure {} = getClosure sfi 0
+    toBitmapPayload sfi = error $ "Unexpected StackFrameIter type: " ++ show sfi
+
+    wordsToBitmapEntries :: WordOffset -> [Word] -> Word -> [StackFrameIter]
+    wordsToBitmapEntries _ [] 0 = []
+    wordsToBitmapEntries _ [] i = error $ "Invalid state: Empty list, size " ++ show i
+    wordsToBitmapEntries _ l 0 = error $ "Invalid state: Size 0, list " ++ show l
+    wordsToBitmapEntries index' (b : bs) bitmapSize =
+      let entries = toBitmapEntries index' b (min bitmapSize (fromIntegral wORD_SIZE_IN_BITS))
+          mbLastFrame = (listToMaybe . reverse) entries
+       in case mbLastFrame of
+            Just sfi' ->
+              entries
+                ++ wordsToBitmapEntries
+                  ((getIndex sfi') + 1)
+                  bs
+                  subtractDecodedBitmapWord
+            _ -> error "This should never happen! Recursion ended not in base case."
+      where
+        subtractDecodedBitmapWord :: Word
+        subtractDecodedBitmapWord =
+          fromIntegral $
+            max 0 (fromIntegral bitmapSize - wORD_SIZE_IN_BITS)
+
+        toBitmapEntries :: WordOffset -> Word -> Word -> [StackFrameIter]
+        toBitmapEntries _ _ 0 = []
+        toBitmapEntries i bitmapWord bSize =
+          ( if (bitmapWord .&. 1) /= 0
+              then SfiPrimitive stackSnapshot# i
+              else SfiClosure stackSnapshot# i
+          )
+            : toBitmapEntries
+              (i + 1)
+              (bitmapWord `shiftR` 1)
+              (bSize - 1)
+
+        getIndex :: StackFrameIter -> WordOffset
+        getIndex (SfiClosure _ i) = i
+        getIndex (SfiPrimitive _ i) = i
+        getIndex sfi' = error $ "Has no index : " ++ show sfi'
 decodeBitmaps sfi _ _ _ = error $ "Unexpected StackFrameIter type: " ++ show sfi

 decodeSmallBitmap :: SmallBitmapGetter -> StackFrameIter -> WordOffset -> IO [Box]
@@ -296,27 +305,17 @@ decodeSmallBitmap _ sfi _ =
  error $
    "Unexpected StackFrameIter type: " ++ show sfi

-byteArrayToList :: ByteArray -> [Word]
-byteArrayToList (ByteArray bArray) = go 0
-  where
-    go i
-      | i < maxIndex = W# (indexWordArray# bArray (toInt# i)) : go (i + 1)
-      | otherwise = []
-    maxIndex = sizeofByteArray bArray `quot` sizeOf (undefined :: Word)
-
-wordOffsetToWord# :: WordOffset -> Word#
-wordOffsetToWord# wo = intToWord# (fromIntegral wo)
-
+-- | Decode `StackFrameIter` to `Closure`
 unpackStackFrameIter :: StackFrameIter -> IO Closure
 unpackStackFrameIter sfi@(SfiPrimitive {}) =
  UnknownTypeWordSizedPrimitive
    <$> getWord sfi 0
-unpackStackFrameIter sfi@(SfiStackClosure {}) = do
+unpackStackFrameIter sfi@(SfiStackClosure {..}) = do
  info <- getInfoTable sfi
  (stack_size', stack_dirty', stack_marking') <- getStackFields sfi
  case tipe info of
    STACK -> do
-      let stack' = decodeStack' (StackSnapshot (stackSnapshot# sfi))
+      let stack' = decodeStackToBoxes (StackSnapshot stackSnapshot#)
      pure $
        StackClosure
          { info = info,
@@ -326,6 +325,15 @@ unpackStackFrameIter sfi@(SfiStackClosure {}) = do
            stack = stack'
          }
    _ -> error $ "Expected STACK closure, got " ++ show info
+  where
+    decodeStackToBoxes :: StackSnapshot -> [Box]
+    decodeStackToBoxes s =
+      StackFrameBox (stackHead s)
+        : go (advanceStackFrameIter (stackHead s))
+      where
+        go :: Maybe StackFrameIter -> [Box]
+        go Nothing = []
+        go (Just sfi') = StackFrameBox sfi' : go (advanceStackFrameIter sfi')
 unpackStackFrameIter sfi@(SfiClosure {}) = do
  info <- getInfoTable sfi
  unpackStackFrameIter' info
@@ -337,7 +345,7 @@ unpackStackFrameIter sfi@(SfiClosure {}) = do
          bco' <- getClosure sfi offsetStgClosurePayload
          -- The arguments begin directly after the payload's one element
          bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# sfi (offsetStgClosurePayload + 1)
-          pure $
+          pure
            RetBCO
              { info = info,
                bco = bco',
@@ -428,33 +436,26 @@ unpackStackFrameIter sfi@(SfiClosure {}) = do
              }
        x -> error $ "Unexpected closure type on stack: " ++ show x

-- | Size of the byte array in bytes.
-- Copied from `primitive`
-sizeofByteArray :: ByteArray# -> Int
-{-# INLINE sizeofByteArray #-}
-sizeofByteArray arr# = I# (sizeofByteArray# arr#)
-
 -- | 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)
+
+-- | Decode `StackSnapshot` to a Closure
+--
+-- Due to the use of `Box` this decoding is lazy. The first decoded closure is
+-- the representation of the @StgStack@ itself.
 decodeStack :: StackSnapshot -> IO Closure
 decodeStack (StackSnapshot stack#) =
  unpackStackFrameIter $
    SfiStackClosure stack#

-decodeStack' :: StackSnapshot -> [Box]
-decodeStack' s =
-  StackFrameBox (stackHead s)
-    : go (advanceStackFrameIter (stackHead s))
-  where
-    go :: Maybe StackFrameIter -> [Box]
-    go Nothing = []
-    go (Just sfi) = StackFrameBox sfi : go (advanceStackFrameIter sfi)
-
 #else
 module GHC.Exts.Stack.Decode where
 #endif
--- a/libraries/ghc-heap/tests/TestUtils.hs
+++ b/libraries/ghc-heap/tests/TestUtils.hs
@@ -17,9 +17,9 @@ import Data.Array.Byte
 import Data.Foldable
 import Debug.Trace
 import GHC.Exts
-import GHC.Exts.Stack.Decode
 import GHC.Exts.Heap
 import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Decode
 import GHC.Records
 import GHC.Stack (HasCallStack)
 import GHC.Stack.CloneStack
No results found