[Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: RetFun
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Nov 19 08:31:54 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
b49d6c91 by Sven Tennie at 2022-11-06T16:28:15+01:00
RetFun
- - - - -
499e2860 by Sven Tennie at 2022-11-19T09:31:37+01:00
Save
- - - - -
6 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/StackConstants.hsc
- libraries/ghc-heap/cbits/Stack.c
- libraries/ghc-heap/cbits/Stack.cmm
- shell.nix
- utils/deriveConstants/Main.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -123,7 +123,22 @@ toClosure f# (StackFrameIter (# s#, i# #)) = unsafePerformIO $
unpackStackFrameIter :: StackFrameIter -> StackFrame
unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
case (toEnum . fromIntegral) (W# (getInfoTableType# s# i#)) of
- RET_BCO -> RetBCO
+ RET_BCO -> let
+ instrs' = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetBCOFrameInstrs)) sfi
+ literals' = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetBCOFrameLiterals)) sfi
+ ptrs' = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetBCOFramePtrs)) sfi
+ arity' = W# (getHalfWord# s# i# (intToWord# offsetStgRetBCOFrameArity))
+ size' = W# (getHalfWord# s# i# (intToWord# offsetStgRetBCOFrameSize))
+ payload' =
+ in
+ RetBCO {
+ instrs = instrs',
+ literals = literals',
+ ptrs = ptrs',
+ arity = arity',
+ size = size',
+ payload = payload'
+ }
RET_SMALL -> let !(# bitmap#, size#, special# #) = getSmallBitmap# s# i#
bes = toBitmapEntries (StackFrameIter (# s#, plusWord# i# 1## #))(W# bitmap#) (W# size#)
payloads = map toBitmapPayload bes
@@ -137,10 +152,27 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) =
in
RetBig payloads
RET_FUN -> let
- t = getRetFunType# s# i#
+ t = (toEnum . fromInteger . toInteger) (W# (getRetFunType# s# i#))
size = W# (getWord# s# i# (intToWord# offsetStgRetFunFrameSize))
fun = toClosure (unpackClosureReferencedByFrame# (intToWord# offsetStgRetFunFrameFun)) sfi
- payload :: [CL.Closure]
+ payload =
+ -- TODO: Much duplication with RET_SMALL and RET_BIG
+ case t of
+ ARG_GEN_BIG ->
+ let
+ !(# bitmapArray#, size# #) = getRetFunLargeBitmap# s# i#
+ bitmapWords :: [Word] = foldrByteArray (\w acc -> W# w : acc) [] bitmapArray#
+ bes = wordsToBitmapEntries (StackFrameIter (# s#, plusWord# i# 2## #)) (trace ("bitmapWords" ++ show bitmapWords) bitmapWords) (trace ("XXX size " ++ show (W# size#))(W# size#))
+ payloads = map toBitmapPayload bes
+ in
+ payloads
+ _ ->
+ let
+ !(# bitmap#, size# #) = getRetFunSmallBitmap# s# i#
+ bes = toBitmapEntries (StackFrameIter (# s#, plusWord# i# 2## #))(W# bitmap#) (W# size#)
+ payloads = map toBitmapPayload bes
+ in
+ payloads
in
RetFun t size fun payload
-- TODO: Decode update frame type
@@ -207,8 +239,6 @@ intToWord# i = int2Word# (toInt# i)
foreign import prim "unpackClosureFromStackFramezh" unpackClosureFromStackFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
-foreign import prim "unpackUpdateeFromUpdateFramezh" unpackUpdateeFromUpdateFrame# :: StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# b #)
-
foreign import prim "derefStackWordzh" derefStackWord# :: StackSnapshot# -> Word# -> Word#
foreign import prim "getUpdateFrameTypezh" getUpdateFrameType# :: StackSnapshot# -> Word# -> Word#
@@ -221,6 +251,8 @@ foreign import prim "getUnderflowFrameNextChunkzh" getUnderflowFrameNextChunk# :
foreign import prim "getWordzh" getWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+foreign import prim "getHalfWordzh" getHalfWord# :: StackSnapshot# -> Word# -> Word# -> Word#
+
foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word#
data BitmapPayload = Closure CL.Closure | Primitive Word
@@ -270,8 +302,15 @@ data StackFrame =
StopFrame |
RetSmall { knownRetSmallType :: SpecialRetSmall, payload :: [BitmapPayload]} |
RetBig { payload :: [BitmapPayload] } |
- RetFun { retFunType :: RetFunType, size :: Word, fun :: CL.Closure, payload :: [CL.Closure]} |
- RetBCO
+ RetFun { retFunType :: RetFunType, size :: Word, fun :: CL.Closure, payload :: [BitmapPayload]} |
+ RetBCO {
+ instrs :: CL.Closure,
+ literals :: CL.Closure,
+ ptrs :: CL.Closure,
+ arity :: Word,
+ size :: Word,
+ payload :: [BitmapPayload]
+ }
deriving (Show)
data RetFunType =
=====================================
libraries/ghc-heap/GHC/Exts/StackConstants.hsc
=====================================
@@ -1,5 +1,9 @@
+{-# LANGUAGE CPP #-}
module GHC.Exts.StackConstants where
+-- TODO: Better expression to allow is only for the latest (this branch) GHC?
+#if MIN_VERSION_base(4,17,0)
+
import Prelude
#include "Rts.h"
@@ -43,3 +47,19 @@ offsetStgRetFunFrameFun = (#const OFFSET_StgRetFun_fun) + (#size StgHeader)
offsetStgRetFunFramePayload :: Int
offsetStgRetFunFramePayload = (#const OFFSET_StgRetFun_payload) + (#size StgHeader)
+
+offsetStgRetBCOFrameInstrs :: Int
+offsetStgRetBCOFrameInstrs = (#const OFFSET_StgRetBCO_instrs) + (#size StgHeader)
+
+offsetStgRetBCOFrameLiterals :: Int
+offsetStgRetBCOFrameLiterals = (#const OFFSET_StgRetBCO_literals) + (#size StgHeader)
+
+offsetStgRetBCOFramePtrs :: Int
+offsetStgRetBCOFramePtrs = (#const OFFSET_StgRetBCO_ptrs) + (#size StgHeader)
+
+offsetStgRetBCOFrameArity :: Int
+offsetStgRetBCOFrameArity = (#const OFFSET_StgRetBCO_arity) + (#size StgHeader)
+
+offsetStgRetBCOFrameSize :: Int
+offsetStgRetBCOFrameSize = (#const OFFSET_StgRetBCO_size) + (#size StgHeader)
+#endif
=====================================
libraries/ghc-heap/cbits/Stack.c
=====================================
@@ -111,11 +111,11 @@ StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
switch (fun_info->f.fun_type) {
case ARG_GEN:
- return BITMAP_BITS(fun_info->f.b.bitmap),
+ return BITMAP_BITS(fun_info->f.b.bitmap);
case ARG_GEN_BIG:
return GET_FUN_LARGE_BITMAP(fun_info)->size;
default:
- return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
+ return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
}
}
@@ -130,7 +130,7 @@ StgWord getBitmapWord(StgClosure *c) {
return bitmapWord;
}
-StgWord getRetFunBitmapWord(StgClosure *ret_fun) {
+StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
@@ -208,8 +208,8 @@ StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
}
StgWord getRetFunType(StgRetFun *ret_fun) {
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
- StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+ const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
return fun_info->f.fun_type;
}
=====================================
libraries/ghc-heap/cbits/Stack.cmm
=====================================
@@ -181,6 +181,13 @@ getWordzh(P_ stack, W_ index, W_ offset){
return (W_[wordAddr]);
}
+// TODO: Rename: index -> wordOffset, offset -> byteOffset
+getHalfWordzh(P_ stack, W_ index, W_ offset){
+ P_ wordAddr;
+ wordAddr = (StgStack_sp(stack) + WDS(index) + offset);
+ return (HALF_WORD[wordAddr]);
+}
+
getUnderflowFrameNextChunkzh(P_ stack, W_ index){
P_ closurePtr, closurePtrPrime, updateePtr;
closurePtr = (StgStack_sp(stack) + WDS(index));
=====================================
shell.nix
=====================================
@@ -1,7 +1,7 @@
import ghc.nix/default.nix {
-# bootghc = "ghc902";
withDocs = false;
withHadrianDeps = true;
- withLlvm = true;
+ withLlvm = false;
withIde = true;
+ withGhcid = true;
}
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -464,9 +464,10 @@ wanteds os = concat
,closureField C "StgCatchFrame" "handler"
,closureField C "StgCatchFrame" "exceptions_blocked"
- ,closureField C "StgRetFun" "size"
- ,closureField C "StgRetFun" "fun"
- ,closureField C "StgRetFun" "payload"
+ ,structSize C "StgRetFun"
+ ,fieldOffset C "StgRetFun" "size"
+ ,fieldOffset C "StgRetFun" "fun"
+ ,fieldOffset C "StgRetFun" "payload"
,closureSize C "StgPAP"
,closureField C "StgPAP" "n_args"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/453b2623e13aefe4193c03fc55793ac30de33e16...499e2860500f4661507989146290cf0b18035d7f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/453b2623e13aefe4193c03fc55793ac30de33e16...499e2860500f4661507989146290cf0b18035d7f
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/20221119/16aa141d/attachment-0001.html>
More information about the ghc-commits
mailing list