Use with#

4 files changed, 33 insertions, 61 deletions

diff --git a/libraries/base/Foreign/ForeignPtr/Imp.hs b/libraries/base/Foreign/ForeignPtr/Imp.hs
index 2fc18689a9..3af5da13a9 100644
--- a/libraries/base/Foreign/ForeignPtr/Imp.hs
+++ b/libraries/base/Foreign/ForeignPtr/Imp.hs
@@ -66,31 +66,6 @@ newForeignPtr finalizer p
        addForeignPtrFinalizer finalizer fObj
        return fObj
 
-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 fo io
-  = do r <- io (unsafeForeignPtrToPtr fo)
-       touchForeignPtr fo
-       return r
-
 -- | This variant of 'newForeignPtr' adds a finalizer that expects an
 -- environment in addition to the finalized pointer.  The environment
 -- that will be passed to the finalizer is fixed by the second argument to
diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs
index c32f0b62d7..2ad07c1ae2 100644
--- a/libraries/base/Foreign/Marshal/Alloc.hs
+++ b/libraries/base/Foreign/Marshal/Alloc.hs
@@ -68,6 +68,7 @@ import GHC.IO.Exception
 import GHC.Real
 import GHC.Ptr
 import GHC.Base
+import GHC.Prim                 ( keepAlive# )
 
 -- exported functions
 -- ------------------
@@ -116,19 +117,6 @@ alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
 alloca  =
   allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a))
 
--- Note [NOINLINE for touch#]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously
--- fragile in the presence of simplification (see #14346). In particular, the
--- simplifier may drop the continuation containing the touch# if it can prove
--- that the action passed to allocaBytes will not return. The hack introduced to
--- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the
--- simplifier can't see the divergence.
---
--- These can be removed once #14375 is fixed, which suggests that we instead do
--- away with touch# in favor of a primitive that will capture the scoping left
--- implicit in the case of touch#.
-
 -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
 -- a pointer to a temporarily allocated block of memory of @n@ bytes.
 -- The block of memory is sufficiently aligned for any of the basic
@@ -142,13 +130,9 @@ allocaBytes (I# size) action = IO $ \ s0 ->
      case newPinnedByteArray# size s0      of { (# s1, mbarr# #) ->
      case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
      let addr = Ptr (byteArrayContents# barr#) in
-     case action addr     of { IO action' ->
-     case action' s2      of { (# s3, r #) ->
-     case touch# barr# s3 of { s4 ->
-     (# s4, r #)
-  }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytes #-}
+     case action addr                      of { IO action' ->
+     keepAlive# barr# action' s2
+  }}}
 
 allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
 allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
@@ -156,12 +140,8 @@ allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
      case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->
      let addr = Ptr (byteArrayContents# barr#) in
      case action addr     of { IO action' ->
-     case action' s2      of { (# s3, r #) ->
-     case touch# barr# s3 of { s4 ->
-     (# s4, r #)
-  }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytesAligned #-}
+     keepAlive# barr# action' s2
+  }}}
 
 -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
 -- to the size needed to store values of type @b@.  The returned pointer
diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs
index 92aef540d1..6a1b3c8370 100644
--- a/libraries/base/GHC/ForeignPtr.hs
+++ b/libraries/base/GHC/ForeignPtr.hs
@@ -37,6 +37,7 @@ module GHC.ForeignPtr
         mallocPlainForeignPtrAlignedBytes,
         addForeignPtrFinalizer,
         addForeignPtrFinalizerEnv,
+        withForeignPtr,
         touchForeignPtr,
         unsafeForeignPtrToPtr,
         castForeignPtr,
@@ -54,6 +55,7 @@ import GHC.Base
 import GHC.IORef
 import GHC.STRef        ( STRef(..) )
 import GHC.Ptr          ( Ptr(..), FunPtr(..) )
+import GHC.Prim         ( keepAlive# )
 
 import Unsafe.Coerce    ( unsafeCoerce, unsafeCoerceUnlifted )
 
@@ -388,6 +390,30 @@ 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 fo@(ForeignPtr _ r) f = IO $ \s ->
+  case f (unsafeForeignPtrToPtr fo) of
+    IO action# -> keepAlive# r action# s
+
 touchForeignPtr :: ForeignPtr a -> IO ()
 -- ^This function ensures that the foreign object in
 -- question is alive at the given place in the sequence of IO
diff --git a/libraries/ghc-compact/GHC/Compact/Serialized.hs b/libraries/ghc-compact/GHC/Compact/Serialized.hs
index 0263cdf9f1..2d745f7b11 100644
--- a/libraries/ghc-compact/GHC/Compact/Serialized.hs
+++ b/libraries/ghc-compact/GHC/Compact/Serialized.hs
@@ -74,12 +74,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
       rest <- go next
       return $ item : rest
 
--- We MUST mark withSerializedCompact as NOINLINE
--- Otherwise the compiler will eliminate the call to touch#
--- causing the Compact# to be potentially GCed too eagerly,
--- before func had a chance to copy everything into its own
--- buffers/sockets/whatever
-
 -- | Serialize the 'Compact', and call the provided function with
 -- with the 'Compact' serialized representation.  It is not safe
 -- to return the pointer from the action and use it after
@@ -89,7 +83,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
 -- unsound to use 'unsafeInterleaveIO' to lazily construct
 -- a lazy bytestring from the 'Ptr'.
 --
-{-# NOINLINE withSerializedCompact #-}
 withSerializedCompact :: Compact a ->
                          (SerializedCompact a -> IO c) -> IO c
 withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
@@ -97,9 +90,7 @@ withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
                     (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
   blockList <- mkBlockList buffer
   let serialized = SerializedCompact blockList rootPtr
-  r <- func serialized
-  IO (\s -> case touch# buffer s of
-         s' -> (# s', r #) )
+  IO (\s1 -> case func serialized of IO action' -> keepAlive# buffer action' s1)
 
 fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
                  (# State# RealWorld, Maybe (Compact a) #)