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 a242a86d688203c0a8821238d0b89dc5e61b9572..c05fbe1f2810adb74cfc75b9e1840012e4ce42dd 100644 (file)
--- 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: