[Git][ghc/ghc][wip/keepAlive] And now for something completely different...

[Ben Gamari]

Ben Gamari pushed to branch wip/keepAlive at Glasgow Haskell Compiler / GHC


Commits:
2590af96 by Ben Gamari at 2020-05-24T19:50:50-04:00
And now for something completely different...

- - - - -


6 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Settings.hs
- compiler/GHC/StgToCmm/Prim.hs
- includes/rts/storage/Closures.h
- rts/StgMiscClosures.cmm
- utils/deriveConstants/Main.hs


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -43,6 +43,7 @@ module GHC.Cmm.CLabel (
 
         mkDirty_MUT_VAR_Label,
         mkNonmovingWriteBarrierEnabledLabel,
+        mkKeepAliveInfoLabel,
         mkUpdInfoLabel,
         mkBHUpdInfoLabel,
         mkIndStaticInfoLabel,
@@ -500,6 +501,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label,
     mkNonmovingWriteBarrierEnabledLabel,
+    mkKeepAliveInfoLabel,
     mkUpdInfoLabel,
     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
@@ -512,6 +514,7 @@ mkDirty_MUT_VAR_Label,
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkKeepAliveInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_keepAlive_frame")   CmmInfo
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo


=====================================
compiler/GHC/Settings.hs
=====================================
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 
+
 -- | Run-time settings
 module GHC.Settings
   ( Settings (..)


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -39,7 +39,6 @@ import GHC.StgToCmm.Prof ( costCentreFrom )
 import GHC.Driver.Session
 import GHC.Platform
 import GHC.Types.Basic
-import GHC.Types.Id.Make ( realWorldPrimId )
 import GHC.Cmm.BlockId
 import GHC.Cmm.Graph
 import GHC.Stg.Syntax
@@ -86,12 +85,8 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty
 
 cgOpApp (StgPrimOp KeepAliveOp) args _res_ty
   | [x, s, StgVarArg k] <- args = do
-      { emitComment $ fsLit "keepAlive#"
-      ; r <- cgExpr (StgApp k [s])
-      ; cmm_args <- getNonVoidArgAmodes [x, StgVarArg realWorldPrimId]
-      ; emitPrimCall [] MO_Touch cmm_args
-      ; return r
-      }
+    x' <- getNonVoidArgAmodes [x]
+    emitKeepAliveFrame (case x' of [y] -> y) $ cgExpr (StgApp k [s])
   | otherwise = pprPanic "ill-formed keepAlive#" (ppr args)
 
 cgOpApp (StgPrimOp primop) args res_ty = do
@@ -131,6 +126,20 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty
         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
         ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
+emitKeepAliveFrame :: CmmExpr -> FCode a -> FCode a
+emitKeepAliveFrame x body
+  = do
+        updfr <- getUpdFrameOff
+        dflags <- getDynFlags
+        let hdr = fixedHdrSize dflags
+            off_frame = updfr + hdr + sIZEOF_StgKeepAliveFrame_NoHdr dflags
+            frame = CmmStackSlot Old off_frame
+            off_closure = hdr + oFFSET_StgKeepAliveFrame_closure dflags
+
+        emitStore frame (mkLblExpr mkKeepAliveInfoLabel)
+        emitStore (cmmOffset (targetPlatform dflags) frame off_closure) x
+        withUpdFrameOff off_frame body
+
 -- | Interpret the argument as an unsigned value, assuming the value
 -- is given in two-complement form in the given width.
 --


=====================================
includes/rts/storage/Closures.h
=====================================
@@ -194,6 +194,11 @@ typedef struct {
     StgClosure *handler;
 } StgCatchFrame;
 
+typedef struct {
+    StgHeader  header;
+    StgClosure *closure;
+} StgKeepAliveFrame;
+
 typedef struct {
     const StgInfoTable* info;
     struct StgStack_ *next_chunk;


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -68,6 +68,17 @@ INFO_TABLE_RET (stg_restore_cccs_eval, RET_SMALL, W_ info_ptr, W_ cccs)
     jump stg_ap_0_fast(ret);
 }
 
+/* ----------------------------------------------------------------------------
+   keepAlive#
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_RET(stg_keepAlive_frame, RET_SMALL, W_ info_ptr)
+    /* explicit stack */
+{
+    Sp_adj(1);
+    jump %ENTRY_CODE(Sp(0)) [*]; // N.B. all registers live
+}
+
 /* ----------------------------------------------------------------------------
    Support for the bytecode interpreter.
    ------------------------------------------------------------------------- */


=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -466,6 +466,9 @@ wanteds os = concat
 
           ,closureField C "StgCatchFrame" "handler"
           ,closureField C "StgCatchFrame" "exceptions_blocked"
+          
+          ,closureSize  Both "StgKeepAliveFrame"
+          ,closureField Both "StgKeepAliveFrame" "closure"
 
           ,closureSize       C "StgPAP"
           ,closureField      C "StgPAP" "n_args"



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2590af96c9dd1bd12ed939bceefaf643b7cf1534
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/20200524/eeee6023/attachment-0001.html>