From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 31 Jan 2015 00:45:44 +0000 (-0700)
Subject: smp: without-interrupts: ffi.scm
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cb27425f0a5099d46fa73219892f9aabc4eb5c42;p=mit-scheme.git

smp: without-interrupts: ffi.scm
---

diff --git a/README.txt b/README.txt
index e3dde9d56..dcb799724 100644
--- a/README.txt
+++ b/README.txt
@@ -1020,9 +1020,20 @@ The hits with accompanying analysis:
 	OK?  What is this?  Does it run in multiple threads?
 
   ffi.scm:316:  (without-interrupts
+	Caller: call-alien
   ffi.scm:371:	(without-interrupts
+	Caller: make-alien-to-free
   ffi.scm:391:	      (without-interrupts
+	Caller: free
   ffi.scm:422:  (without-interrupts
+	Caller: register-c-callback
+
+	OK.  Modifications to the registered-callbacks vector and
+	malloced aliens list are now serialized by mutexes.
+	Call-alien still uses without-interrupts.  It must avoid
+	preemption during a callback (which could cause another
+	thread, expecting to return from C_to_interface, to return
+	from the callback instead).
 
   floenv.scm:143:	(without-interrupts
   floenv.scm:156:	(without-interrupts
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index e21557078..8572955ae 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.
@@ -295,6 +295,11 @@ USA.
 (define-integrable (c-poke-bytes alien offset count buffer start)
   ((ucode-primitive c-poke-bytes 5) alien offset count buffer start))
 
+(define-integrable (processor-id)
+  (if enable-smp?
+      ((ucode-primitive smp-id 0))
+      0))
+
 (define (c-enum-name value enum-name constants)
   enum-name
   (let loop ((consts constants))
@@ -315,45 +320,29 @@ USA.
    args)
   (without-interrupts
    (lambda ()
-     (call-alien* alien-function args))))
-
-(define (call-alien* alien-function args)
-  (let ((old-top calloutback-stack))
-    (%if-tracing
-     (outf-error ";"(tindent)"=> "alien-function" "args"\n")
-     (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")
-       (set! calloutback-stack old-top)
-       (outf-error ";"(tindent)"<= "value"\n"))
-      value)))
+     (let* ((id (processor-id))
+	    (old-top (vector-ref calloutback-stacks id)))
+       (%trace ";"(tindent id)"=> "alien-function" "args)
+       (vector-set! calloutback-stacks id
+		    (cons (cons alien-function args) old-top))
+       (let ((value (apply (ucode-primitive c-call -1) alien-function args)))
+	 (%assert (eq? id (processor-id))
+		  "call-alien: slipped processors")
+	 (%assert (eq? old-top (cdr (vector-ref calloutback-stacks id)))
+		  "call-alien: freak stack "(vector-ref calloutback-stacks id))
+	 (vector-set! calloutback-stacks id old-top)
+	 (%trace ";"(tindent id)"<= "value)
+	 value)))))
 
 
 ;;; Malloc/Free
 
 ;; Weak alist of: ( malloc alien X copy for c-free )...
 (define malloced-aliens '())
-
-(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))))))
+(define malloced-aliens-mutex)
 
 (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)))
@@ -363,12 +352,31 @@ USA.
 	  (loop (cdr aliens)))))
   (set! malloced-aliens '()))
 
+(define (free-malloced-aliens)
+  (with-thread-mutex-locked 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 (make-alien-to-free ctype init)
   ;; Register BEFORE initializing (allocating).
   (let ((alien (make-alien ctype)))
     (let ((copy (make-alien ctype)))
       (let ((entry (weak-cons alien copy)))
-	(without-interrupts
+	(with-thread-mutex-locked malloced-aliens-mutex
 	 (lambda ()
 	   (set! malloced-aliens (cons entry malloced-aliens)))))
       (init copy)
@@ -388,7 +396,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-locked malloced-aliens-mutex
 	       (lambda ()
 		 (if (not (alien-null? alien))
 		     (begin
@@ -410,16 +418,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-locked registered-callbacks-mutex
    (lambda ()
      (let ((id first-free-id))
        (set! first-free-id (next-free-id (1+ id)))
@@ -439,11 +449,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-locked 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
@@ -461,23 +473,27 @@ USA.
   ;; by a callback trampoline.  The callout should have already masked
   ;; all but the GC interrupts.
 
+  (%assert (fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok))
+	   "callback-handler: can be interrupted")
   (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)
-    (let ((old-top calloutback-stack))
-      (%if-tracing
-       (outf-error ";"(tindent)"=>> "procedure" "args"\n")
-       (set! calloutback-stack (cons (cons procedure args) old-top)))
+    (let* ((id (processor-id))
+	   (old-top (vector-ref calloutback-stacks id)))
+      (%trace ";"(tindent id)"=>> "procedure" "args)
+      (vector-set! calloutback-stacks id (cons (cons procedure args) old-top))
       (let ((value (apply-callback-proc procedure args)))
-	(%if-tracing
-	 (%assert (and (pair? calloutback-stack)
-		       (eq? old-top (cdr calloutback-stack)))
-		  "callback-handler: freak stack "calloutback-stack"\n")
-	 (set! calloutback-stack old-top)
-	 (outf-error ";"(tindent)"<<= "value"\n"))
+	(%assert (eq? id (processor-id))
+		 "callback-handler: slipped processors")
+	(%assert (and (pair? (vector-ref calloutback-stacks id))
+		      (eq? old-top (cdr (vector-ref calloutback-stacks id))))
+		 "callback-handler: freak stack "
+		 (vector-ref calloutback-stacks id))
+	(vector-set! calloutback-stacks id old-top)
+	(%trace ";"(tindent id)"<<= "value)
 	value))))
 
 (define (apply-callback-proc procedure args)
@@ -563,7 +579,7 @@ USA.
 			       kernel)))))
 
 
-(define calloutback-stack '())
+(define calloutback-stacks)
 
 (define %trace? #f)
 
@@ -573,7 +589,7 @@ USA.
   (reset-callbacks!)
   (set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
   (set! %trace? #f)
-  (set! calloutback-stack '()))
+  (set! calloutback-stacks (make-vector processor-count '())))
 
 (define (initialize-package!)
   (reset-package!)
@@ -582,12 +598,6 @@ USA.
   (add-gc-daemon! free-malloced-aliens)
   unspecific)
 
-(define-syntax %if-tracing
-  (syntax-rules ()
-    ((_ BODY ...)
-     (if %trace?
-	 (begin BODY ...)))))
-
 (define-syntax %assert
   (syntax-rules ()
     ((_ TEST MSG ...)
@@ -598,7 +608,7 @@ USA.
   (syntax-rules ()
     ((_ MSG ...)
      (if %trace?
-	 (outf-error MSG ...)))))
+	 (outf-error MSG ... "\n")))))
 
-(define (tindent)
-  (make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file
+(define (tindent id)
+  (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a937dd7e8..1e3043053 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3301,6 +3301,9 @@ USA.
 (define-package (runtime ffi)
   (parent (runtime))
   (files "ffi")
+  (import (runtime thread)
+	  enable-smp?
+	  processor-count)
   (export ()
 	  make-alien
 	  copy-alien