ffi: Avoid most longjmps in C-CALL primitive (callout_continue).

Rather than abort after every callout (in callout_continue), call the
second trampoline directly, after unsealing the Scheme stack.

diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm
index 68b9fccdfba4c954deaa671a041c52c7257428c1..7c6d8894fd3a411646cf8e171996e30e95f06be8 100644 (file)
--- a/src/ffi/generator.scm
+++ b/src/ffi/generator.scm
@@ -129,7 +129,7 @@ Scm_continue_"name" (void)
       (let ((name (symbol-name name)))
        (write-string
         (string-append "
-void
+SCM
 Scm_"name" (void)
 \{
   /* Declare. */" declares "
@@ -142,8 +142,7 @@ Scm_"name" (void)
   /* Save. */
   callout_unseal (&Scm_continue_"name");" saves "
 
-  callout_continue (&Scm_continue_"name");
-  /* NOTREACHED */
+  return callout_continue (&Scm_continue_"name");
 }
 "))))))
 

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 122270b3edfdd3789adcdf651e4bcd1c931f2228..97f08fc283cd3faf5582a2a13e6580de20e96147 100644 (file)
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -418,13 +418,7 @@ DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0)
     CalloutTrampOut tramp;
 
     tramp = (CalloutTrampOut) arg_alien_entry (1);
-    tramp ();
-    /* NOTREACHED */
-    outf_error ("\ninternal error: Callout part1 trampoline returned.\n");
-    outf_flush_error ();
-    signal_error_from_primitive (ERR_EXTERNAL_RETURN);
-    /* really NOTREACHED */
-    PRIMITIVE_RETURN (UNSPECIFIC);
+    PRIMITIVE_RETURN (tramp ());
   }
 }
 
@@ -524,18 +518,33 @@ callout_unseal (CalloutTrampIn expected)
   cstack_pop (tos);
 }
 
-void
+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. */
+  SCM val;
 
   CSTACK_PUSH (int, cstack_depth);
   CSTACK_PUSH (CalloutTrampIn, tramp);
 
-  PRIMITIVE_ABORT (PRIM_POP_RETURN);
-  /* NOTREACHED */
+  /* Just call; do not actually abort. */
+  /* PRIMITIVE_ABORT (PRIM_POP_RETURN); */
+
+  /* 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(); */
+  val = tramp ();
+  return (val);
 }
 
 DEFINE_PRIMITIVE ("C-CALL-CONTINUE", Prim_c_call_continue, 1, LEXPR, 0)

diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index 59c6465ec63a57d059cfe80b49fb6fe9b0fb3b58..36eba3de6087ff67436ffefa6eac77867ca36504 100644 (file)
--- a/src/microcode/pruxffi.h
+++ b/src/microcode/pruxffi.h
@@ -50,11 +50,11 @@ extern void cstack_pop (char* tos);
   TOS = cstack_lpop (TOS, sizeof (TYPE));                              \
   VAR = *(TYPE *)TOS;
 
-typedef void (*CalloutTrampOut)(void);
+typedef SCM (*CalloutTrampOut)(void);
 typedef SCM (*CalloutTrampIn)(void);
 extern void callout_seal (CalloutTrampIn tramp);
 extern void callout_unseal (CalloutTrampIn expected);
-extern void callout_continue (CalloutTrampIn tramp);
+extern SCM callout_continue (CalloutTrampIn tramp);
 extern char* callout_lunseal (CalloutTrampIn expected);
 extern void callout_pop (char* tos);