From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Wed, 9 Aug 2017 23:03:08 +0000 (-0700)
Subject: ffi: Simplify callback_run_kernel.  Eliminate callback abort.
X-Git-Tag: mit-scheme-pucked-9.2.12~91
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5829d83d500e0055f6a75c5681433a956cd772ff;p=mit-scheme.git

ffi: Simplify callback_run_kernel.  Eliminate callback abort.
---

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 69245d0f1..796c457b7 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -581,12 +581,8 @@ callback_run_kernel (long callback_id, CallbackKernel kernel)
 {
   /* 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
+  SCM * saved_stack_pointer, * saved_last_return_code;
+  unsigned long nargs = GET_LEXPR_ACTUALS;
 
   if (run_callback == SHARP_F)
     {
@@ -594,50 +590,58 @@ callback_run_kernel (long callback_id, CallbackKernel kernel)
       if (run_callback == SHARP_F)
 	{
 	  outf_error_line
-	    ("\nWarning: punted callback #%ld.  Missing primitives!",
+	    ("\nWarning: punted callback #%ld.  Missing primitive!",
 	     callback_id);
 	  SET_VAL (FIXNUM_ZERO);
 	  return;
 	}
     }
 
+  if (GET_PRIMITIVE != c_call_continue)
+    abort_to_interpreter (ERR_CANNOT_RECURSE);
+    /*NOTREACHED*/
+
   cstack_depth += 1;
   CSTACK_PUSH (int, cstack_depth);
   CSTACK_PUSH (CallbackKernel, kernel);
 
-  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;
+  /* For a traceable stack... */
+  STACK_PUSH (c_call_continue);
+  PUSH_APPLY_FRAME_HEADER (nargs);
+  SET_RC (RC_INTERNAL_APPLY);
+  SET_EXP (c_call_continue);
+  SAVE_CONT ();
 
+  saved_last_return_code = last_return_code;
+  saved_stack_pointer = stack_pointer;
  Will_Push ((2 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1);
   SET_RC (RC_END_OF_COMPUTATION);
-  SET_EXP (primitive);
+  SET_EXP (run_callback);
   SAVE_CONT ();
   STACK_PUSH (run_callback);
   PUSH_APPLY_FRAME_HEADER (0);
   SET_RC (RC_INTERNAL_APPLY);
-  SET_EXP (SHARP_F);
+  SET_EXP (run_callback);
   SAVE_CONT ();
  Pushed ();
+  SET_EXP (SHARP_F);		/* fall through to pop_return */
   Re_Enter_Interpreter ();
 
-  if (stack_pointer != sp)
+  if (stack_pointer != saved_stack_pointer
+#ifdef ENABLE_DEBUGGING_TOOLS
+      || ((STACK_REF (0)) != (MAKE_RETURN_CODE (RC_INTERNAL_APPLY)))
+      || ((STACK_REF (1)) != c_call_continue)
+      || ((STACK_REF (2)) != (MAKE_OBJECT (0, nargs+1)))
+      || ((STACK_REF (3)) != c_call_continue)
+#endif
+      )
     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
+  last_return_code = saved_last_return_code;
+  stack_pointer = STACK_LOC (4);
+  SET_PRIMITIVE (c_call_continue);
+  SET_LEXPR_ACTUALS (nargs);
 
   cstack_depth -= 1;
 }
@@ -662,7 +666,8 @@ DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
       }
 
     kernel ();
-    /* NOTREACHED */
+    /* This primitive is only run by the re-entered interpreter and,
+       with zero arguments, its apply frame is already gone. */
     PRIMITIVE_RETURN (UNSPECIFIC);
   }
 }
@@ -706,23 +711,22 @@ callback_run_handler (long callback_id, SCM arglist)
   /* Used by callback kernels, inside the interpreter.  Thus it MAY GC
      abort.
 
-     Push a Scheme callback handler apply frame.  This leaves the
-     interpreter ready to tail-call the Scheme procedure.  (The
-     RUN-CALLBACK primitive apply frame is already gone.)  The
-     trampoline should abort with PRIM_APPLY. */
+     Push a Scheme callback handler apply frame.  (The RUN-CALLBACK
+     primitive apply frame is already gone.) */
 
   SCM handler, fixnum_id;
 
   handler = valid_callback_handler ();
   fixnum_id = valid_callback_id (callback_id);
 
-  stop_history ();
-
-  Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
+  Will_Push (3 + STACK_ENV_EXTRA_SLOTS + CONTINUATION_SIZE);
   STACK_PUSH (arglist);
   STACK_PUSH (fixnum_id);
   STACK_PUSH (handler);
   PUSH_APPLY_FRAME_HEADER (2);
+  SET_RC (RC_INTERNAL_APPLY);
+  SET_EXP (run_callback);
+  SAVE_CONT ();
   Pushed ();
 }
 
@@ -761,7 +765,6 @@ void
 callback_return (char * tos)
 {
   cstack_pop (tos);
-  PRIMITIVE_ABORT (PRIM_APPLY);
 }
 
 /* Converters */