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 c6654ca528bfc8e36b07f210dbf4590caa5a1677..9cf2961669377bc6ffab089320a55d512be727da 100644 (file)
--- 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);
 }
 \f

diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index c6f77061eb4351b9537be082f9b63860fcb18cf3..4e59c87839b78a540126e9fdf8c428adf4dbd7bd 100644 (file)
--- 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 03467633e13084f6abdf2d7172aaa57b5a3f4ce5..a26260f165173f68a3df776925940a4e5a7be7ff 100644 (file)
--- a/src/microcode/interp.c
+++ b/src/microcode/interp.c
@@ -253,7 +253,7 @@ abort_to_interpreter_argument (void)
 long prim_apply_error_code;
 \f
 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 0da66431948269f680d724f972ca880eb2c79515..69245d0f1416c305a68c27fa9c3d55d579ba019f 100644 (file)
--- 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 746adb325d0839d4b3effc1544aaaee43d9fdef3..6a919b10e046a62c82e0db5da9f629d6563b5b7c 100644 (file)
--- 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))