Allow bytecode interpreter to make unsafe foreign calls
authorBen Gamari <bgamari.foss@gmail.com>
Tue, 27 Jun 2017 14:26:01 +0000 (10:26 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 27 Jun 2017 16:55:06 +0000 (12:55 -0400)
Reviewers: austin, hvr, erikd, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #8281, #13730.

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

compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeInstr.hs
rts/Interpreter.c
testsuite/tests/ffi/should_fail/Makefile
testsuite/tests/ffi/should_fail/UnsafeReenter.hs [new file with mode: 0644]
testsuite/tests/ffi/should_fail/UnsafeReenter.stderr [new file with mode: 0644]
testsuite/tests/ffi/should_fail/UnsafeReenter.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_fail/UnsafeReenterC.c [new file with mode: 0644]
testsuite/tests/ffi/should_fail/all.T

index 7ad51a7..a7cd6da 100644 (file)
@@ -1164,8 +1164,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
      let
          -- do the call
-         do_call      = unitOL (CCALL stk_offset token
-                                 (fromIntegral (fromEnum (playInterruptible safety))))
+         do_call      = unitOL (CCALL stk_offset token flags)
+           where flags = case safety of
+                           PlaySafe          -> 0x0
+                           PlayInterruptible -> 0x1
+                           PlayRisky         -> 0x2
+
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
                         `snocOL` RETURN_UBX (toArgRep r_rep)
index 4344432..5252802 100644 (file)
@@ -132,7 +132,11 @@ data BCInstr
    -- For doing calls to C (via glue code generated by libffi)
    | CCALL            Word16    -- stack frame size
                       (RemotePtr C_ffi_cif) -- addr of the glue code
-                      Word16    -- whether or not the call is interruptible
+                      Word16    -- flags.
+                                --
+                                -- 0x1: call is interruptible
+                                -- 0x2: call is unsafe
+                                --
                                 -- (XXX: inefficient, but I don't know
                                 -- what the alignment constraints are.)
 
@@ -235,12 +239,13 @@ instance Outputable BCInstr where
    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
    ppr CASEFAIL              = text "CASEFAIL"
    ppr (JMP lab)             = text "JMP"      <+> ppr lab
-   ppr (CCALL off marshall_addr int) = text "CCALL   " <+> ppr off
+   ppr (CCALL off marshall_addr flags) = text "CCALL   " <+> ppr off
                                                 <+> text "marshall code at"
                                                <+> text (show marshall_addr)
-                                               <+> (if int == 1
-                                                    then text "(interruptible)"
-                                                    else empty)
+                                               <+> (case flags of
+                                                      0x1 -> text "(interruptible)"
+                                                      0x2 -> text "(unsafe)"
+                                                      _   -> empty)
    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
                                                <+> text "by" <+> ppr n
    ppr ENTER                 = text "ENTER"
index 1a883a5..9291473 100644 (file)
@@ -1598,7 +1598,9 @@ run_BCO:
             void *tok;
             int stk_offset            = BCO_NEXT;
             int o_itbl                = BCO_GET_LARGE_ARG;
-            int interruptible         = BCO_NEXT;
+            int flags                 = BCO_NEXT;
+            bool interruptible        = flags & 0x1;
+            bool unsafe_call          = flags & 0x2;
             void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
 
             /* the stack looks like this:
@@ -1686,15 +1688,19 @@ run_BCO:
             Sp[1] = (W_)obj;
             Sp[0] = (W_)&stg_ret_p_info;
 
-            SAVE_THREAD_STATE();
-            tok = suspendThread(&cap->r, interruptible);
+            if (!unsafe_call) {
+                SAVE_THREAD_STATE();
+                tok = suspendThread(&cap->r, interruptible);
+            }
 
             // We already made a copy of the arguments above.
             ffi_call(cif, fn, ret, argptrs);
 
             // And restart the thread again, popping the stg_ret_p frame.
-            cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
-            LOAD_THREAD_STATE();
+            if (!unsafe_call) {
+                cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
+                LOAD_THREAD_STATE();
+            }
 
             if (Sp[0] != (W_)&stg_ret_p_info) {
                 // the stack is not how we left it.  This probably
index 9101fbd..51f063c 100644 (file)
@@ -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 (file)
index 0000000..5aea5a8
--- /dev/null
@@ -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 (file)
index 0000000..20aa3d7
--- /dev/null
@@ -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 (file)
index 0000000..fecadce
--- /dev/null
@@ -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 (file)
index 0000000..6ccf2b8
--- /dev/null
@@ -0,0 +1,6 @@
+#include <stdio.h>
+
+void hello(void (*f)()) {
+  printf("in C\n");
+  f();
+}
index 9e06762..944f172 100644 (file)
@@ -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'])