[Git][ghc/ghc][wip/decode_cloned_stack] 5 commits: Assert more
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Oct 8 13:31:39 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
4cc6d41d by Sven Tennie at 2022-10-08T11:56:37+00:00
Assert more
- - - - -
e5a82373 by Sven Tennie at 2022-10-08T12:31:18+00:00
Sober casts; mute debug belchs
- - - - -
4668dd13 by Sven Tennie at 2022-10-08T12:33:41+00:00
Cleanup
- - - - -
3bb4beab by Sven Tennie at 2022-10-08T12:44:06+00:00
Delete unused StackFFI HSC code
- - - - -
ae908a83 by Sven Tennie at 2022-10-08T13:30:47+00:00
Recognize special small rets
- - - - -
5 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- − libraries/ghc-heap/GHC/Exts/Heap/StackFFI.hsc
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- libraries/ghc-heap/ghc-heap.cabal.in
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -57,7 +57,7 @@ foreign import prim "getInfoTableTypezh" getInfoTableType# :: StackSnapshot# ->
foreign import prim "getLargeBitmapzh" getLargeBitmap# :: StackSnapshot# -> Word# -> (# ByteArray#, Word# #)
-foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word# #)
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: StackSnapshot# -> Word# -> (# Word#, Word#, Word# #)
data BitmapEntry = BitmapEntry {
closureFrame :: StackFrameIter,
@@ -110,11 +110,12 @@ unpackStackFrameIter :: StackFrameIter -> StackFrame
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#, special# #) = getSmallBitmap# s# i#
bes = toBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #))(W# bitmap#) (W# size#)
payloads = map toBitmapPayload bes
+ special = (toEnum . fromInteger . toInteger) (W# special#)
in
- RetSmall None payloads
+ RetSmall special 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## #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
@@ -167,6 +168,7 @@ instance Show BitmapPayload where
-- TODO There are likely more. See MiscClosures.h
data SpecialRetSmall =
+ -- TODO: Shoudn't `None` be better `Maybe ...`
None |
ApV |
ApF |
=====================================
libraries/ghc-heap/GHC/Exts/Heap/StackFFI.hsc deleted
=====================================
@@ -1,75 +0,0 @@
-module GHC.Exts.Heap.StackFFI where
-
-#include "Rts.h"
-#undef BLOCK_SIZE
-#undef MBLOCK_SIZE
-#undef BLOCKS_PER_MBLOCK
-#include "DerivedConstants.h"
-
--- TODO: Check imports: Are all needed?
-import Prelude -- See note [Why do we import Prelude here?]
-import GHC.Exts.Heap.InfoTable.Types
-#if !defined(TABLES_NEXT_TO_CODE)
-import GHC.Exts.Heap.Constants
-import Data.Maybe
-#endif
-import Foreign
-import Debug.Trace
-
-peekSmallBitmapWord :: Ptr StgInfoTable -> IO Word
-peekSmallBitmapWord itbl =
-#if !defined(TABLES_NEXT_TO_CODE)
- let ptr = itbl `plusPtr` (negate wORD_SIZE)
-#else
- let ptr = itbl
-#endif
- in
- (#peek struct StgInfoTable_, layout.bitmap) ptr
-
--- TODO: unused
--- #define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
-bitmapSize :: Word -> Word
-bitmapSize b = b .&. (#const BITMAP_SIZE_MASK)
-
--- TODO: unused
--- #define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
-bitmapBits :: Word -> Word
-bitmapBits b = b `shiftR` (#const BITMAP_BITS_SHIFT)
-
-data LargeBitmap = LargeBitmap {
- size :: Word,
- bitmap :: [Word]
-} deriving (Show)
-
-peekStgLargeBitmap :: Ptr LargeBitmap -> IO LargeBitmap
-peekStgLargeBitmap largeBitmapPtr = do
--- #if !defined(TABLES_NEXT_TO_CODE)
--- largeBitmapPtr <- (#peek struct StgInfoTable_, layout.large_bitmap) itbl
--- #else
--- -- large_bitmap_offset
--- offset <- (#peek struct StgInfoTable_, layout.large_bitmap_offset) itbl
--- let largeBitmapPtr = plusPtr itbl offset
--- #endif
- traceM $ "peekStgLargeBitmap - largeBitmapPtr : " ++ show largeBitmapPtr
- size' <- (#peek StgLargeBitmap, size) largeBitmapPtr
- traceM $ "peekStgLargeBitmap - size' : " ++ show size'
- -- bitmapArrayPtr <- (#peek StgLargeBitmap, bitmap) largeBitmapPtr
- -- traceM $ "peekStgLargeBitmap - bitmapArrayPtr : " ++ show bitmapArrayPtr
- bitmap' <- peekArray size' (plusPtr largeBitmapPtr (#const OFFSET_StgLargeBitmap_bitmap))
- pure $ LargeBitmap {
- -- This is safe: ´StgLargeBitmap.size´ is a StgWord in C/RTS
- size = fromIntegral size',
- bitmap = bitmap'
- }
-
-bitsInWord :: Word
-bitsInWord = (#const BITS_IN(StgWord))
-
-bytesInWord :: Word
-bytesInWord = (#const sizeof(StgWord))
-
-payloadOffset = (#size StgHeader) + (#const OFFSET_StgClosure_payload)
--- TODO: Ptr should not be polymorphic. I.e. use a saturized type.
--- TODO: Doesn't need to be here (in hsc file)
-payloadPtr :: Ptr a -> Ptr Word
-payloadPtr sp = plusPtr sp payloadOffset
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -13,7 +13,7 @@ StgWord stackFrameSize(StgStack* stack, StgWord index){
}
StgStack* getUnderflowFrameStack(StgStack* stack, StgWord index){
- StgClosure* frame = stack->sp + index;
+ StgClosure* frame = (StgClosure *) stack->sp + index;
ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
@@ -31,8 +31,9 @@ const StgInfoTable *getItbl(StgClosure *closure) {
return get_itbl(closure);
};
-StgWord getSpecialRetSmall(StgPtr sp) {
- StgWord c = *sp;
+StgWord getSpecialRetSmall(StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+ StgWord c = *(StgWord*)closure;
if (c == (StgWord)&stg_ap_v_info) {
return 1;
} else if (c == (StgWord)&stg_ap_f_info) {
@@ -78,31 +79,29 @@ StgWord getSpecialRetSmall(StgPtr sp) {
}
}
-// TODO: Consider to use HSC
StgWord getBitmapSize(StgClosure *c){
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- StgInfoTable* info = get_itbl(c);
+ const StgInfoTable* info = get_itbl(c);
StgWord bitmap = info->layout.bitmap;
return BITMAP_SIZE(bitmap);
}
-// TODO: Consider to use HSC
StgWord getBitmapWord(StgClosure *c){
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- StgInfoTable* info = get_itbl(c);
+ const StgInfoTable* info = get_itbl(c);
StgWord bitmap = info->layout.bitmap;
- debugBelch("getBitmapWord - bitmap : %lu \n", bitmap);
+ // debugBelch("getBitmapWord - bitmap : %lu \n", bitmap);
StgWord bitmapWord = BITMAP_BITS(bitmap);
- debugBelch("getBitmapWord - bitmapWord : %lu \n", bitmapWord);
+ // debugBelch("getBitmapWord - bitmapWord : %lu \n", bitmapWord);
return bitmapWord;
}
StgWord getLargeBitmapSize(StgClosure *c){
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- StgInfoTable* info = get_itbl(c);
+ const StgInfoTable* info = get_itbl(c);
StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
return bitmap->size;
}
@@ -116,10 +115,10 @@ StgWord getLargeBitmapSize(StgClosure *c){
StgArrBytes* getLargeBitmaps(Capability *cap, StgClosure *c){
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- StgInfoTable* info = get_itbl(c);
+ const StgInfoTable* info = get_itbl(c);
StgLargeBitmap* bitmap = GET_LARGE_BITMAP(info);
StgWord neededWords = ROUNDUP_BITS_TO_WDS(bitmap->size);
- StgArrBytes* array = allocate(cap, sizeofW(StgArrBytes) + neededWords);
+ StgArrBytes* array = (StgArrBytes *) allocate(cap, sizeofW(StgArrBytes) + neededWords);
SET_HDR(array, &stg_ARR_WORDS_info, CCCS);
array->bytes = WDS(ROUNDUP_BITS_TO_WDS(bitmap->size));
@@ -130,10 +129,6 @@ StgArrBytes* getLargeBitmaps(Capability *cap, StgClosure *c){
return array;
}
-StgLargeBitmap* getLargeBitmapPtr(const StgInfoTable *info) {
- return GET_LARGE_BITMAP(info);
-}
-
#if defined(DEBUG)
extern void printStack ( StgStack *stack );
void belchStack(StgStack* stack){
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -48,7 +48,14 @@ advanceStackFrameIterzh (P_ stack, W_ index) {
}
}
- ccall debugBelch("advanceStackFrameIterzh - stack %p, newStack %p, frameSize %ul, newIdex %ul, hasNext %ul, stackBottom %p\n", stack, newStack, frameSize, newIndex, hasNext, stackBottom);
+ // TODO: Execute this block only in -DDEBUG
+ if(hasNext > 0) {
+ P_ nextClosure;
+ nextClosure = StgStack_sp(stack) + WDS(index);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(nextClosure));
+ }
+
+ // 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);
}
@@ -61,12 +68,13 @@ derefStackWordzh (P_ stack, W_ index) {
getInfoTableTypezh (P_ stack, W_ index) {
P_ p, info;
- p = (StgStack_sp(stack) + WDS(index));
+ p = StgStack_sp(stack) + WDS(index);
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
info = %INFO_PTR(p);
W_ type;
type = TO_W_(%INFO_TYPE(%STD_INFO(info)));
- ccall debugBelch("getInfoTableTypezh - stack %p , index %ul, closure ptr p %p, info ptr %p, itbl type %ul\n", stack, index, p, info, type);
+ // 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);
}
@@ -75,12 +83,13 @@ getSmallBitmapzh(P_ stack, W_ index) {
c = StgStack_sp(stack) + WDS(index);
ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
- W_ bitmap, size;
+ W_ bitmap, size, specialType;
(bitmap) = ccall getBitmapWord(c);
(size) = ccall getBitmapSize(c);
+ (specialType) = ccall getSpecialRetSmall(c);
- ccall debugBelch("getSmallBitmapzh - bitmap %ul, size %ul\n", bitmap, size);
- return (bitmap, size);
+ // ccall debugBelch("getSmallBitmapzh - bitmap %ul, size %ul\n", bitmap, size);
+ return (bitmap, size, specialType);
}
unpackClosureFromStackFramezh(P_ stack, W_ index){
@@ -99,7 +108,7 @@ getLargeBitmapzh(P_ stack, W_ index){
(stgArrBytes) = ccall getLargeBitmaps(MyCapability(), c);
(size) = ccall getLargeBitmapSize(c);
- ccall debugBelch("getLargeBitmapzh - size %ul\n", size);
+ // ccall debugBelch("getLargeBitmapzh - size %ul\n", size);
return (stgArrBytes, size);
}
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -49,5 +49,4 @@ library
GHC.Exts.Heap.ProfInfo.Types
GHC.Exts.Heap.ProfInfo.PeekProfInfo
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
- GHC.Exts.Heap.StackFFI
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f6ca800f8bc48ea749757654ebb926c7b6ea9eb...ae908a83a593fd4672e2234b3b149c43881fb8bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f6ca800f8bc48ea749757654ebb926c7b6ea9eb...ae908a83a593fd4672e2234b3b149c43881fb8bc
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/20221008/045da640/attachment-0001.html>
More information about the ghc-commits
mailing list