From: Matt Birkholz Date: Mon, 7 Aug 2017 01:16:52 +0000 (-0700) Subject: ffi: Follow example of C_call_scheme and eliminate aborts. X-Git-Tag: mit-scheme-pucked-9.2.12~92 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=480e2460fbbdec7ebacb1d530c71f00d1e12c07d;p=mit-scheme.git ffi: Follow example of C_call_scheme and eliminate aborts. Punt pop_return_p parameter to Interpret; instead, leave #f in EXP and Re_Enter_Interpreter, like C_call_scheme. Keep callouts simple, fast. Make callbacks save/restore machine state (last_return_code, C_Frame_Pointer, C_Stack_Pointer, LEXPR_ACTUALS and PRIMITIVE) and use RC_END_OF_COMPUTATION, also like C_call_scheme. Add a gc-flip to the test callback. --- diff --git a/src/microcode/boot.c b/src/microcode/boot.c index c6654ca52..9cf296166 100644 --- a/src/microcode/boot.c +++ b/src/microcode/boot.c @@ -199,7 +199,7 @@ start_scheme (void) static void Do_Enter_Interpreter (void) { - Interpret (0); + Interpret (); outf_fatal ("\nThe interpreter returned to top level!\n"); Microcode_Termination (TERM_EXIT); } @@ -215,7 +215,7 @@ Enter_Interpreter (void) SCHEME_OBJECT Re_Enter_Interpreter (void) { - Interpret (0); + Interpret (); return (GET_VAL); } diff --git a/src/microcode/extern.h b/src/microcode/extern.h index c6f77061e..4e59c8783 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -371,7 +371,7 @@ extern void preserve_interrupt_mask (void); extern void canonicalize_primitive_context (void); extern void back_out_of_primitive (void); -extern void Interpret (int pop_return_p); +extern void Interpret (void); extern void Do_Micro_Error (long, bool); extern void Stack_Death (void) NORETURN; extern SCHEME_OBJECT * control_point_start (SCHEME_OBJECT); diff --git a/src/microcode/interp.c b/src/microcode/interp.c index 03467633e..a26260f16 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -253,7 +253,7 @@ abort_to_interpreter_argument (void) long prim_apply_error_code; void -Interpret (int pop_return_p) +Interpret (void) { long dispatch_code; struct interpreter_state_s new_state; @@ -274,10 +274,7 @@ Interpret (int pop_return_p) switch (dispatch_code) { case 0: /* first time */ - if (pop_return_p) - goto pop_return; /* continue */ - else - break; /* fall into eval */ + break; /* fall into eval */ case PRIM_APPLY: PROCEED_AFTER_PRIMITIVE (); diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index 0da664319..69245d0f1 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -215,7 +215,7 @@ DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0) else { SCM string = char_pointer_to_string (*ptr); - set_alien_address ((ARG_REF (1)), (ptr + 1)); /* No more aborts! */ + set_alien_address ((ARG_REF (1)), (ptr + 1)); PRIMITIVE_RETURN (string); } } @@ -413,7 +413,6 @@ DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0) /* All the smarts are in the trampolines. */ PRIMITIVE_HEADER (LEXPR); - canonicalize_primitive_context (); { CalloutTrampOut tramp; @@ -456,11 +455,7 @@ void callout_seal (CalloutTrampIn tramp) { /* Used in a callout part1 trampoline. Arrange for subsequent - aborts to start part2. - - Seal the CStack, substitute the C-CALL-CONTINUE primitive for - the C-CALL primitive, and back out. The tramp can then execute - the toolkit function safely, even if there is a callback. */ + aborts to start part2. */ if (c_call_continue == SHARP_F) { @@ -477,9 +472,7 @@ callout_seal (CalloutTrampIn tramp) CSTACK_PUSH (int, cstack_depth); CSTACK_PUSH (CalloutTrampIn, tramp); - /* Back out of C-CALL-CONTINUE. */ SET_PRIMITIVE (c_call_continue); - back_out_of_primitive (); alienate_float_environment (); } @@ -508,34 +501,16 @@ SCM callout_continue (CalloutTrampIn tramp) { /* Re-seal the CStack frame over the C results (again, pushing the - cstack_depth and callout-part2) and abort. Restart as - C-CALL-CONTINUE and run callout-part2. */ + cstack_depth and callout-part2) and call the restartable tramp. + If it aborts, it restarts as C-CALL-CONTINUE and retries + part2. */ + SCM val; + CSTACK_PUSH (int, cstack_depth); CSTACK_PUSH (CalloutTrampIn, tramp); -#if 1 - PRIMITIVE_ABORT (PRIM_POP_RETURN); - /* NOTREACHED */ -#else - /* Just call; do not actually abort. */ - - /* This is fubared by a GC during a callback. callback_run_kernel - probably needs to use something like apply_compiled_from_ - primitive for this to work... */ - - /* Remove stack sealant created by callout_seal (which used - back_out_of_primitive), as if removed by pop_return in Interp() - after the abort. */ - SET_PRIMITIVE (SHARP_F); /* PROCEED_AFTER_PRIMITIVE (); */ - RESTORE_CONT (); - assert (RC_INTERNAL_APPLY == (OBJECT_DATUM(GET_RET))); - SET_LEXPR_ACTUALS (APPLY_FRAME_N_ARGS ()); - stack_pointer = (APPLY_FRAME_ARGS ()); - SET_EXP (APPLY_FRAME_PROCEDURE ()); - /* APPLY_PRIMITIVE_FROM_INTERPRETER (Function); */ - /* Prim_c_call_continue(); */ - return (tramp ()); -#endif + val = tramp (); + return (val); } DEFINE_PRIMITIVE ("C-CALL-CONTINUE", Prim_c_call_continue, 1, LEXPR, 0) @@ -595,22 +570,28 @@ callout_pop (char * tos) /* Callbacks */ static SCM run_callback = SHARP_F; -static SCM return_to_c = 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) { - /* Used by callback trampolines. - - Expect the args on the CStack. Push a couple primitive apply - frames on the Scheme stack and seal the CStack. Then call - Interpret(). Cannot abort. */ + /* Used by callback trampolines after saving the callback args on + the CStack. */ + SCM primitive, prim_lexpr, * sp; + SCM * callers_last_return_code; +#ifdef CC_IS_NATIVE + void * cfp = C_Frame_Pointer; + void * csp = C_Stack_Pointer; +#endif if (run_callback == SHARP_F) { run_callback = find_primitive_cname ("RUN-CALLBACK", false, false, 0); - return_to_c = find_primitive_cname ("RETURN-TO-C", false, false, 0); - if (run_callback == SHARP_F || return_to_c == SHARP_F) + if (run_callback == SHARP_F) { outf_error_line ("\nWarning: punted callback #%ld. Missing primitives!", @@ -620,28 +601,44 @@ callback_run_kernel (long callback_id, CallbackKernel kernel) } } - /* Need to push 2 each of prim+header+continuation. */ - if (! CAN_PUSH_P (2 * (1 + 1 + CONTINUATION_SIZE))) - { - outf_error_line - ("\nWarning: punted callback #%ld. No room on stack!", callback_id); - SET_VAL (FIXNUM_ZERO); - return; - } - cstack_depth += 1; CSTACK_PUSH (int, cstack_depth); CSTACK_PUSH (CallbackKernel, kernel); - STACK_PUSH (return_to_c); - PUSH_APPLY_FRAME_HEADER (0); - SET_RC (RC_INTERNAL_APPLY); - SAVE_CONT(); + primitive = GET_PRIMITIVE; + prim_lexpr = GET_LEXPR_ACTUALS; + callers_last_return_code = last_return_code; + + if (! (PRIMITIVE_P (primitive))) + abort_to_interpreter (ERR_CANNOT_RECURSE); + /*NOTREACHED*/ + assert (primitive == c_call_continue); + sp = stack_pointer; + + Will_Push ((2 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1); + SET_RC (RC_END_OF_COMPUTATION); + SET_EXP (primitive); + SAVE_CONT (); STACK_PUSH (run_callback); PUSH_APPLY_FRAME_HEADER (0); - SAVE_CONT(); - Interpret (1); - alienate_float_environment (); + SET_RC (RC_INTERNAL_APPLY); + SET_EXP (SHARP_F); + SAVE_CONT (); + Pushed (); + Re_Enter_Interpreter (); + + if (stack_pointer != sp) + signal_error_from_primitive (ERR_STACK_HAS_SLIPPED); + /*NOTREACHED*/ + + last_return_code = callers_last_return_code; + SET_LEXPR_ACTUALS (prim_lexpr); + SET_PRIMITIVE (primitive); +#ifdef CC_IS_NATIVE + C_Frame_Pointer = cfp; + C_Stack_Pointer = csp; +#endif + cstack_depth -= 1; } @@ -670,28 +667,6 @@ DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0) } } -DEFINE_PRIMITIVE ("RETURN-TO-C", Prim_return_to_c, 0, 0, 0) -{ - /* Callbacks are possible while stopped. The PRIM_RETURN_TO_C abort - expects this primitive to clean up its stack frame. */ - - PRIMITIVE_HEADER (0); - canonicalize_primitive_context (); - { - SCM primitive; - long nargs; - - primitive = GET_PRIMITIVE; - assert (PRIMITIVE_P (primitive)); - nargs = (PRIMITIVE_N_ARGUMENTS (primitive)); - POP_PRIMITIVE_FRAME (nargs); - SET_EXP (SHARP_F); - PRIMITIVE_ABORT (PRIM_RETURN_TO_C); - /* NOTREACHED */ - PRIMITIVE_RETURN (UNSPECIFIC); - } -} - /* This is mainly for src/glib/glibio.c, so it does not need to include prim.h, scheme.h and everything. */ void diff --git a/tests/ffi/test-ffi-wrapper.scm b/tests/ffi/test-ffi-wrapper.scm index 746adb325..6a919b10e 100644 --- a/tests/ffi/test-ffi-wrapper.scm +++ b/tests/ffi/test-ffi-wrapper.scm @@ -17,7 +17,9 @@ (chars (malloc (1+ (* (c-sizeof "char") (bytevector-length bytevector))) '(* char))) - (callback-id (C-callback (lambda (d) (* d pi))))) + (callback-id (C-callback (lambda (d) + (outf-error "Callback flip "(gc-flip)"\n") + (* d pi))))) (C->= struct "TestStruct first" (char->integer #\A)) (C->= struct "TestStruct second" pi) (C->= struct "TestStruct third" (char->integer #\C))