From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 29 Apr 2016 18:38:21 +0000 (-0700)
Subject: runtime/ffi.scm: Avoid swapping threads during callbacks.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~50
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=37d9317b8490fcfbdd8f298d70cf41aa4e80d0d6;p=mit-scheme.git

runtime/ffi.scm: Avoid swapping threads during callbacks.

Block thread events during callouts.

Replace the callback error restart with an error handler that just
returns 0 from the callback.  Until the debugger can run without-
interrupts (blocking for console IO instead of suspending for an IO
thread event) it may not run during a callback.
---

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index a242a86d6..c05fbe1f2 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -354,9 +354,11 @@ USA.
      (if (alien-function? arg)
 	 (alien-function-cache! arg)))
    args)
-  (without-interrupts
+  (with-thread-events-blocked
    (lambda ()
-     (call-alien* alien-function args))))
+     (without-interrupts
+      (lambda ()
+	(call-alien* alien-function args))))))
 
 #;(define-integrable (call-alien* alien-function args)
   (apply (ucode-primitive c-call -1) alien-function args))
@@ -540,22 +542,18 @@ USA.
 (define (apply-callback-proc procedure args)
   (call-with-current-continuation
    (lambda (return)
-     (with-restart
-      'USE-VALUE			;name
-      "Return a value from the callback." ;reporter
-      return				;effector
-      (lambda ()			;interactor
-	(values (prompt-for-evaluated-expression
-		 "Value to return from callback")))
-      (lambda ()			;thunk
-	(let ((done? #f))
-	  (if (not done?)
-	      (begin
-		(set! done? #t)
-		(apply procedure args))
-	      (let loop ()
-		(error "Cannot return from a callback more than once.")
-		(loop)))))))))
+     (parameterize ((param:standard-error-hook
+		     (named-lambda (callback-error-handler condition)
+		       (let ((continuation return))
+			 (set! return #f)
+			 (outf-error ";error in callback: "condition"\n")
+			 (continuation 0)))))
+       (let* ((value (apply procedure args))
+	      (continuation return))
+	 (set! return #f)
+	 (if continuation
+	     (continuation value)
+	     (error "Cannot return from a callback multiple times.")))))))
 
 ;;; For callback debugging: