From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Wed, 30 May 2018 14:39:36 +0000 (-0700)
Subject: runtime/ffi: Do not dynamic-wind around callouts and callbacks.
X-Git-Tag: mit-scheme-pucked-gdbm-0.3.4~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ce193bc1e1b14e48dad8068e10ceaa28df57dea;p=mit-scheme.git

runtime/ffi: Do not dynamic-wind around callouts and callbacks.
---

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 64f6cf172..511c44261 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -370,9 +370,10 @@ USA.
    (lambda ()
      (without-interrupts
       (lambda ()
-	(flo:preserving-environment
-	 (lambda ()
-	   (call-alien* alien-function args))))))))
+	(let* ((saved (flo:environment))
+	       (value (call-alien* alien-function args)))
+	  (flo:set-environment! saved)
+	  value))))))
 
 #;(define-integrable (call-alien* alien-function args)
   (apply (ucode-primitive c-call -1) alien-function args))
@@ -529,15 +530,13 @@ USA.
   ;; by a callback trampoline.  The callout should have already masked
   ;; all but the GC interrupts.
 
-  (flo:with-default-environment
-   (lambda ()
-     (if (not (< id (vector-length registered-callbacks)))
-	 (error:bad-range-argument id 'apply-callback))
-     (let ((procedure (vector-ref registered-callbacks id)))
-       (if (not procedure)
-	   (error:bad-range-argument id 'apply-callback))
-       (normalize-aliens! args)
-       (callback-handler* procedure args)))))
+  (if (not (< id (vector-length registered-callbacks)))
+      (error:bad-range-argument id 'apply-callback))
+  (let ((procedure (vector-ref registered-callbacks id)))
+    (if (not procedure)
+	(error:bad-range-argument id 'apply-callback))
+    (normalize-aliens! args)
+    (callback-handler* procedure args)))
 
 #;(define-integrable (callback-handler* procedure args)
   (apply-callback-proc procedure args))