Remove without-interrupts from runtime/ffi.scm (mostly).

Modifications to the registered-callbacks vector and the malloced
aliens list are now serialized by mutexes.  Call-alien still needs
without-interrupts.  It must avoid preemption during a callback.

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index e2155707838f3666525795b3d09e6dd137bc498f..31a38ba129d3032a78934083970c855ae303f6ae 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -200,7 +200,7 @@ USA.
   ;; Caseful symbol or list, e.g. (* |GtkWidget|).
   return-type
 
-  ;; Alist of parameter names * types, e.g. ((widget (* |GtkWidget|))...)
+  ;; Alist of parameter names * types, e.g. ((widget . (* |GtkWidget|))...)
   parameters
 
   ;; Filename from which the EXTERN declaration was read.
@@ -321,11 +321,11 @@ USA.
   (let ((old-top calloutback-stack))
     (%if-tracing
      (outf-error ";"(tindent)"=> "alien-function" "args"\n")
-     (set! calloutback-stack (cons (cons* alien-function args) old-top)))
+     (set! calloutback-stack (cons (cons alien-function args) old-top)))
     (let ((value (apply (ucode-primitive c-call -1) alien-function args)))
       (%if-tracing
        (%assert (eq? old-top (cdr calloutback-stack))
-               "call-alien: freak stack "calloutback-stack"\n")
+               "call-alien: freak stack" calloutback-stack)
        (set! calloutback-stack old-top)
        (outf-error ";"(tindent)"<= "value"\n"))
       value)))
@@ -335,25 +335,29 @@ USA.
 
 ;; Weak alist of: ( malloc alien X copy for c-free )...
 (define malloced-aliens '())
+(define malloced-aliens-mutex)
 
 (define (free-malloced-aliens)
-  (let loop ((aliens malloced-aliens)
-            (prev #f))
-    (if (pair? aliens)
-       (if (weak-pair/car? (car aliens))
-           (loop (cdr aliens) aliens)
-           (let ((copy (weak-cdr (car aliens)))
-                 (next (cdr aliens)))
-             (if prev
-                 (set-cdr! prev next)
-                 (set! malloced-aliens next))
-             (if (not (alien-null? copy))
-                 (begin
-                   ((ucode-primitive c-free 1) copy)
-                   (alien-null! copy)))
-             (loop next prev))))))
+  (with-thread-mutex-lock malloced-aliens-mutex
+    (lambda ()
+      (let loop ((aliens malloced-aliens)
+                (prev #f))
+       (if (pair? aliens)
+           (if (weak-pair/car? (car aliens))
+               (loop (cdr aliens) aliens)
+               (let ((copy (weak-cdr (car aliens)))
+                     (next (cdr aliens)))
+                 (if prev
+                     (set-cdr! prev next)
+                     (set! malloced-aliens next))
+                 (if (not (alien-null? copy))
+                     (begin
+                       ((ucode-primitive c-free 1) copy)
+                       (alien-null! copy)))
+                 (loop next prev))))))))
 
 (define (reset-malloced-aliens!)
+  (set! malloced-aliens-mutex (make-thread-mutex))
   (let loop ((aliens malloced-aliens))
     (if (pair? aliens)
        (let ((alien (weak-car (car aliens)))
@@ -368,7 +372,7 @@ USA.
   (let ((alien (make-alien ctype)))
     (let ((copy (make-alien ctype)))
       (let ((entry (weak-cons alien copy)))
-       (without-interrupts
+       (with-thread-mutex-lock malloced-aliens-mutex
         (lambda ()
           (set! malloced-aliens (cons entry malloced-aliens)))))
       (init copy)
@@ -388,7 +392,7 @@ USA.
        (if (not weak)
            (warn "Cannot free an alien that was not malloced:" alien)
            (let ((copy (weak-cdr weak)))
-             (without-interrupts
+             (with-thread-mutex-lock malloced-aliens-mutex
               (lambda ()
                 (if (not (alien-null? alien))
                     (begin
@@ -410,16 +414,18 @@ USA.
 ;;; Callback support
 
 (define registered-callbacks)
+(define registered-callbacks-mutex)
 (define first-free-id)
 
 (define (reset-callbacks!)
   (set! registered-callbacks (make-vector 100 #f))
+  (set! registered-callbacks-mutex (make-thread-mutex))
   (set! first-free-id 1))
 
 (define (register-c-callback procedure)
   (if (not (procedure? procedure))
       (error:wrong-type-argument procedure "a procedure" 'register-c-callback))
-  (without-interrupts
+  (with-thread-mutex-lock registered-callbacks-mutex
    (lambda ()
      (let ((id first-free-id))
        (set! first-free-id (next-free-id (1+ id)))
@@ -439,11 +445,13 @@ USA.
            (else (next-id (1+ id)))))))
 
 (define (de-register-c-callback id)
-  (vector-set! registered-callbacks id #f)
-  ;; Uncomment to recycle ids.
-  ;;(if (< id first-free-id)
-  ;;    (set! first-free-id id))
-  )
+  (with-thread-mutex-lock registered-callbacks-mutex
+   (lambda ()
+     (vector-set! registered-callbacks id #f)
+     ;; Uncomment to recycle ids.
+     (if (< id first-free-id)
+        (set! first-free-id id))
+     )))
 
 (define (normalize-aliens! args)
   ;; Any vectors among ARGS are assumed to be freshly-consed aliens
@@ -475,7 +483,7 @@ USA.
        (%if-tracing
         (%assert (and (pair? calloutback-stack)
                       (eq? old-top (cdr calloutback-stack)))
-                 "callback-handler: freak stack "calloutback-stack"\n")
+                 "callback-handler: freak stack" calloutback-stack)
         (set! calloutback-stack old-top)
         (outf-error ";"(tindent)"<<= "value"\n"))
        value))))