From d3e649431b875e76abf678ea68a3931c15c25e92 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 14 Aug 2017 14:12:10 -0700 Subject: [PATCH] ffi: Add re_enter_scheme to work with abort_to_c for glib mainloop. --- src/microcode/pruxffi.c | 57 +++++++++++++++++++++++++++++------------ 1 file changed, 40 insertions(+), 17 deletions(-) diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index 796c457b7..72a4674d2 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -571,10 +571,6 @@ callout_pop (char * tos) static SCM run_callback = SHARP_F; extern SCHEME_OBJECT Re_Enter_Interpreter (void); -#ifdef CC_IS_NATIVE -extern void * C_Frame_Pointer; -extern void * C_Stack_Pointer; -#endif void callback_run_kernel (long callback_id, CallbackKernel kernel) @@ -672,15 +668,6 @@ DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0) } } -/* This is mainly for src/glib/glibio.c, so it does not need to include - prim.h, scheme.h and everything. */ -void -abort_to_c (void) -{ - PRIMITIVE_ABORT (PRIM_RETURN_TO_C); - /* NOTREACHED */ -} - char * callback_lunseal (CallbackKernel expected) { @@ -1029,7 +1016,7 @@ flovec_length (double *first) DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) { - /* To avoid the normal i/o system when debugging a callback. */ + /* To avoid the normal IO system when debugging a callback. */ PRIMITIVE_HEADER (1); { @@ -1047,13 +1034,49 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) PRIMITIVE_RETURN (UNSPECIFIC); } } + +/* Re-Entering the Interpreter + + These functions are used by the glib plugin to (re)enter the + interpreter in a GSource dispatch method, and to throw out again to + return from the method. */ + +void +re_enter_scheme (void) +{ + assert (GET_PRIMITIVE == c_call_continue); + back_out_of_primitive (); + Re_Enter_Interpreter (); + + assert (GET_PRIMITIVE == SHARP_F); + assert (GET_EXP == SHARP_F); + assert ((STACK_REF (0)) == (MAKE_RETURN_CODE (RC_INTERNAL_APPLY))); + assert ((STACK_REF (1)) == SHARP_F); + assert ((OBJECT_TYPE (STACK_REF (2))) == TC_FALSE); + assert ((STACK_REF (3)) == c_call_continue); + + SET_PRIMITIVE (c_call_continue); + SET_LEXPR_ACTUALS (APPLY_FRAME_HEADER_N_ARGS (STACK_REF (2))); + stack_pointer = STACK_LOC (4); + alienate_float_environment (); +} + +void +abort_to_c (void) +{ + assert (GET_PRIMITIVE == c_call_continue); + back_out_of_primitive (); + PRIMITIVE_ABORT (PRIM_RETURN_TO_C); + /* NOTREACHED */ +} int interrupts_p (void) { - /* Just the pending interrupts bitmap, ignoring the INT_MASK. */ - /* This is mainly for src/glib/glibio.c, which finds pending_ - interrupts_p() useless; it is always /gc-ok. */ + /* Just the interrupts bitmap, ignoring the INT_MASK, which often is + /gc-ok while a toolkit is running (making pending_interrupts_p() + useless). This function allows the toolkit to see if the Scheme + machine has received an interrupt and needs to run. */ return (GET_INT_CODE); } -- 2.25.1