[Git][ghc/ghc][wip/decode_cloned_stack] Hacked further

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC


Commits:
1e2de6a7 by Sven Tennie at 2022-10-03T17:56:07+00:00
Hacked further

- - - - -


2 changed files:

- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/cbits/Stack.cmm


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -34,7 +34,12 @@ import GHC.Exts.Heap.StackFFI (bitsInWord)
 import GHC.Exts.Heap.Closures (closureSize)
 import System.Mem (performMajorGC)
 
-type StackFrameIter# = (# StackSnapshot#, Word# #)
+type StackFrameIter# = (#
+                          -- | StgStack
+                          StackSnapshot#,
+                          -- | offset in machine words
+                          Word#
+                        #)
 
 data StackFrameIter = StackFrameIter StackFrameIter#
 
@@ -52,11 +57,27 @@ advanceStackFrameIter (StackFrameIter (# s, i #)) = let (# s', i', hasNext #) =
 
 foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# -> Word# -> Word#
 
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+
+data BitmapEntry = BitmapEntry {
+    closureFrame :: StackFrameIter,
+    isPrimitive :: Bool
+  } deriving (Show)
+
+toBitmapEntries :: StackFrameIter -> Word -> Word -> [BitmapEntry]
+toBitmapEntries _ _ 0 = []
+toBitmapEntries sfi@(StackFrameIter(# s, i #) bitmap size = BitmapEntry {
+  closureFrame = sfi,
+  isPrimitive = (bitmap .&. 1) == 0
+                                            } : toBitmapEntries (StackFrameIter (# s , i + 1 #)) (bitmap `shiftR` 1) (size - 1)
+
 unpackStackFrameIter :: StackFrameIter -> StackFrame
 unpackStackFrameIter (StackFrameIter (# s, i #)) =
   case (toEnum . fromIntegral) (W# (getInfoTableType# s i)) of
      RET_BCO -> RetBCO
-     RET_SMALL -> RetSmall None []
+     RET_SMALL -> let (# bitmap#, size# #) = getSmallBitmap# s i
+                  in
+                    RetSmall None []
      RET_BIG ->  RetBig []
      RET_FUN ->  RetFun
      UPDATE_FRAME ->  UpdateFrame


=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -48,7 +48,7 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
     }
   }
 
-  ccall debugBelch("advanceStackFrameIterzh - stack %p,  newStack %p, frameSize %ul, newIdex %ul, hasNext %ul\n", stack, newStack, frameSize, newIndex, hasNext);
+  ccall debugBelch("advanceStackFrameIterzh - stack %p,  newStack %p, frameSize %ul, newIdex %ul, hasNext %ul, stackBottom %p\n", stack, newStack, frameSize, newIndex, hasNext, stackBottom);
   return (newStack, newIndex, hasNext);
 }
 
@@ -56,7 +56,7 @@ derefStackWordzh (P_ stack, W_ index) {
   P_ sp;
   sp = StgStack_sp(stack);
 
-  return (W_[sp + index]);
+  return (W_[sp + WDS(index)]);
 }
 
 getInfoTableTypezh (P_ stack, W_ index) {
@@ -69,3 +69,21 @@ getInfoTableTypezh (P_ stack, W_ index) {
     ccall debugBelch("getInfoTableTypezh - stack %p , index %ul, closure ptr p %p, info ptr %p, itbl type %ul\n", stack, index, p, info, type);
     return (type);
 }
+
+getSmallBitmapzh(P_ stack, W_ index) {
+  P_ itbl;
+  itbl = %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);
+  return (bitmap, size);
+}
+
+unpackClosureFromStackFramezh(P_ stack, W_ index){
+  P_ closurePtr;
+  closurePtr = (StgStack_sp(stack) + WDS(index));
+  return (stg_unpackClosurezh(closurePtr));
+}



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e2de6a72d4c5bf12b213239877619d252499837

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e2de6a72d4c5bf12b213239877619d252499837
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/20221003/ebba6504/attachment-0001.html>