[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: More on bitmap decoding
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Oct 7 12:21:29 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
f9b72237 by Sven Tennie at 2022-10-06T12:40:23+00:00
More on bitmap decoding
- - - - -
42318ec6 by Sven Tennie at 2022-10-07T12:20:47+00:00
Decode large bitmap...
- - - - -
4 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- rts/Printer.c
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -9,30 +9,24 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE BangPatterns #-}
-- 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 Data.Maybe
import Data.Bits
import Foreign
-
+import System.IO.Unsafe
import Prelude
import GHC.Stack.CloneStack
import GHC.Exts.Heap
-import GHC.Ptr
import Debug.Trace
import GHC.Exts
-import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
-import Numeric
import qualified GHC.Exts.Heap.Closures as CL
-import GHC.Exts.Heap.StackFFI as StackFFI
-import Data.Bits
-import GHC.Exts.Heap (Closure)
-import GHC.Exts.Heap.StackFFI (bitsInWord)
-import GHC.Exts.Heap.Closures (closureSize)
-import System.Mem (performMajorGC)
type StackFrameIter# = (#
-- | StgStack
@@ -43,6 +37,10 @@ type StackFrameIter# = (#
data StackFrameIter = StackFrameIter StackFrameIter#
+-- TODO: Remove this instance (debug only)
+instance Show StackFrameIter where
+ show (StackFrameIter (# _, i# #)) = "StackFrameIter " ++ "(StackSnapshot _" ++ " " ++ show (W# i#)
+
-- | Get an interator starting with the top-most stack frame
stackHead :: StackSnapshot -> StackFrameIter
stackHead (StackSnapshot s) = StackFrameIter (# s , 0## #) -- GHC stacks are never empty
@@ -51,12 +49,14 @@ foreign import prim "advanceStackFrameIterzh" advanceStackFrameIter# :: StackSna
-- | Advance iterator to the next stack frame (if any)
advanceStackFrameIter :: StackFrameIter -> Maybe StackFrameIter
-advanceStackFrameIter (StackFrameIter (# s, i #)) = let (# s', i', hasNext #) = advanceStackFrameIter# s i in
+advanceStackFrameIter (StackFrameIter (# s, i #)) = let !(# s', i', hasNext #) = advanceStackFrameIter# s i in
if (I# hasNext) > 0 then Just $ StackFrameIter (# s', i' #)
else Nothing
foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# -> Word# -> Word#
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
+
foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
data BitmapEntry = BitmapEntry {
@@ -64,21 +64,63 @@ data BitmapEntry = BitmapEntry {
isPrimitive :: Bool
} deriving (Show)
+wordsToBitmapEntries :: StackFrameIter -> [Word] -> Word -> [BitmapEntry]
+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) size =
+ let entries = toBitmapEntries sfi b size
+ mbLastEntry = (listToMaybe . reverse) entries
+ mbLastFrame = fmap closureFrame mbLastEntry
+ in
+ case mbLastFrame of
+ Just (StackFrameIter (# s'#, i'# #)) ->
+ entries ++ wordsToBitmapEntries (StackFrameIter (# s'#, plusWord# i'# 1## #)) bs (subtractDecodedBitmapWord size)
+ Nothing -> error "This should never happen! Recursion ended not in base case."
+ where
+ subtractDecodedBitmapWord :: Word -> Word
+ subtractDecodedBitmapWord size = fromIntegral $ max 0 ((fromIntegral size) - wORD_SIZE_IN_BITS)
+
toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
toBitmapEntries _ _ 0 = []
-toBitmapEntries sfi@(StackFrameIter(# s, i #) bitmap size = BitmapEntry {
+toBitmapEntries sfi@(StackFrameIter(# s, i #)) bitmap size = BitmapEntry {
closureFrame = sfi,
isPrimitive = (bitmap .&. 1) == 0
- } : toBitmapEntries (StackFrameIter (# s , i + 1 #)) (bitmap `shiftR` 1) (size - 1)
+ } : toBitmapEntries (StackFrameIter (# s , plusWord# i 1## #)) (bitmap `shiftR` 1) (size - 1)
+
+toBitmapPayload :: BitmapEntry -> BitmapPayload
+toBitmapPayload e | isPrimitive e = Primitive . toWord . closureFrame $ e
+ where
+ toWord (StackFrameIter (# s#, i# #)) = W# (derefStackWord# s# i#)
+toBitmapPayload e = Closure . unsafePerformIO . toClosure . closureFrame $ e
+ where
+ toClosure (StackFrameIter (# s#, i# #)) =
+ case unpackClosureFromStackFrame# s# i# 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]
+ ]
+
+ getClosureDataFromHeapRep heapRep infoTablePtr ptrList
+
unpackStackFrameIter :: StackFrameIter -> StackFrame
-unpackStackFrameIter (StackFrameIter (# s, i #)) =
- case (toEnum . fromIntegral) (W# (getInfoTableType# s i)) of
+unpackStackFrameIter (StackFrameIter (# s#, i# #)) =
+ case (toEnum . fromIntegral) (W# (getInfoTableType# s# i#)) of
RET_BCO -> RetBCO
- RET_SMALL -> let (# bitmap#, size# #) = getSmallBitmap# s i
+ RET_SMALL -> let !(# bitmap#, size# #) = getSmallBitmap# s# i#
+ bes = toBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #))(W# bitmap#) (W# size#)
+ payloads = map toBitmapPayload bes
in
- RetSmall None []
- RET_BIG -> RetBig []
+ RetSmall None payloads
+ RET_BIG -> let !(# bitmapArray#, size# #) = getLargeBitmap# s# i#
+ bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
+ bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #)) bitmapWords (trace ("XXX size " ++ show (W# size#))(W# size#))
+ payloads = map toBitmapPayload bes
+ in
+ RetBig payloads
RET_FUN -> RetFun
UPDATE_FRAME -> UpdateFrame
CATCH_FRAME -> CatchFrame
@@ -89,10 +131,33 @@ unpackStackFrameIter (StackFrameIter (# s, i #)) =
CATCH_STM_FRAME -> CatchStmFrame
x -> error $ "Unexpected closure type on stack: " ++ show x
+-- | Right-fold over the elements of a 'ByteArray'.
+-- Copied from `primitive`
+foldrByteArray :: forall b. (Word# -> b -> b) -> b -> ByteArray# -> b
+{-# INLINE foldrByteArray #-}
+foldrByteArray f z arr = go 0
+ where
+ go i
+ | i < maxI = f (indexWordArray# arr (toInt# i)) (go (i + 1))
+ | otherwise = z
+ maxI = sizeofByteArray arr `quot` sizeOf (undefined :: Word)
+
+-- | 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
+
-- TODO: Is the function type below needed? (Was proposed by Ben)
-- derefStackPtr :: StackSnapshot# -> Int# -> a
-foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Int# -> Word#
+foreign import prim "unpackClosureFromStackFramezh" unpackClosureFromStackFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
+
+foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
data BitmapPayload = Closure CL.Closure | Primitive Word
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -1,3 +1,4 @@
+#include "MachDeps.h"
#include "Rts.h"
#include "rts/Messages.h"
#include "rts/storage/ClosureTypes.h"
@@ -93,6 +94,31 @@ StgWord getBitmapWord(StgInfoTable *info){
return bitmapWord;
}
+StgWord getLargeBitmapSize(StgInfoTable *info){
+ StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ return bitmap->size;
+}
+
+#define ROUNDUP_BITS_TO_WDS(n) (((n) + WORD_SIZE_IN_BITS - 1) / WORD_SIZE_IN_BITS )
+
+// Copied from Cmm.h
+#define SIZEOF_W SIZEOF_VOID_P
+#define WDS(n) ((n)*SIZEOF_W)
+
+StgArrBytes* getLargeBitmaps(Capability *cap, StgInfoTable *info){
+ StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
+ StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
+ StgArrBytes* array = allocate(cap, sizeofW(StgArrBytes) + neededWords);
+ SET_HDR(array, &stg_ARR_WORDS_info, CCCS);
+ array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
+
+ for(int i = 0; i < neededWords; i++) {
+ array->payload[i] = bitmap->bitmap[i];
+ }
+
+ return array;
+}
+
StgLargeBitmap* getLargeBitmapPtr(const StgInfoTable *info) {
return GET_LARGE_BITMAP(info);
}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -72,18 +72,31 @@ getInfoTableTypezh (P_ stack, W_ index) {
getSmallBitmapzh(P_ stack, W_ index) {
P_ itbl;
- itbl = %INFO_PTR(StgStack_sp(stack) + WDS(index));
+ itbl = %STD_INFO(%INFO_PTR(StgStack_sp(stack) + WDS(index)));
W_ bitmap, size;
(bitmap) = ccall getBitmapWord(itbl);
(size) = ccall getBitmapSize(itbl);
- ccall debugBelch("getSmallBitmapzh - bitmap %ul, size %ul", bitmap, size);
+ ccall debugBelch("getSmallBitmapzh - bitmap %ul, size %ul\n", bitmap, size);
return (bitmap, size);
}
unpackClosureFromStackFramezh(P_ stack, W_ index){
P_ closurePtr;
closurePtr = (StgStack_sp(stack) + WDS(index));
- return (stg_unpackClosurezh(closurePtr));
+ jump stg_unpackClosurezh(closurePtr);
+}
+
+getLargeBitmapzh(P_ stack, W_ index){
+ P_ itbl, stgArrBytes;
+ W_ size;
+ itbl = %STD_INFO(%INFO_PTR(StgStack_sp(stack) + WDS(index)));
+
+ (stgArrBytes) = ccall getLargeBitmaps(MyCapability(), itbl);
+ (size) = ccall getLargeBitmapSize(itbl);
+
+ ccall debugBelch("getLargeBitmapzh - size %ul\n", size);
+
+ return (stgArrBytes, size);
}
=====================================
rts/Printer.c
=====================================
@@ -489,7 +489,7 @@ printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap,
debugBelch("printSmallBitmap - payload %p\n", payload);
debugBelch("printSmallBitmap - bitmap ");
printBits(sizeof(StgWord), &bitmap);
- debugBelch("printSmallBitmap - size %u\n", size);
+ debugBelch("printSmallBitmap - size %u, bitmap %ul\n", size, bitmap);
uint32_t i;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e2de6a72d4c5bf12b213239877619d252499837...42318ec6950af7308ac720087711f8610aeaea48
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e2de6a72d4c5bf12b213239877619d252499837...42318ec6950af7308ac720087711f8610aeaea48
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/20221007/5bb1f41e/attachment-0001.html>
More information about the ghc-commits
mailing list