1 files changed, 38 insertions, 1 deletions

diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs
index a64d4d19c6..6cc55221f4 100644
--- a/libraries/base/GHC/ForeignPtr.hs
+++ b/libraries/base/GHC/ForeignPtr.hs
@@ -45,8 +45,11 @@ module GHC.ForeignPtr
         unsafeForeignPtrToPtr,
         castForeignPtr,
         plusForeignPtr,
-        -- * Finalization
+        -- * Control over lifetype
+        withForeignPtr,
+        unsafeWithForeignPtr,
         touchForeignPtr,
+        -- * Finalization
         finalizeForeignPtr
         -- * Commentary
         -- $commentary
@@ -503,6 +506,40 @@ newForeignPtr_ (Ptr obj) =  do
   r <- newIORef NoFinalizers
   return (ForeignPtr obj (PlainForeignPtr r))
 
+withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+-- ^This is a way to look at the pointer living inside a
+-- foreign object.  This function takes a function which is
+-- applied to that pointer. The resulting 'IO' action is then
+-- executed. The foreign object is kept alive at least during
+-- the whole action, even if it is not used directly
+-- inside. Note that it is not safe to return the pointer from
+-- the action and use it after the action completes. All uses
+-- of the pointer should be inside the
+-- 'withForeignPtr' bracket.  The reason for
+-- this unsafeness is the same as for
+-- 'unsafeForeignPtrToPtr' below: the finalizer
+-- may run earlier than expected, because the compiler can only
+-- track usage of the 'ForeignPtr' object, not
+-- a 'Ptr' object made from it.
+--
+-- This function is normally used for marshalling data to
+-- or from the object pointed to by the
+-- 'ForeignPtr', using the operations from the
+-- 'Storable' class.
+withForeignPtr = unsafeWithForeignPtr
+
+-- | This is similar to 'withForeignPtr' but comes with an important caveat:
+-- the user must guarantee that the continuation does not diverge (e.g. loop or
+-- 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.
+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+unsafeWithForeignPtr fo f = do
+  r <- f (unsafeForeignPtrToPtr fo)
+  touchForeignPtr fo
+  return r
+
 touchForeignPtr :: ForeignPtr a -> IO ()
 -- ^This function ensures that the foreign object in
 -- question is alive at the given place in the sequence of IO