Introduce keepAlive primop

10 files changed, 110 insertions, 18 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 2ba94c1982..454c2e3a9e 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3121,6 +3121,20 @@ primop NumSparks "numSparks#" GenPrimOp
    has_side_effects = True
    out_of_line = True
 
+
+------------------------------------------------------------------------
+section "Controlling object lifetime"
+        {Ensuring that objects don't die a premature death.}
+------------------------------------------------------------------------
+
+-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
+primop KeepAliveOp "keepAlive#" GenPrimOp
+   o -> State# RealWorld -> (State# RealWorld -> p) -> p
+   { TODO. }
+   with
+   strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }
+
+
 ------------------------------------------------------------------------
 section "Tag to enum stuff"
         {Convert back and forth between values of enumerated types
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index a67955ad2b..1e34a5fd62 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -1642,6 +1642,8 @@ app_ok primop_ok fun args
         -> False       --     for the special cases for SeqOp and DataToTagOp
         | DataToTagOp <- op
         -> False
+        | KeepAliveOp <- op
+        -> False
 
         | otherwise
         -> primop_ok op  -- Check the primop itself
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#
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index b08edea624..2ea28a8eb2 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1623,6 +1623,8 @@ emitPrimOp dflags primop = case primop of
   TraceMarkerOp -> alwaysExternal
   SetThreadAllocationCounter -> alwaysExternal
 
+  KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"
+
  where
   profile = targetProfile dflags
   platform = profilePlatform profile
diff --git a/docs/users_guide/9.0.1-notes.rst b/docs/users_guide/9.0.1-notes.rst
index 46c847191a..95e9852e61 100644
--- a/docs/users_guide/9.0.1-notes.rst
+++ b/docs/users_guide/9.0.1-notes.rst
@@ -347,12 +347,29 @@ Haddock
     -- | This comment used to trigger a parse error
     main = putStrLn "Hello"
 
+``base`` library
+~~~~~~~~~~~~~~~~
+
+- ``Foreign.ForeignPtr.withForeignPtr`` is now less aggressively optimised,
+  avoiding the unsoundness issue reported in
+  :ghc-ticket:`17760` in exchange for a small amount of additional allocation.
+
+  If your application is impacted significantly by this change and the
+  continuation given to ``withForeignPtr`` will not *provably* diverge (via
+  throwing of an exception or looping) then the previous optimisation behavior
+  can be recovered by instead using ``GHC.ForeignPtr.unsafeWithForeignPtr``.
+
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
 - Add a known-key ``cstringLength#`` to ``GHC.CString`` that is eligible
   for constant folding by a built-in rule.
 
+- A new primop, ``keepAlive#``, has been introduced to replace ``touch#`` in
+  controlling object lifetime without the soundness issues affecting the latter
+  (see :ghc-ticket:`17760`)
+
 ``ghc`` library
 ~~~~~~~~~~~~~~~
 
diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs
index 6cc55221f4..79d1614529 100644
--- a/libraries/base/GHC/ForeignPtr.hs
+++ b/libraries/base/GHC/ForeignPtr.hs
@@ -533,7 +533,13 @@ withForeignPtr = unsafeWithForeignPtr
 -- throw an exception). In exchange for this loss of generality, this function
 -- offers the ability of GHC to optimise more aggressively.
 --
--- See issue #17760 for the motivation for this function.
+-- Specifically, applications of the form:
+-- @
+-- unsafeWithForeignPtr fptr ('Control.Monad.forever' something)
+-- @
+--
+-- See GHC issue #17760 for more information about the unsoundness behavior
+-- that this function can result in.
 unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
 unsafeWithForeignPtr fo f = do
   r <- f (unsafeForeignPtrToPtr fo)
@@ -543,18 +549,19 @@ unsafeWithForeignPtr fo f = do
 touchForeignPtr :: ForeignPtr a -> IO ()
 -- ^This function ensures that the foreign object in
 -- question is alive at the given place in the sequence of IO
--- actions. In particular 'Foreign.ForeignPtr.withForeignPtr'
--- does a 'touchForeignPtr' after it
--- executes the user action.
---
--- Note that this function should not be used to express dependencies
--- between finalizers on 'ForeignPtr's.  For example, if the finalizer
--- for a 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second
--- 'ForeignPtr' @F2@, then the only guarantee is that the finalizer
--- for @F2@ is never started before the finalizer for @F1@.  They
--- might be started together if for example both @F1@ and @F2@ are
--- otherwise unreachable, and in that case the scheduler might end up
--- running the finalizer for @F2@ first.
+-- actions. However, this comes with a significant caveat: the contract above
+-- does not hold if GHC can demonstrate that the code preceeding
+-- @touchForeignPtr@ diverges (e.g. by looping infinitely or throwing an
+-- exception). For this reason, you are strongly advised to use instead
+-- 'withForeignPtr' where possible.
+--
+-- Also, note that this function should not be used to express dependencies
+-- between finalizers on 'ForeignPtr's.  For example, if the finalizer for a
+-- 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second 'ForeignPtr' @F2@,
+-- then the only guarantee is that the finalizer for @F2@ is never started
+-- before the finalizer for @F1@.  They might be started together if for
+-- example both @F1@ and @F2@ are otherwise unreachable, and in that case the
+-- scheduler might end up running the finalizer for @F2@ first.
 --
 -- In general, it is not recommended to use finalizers on separate
 -- objects with ordering constraints between them.  To express the
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 02202aaa60..02df43857a 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -52,17 +52,28 @@
   * Add `MonadFix` and `MonadZip` instances for `Complex`
 
   * Add `Ix` instances for tuples of size 6 through 15
+   
+  * Correct `Bounded` instance and remove `Enum` and `Integral` instances for
+    `Data.Ord.Down`.
 
   * `catMaybes` is now implemented using `mapMaybe`, so that it is both a "good
     consumer" and "good producer" for list-fusion (#18574)
 
+  * `Foreign.ForeignPtr.withForeignPtr` is now less aggressively optimised,
+    avoiding the soundness issue reported in
+    [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760) in exchange for
+    a small amount more allocation. If your application regresses significantly
+    *and* the continuation given to `withForeignPtr` will *not* provably
+    diverge then the previous optimisation behavior can be recovered by instead
+    using `GHC.ForeignPtr.unsafeWithForeignPtr`.
+
   * Correct `Bounded` instance and remove `Enum` and `Integral` instances for
     `Data.Ord.Down`.
 
   * `Data.Foldable` methods `maximum{,By}`, `minimum{,By}`, `product` and `sum`
     are now stricter by default, as well as in the class implementation for List.
 
-## 4.14.0.0 *TBA*
+## 4.14.0.0 *Jan 2020*
   * Bundled with GHC 8.10.1
 
   * Add a `TestEquality` instance for the `Compose` newtype.
@@ -354,7 +365,7 @@
     in constant space when applied to lists. (#10830)
 
   * `mkFunTy`, `mkAppTy`, and `mkTyConApp` from `Data.Typeable` no longer exist.
-    This functionality is superseded by the interfaces provided by
+    This functionality is superceded by the interfaces provided by
     `Type.Reflection`.
 
   * `mkTyCon3` is no longer exported by `Data.Typeable`. This function is
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index e36ed57f4e..a4465684d6 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -33,6 +33,10 @@
 
         infix 4 ~, ~~
 
+- Introduce `keepAlive#` to replace `touch#` in controlling object lifetime without
+  the soundness issues of the latter (see
+  [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760)).
+
 ## 0.6.1 (edit as necessary)
 
 - Shipped with GHC 8.10.1
diff --git a/testsuite/tests/ghci/should_run/T16012.script b/testsuite/tests/ghci/should_run/T16012.script
index ab8b2d0ee0..2394e9c0ec 100644
--- a/testsuite/tests/ghci/should_run/T16012.script
+++ b/testsuite/tests/ghci/should_run/T16012.script
@@ -3,4 +3,4 @@
 -- should always return a reasonably low result.
 
 n <- System.Mem.getAllocationCounter
-if (n < 0 && n >= -160000) then putStrLn "Alloction counter in expected range" else (putStrLn $ "Unexpected allocation counter result:" ++ show n)
+if (n < 0 && n >= -200000) then putStrLn "Allocation counter in expected range" else (putStrLn $ "Unexpected allocation counter result:" ++ show n)
diff --git a/testsuite/tests/ghci/should_run/T16012.stdout b/testsuite/tests/ghci/should_run/T16012.stdout
index 2eb23fdb4c..0951b0f82b 100644
--- a/testsuite/tests/ghci/should_run/T16012.stdout
+++ b/testsuite/tests/ghci/should_run/T16012.stdout
@@ -1 +1 @@
-Alloction counter in expected range
+Allocation counter in expected range