From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 26 Nov 2013 17:07:29 +0000 (-0700)
Subject: ffi: Avoid longjmps in C-CALL primitive (callout_continue).
X-Git-Tag: release-9.2.0~50
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a50833adf2a5046a90027d173079001fe989549;p=mit-scheme.git

ffi: Avoid 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 68b9fccdf..7c6d8894f 100644
--- 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 cbef761d6..c6f648204 100644
--- 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 59c6465ec..36eba3de6 100644
--- 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);