Commit 9ef909db authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari
Browse files

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
parent 914962ca
......@@ -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)
......
......@@ -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"
......
......@@ -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
......
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
{-# 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"
UnsafeReenter: schedule: re-entered unsafely.
Perhaps a 'foreign import unsafe' should be 'safe'?
#include <stdio.h>
void hello(void (*f)()) {
printf("in C\n");
f();
}
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment