From 75d9088c26f9708a8da8751f15caa0623993b387 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 16 Jun 2015 19:26:59 -0700
Subject: [PATCH] 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.
---
 src/runtime/ffi.scm | 62 +++++++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 27 deletions(-)

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index e21557078..31a38ba12 100644
--- 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))))
-- 
2.25.1