Fix a bug with mallocForeignPtr and finalizers (#10904)

Summary: See Note [MallocPtr finalizers]

Test Plan: validate; new test T10904

Reviewers: ezyang, bgamari, austin, hvr, rwbarton

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1275

5 files changed, 88 insertions, 15 deletions

diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs
index 0b9118ea07..a1ff1ba6bf 100644
--- a/libraries/base/GHC/ForeignPtr.hs
+++ b/libraries/base/GHC/ForeignPtr.hs
@@ -248,11 +248,18 @@ addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()
 -- finalizer will run /before/ all other finalizers for the same
 -- object which have already been registered.
 addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of
-  PlainForeignPtr r -> f r >> return ()
-  MallocPtr     _ r -> f r >> return ()
+  PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p ()
+  MallocPtr     _ r -> insertCFinalizer r fp 0# nullAddr# p c
   _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
- where
-    f r = insertCFinalizer r fp 0# nullAddr# p
+
+-- Note [MallocPtr finalizers] (#10904)
+--
+-- When we have C finalizers for a MallocPtr, the memory is
+-- heap-resident and would normally be recovered by the GC before the
+-- finalizers run.  To prevent the memory from being reused too early,
+-- we attach the MallocPtr constructor to the "value" field of the
+-- weak pointer when we call mkWeak# in ensureCFinalizerWeak below.
+-- The GC will keep this field alive until the finalizers have run.
 
 addForeignPtrFinalizerEnv ::
   FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()
@@ -261,11 +268,9 @@ addForeignPtrFinalizerEnv ::
 -- finalizer.  The environment passed to the finalizer is fixed by the
 -- second argument to 'addForeignPtrFinalizerEnv'
 addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of
-  PlainForeignPtr r -> f r >> return ()
-  MallocPtr     _ r -> f r >> return ()
+  PlainForeignPtr r -> insertCFinalizer r fp 1# ep p ()
+  MallocPtr     _ r -> insertCFinalizer r fp 1# ep p c
   _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
- where
-    f r = insertCFinalizer r fp 1# ep p
 
 addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
 -- ^This function adds a finalizer to the given @ForeignPtr@.  The
@@ -327,9 +332,9 @@ insertHaskellFinalizer r f = do
 data MyWeak = MyWeak (Weak# ())
 
 insertCFinalizer ::
-  IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> IO ()
-insertCFinalizer r fp flag ep p = do
-  MyWeak w <- ensureCFinalizerWeak r
+  IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> value -> IO ()
+insertCFinalizer r fp flag ep p val = do
+  MyWeak w <- ensureCFinalizerWeak r val
   IO $ \s -> case addCFinalizerToWeak# fp p flag ep w s of
       (# s1, 1# #) -> (# s1, () #)
 
@@ -337,16 +342,17 @@ insertCFinalizer r fp flag ep p = do
       -- has finalized w by calling foreignPtrFinalizer. We retry now.
       -- This won't be an infinite loop because that thread must have
       -- replaced the content of r before calling finalizeWeak#.
-      (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p) s1
+      (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p val) s1
 
-ensureCFinalizerWeak :: IORef Finalizers -> IO MyWeak
-ensureCFinalizerWeak ref@(IORef (STRef r#)) = do
+ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak
+ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do
   fin <- readIORef ref
   case fin of
       CFinalizers weak -> return (MyWeak weak)
       HaskellFinalizers{} -> noMixingError
       NoFinalizers -> IO $ \s ->
-          case mkWeakNoFinalizer# r# () s of { (# s1, w #) ->
+          case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) ->
+             -- See Note [MallocPtr finalizers] (#10904)
           case atomicModifyMutVar# r# (update w) s1 of
               { (# s2, (weak, needKill ) #) ->
           if needKill
diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c
index 60ac53f4b0..9a32198c99 100644
--- a/rts/sm/MarkWeak.c
+++ b/rts/sm/MarkWeak.c
@@ -191,6 +191,11 @@ static void collectDeadWeakPtrs (generation *gen)
 {
     StgWeak *w, *next_w;
     for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) {
+        // If we have C finalizers, keep the value alive for this GC.
+        // See Note [MallocPtr finalizers] in GHC.ForeignPtr, and #10904
+        if (w->cfinalizers != &stg_NO_FINALIZER_closure) {
+            evacuate(&w->value);
+        }
         evacuate(&w->finalizer);
         next_w = w->link;
         w->link = dead_weak_ptr_list;
diff --git a/testsuite/tests/rts/T10904.hs b/testsuite/tests/rts/T10904.hs
new file mode 100644
index 0000000000..264df3a45b
--- /dev/null
+++ b/testsuite/tests/rts/T10904.hs
@@ -0,0 +1,28 @@
+import Control.Concurrent
+import Control.Monad
+import Foreign
+import Foreign.C.Types
+import System.Environment
+
+
+foreign import ccall safe "finalizerlib.h init_value"
+    init_value :: Ptr CInt -> IO ()
+
+foreign import ccall safe "finalizerlib.h &finalize_value"
+    finalize_value :: FinalizerPtr CInt
+
+
+allocateValue :: IO ()
+allocateValue = do
+    fp <- mallocForeignPtrBytes 10000
+    withForeignPtr fp init_value
+    addForeignPtrFinalizer finalize_value fp
+
+
+main :: IO ()
+main = do
+    [n] <- fmap (fmap read) getArgs
+    _ <- forkIO (loop n)
+    loop n
+  where
+    loop n = replicateM_ n allocateValue
diff --git a/testsuite/tests/rts/T10904lib.c b/testsuite/tests/rts/T10904lib.c
new file mode 100644
index 0000000000..bfed67b695
--- /dev/null
+++ b/testsuite/tests/rts/T10904lib.c
@@ -0,0 +1,30 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+
+#define MAGIC 0x11223344
+
+void
+init_value(int * p)
+{
+    *p = MAGIC;
+}
+
+
+void
+finalize_value(int * p)
+{
+    static long counter = 0;
+
+    counter += 1;
+
+    if (counter % 1000000 == 0) {
+        fprintf(stderr, "finalize_value: %ld calls\n", counter);
+    }
+
+    if (*p != MAGIC) {
+        fprintf(stderr, "finalize_value: %x != %x after %ld calls\n",
+                *p, MAGIC, counter);
+        abort();
+    }
+}
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index c9ad12bf5d..9892050b34 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -329,3 +329,7 @@ test('T9839_06', [ only_ways(prof_ways), ignore_output, exit_code(1), extra_run_
 # in 'epoll' and 'select' backends on reading from EBADF
 # mingw32 skip as UNIX pipe and close(fd) is used to exercise the problem
 test('T10590', [ignore_output, when(opsys('mingw32'),skip)], compile_and_run, [''])
+
+# 20000 was easily enough to trigger the bug with 7.10
+test('T10904', [ omit_ways(['ghci']), extra_run_opts('20000') ],
+               compile_and_run, ['T10904lib.c'])