[Git][ghc/ghc][wip/orig-thunk-info] compiler: Record original thunk info tables on stack

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Mon Jul 10 18:34:43 UTC 2023



Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC


Commits:
d1c258db by Ben Gamari at 2023-07-10T14:34:34-04:00
compiler: Record original thunk info tables on stack

Here we introduce a new code generation option, `-forig-thunk-info`,
which ensures that an `stg_orig_thunk_info` frame is pushed before every
update frame. This can be invaluable when debugging thunk cycles and
similar.

See Note [Original thunk info table frames] for details.

Closes #23255.

- - - - -


15 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Config.hs
- docs/users_guide/debugging.rst
- rts/RtsSymbols.c
- rts/StgMiscClosures.cmm
- rts/include/rts/storage/Closures.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/codeGen/should_run/OrigThunkInfo.hs
- + testsuite/tests/codeGen/should_run/OrigThunkInfo.stdout
- testsuite/tests/codeGen/should_run/all.T
- utils/deriveConstants/Main.hs


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -53,6 +53,7 @@ module GHC.Cmm.CLabel (
         mkDirty_MUT_VAR_Label,
         mkMUT_VAR_CLEAN_infoLabel,
         mkNonmovingWriteBarrierEnabledLabel,
+        mkOrigThunkInfoLabel,
         mkUpdInfoLabel,
         mkBHUpdInfoLabel,
         mkIndStaticInfoLabel,
@@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label,
     mkNonmovingWriteBarrierEnabledLabel,
-    mkUpdInfoLabel,
+    mkOrigThunkInfoLabel, mkUpdInfoLabel,
     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
     mkMAP_DIRTY_infoLabel,
@@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label,
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkOrigThunkInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" )     CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC")        CmmInfo


=====================================
compiler/GHC/Driver/Config/StgToCmm.hs
=====================================
@@ -41,6 +41,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
   , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags
   , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags
   , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags
+  , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo         dflags
   , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags
   , stgToCmmOmitYields    = gopt Opt_OmitYields            dflags
   , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas  dflags


=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -338,6 +338,7 @@ data GeneralFlag
    | Opt_IgnoreHpcChanges
    | Opt_ExcessPrecision
    | Opt_EagerBlackHoling
+   | Opt_OrigThunkInfo
    | Opt_NoHsMain
    | Opt_SplitSections
    | Opt_StgStats
@@ -576,6 +577,7 @@ codeGenFlags = EnumSet.fromList
      -- Flags that affect debugging information
    , Opt_DistinctConstructorTables
    , Opt_InfoTableMap
+   , Opt_OrigThunkInfo
    ]
 
 data WarningFlag =


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2347,6 +2347,7 @@ fFlagsDeps = [
   flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,
   flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,
   flagSpec "eager-blackholing"                Opt_EagerBlackHoling,
+  flagSpec "orig-thunk-info"                  Opt_OrigThunkInfo,
   flagSpec "embed-manifest"                   Opt_EmbedManifest,
   flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,
   flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,


=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -730,7 +730,8 @@ setupUpdate closure_info node body
               lbl | bh        = mkBHUpdInfoLabel
                   | otherwise = mkUpdInfoLabel
 
-          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
+          pushOrigThunkInfoFrame closure_info
+            $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
 
   | otherwise   -- A static closure
   = do  { tickyUpdateBhCaf closure_info
@@ -738,7 +739,8 @@ setupUpdate closure_info node body
         ; if closureUpdReqd closure_info
           then do       -- Blackhole the (updatable) CAF:
                 { upd_closure <- link_caf node
-                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
+                ; pushOrigThunkInfoFrame closure_info
+                    $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
           else do {tickyUpdateFrameOmitted; body}
     }
 
@@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body
   = do
        updfr  <- getUpdFrameOff
        profile <- getProfile
-       let
-           hdr         = fixedHdrSize profile
+       let hdr         = fixedHdrSize profile
            frame       = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
        --
        emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
@@ -773,6 +774,47 @@ emitUpdateFrame frame lbl updatee = do
   emitStore (cmmOffset platform frame off_updatee) updatee
   initUpdFrameProf frame
 
+-----------------------------------------------------------------------------
+-- Original thunk info table frames
+--
+-- Note [Original thunk info table frames]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very
+-- useful to know which thunks the program is in the process of evaluating.
+-- However, in the case of updateable thunks this can be very difficult
+-- to determine since the process of blackholing overwrites the thunk's
+-- info table pointer.
+--
+-- To help in such situations we provide the -forig-thunk-info flag. This enables
+-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to
+-- accompany each update frame. As the name suggests, this frame captures the
+-- the original info table of the thunk being updated. The entry code for these
+-- frames has no operational effects; the frames merely exist as breadcrumbs
+-- for debugging.
+
+pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
+pushOrigThunkInfoFrame closure_info body = do
+  cfg <- getStgToCmmConfig
+  if stgToCmmOrigThunkInfo cfg
+     then do_it
+     else body
+  where
+    orig_itbl = mkLblExpr (closureInfoLabel closure_info)
+    do_it = do
+      updfr <- getUpdFrameOff
+      profile <- getProfile
+      let platform = profilePlatform profile
+          hdr = fixedHdrSize profile
+          orig_info_frame_sz =
+              hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile)
+          off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile)
+          frame_off = updfr + orig_info_frame_sz
+          frame = CmmStackSlot Old frame_off
+      --
+      emitStore frame (mkLblExpr mkOrigThunkInfoLabel)
+      emitStore (cmmOffset platform frame off_orig_info) orig_itbl
+      withUpdFrameOff frame_off body
+
 -----------------------------------------------------------------------------
 -- Entering a CAF
 --


=====================================
compiler/GHC/StgToCmm/Config.hs
=====================================
@@ -50,6 +50,7 @@ data StgToCmmConfig = StgToCmmConfig
   , stgToCmmFastPAPCalls   :: !Bool              -- ^
   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled
   , stgToCmmEagerBlackHole :: !Bool              -- ^
+  , stgToCmmOrigThunkInfo  :: !Bool              -- ^ Push @stg_orig_thunk_info@ frames during thunk update.
   , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See note [Mapping
                                                  -- Info Tables to Source Positions]
   , stgToCmmOmitYields     :: !Bool              -- ^ true means omit heap checks when no allocation is performed


=====================================
docs/users_guide/debugging.rst
=====================================
@@ -1115,6 +1115,18 @@ Checking for consistency
     cases. This is helpful when debugging demand analysis or type checker bugs
     which can sometimes manifest as segmentation faults.
 
+.. ghc-flag:: -forig-thunk-info
+    :shortdesc: Generate ``stg_orig_thunk_info`` stack frames on thunk entry
+    :type: dynamic
+
+    When debugging cyclic thunks it can be helpful to know the original
+    info table of a thunk being evaluated. This flag enables code generation logic
+    to facilitate this, producing a ``stg_orig_thunk_info`` stack frame alongside
+    the usual update frame; such ``orig_thunk`` frames have no operational
+    effect but capture the original info table of the updated thunk for inspection
+    by debugging tools. See ``Note [Original thunk info table frames]`` in
+    ``GHC.StgToCmm.Bind`` for details.
+
 .. ghc-flag:: -fcheck-prim-bounds
     :shortdesc: Instrument array primops with bounds checks.
     :type: dynamic


=====================================
rts/RtsSymbols.c
=====================================
@@ -870,7 +870,8 @@ extern char **environ;
       SymI_HasDataProto(stg_unpack_cstring_utf8_info)                       \
       SymI_HasDataProto(stg_upd_frame_info)                                 \
       SymI_HasDataProto(stg_bh_upd_frame_info)                              \
-      SymI_HasProto(suspendThread)                                      \
+      SymI_HasDataProto(stg_orig_thunk_info_frame_info)                     \
+      SymI_HasProto(suspendThread)                                          \
       SymI_HasDataProto(stg_takeMVarzh)                                     \
       SymI_HasDataProto(stg_readMVarzh)                                     \
       SymI_HasDataProto(stg_threadStatuszh)                                 \
@@ -878,7 +879,7 @@ extern char **environ;
       SymI_HasDataProto(stg_tryTakeMVarzh)                                  \
       SymI_HasDataProto(stg_tryReadMVarzh)                                  \
       SymI_HasDataProto(stg_unmaskAsyncExceptionszh)                        \
-      SymI_HasProto(unloadObj)                                          \
+      SymI_HasProto(unloadObj)                                              \
       SymI_HasDataProto(stg_unsafeThawArrayzh)                              \
       SymI_HasDataProto(stg_waitReadzh)                                     \
       SymI_HasDataProto(stg_waitWritezh)                                    \
@@ -892,7 +893,7 @@ extern char **environ;
       SymI_NeedsProto(stg_interp_constr5_entry)                         \
       SymI_NeedsProto(stg_interp_constr6_entry)                         \
       SymI_NeedsProto(stg_interp_constr7_entry)                         \
-      SymI_HasDataProto(stg_arg_bitmaps)                                    \
+      SymI_HasDataProto(stg_arg_bitmaps)                                \
       SymI_HasProto(large_alloc_lim)                                    \
       SymI_HasProto(g0)                                                 \
       SymI_HasProto(allocate)                                           \


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -45,6 +45,17 @@ import CLOSURE stg_ret_t_info;
 import CLOSURE stg_ret_v_info;
 #endif
 
+/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */
+INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
+                W_ info_ptr,
+                W_ thunk_info_ptr)
+    /* no args => explicit stack */
+{
+    unwind Sp = W_[Sp + WDS(2)];
+    Sp_adj(2);
+    jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live!
+}
+
 /* ----------------------------------------------------------------------------
    Stack underflow
    ------------------------------------------------------------------------- */


=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -261,6 +261,13 @@ typedef struct _StgUpdateFrame {
     StgClosure *updatee;
 } StgUpdateFrame;
 
+// Thunk update frame
+//
+// Closure types: RET_SMALL
+typedef struct _StgOrigThunkInfoFrame {
+    StgHeader  header;
+    StgInfoTable *info_ptr;
+} StgOrigThunkInfoFrame;
 
 // Closure types: RET_SMALL
 typedef struct {


=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -52,6 +52,7 @@ RTS_RET(stg_upd_frame);
 RTS_RET(stg_bh_upd_frame);
 RTS_RET(stg_marked_upd_frame);
 RTS_RET(stg_noupd_frame);
+RTS_RET(stg_orig_thunk_info_frame);
 RTS_RET(stg_catch_frame);
 RTS_RET(stg_catch_retry_frame);
 RTS_RET(stg_atomically_frame);


=====================================
testsuite/tests/codeGen/should_run/OrigThunkInfo.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+xs = iterate (+1) 0
+ten = xs !! 10
+main = print ten


=====================================
testsuite/tests/codeGen/should_run/OrigThunkInfo.stdout
=====================================
@@ -0,0 +1,2 @@
+10
+


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -225,3 +225,4 @@ test('T22296',[only_ways(llvm_ways)
               ,unless(arch('x86_64'), skip)],compile_and_run,[''])
 test('T22798', normal, compile_and_run, ['-fregs-graph'])
 test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds'])
+test('OrigThunkInfo', normal, compile_and_run, ['-forig-thunk-info'])


=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -437,6 +437,7 @@ wanteds os = concat
           ,structField  Both "StgEntCounter" "entry_count"
 
           ,closureSize  Both "StgUpdateFrame"
+          ,closureSize  Both "StgOrigThunkInfoFrame"
           ,closureSize  C    "StgCatchFrame"
           ,closureSize  C    "StgStopFrame"
           ,closureSize  C    "StgDeadThreadFrame"
@@ -479,6 +480,7 @@ wanteds os = concat
           ,structSize C "StgTSOProfInfo"
 
           ,closureField Both "StgUpdateFrame" "updatee"
+          ,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
 
           ,closureField C "StgCatchFrame" "handler"
           ,closureField C "StgCatchFrame" "exceptions_blocked"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1c258db65eb752a6981750a59f33a3410389356

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1c258db65eb752a6981750a59f33a3410389356
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/20230710/55fc48e1/attachment-0001.html>


More information about the ghc-commits mailing list