Introduce keepAlive primop

1 files changed, 36 insertions, 1 deletions

diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 3b3921f5e2..01934423ed 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -32,7 +32,10 @@ import GHC.Tc.Utils.Env
 import GHC.Unit
 
 import GHC.Builtin.Names
+import GHC.Builtin.PrimOps
 import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
+import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
 
 import GHC.Core.Utils
 import GHC.Core.Opt.Arity
@@ -47,6 +50,7 @@ import GHC.Core.TyCon
 import GHC.Core.DataCon
 import GHC.Core.Opt.OccurAnal
 
+
 import GHC.Data.Maybe
 import GHC.Data.OrdList
 import GHC.Data.FastString
@@ -64,7 +68,6 @@ import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Types.Id.Make ( realWorldPrimId )
 import GHC.Types.Basic
 import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
 import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
@@ -790,6 +793,38 @@ cpeApp top_env expr
         -- rather than the far superior "f x y".  Test case is par01.
         = let (terminal, args', depth') = collect_args arg
           in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+
+    cpe_app env
+            (Var f)
+            args
+            n
+        | Just KeepAliveOp <- isPrimOpId_maybe f
+        , CpeApp (Type arg_rep)
+          : CpeApp (Type arg_ty)
+          : CpeApp (Type _result_rep)
+          : CpeApp (Type result_ty)
+          : CpeApp arg
+          : CpeApp s0
+          : CpeApp k
+          : rest <- pprTrace "cpe_app keepAlive#" (ppr args) args
+        = do { pprTraceM "cpe_app(keepAlive#)" (ppr n)
+             ; y <- newVar result_ty
+             ; s2 <- newVar realWorldStatePrimTy
+             ; -- beta reduce if possible
+             ; (floats, k') <- case k of
+                  Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)
+                  _          -> cpe_app env k (CpeApp s0 : rest) (n-1)
+             ; let touchId = mkPrimOpId TouchOp
+                   expr = Case k' y result_ty [Alt DEFAULT [] rhs]
+                   rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]
+                         in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)]
+             ; pprTraceM "cpe_app(keepAlive)" (ppr expr)
+             ; (floats', expr') <- cpeBody env expr
+             ; return (floats `appendFloats` floats', expr')
+             }
+        | Just KeepAliveOp <- isPrimOpId_maybe f
+        = panic "invalid keepAlive# application"
+
     cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n
         | f `hasKey` runRWKey
         -- N.B. While it may appear that n == 1 in the case of runRW#