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

3 files changed, 62 insertions, 0 deletions

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'])