rts: Make StablePtr derefs thread-safe (#10296)

Stable pointers can now be safely dereferenced while the stable pointer
table is simultaneously being enlarged.

Test Plan: ./validate

Reviewers: ezyang, austin, bgamari, simonmar

Subscribers: carter, thomie

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

GHC Trac Issues: #10296

5 files changed, 77 insertions, 0 deletions

diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index 6181f87d3a..e9cce901b0 100644
--- a/testsuite/tests/rts/Makefile
+++ b/testsuite/tests/rts/Makefile
@@ -111,6 +111,12 @@ T7037:
 T7040_ghci_setup :
 	'$(TEST_HC)' $(TEST_HC_OPTS) $(ghciWayFlags) -c T7040_ghci_c.c
 
+.PHONY: T10296a
+T10296a:
+	$(RM) T10296a_c.o T10296a.o T10296a.hi T10296a_stub.h
+	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -threaded T10296a.hs T10296a_c.c -o T10296a
+	./T10296a +RTS -N2
+
 .PHONY: linker_unload
 linker_unload:
 	$(RM) Test.o Test.hi
diff --git a/testsuite/tests/rts/T10296a.hs b/testsuite/tests/rts/T10296a.hs
new file mode 100644
index 0000000000..136508ff6d
--- /dev/null
+++ b/testsuite/tests/rts/T10296a.hs
@@ -0,0 +1,33 @@
+-- A reduced version of the original test case
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+
+import Control.Concurrent
+import Control.Monad
+import Foreign.C.Types
+import Foreign.Ptr
+
+
+main :: IO ()
+main = do
+    mv <- newEmptyMVar
+    -- Fork a thread to continually dereference a stable pointer...
+    void $ forkIO $ f 1 1000000 >> putMVar mv ()
+    -- ...while we keep enlarging the stable pointer table
+    f 65536 1
+    void $ takeMVar mv
+  where
+    f nWraps nApplies = replicateM_ nWraps $ do
+                            -- Each call to wrap creates a stable pointer
+                            wrappedPlus <- wrap (+)
+                            c_applyFun nApplies wrappedPlus 1 2
+
+
+type CIntFun = CInt -> CInt -> CInt
+
+foreign import ccall "wrapper"
+    wrap :: CIntFun -> IO (FunPtr CIntFun)
+
+foreign import ccall "apply_fun"
+    c_applyFun :: CInt -> FunPtr CIntFun -> CInt -> CInt -> IO CInt
diff --git a/testsuite/tests/rts/T10296a_c.c b/testsuite/tests/rts/T10296a_c.c
new file mode 100644
index 0000000000..6103874fb9
--- /dev/null
+++ b/testsuite/tests/rts/T10296a_c.c
@@ -0,0 +1,13 @@
+typedef int (* IntFun)(int a, int b);
+
+int apply_fun(int n, IntFun f, int a, int b) {
+  int s = 0;
+  int i;
+
+  for (i = 0; i < n; i++) {
+    // Each call back into Haskell using f dereferences a stable pointer
+    s += f(a, b + i);
+  }
+
+  return s;
+}
diff --git a/testsuite/tests/rts/T10296b.hs b/testsuite/tests/rts/T10296b.hs
new file mode 100644
index 0000000000..e5828df165
--- /dev/null
+++ b/testsuite/tests/rts/T10296b.hs
@@ -0,0 +1,19 @@
+-- A variant of the T10296a.hs test case in which
+--   - the FFI machinery has been eliminated
+--   - a primop (deRefStablePtr#) is used to dereference the stable pointer
+--   - the stable pointers are explicitly freed at the end
+
+
+import Control.Concurrent
+import Control.Monad
+import Foreign.StablePtr
+
+
+main :: IO ()
+main = do
+    sp <- newStablePtr ()
+    _ <- forkIO $ forever $ deRefStablePtr sp >> threadDelay 0
+    sps <- replicateM 1048576 $ newStablePtr ()
+    ----------------------------------------------------------
+    mapM_ freeStablePtr sps
+    freeStablePtr sp
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 269bc55f52..720ebfb4c2 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -333,3 +333,9 @@ test('T10728', [extra_run_opts('+RTS -maxN3 -RTS'), only_ways(['threaded2'])],
 
 test('T9405', [extra_clean(['T9405.ticky'])],
               run_command, ['$MAKE -s --no-print-directory T9405'])
+
+test('T10296a', [extra_clean(['T10296a.o','T10296a_c.o','T10296a'])],
+                run_command,
+                ['$MAKE -s --no-print-directory T10296a'])
+
+test('T10296b', [only_ways('threaded2')], compile_and_run, [''])