And now for something completely different...wip/keepAlive

6 files changed, 39 insertions, 7 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c6969be7ca..4f28818291 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/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
diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs
index e0466a1cf2..b5699a7149 100644
--- a/compiler/GHC/Settings.hs
+++ b/compiler/GHC/Settings.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 
+
 -- | Run-time settings
 module GHC.Settings
   ( Settings (..)
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 680645d8d6..338c401d0f 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/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.
 --
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
index 3196efd3de..60c47838c8 100644
--- a/includes/rts/storage/Closures.h
+++ b/includes/rts/storage/Closures.h
@@ -195,6 +195,11 @@ typedef struct {
 } StgCatchFrame;
 
 typedef struct {
+    StgHeader  header;
+    StgClosure *closure;
+} StgKeepAliveFrame;
+
+typedef struct {
     const StgInfoTable* info;
     struct StgStack_ *next_chunk;
 } StgUnderflowFrame;
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 5af3a06b89..0b54ffe6ab 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -69,6 +69,17 @@ INFO_TABLE_RET (stg_restore_cccs_eval, RET_SMALL, W_ info_ptr, W_ cccs)
 }
 
 /* ----------------------------------------------------------------------------
+   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.
    ------------------------------------------------------------------------- */
 
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 1867d824b6..142805bcc5 100644
--- a/utils/deriveConstants/Main.hs
+++ b/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"