Allow bytecode interpreter to make unsafe foreign calls

Reviewers: austin, hvr, erikd, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #8281, #13730.

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

6 files changed, 38 insertions, 1 deletions

diff --git a/testsuite/tests/ffi/should_fail/Makefile b/testsuite/tests/ffi/should_fail/Makefile
index 9101fbd40a..51f063c655 100644
--- a/testsuite/tests/ffi/should_fail/Makefile
+++ b/testsuite/tests/ffi/should_fail/Makefile
@@ -1,3 +1,8 @@
 TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+.PHONY: UnsafeReenterGhci
+UnsafeReenterGhci:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c UnsafeReenterC.c
+	echo ':main' | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) UnsafeReenterC.o UnsafeReenter.hs
diff --git a/testsuite/tests/ffi/should_fail/UnsafeReenter.hs b/testsuite/tests/ffi/should_fail/UnsafeReenter.hs
new file mode 100644
index 0000000000..5aea5a88a1
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/UnsafeReenter.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- | Test that unsafe FFI calls crash the RTS if they attempt to re-enter
+-- Haskell-land
+module Main where
+
+import Foreign
+
+foreign import ccall "wrapper" wrap_f :: IO () -> IO (FunPtr (IO ()))
+foreign import ccall unsafe hello :: FunPtr (IO ()) -> IO ()
+
+f :: IO ()
+f = putStrLn "Back in Haskell"
+
+main :: IO ()
+main = do
+    putStrLn "In Haskell"
+    wrap_f f >>= hello
+    putStrLn "Finished"
diff --git a/testsuite/tests/ffi/should_fail/UnsafeReenter.stderr b/testsuite/tests/ffi/should_fail/UnsafeReenter.stderr
new file mode 100644
index 0000000000..20aa3d7719
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/UnsafeReenter.stderr
@@ -0,0 +1,2 @@
+UnsafeReenter: schedule: re-entered unsafely.
+   Perhaps a 'foreign import unsafe' should be 'safe'?
diff --git a/testsuite/tests/ffi/should_fail/UnsafeReenter.stdout b/testsuite/tests/ffi/should_fail/UnsafeReenter.stdout
new file mode 100644
index 0000000000..fecadce752
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/UnsafeReenter.stdout
@@ -0,0 +1 @@
+in C
diff --git a/testsuite/tests/ffi/should_fail/UnsafeReenterC.c b/testsuite/tests/ffi/should_fail/UnsafeReenterC.c
new file mode 100644
index 0000000000..6ccf2b8d06
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/UnsafeReenterC.c
@@ -0,0 +1,6 @@
+#include <stdio.h>
+
+void hello(void (*f)()) {
+  printf("in C\n");
+  f();
+}
diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T
index 9e067622b5..944f172c02 100644
--- a/testsuite/tests/ffi/should_fail/all.T
+++ b/testsuite/tests/ffi/should_fail/all.T
@@ -14,4 +14,8 @@ test('T5664', normal, compile_fail, ['-v0'])
 test('T7506', normal, compile_fail, [''])
 test('T7243', normal, compile_fail, [''])
 test('T10461', normal, compile_fail, [''])
-
+test('UnsafeReenter', [omit_ways(['ghciext', 'ghci']), exit_code(1)], compile_and_run, ['-v0 UnsafeReenterC.c'])
+test('UnsafeReenterGhci',
+     [exit_code(1), extra_files(['UnsafeReenter.hs', 'UnsafeReenterC.c']), expect_broken(13730)],
+     run_command,
+     ['$MAKE -s --no-print-directory UnsafeReenterGhci'])