Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC

Commits:

25 changed files:

Changes:

  • compiler/GHC/Builtin/primops.txt.pp
    ... ... @@ -3927,6 +3927,16 @@ primop ClearCCSOp "clearCCS#" GenPrimOp
    3927 3927 
        with
    3928 3928 
        out_of_line = True
    3929 3929
    3930 
    +------------------------------------------------------------------------
    3931 
    +section "Annotating call stacks"
    3932 
    +------------------------------------------------------------------------
    3933 
    +
    3934 
    +primop AnnotateStackOp "annotateStack#" GenPrimOp
    3935 
    +   b -> a_reppoly -> a_reppoly
    3936 
    +   { Pushes an annotation frame to the stack which can be reported by backtraces. }
    3937 
    +   with
    3938 
    +   out_of_line = True
    3939 
    +
    3930 3940 
     ------------------------------------------------------------------------
    3931 3941 
     section "Info Table Origin"
    3932 3942 
     ------------------------------------------------------------------------

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -1771,6 +1771,7 @@ emitPrimOp cfg primop =
    1771 1771 
       WhereFromOp   -> alwaysExternal
    1772 1772 
       GetApStackValOp -> alwaysExternal
    1773 1773 
       ClearCCSOp -> alwaysExternal
    1774 
    +  AnnotateStackOp -> alwaysExternal
    1774 1775 
       TraceEventOp -> alwaysExternal
    1775 1776 
       TraceEventBinaryOp -> alwaysExternal
    1776 1777 
       TraceMarkerOp -> alwaysExternal

  • libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
    ... ... @@ -84,6 +84,7 @@ data ClosureType
    84 84 
         | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
    85 85 
         | COMPACT_NFDATA
    86 86 
         | CONTINUATION
    87 
    +    | ANN_FRAME
    87 88 
         | N_CLOSURE_TYPES
    88 89 
      deriving (Enum, Eq, Ord, Show, Generic)
    89 90 
     #endif

  • libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
    ... ... @@ -574,11 +574,15 @@ data GenStackFrame b =
    574 574 
           , retFunPayload       :: ![GenStackField b]
    575 575 
           }
    576 576
    577 
    -  |  RetBCO
    577 
    +  | RetBCO
    578 578 
           { info_tbl            :: !StgInfoTable
    579 579 
           , bco                 :: !b -- ^ always a BCOClosure
    580 580 
           , bcoArgs             :: ![GenStackField b]
    581 581 
           }
    582 
    +  | AnnFrame
    583 
    +      { info_tbl            :: !StgInfoTable
    584 
    +      , annotation          :: !b
    585 
    +      }
    582 586 
       deriving (Foldable, Functor, Generic, Show, Traversable)
    583 587
    584 588 
     data PrimType

  • libraries/ghc-heap/GHC/Exts/Stack.hs
    1 1 
     {-# LANGUAGE CPP #-}
    2 
    -#if MIN_TOOL_VERSION_ghc(9,9,0)
    2 
    +#if MIN_TOOL_VERSION_ghc(9,13,0)
    3 3 
     {-# LANGUAGE RecordWildCards #-}
    4 4
    5 5 
     module GHC.Exts.Stack
    ... ... @@ -30,6 +30,7 @@ stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload
    30 30 
     stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs
    31 31 
     -- The one additional word is a pointer to the next stack chunk
    32 32 
     stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1
    33 
    +stackFrameSize (AnnFrame {}) = sizeStgAnnFrame
    33 34 
     stackFrameSize _ = error "Unexpected stack frame type"
    34 35
    35 36 
     #else

  • libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
    ... ... @@ -3,7 +3,7 @@
    3 3 
     {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    4 4 
     module GHC.Exts.Stack.Constants where
    5 5
    6 
    -#if MIN_TOOL_VERSION_ghc(9,9,0)
    6 
    +#if MIN_TOOL_VERSION_ghc(9,13,0)
    7 7
    8 8 
     import           Prelude
    9 9
    ... ... @@ -88,6 +88,13 @@ offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_pa
    88 88 
     sizeStgRetFunFrame :: Int
    89 89 
     sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
    90 90
    91 
    +sizeStgAnnFrame :: Int
    92 
    +sizeStgAnnFrame = bytesToWords (#const SIZEOF_StgAnnFrame)
    93 
    +
    94 
    +offsetStgAnnFrameAnn :: WordOffset
    95 
    +offsetStgAnnFrameAnn = byteOffsetToWordOffset $
    96 
    +  (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
    97 
    +
    91 98 
     offsetStgBCOFrameInstrs :: ByteOffset
    92 99 
     offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
    93 100

  • libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
    1 1 
     {-# LANGUAGE CPP #-}
    2 
    -#if MIN_TOOL_VERSION_ghc(9,9,0)
    2 
    +#if MIN_TOOL_VERSION_ghc(9,13,0)
    3 3 
     {-# LANGUAGE BangPatterns #-}
    4 4 
     {-# LANGUAGE DuplicateRecordFields #-}
    5 5 
     {-# LANGUAGE FlexibleInstances #-}
    ... ... @@ -377,6 +377,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
    377 377 
                       catchFrameCode = catchFrameCode',
    378 378 
                       handler = handler'
    379 379 
                     }
    380 
    +        ANN_FRAME ->
    381 
    +          let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
    382 
    +           in
    383 
    +             pure $
    384 
    +               AnnFrame
    385 
    +                { info_tbl = info,
    386 
    +                  annotation = annotation
    387 
    +                }
    380 388 
             x -> error $ "Unexpected closure type on stack: " ++ show x
    381 389
    382 390 
     -- | Unbox 'Int#' from 'Int'

  • libraries/ghc-heap/tests/all.T
    ... ... @@ -103,3 +103,5 @@ test('stack_misc_closures',
    103 103 
              ]
    104 104 
           , '-debug' # Debug RTS to use checkSTACK() (Sanity.c)
    105 105 
           ])
    106 
    +
    107 
    +test('ann_frame', normal, compile_and_run, [''])

  • libraries/ghc-heap/tests/ann_frame.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE GADTs #-}
    3 
    +
    4 
    +import Data.Typeable
    5 
    +import GHC.Exts
    6 
    +import GHC.Exts.Heap.Closures as Closures
    7 
    +import GHC.Exts.Stack.Decode
    8 
    +import GHC.Stack.CloneStack
    9 
    +import System.IO.Unsafe
    10 
    +import Unsafe.Coerce
    11 
    +
    12 
    +data StackAnnotation where
    13 
    +  StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation
    14 
    +
    15 
    +annotateStack
    16 
    +  :: forall a r b.
    17 
    +     (Typeable a, Show a)
    18 
    +  => a -> b -> b
    19 
    +annotateStack ann =
    20 
    +  annotateStack# (StackAnnotation ann)
    21 
    +
    22 
    +hello :: Int -> Int -> Int
    23 
    +hello x y = annotateStack (x,y) $ unsafePerformIO $ do
    24 
    +  stack <- GHC.Stack.CloneStack.cloneMyStack
    25 
    +  decoded <- GHC.Exts.Stack.Decode.decodeStack stack
    26 
    +  print [ show x
    27 
    +        | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded
    28 
    +        , StackAnnotation x <- pure $ unsafeCoerce ann
    29 
    +        ]
    30 
    +  return $ x + y + 42
    31 
    +{-# OPAQUE hello #-}
    32 
    +
    33 
    +main :: IO ()
    34 
    +main =
    35 
    +  print $ hello 2 3
    36 
    +

  • libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
    ... ... @@ -83,5 +83,6 @@ data ClosureType
    83 83 
         | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
    84 84 
         | COMPACT_NFDATA
    85 85 
         | CONTINUATION
    86 
    +    | ANN_FRAME
    86 87 
         | N_CLOSURE_TYPES
    87 88 
         deriving (Enum, Eq, Ord, Show, Generic)

  • rts/ClosureFlags.c
    ... ... @@ -88,8 +88,9 @@ const StgWord16 closure_flags[] = {
    88 88 
      [SMALL_MUT_ARR_PTRS_FROZEN_CLEAN] =  (_HNF|     _NS|          _UPT     ),
    89 89 
      [COMPACT_NFDATA]       =  (_HNF|     _NS                               ),
    90 90 
      [CONTINUATION]         =  (_HNF|     _NS|         _UPT                 ),
    91 
    + [ANN_FRAME]            =  (     _BTM|                             _FRM ),
    91 92 
     };
    92 93
    93 
    -#if N_CLOSURE_TYPES != 65
    94 
    +#if N_CLOSURE_TYPES != 66
    94 95 
     #error Closure types changed: update ClosureFlags.c!
    95 96 
     #endif

  • rts/LdvProfile.c
    ... ... @@ -154,6 +154,7 @@ processHeapClosureForDead( const StgClosure *c )
    154 154 
         case CATCH_STM_FRAME:
    155 155 
         case CATCH_RETRY_FRAME:
    156 156 
         case ATOMICALLY_FRAME:
    157 
    +    case ANN_FRAME:
    157 158 
             // others
    158 159 
         case INVALID_OBJECT:
    159 160 
         case COMPACT_NFDATA:

  • rts/PrimOps.cmm
    ... ... @@ -2800,6 +2800,28 @@ stg_clearCCSzh (P_ arg)
    2800 2800 
         jump stg_ap_v_fast(arg);
    2801 2801 
     }
    2802 2802
    2803 
    +#define ANN_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,ann) \
    2804 
    +  w_ info_ptr,                                     \
    2805 
    +  PROF_HDR_FIELDS(w_,p1,p2)                        \
    2806 
    +  p_ ann
    2807 
    +
    2808 
    +INFO_TABLE_RET (stg_ann_frame, ANN_FRAME,
    2809 
    +                ANN_FRAME_FIELDS(W_,P_, info_ptr, p1, p2, ann))
    2810 
    +    /* no args => explicit stack */
    2811 
    +{
    2812 
    +    unwind Sp = W_[Sp + SIZEOF_StgAnnFrame];
    2813 
    +    Sp = Sp + SIZEOF_StgAnnFrame;
    2814 
    +    jump %ENTRY_CODE(Sp(0)) GP_ARG_REGS; // NB. all GP arg regs live!
    2815 
    +}
    2816 
    +
    2817 
    +stg_annotateStackzh (P_ ann, P_ cont)
    2818 
    +{
    2819 
    +    STK_CHK_GEN();
    2820 
    +    jump stg_ap_0_fast
    2821 
    +        (ANN_FRAME_FIELDS(,,stg_ann_frame_info, CCCS, 0, ann))(cont);
    2822 
    +
    2823 
    +}
    2824 
    +
    2803 2825 
     stg_numSparkszh ()
    2804 2826 
     {
    2805 2827 
         W_ n;

  • rts/Printer.c
    ... ... @@ -270,6 +270,17 @@ printClosure( const StgClosure *obj )
    270 270 
         case RET_FUN:
    271 271 
         */
    272 272
    273 
    +    case ANN_FRAME:
    274 
    +        {
    275 
    +            StgAnnFrame* frame = (StgAnnFrame*)obj;
    276 
    +            debugBelch("ANN_FRAME(");
    277 
    +            printPtr((StgPtr)GET_INFO((StgClosure *)frame));
    278 
    +            debugBelch(",");
    279 
    +            printPtr((StgPtr)frame->ann);
    280 
    +            debugBelch(")\n");
    281 
    +            break;
    282 
    +        }
    283 
    +
    273 284 
         case UPDATE_FRAME:
    274 285 
             {
    275 286 
                 StgUpdateFrame* frame = (StgUpdateFrame*)obj;
    ... ... @@ -1123,6 +1134,7 @@ const char *closure_type_names[] = {
    1123 1134 
      [RET_FUN]               = "RET_FUN",
    1124 1135 
      [UPDATE_FRAME]          = "UPDATE_FRAME",
    1125 1136 
      [CATCH_FRAME]           = "CATCH_FRAME",
    1137 
    + [ANN_FRAME]             = "ANN_FRAME",
    1126 1138 
      [UNDERFLOW_FRAME]       = "UNDERFLOW_FRAME",
    1127 1139 
      [STOP_FRAME]            = "STOP_FRAME",
    1128 1140 
      [BLOCKING_QUEUE]        = "BLOCKING_QUEUE",
    ... ... @@ -1155,7 +1167,7 @@ const char *closure_type_names[] = {
    1155 1167 
      [CONTINUATION]          = "CONTINUATION",
    1156 1168 
     };
    1157 1169
    1158 
    -#if N_CLOSURE_TYPES != 65
    1170 
    +#if N_CLOSURE_TYPES != 66
    1159 1171 
     #error Closure types changed: update Printer.c!
    1160 1172 
     #endif
    1161 1173

  • rts/RetainerProfile.c
    ... ... @@ -217,6 +217,7 @@ isRetainer( const StgClosure *c )
    217 217 
         case RET_SMALL:
    218 218 
         case RET_BIG:
    219 219 
         case RET_FUN:
    220 
    +    case ANN_FRAME:
    220 221 
             // other cases
    221 222 
         case IND:
    222 223 
         case INVALID_OBJECT:

  • rts/TraverseHeap.c
    ... ... @@ -529,6 +529,7 @@ traverseGetChildren(StgClosure *c, StgClosure **first_child, bool *other_childre
    529 529 
         case RET_BCO:
    530 530 
         case RET_SMALL:
    531 531 
         case RET_BIG:
    532 
    +    case ANN_FRAME:
    532 533 
             // invalid objects
    533 534 
         case IND:
    534 535 
         case INVALID_OBJECT:
    ... ... @@ -832,6 +833,7 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data,
    832 833 
             case RET_BCO:
    833 834 
             case RET_SMALL:
    834 835 
             case RET_BIG:
    836 
    +        case ANN_FRAME:
    835 837 
                 // invalid objects
    836 838 
             case IND:
    837 839 
             case INVALID_OBJECT:
    ... ... @@ -965,6 +967,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackElement *sep,
    965 967 
             case CATCH_RETRY_FRAME:
    966 968 
             case ATOMICALLY_FRAME:
    967 969 
             case RET_SMALL:
    970 
    +        case ANN_FRAME:
    968 971 
                 bitmap = BITMAP_BITS(info->i.layout.bitmap);
    969 972 
                 size   = BITMAP_SIZE(info->i.layout.bitmap);
    970 973 
                 p++;

  • rts/include/rts/storage/ClosureTypes.h
    ... ... @@ -89,4 +89,5 @@
    89 89 
     #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62
    90 90 
     #define COMPACT_NFDATA                63
    91 91 
     #define CONTINUATION                  64
    92 
    -#define N_CLOSURE_TYPES               65
    92 
    +#define ANN_FRAME                     65
    93 
    +#define N_CLOSURE_TYPES               66

  • rts/include/rts/storage/Closures.h
    ... ... @@ -312,6 +312,15 @@ typedef struct {
    312 312 
         StgClosure *result;
    313 313 
     } StgDeadThreadFrame;
    314 314
    315 
    +// Stack frame annotating an execution context with a Haskell value
    316 
    +// for backtrace purposes.
    317 
    +//
    318 
    +// Closure types: ANN_FRAME
    319 
    +typedef struct {
    320 
    +    StgHeader header;
    321 
    +    StgClosure *ann;
    322 
    +} StgAnnFrame;
    323 
    +
    315 324 
     // A function return stack frame: used when saving the state for a
    316 325 
     // garbage collection at a function entry point.  The function
    317 326 
     // arguments are on the stack, and we also save the function (its

  • rts/js/profiling.js
    ... ... @@ -333,3 +333,8 @@ function h$buildCCSPtr(o) {
    333 333 
     function h$clearCCS(a) {
    334 334 
       throw new Error("ClearCCSOp not implemented");
    335 335 
     }
    336 
    +
    337 
    +// we throw away the annotation here.
    338 
    +function h$annotateStack(o) {
    339 
    +    return o;
    340 
    +}

  • rts/sm/Compact.c
    ... ... @@ -351,6 +351,7 @@ thread_stack(P_ p, P_ stack_end)
    351 351 
             case STOP_FRAME:
    352 352 
             case CATCH_FRAME:
    353 353 
             case RET_SMALL:
    354 
    +        case ANN_FRAME:
    354 355 
             {
    355 356 
                 W_ bitmap = BITMAP_BITS(info->i.layout.bitmap);
    356 357 
                 W_ size   = BITMAP_SIZE(info->i.layout.bitmap);

  • rts/sm/Evac.c
    ... ... @@ -996,6 +996,7 @@ loop:
    996 996 
       case CATCH_STM_FRAME:
    997 997 
       case CATCH_RETRY_FRAME:
    998 998 
       case ATOMICALLY_FRAME:
    999 
    +  case ANN_FRAME:
    999 1000 
         // shouldn't see these
    1000 1001 
         barf("evacuate: stack frame at %p\n", q);
    1001 1002

  • rts/sm/NonMovingMark.c
    ... ... @@ -1180,6 +1180,7 @@ trace_stack_ (MarkQueue *queue, StgPtr sp, StgPtr spBottom)
    1180 1180 
             case STOP_FRAME:
    1181 1181 
             case CATCH_FRAME:
    1182 1182 
             case RET_SMALL:
    1183 
    +        case ANN_FRAME:
    1183 1184 
             {
    1184 1185 
                 StgWord bitmap = BITMAP_BITS(info->i.layout.bitmap);
    1185 1186 
                 StgWord size   = BITMAP_SIZE(info->i.layout.bitmap);

  • rts/sm/Sanity.c
    ... ... @@ -128,6 +128,7 @@ checkStackFrame( StgPtr c )
    128 128 
         case UNDERFLOW_FRAME:
    129 129 
         case STOP_FRAME:
    130 130 
         case RET_SMALL:
    131 
    +    case ANN_FRAME:
    131 132 
             size = BITMAP_SIZE(info->i.layout.bitmap);
    132 133 
             checkSmallBitmap((StgPtr)c + 1,
    133 134 
                              BITMAP_BITS(info->i.layout.bitmap), size);

  • rts/sm/Scav.c
    ... ... @@ -1983,6 +1983,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
    1983 1983 
         case STOP_FRAME:
    1984 1984 
         case CATCH_FRAME:
    1985 1985 
         case RET_SMALL:
    1986 
    +    case ANN_FRAME:
    1986 1987 
             bitmap = BITMAP_BITS(info->i.layout.bitmap);
    1987 1988 
             size   = BITMAP_SIZE(info->i.layout.bitmap);
    1988 1989 
             // NOTE: the payload starts immediately after the info-ptr, we

  • utils/deriveConstants/Main.hs
    ... ... @@ -443,6 +443,8 @@ wanteds os = concat
    443 443 
               ,closureSize  C    "StgStopFrame"
    444 444 
               ,closureSize  C    "StgDeadThreadFrame"
    445 445 
               ,closureField C    "StgDeadThreadFrame" "result"
    446 
    +          ,structSize   C    "StgAnnFrame"
    447 
    +          ,closureField C    "StgAnnFrame" "ann"
    446 448
    447 449 
               ,closureSize  Both "StgMutArrPtrs"
    448 450 
               ,closureField Both "StgMutArrPtrs" "ptrs"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help