[Git][ghc/ghc][wip/ann-frame] Annotate frame
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed Mar 5 20:20:38 UTC 2025
Ben Gamari pushed to branch wip/ann-frame at Glasgow Haskell Compiler / GHC
Commits:
e5b0ed0c by Ben Gamari at 2025-03-05T15:20:12-05:00
Annotate frame
- - - - -
25 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/ann_frame.hs
- libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
- rts/ClosureFlags.c
- rts/LdvProfile.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RetainerProfile.c
- rts/TraverseHeap.c
- rts/include/rts/storage/ClosureTypes.h
- rts/include/rts/storage/Closures.h
- rts/js/profiling.js
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- rts/sm/Sanity.c
- rts/sm/Scav.c
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3927,6 +3927,16 @@ primop ClearCCSOp "clearCCS#" GenPrimOp
with
out_of_line = True
+------------------------------------------------------------------------
+section "Annotating call stacks"
+------------------------------------------------------------------------
+
+primop AnnotateStackOp "annotateStack#" GenPrimOp
+ b -> a_reppoly -> a_reppoly
+ { Pushes an annotation frame to the stack which can be reported by backtraces. }
+ with
+ out_of_line = True
+
------------------------------------------------------------------------
section "Info Table Origin"
------------------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1763,6 +1763,7 @@ emitPrimOp cfg primop =
WhereFromOp -> alwaysExternal
GetApStackValOp -> alwaysExternal
ClearCCSOp -> alwaysExternal
+ AnnotateStackOp -> alwaysExternal
TraceEventOp -> alwaysExternal
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
=====================================
@@ -84,6 +84,7 @@ data ClosureType
| SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
| COMPACT_NFDATA
| CONTINUATION
+ | ANN_FRAME
| N_CLOSURE_TYPES
deriving (Enum, Eq, Ord, Show, Generic)
#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -574,11 +574,15 @@ data GenStackFrame b =
, retFunPayload :: ![GenStackField b]
}
- | RetBCO
+ | RetBCO
{ info_tbl :: !StgInfoTable
, bco :: !b -- ^ always a BCOClosure
, bcoArgs :: ![GenStackField b]
}
+ | AnnFrame
+ { info_tbl :: !StgInfoTable
+ , annotation :: !b
+ }
deriving (Foldable, Functor, Generic, Show, Traversable)
data PrimType
=====================================
libraries/ghc-heap/GHC/Exts/Stack.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
-#if MIN_TOOL_VERSION_ghc(9,9,0)
+#if MIN_TOOL_VERSION_ghc(9,13,0)
{-# LANGUAGE RecordWildCards #-}
module GHC.Exts.Stack
@@ -30,6 +30,7 @@ stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload
stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs
-- The one additional word is a pointer to the next stack chunk
stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1
+stackFrameSize (AnnFrame {}) = sizeStgAnnFrame
stackFrameSize _ = error "Unexpected stack frame type"
#else
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
=====================================
@@ -3,7 +3,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Exts.Stack.Constants where
-#if MIN_TOOL_VERSION_ghc(9,9,0)
+#if MIN_TOOL_VERSION_ghc(9,13,0)
import Prelude
@@ -88,6 +88,13 @@ offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_pa
sizeStgRetFunFrame :: Int
sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
+sizeStgAnnFrame :: Int
+sizeStgAnnFrame = bytesToWords (#const SIZEOF_StgAnnFrame)
+
+offsetStgAnnFrameAnn :: WordOffset
+offsetStgAnnFrameAnn = byteOffsetToWordOffset $
+ (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
+
offsetStgBCOFrameInstrs :: ByteOffset
offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
-#if MIN_TOOL_VERSION_ghc(9,9,0)
+#if MIN_TOOL_VERSION_ghc(9,13,0)
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -377,6 +377,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
catchFrameCode = catchFrameCode',
handler = handler'
}
+ ANN_FRAME ->
+ let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
+ in
+ pure $
+ AnnFrame
+ { info_tbl = info,
+ annotation = annotation
+ }
x -> error $ "Unexpected closure type on stack: " ++ show x
-- | Unbox 'Int#' from 'Int'
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -103,3 +103,5 @@ test('stack_misc_closures',
]
, '-debug' # Debug RTS to use checkSTACK() (Sanity.c)
])
+
+test('ann_frame', normal, compile_and_run, [''])
=====================================
libraries/ghc-heap/tests/ann_frame.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE GADTs #-}
+
+import Data.Typeable
+import GHC.Exts
+import GHC.Exts.Heap.Closures as Closures
+import GHC.Exts.Stack.Decode
+import GHC.Stack.CloneStack
+import System.IO.Unsafe
+import Unsafe.Coerce
+
+data StackAnnotation where
+ StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation
+
+annotateStack
+ :: forall a r b.
+ (Typeable a, Show a)
+ => a -> b -> b
+annotateStack ann =
+ annotateStack# (StackAnnotation ann)
+
+hello :: Int -> Int -> Int
+hello x y = annotateStack (x,y) $ unsafePerformIO $ do
+ stack <- GHC.Stack.CloneStack.cloneMyStack
+ decoded <- GHC.Exts.Stack.Decode.decodeStack stack
+ print [ show x
+ | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded
+ , StackAnnotation x <- pure $ unsafeCoerce ann
+ ]
+ return $ x + y + 42
+{-# OPAQUE hello #-}
+
+main :: IO ()
+main =
+ print $ hello 2 3
+
=====================================
libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
=====================================
@@ -83,5 +83,6 @@ data ClosureType
| SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
| COMPACT_NFDATA
| CONTINUATION
+ | ANN_FRAME
| N_CLOSURE_TYPES
deriving (Enum, Eq, Ord, Show, Generic)
=====================================
rts/ClosureFlags.c
=====================================
@@ -88,8 +88,9 @@ const StgWord16 closure_flags[] = {
[SMALL_MUT_ARR_PTRS_FROZEN_CLEAN] = (_HNF| _NS| _UPT ),
[COMPACT_NFDATA] = (_HNF| _NS ),
[CONTINUATION] = (_HNF| _NS| _UPT ),
+ [ANN_FRAME] = ( _BTM| _FRM ),
};
-#if N_CLOSURE_TYPES != 65
+#if N_CLOSURE_TYPES != 66
#error Closure types changed: update ClosureFlags.c!
#endif
=====================================
rts/LdvProfile.c
=====================================
@@ -154,6 +154,7 @@ processHeapClosureForDead( const StgClosure *c )
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
+ case ANN_FRAME:
// others
case INVALID_OBJECT:
case COMPACT_NFDATA:
=====================================
rts/PrimOps.cmm
=====================================
@@ -2804,6 +2804,28 @@ stg_clearCCSzh (P_ arg)
jump stg_ap_v_fast(arg);
}
+#define ANN_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,ann) \
+ w_ info_ptr, \
+ PROF_HDR_FIELDS(w_,p1,p2) \
+ p_ ann
+
+INFO_TABLE_RET (stg_ann_frame, ANN_FRAME,
+ ANN_FRAME_FIELDS(W_,P_, info_ptr, p1, p2, ann))
+ /* no args => explicit stack */
+{
+ unwind Sp = W_[Sp + SIZEOF_StgAnnFrame];
+ Sp = Sp + SIZEOF_StgAnnFrame;
+ jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live!
+}
+
+stg_annotateStackzh (P_ ann, P_ cont)
+{
+ STK_CHK_GEN();
+ jump stg_ap_0_fast
+ (ANN_FRAME_FIELDS(,,stg_ann_frame_info, CCCS, 0, ann))(cont);
+
+}
+
stg_numSparkszh ()
{
W_ n;
=====================================
rts/Printer.c
=====================================
@@ -270,6 +270,17 @@ printClosure( const StgClosure *obj )
case RET_FUN:
*/
+ case ANN_FRAME:
+ {
+ StgAnnFrame* frame = (StgAnnFrame*)obj;
+ debugBelch("ANN_FRAME(");
+ printPtr((StgPtr)GET_INFO((StgClosure *)frame));
+ debugBelch(",");
+ printPtr((StgPtr)frame->ann);
+ debugBelch(")\n");
+ break;
+ }
+
case UPDATE_FRAME:
{
StgUpdateFrame* frame = (StgUpdateFrame*)obj;
@@ -1123,6 +1134,7 @@ const char *closure_type_names[] = {
[RET_FUN] = "RET_FUN",
[UPDATE_FRAME] = "UPDATE_FRAME",
[CATCH_FRAME] = "CATCH_FRAME",
+ [ANN_FRAME] = "ANN_FRAME",
[UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",
[STOP_FRAME] = "STOP_FRAME",
[BLOCKING_QUEUE] = "BLOCKING_QUEUE",
@@ -1155,7 +1167,7 @@ const char *closure_type_names[] = {
[CONTINUATION] = "CONTINUATION",
};
-#if N_CLOSURE_TYPES != 65
+#if N_CLOSURE_TYPES != 66
#error Closure types changed: update Printer.c!
#endif
=====================================
rts/RetainerProfile.c
=====================================
@@ -217,6 +217,7 @@ isRetainer( const StgClosure *c )
case RET_SMALL:
case RET_BIG:
case RET_FUN:
+ case ANN_FRAME:
// other cases
case IND:
case INVALID_OBJECT:
=====================================
rts/TraverseHeap.c
=====================================
@@ -529,6 +529,7 @@ traverseGetChildren(StgClosure *c, StgClosure **first_child, bool *other_childre
case RET_BCO:
case RET_SMALL:
case RET_BIG:
+ case ANN_FRAME:
// invalid objects
case IND:
case INVALID_OBJECT:
@@ -832,6 +833,7 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data,
case RET_BCO:
case RET_SMALL:
case RET_BIG:
+ case ANN_FRAME:
// invalid objects
case IND:
case INVALID_OBJECT:
@@ -965,6 +967,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackElement *sep,
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
case RET_SMALL:
+ case ANN_FRAME:
bitmap = BITMAP_BITS(info->i.layout.bitmap);
size = BITMAP_SIZE(info->i.layout.bitmap);
p++;
=====================================
rts/include/rts/storage/ClosureTypes.h
=====================================
@@ -89,4 +89,5 @@
#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62
#define COMPACT_NFDATA 63
#define CONTINUATION 64
-#define N_CLOSURE_TYPES 65
+#define ANN_FRAME 65
+#define N_CLOSURE_TYPES 66
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -312,6 +312,15 @@ typedef struct {
StgClosure *result;
} StgDeadThreadFrame;
+// Stack frame annotating an execution context with a Haskell value
+// for backtrace purposes.
+//
+// Closure types: ANN_FRAME
+typedef struct {
+ StgHeader header;
+ StgClosure *ann;
+} StgAnnFrame;
+
// A function return stack frame: used when saving the state for a
// garbage collection at a function entry point. The function
// arguments are on the stack, and we also save the function (its
=====================================
rts/js/profiling.js
=====================================
@@ -333,3 +333,8 @@ function h$buildCCSPtr(o) {
function h$clearCCS(a) {
throw new Error("ClearCCSOp not implemented");
}
+
+// we throw away the annotation here.
+function h$annotateStack(o) {
+ return o;
+}
=====================================
rts/sm/Compact.c
=====================================
@@ -351,6 +351,7 @@ thread_stack(P_ p, P_ stack_end)
case STOP_FRAME:
case CATCH_FRAME:
case RET_SMALL:
+ case ANN_FRAME:
{
W_ bitmap = BITMAP_BITS(info->i.layout.bitmap);
W_ size = BITMAP_SIZE(info->i.layout.bitmap);
=====================================
rts/sm/Evac.c
=====================================
@@ -996,6 +996,7 @@ loop:
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
case ATOMICALLY_FRAME:
+ case ANN_FRAME:
// shouldn't see these
barf("evacuate: stack frame at %p\n", q);
=====================================
rts/sm/NonMovingMark.c
=====================================
@@ -1180,6 +1180,7 @@ trace_stack_ (MarkQueue *queue, StgPtr sp, StgPtr spBottom)
case STOP_FRAME:
case CATCH_FRAME:
case RET_SMALL:
+ case ANN_FRAME:
{
StgWord bitmap = BITMAP_BITS(info->i.layout.bitmap);
StgWord size = BITMAP_SIZE(info->i.layout.bitmap);
=====================================
rts/sm/Sanity.c
=====================================
@@ -128,6 +128,7 @@ checkStackFrame( StgPtr c )
case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_SMALL:
+ case ANN_FRAME:
size = BITMAP_SIZE(info->i.layout.bitmap);
checkSmallBitmap((StgPtr)c + 1,
BITMAP_BITS(info->i.layout.bitmap), size);
=====================================
rts/sm/Scav.c
=====================================
@@ -1983,6 +1983,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
case STOP_FRAME:
case CATCH_FRAME:
case RET_SMALL:
+ case ANN_FRAME:
bitmap = BITMAP_BITS(info->i.layout.bitmap);
size = BITMAP_SIZE(info->i.layout.bitmap);
// NOTE: the payload starts immediately after the info-ptr, we
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -443,6 +443,8 @@ wanteds os = concat
,closureSize C "StgStopFrame"
,closureSize C "StgDeadThreadFrame"
,closureField C "StgDeadThreadFrame" "result"
+ ,structSize C "StgAnnFrame"
+ ,closureField C "StgAnnFrame" "ann"
,closureSize Both "StgMutArrPtrs"
,closureField Both "StgMutArrPtrs" "ptrs"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e5b0ed0c2085cca93a61e24c4425d32de98afeb5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e5b0ed0c2085cca93a61e24c4425d32de98afeb5
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/20250305/51554224/attachment-0001.html>
More information about the ghc-commits
mailing list