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

[Ben Gamari (@bgamari)]

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


Commits:
11da4583 by Ben Gamari at 2023-04-12T12:04:00-04:00
compiler: Record original thunk info tables on stack

- - - - -


5 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/StgToCmm/Bind.hs
- rts/StgMiscClosures.cmm
- rts/include/rts/storage/Closures.h
- 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/StgToCmm/Bind.hs
=====================================
@@ -754,12 +754,31 @@ pushUpdateFrame lbl updatee body
   = do
        updfr  <- getUpdFrameOff
        profile <- getProfile
-       let
+       let push_orig_thunk_info = True
            hdr         = fixedHdrSize profile
-           frame       = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
+           orig_info_frame_sz
+             | push_orig_thunk_info
+                              = hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile)
+             | otherwise      = 0
+           frame1      = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
+           frame2      = frame1 + orig_info_frame_sz
        --
-       emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
-       withUpdFrameOff frame body
+       emitUpdateFrame (CmmStackSlot Old frame1) lbl updatee
+       when push_orig_thunk_info $ emitOrigThunkInfoFrame (CmmStackSlot Old frame2) updatee
+       withUpdFrameOff frame2 body
+
+emitOrigThunkInfoFrame :: CmmExpr -> CmmExpr -> FCode ()
+emitOrigThunkInfoFrame frame updatee = do
+  profile <- getProfile
+  cfg <- getStgToCmmConfig
+  let platform      = profilePlatform profile
+      hdr           = fixedHdrSize profile
+      off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_orig_info (profileConstants profile)
+      align_check   = stgToCmmAlignCheck cfg
+      info_ptr      = cmmLoadBWord platform (closureInfoPtr platform align_check updatee)
+  emitStore frame (mkLblExpr mkOrigThunkInfoLabel)
+  emitStore (cmmOffset platform frame off_orig_info) info_ptr
+  initUpdFrameProf frame
 
 emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
 emitUpdateFrame frame lbl updatee = do


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -45,6 +45,16 @@ import CLOSURE stg_ret_t_info;
 import CLOSURE stg_ret_v_info;
 #endif
 
+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 {


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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11da4583383c2365c680313eaf055095e188a379
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/20230412/6f463096/attachment-0001.html>