Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 1dd1bff4 by Ben Gamari at 2025-05-14T17:19:40+02: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 ===================================== @@ -1771,6 +1771,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 ===================================== @@ -2800,6 +2800,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/1dd1bff4867f2ca3c7863d4d5aa7bdad... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd1bff4867f2ca3c7863d4d5aa7bdad... You're receiving this email because of your account on gitlab.haskell.org.