From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 19 Jun 2015 20:04:04 +0000 (-0700)
Subject: Remove without-interrupts from runtime/queue.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~34
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=060a46076fcdb21b0d25b1e18ef16aaf8211c732;p=mit-scheme.git

Remove without-interrupts from runtime/queue.scm.

Add make-serial-queue and use it in runtime globals: the event
distributors, GC daemons and REPLs.  Note that the "safe" queue
operations, when applied to non-serializing queues in SMPing worlds,
are NOT thread-safe.  This only happens in LIAR, SWAT, Edwin, X11
Graphics and OS2 Graphics -- single-threaded applications.
---

diff --git a/src/runtime/events.scm b/src/runtime/events.scm
index 6be93e1fd..691842c95 100644
--- a/src/runtime/events.scm
+++ b/src/runtime/events.scm
@@ -37,7 +37,7 @@ USA.
 (define-structure (event-distributor
 		   (constructor make-event-distributor ())
 		   (conc-name event-distributor/))
-  (events (make-queue))
+  (events (make-serial-queue))
   (lock false)
   (receivers '()))
 
diff --git a/src/runtime/gcdemn.scm b/src/runtime/gcdemn.scm
index 12e0e95d5..2739c263f 100644
--- a/src/runtime/gcdemn.scm
+++ b/src/runtime/gcdemn.scm
@@ -30,15 +30,20 @@ USA.
 (declare (usual-integrations))
 
 (define (initialize-package!)
-  (set! primitive-gc-daemons (make-queue))
+  (set! primitive-gc-daemons (make-serial-queue))
   (set! trigger-primitive-gc-daemons! (make-trigger primitive-gc-daemons))
   (set! add-primitive-gc-daemon! (make-adder primitive-gc-daemons))
-  (set! gc-daemons (make-queue))
+  (set! add-primitive-gc-daemon!/unsafe
+	(make-adder/unsafe primitive-gc-daemons))
+  (set! gc-daemons (make-serial-queue))
   (set! trigger-gc-daemons! (make-trigger gc-daemons))
   (set! add-gc-daemon! (make-adder gc-daemons))
-  (set! secondary-gc-daemons (make-queue))
+  (set! add-gc-daemon!/unsafe (make-adder/unsafe gc-daemons))
+  (set! secondary-gc-daemons (make-serial-queue))
   (set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
   (set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
+  (set! add-secondary-gc-daemon!/unsafe
+	(make-adder/unsafe secondary-gc-daemons))
   (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
     (vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
     ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
@@ -49,6 +54,7 @@ USA.
 (define primitive-gc-daemons)
 (define trigger-primitive-gc-daemons!)
 (define add-primitive-gc-daemon!)
+(define add-primitive-gc-daemon!/unsafe)
 
 ;;; GC-DAEMONS are executed after each GC from an interrupt handler.
 ;;; This interrupt handler has lower priority than the GC interrupt,
@@ -58,6 +64,7 @@ USA.
 (define gc-daemons)
 (define trigger-gc-daemons!)
 (define add-gc-daemon!)
+(define add-gc-daemon!/unsafe)
 (define (add-gc-daemon!/no-restore daemon)
   (add-gc-daemon!
    (lambda ()
@@ -70,6 +77,7 @@ USA.
 (define secondary-gc-daemons)
 (define trigger-secondary-gc-daemons!)
 (define add-secondary-gc-daemon!)
+(define add-secondary-gc-daemon!/unsafe)
 
 (define (make-trigger daemons)
   (lambda ()
@@ -80,6 +88,10 @@ USA.
   (lambda (daemon)
     (enqueue! daemons daemon)))
 
+(define (make-adder/unsafe daemons)
+  (lambda (daemon)
+    (enqueue!/unsafe daemons daemon)))
+
 (define (gc-clean #!optional threshold)
   (let ((threshold
 	 (cond ((default-object? threshold) 100)
diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm
index 95dda1184..0455f691d 100644
--- a/src/runtime/poplat.scm
+++ b/src/runtime/poplat.scm
@@ -34,7 +34,7 @@ USA.
 
 (define (initialize-package!)
   (set! population-of-populations (list population-tag (make-thread-mutex)))
-  (add-secondary-gc-daemon! clean-all-populations!))
+  (add-secondary-gc-daemon!/unsafe clean-all-populations!))
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! population-tag
diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm
index e4e9e360f..f61cb46ad 100644
--- a/src/runtime/prop1d.scm
+++ b/src/runtime/prop1d.scm
@@ -31,7 +31,7 @@ USA.
 
 (define (initialize-package!)
   (set! population-of-1d-tables (make-serial-population/unsafe))
-  (add-secondary-gc-daemon! clean-1d-tables!))
+  (add-secondary-gc-daemon!/unsafe clean-1d-tables!))
 
 (define (initialize-unparser!)
   (unparser/set-tagged-pair-method! 1d-table-tag
diff --git a/src/runtime/queue.scm b/src/runtime/queue.scm
index bf9d0527a..5d646b883 100644
--- a/src/runtime/queue.scm
+++ b/src/runtime/queue.scm
@@ -30,31 +30,34 @@ USA.
 (declare (usual-integrations))
 
 (define-integrable (make-queue)
-  (cons '() '()))
+  (cons* #f '() '()))
+
+(define-integrable (make-serial-queue)
+  (cons* (make-thread-mutex) '() '()))
 
 (define-integrable (queue-empty? queue)
-  (not (pair? (car queue))))
+  (not (pair? (cadr queue))))
 
 (define-integrable (queued?/unsafe queue item)
-  (memq item (car queue)))
+  (memq item (cadr queue)))
 
 (define (enqueue!/unsafe queue object)
   (let ((next (cons object '())))
-    (if (pair? (cdr queue))
-	(set-cdr! (cdr queue) next)
-	(set-car! queue next))
-    (set-cdr! queue next)
+    (if (pair? (cddr queue))
+	(set-cdr! (cddr queue) next)
+	(set-car! (cdr queue) next))
+    (set-cdr! (cdr queue) next)
     unspecific))
 
 (define (dequeue!/unsafe queue)
-  (let ((next (car queue)))
+  (let ((next (cadr queue)))
     (if (not (pair? next))
 	(error "Attempt to dequeue from empty queue"))
     (if (pair? (cdr next))
-	(set-car! queue (cdr next))
+	(set-car! (cdr queue) (cdr next))
 	(begin
-	  (set-car! queue '())
-	  (set-cdr! queue '())))
+	  (set-car! (cdr queue) '())
+	  (set-cdr! (cdr queue) '())))
     (car next)))
 
 (define (queue-map!/unsafe queue procedure)
@@ -65,24 +68,33 @@ USA.
 	  (loop)))))
 
 (define-integrable (queue->list/unsafe queue)
-  (car queue))
+  (cadr queue))
+
+;;; Safe versions of the above operations (when used on a serializing
+;;; queue).
 
-;;; Safe (interrupt locked) versions of the above operations.
+(define-integrable (with-queue-lock queue thunk)
+  (let ((mutex (car queue)))
+    (if mutex
+	(with-thread-mutex-lock mutex
+	  (lambda ()
+	    (without-interruption thunk)))
+	(without-interruption thunk))))
 
 (define-integrable (queued? queue item)
-  (without-interrupts (lambda () (queued?/unsafe queue item))))
+  (with-queue-lock queue (lambda () (queued?/unsafe queue item))))
 
 (define-integrable (enqueue! queue object)
-  (without-interrupts (lambda () (enqueue!/unsafe queue object))))
+  (with-queue-lock queue (lambda () (enqueue!/unsafe queue object))))
 
 (define-integrable (dequeue! queue)
-  (without-interrupts (lambda () (dequeue!/unsafe queue))))
+  (with-queue-lock queue (lambda () (dequeue!/unsafe queue))))
 
 (define (queue-map! queue procedure)
   (let ((empty (list 'EMPTY)))
     (let loop ()
       (let ((item
-	     (without-interrupts
+	     (with-queue-lock queue
 	      (lambda ()
 		(if (queue-empty? queue)
 		    empty
@@ -93,6 +105,6 @@ USA.
 	      (loop)))))))
 
 (define (queue->list queue)
-  (without-interrupts
+  (with-queue-lock queue
     (lambda ()
       (list-copy (queue->list/unsafe queue)))))
\ No newline at end of file
diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 9ea3cf0ed..65c86f072 100644
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -677,7 +677,7 @@ USA.
   (condition #f read-only #t)
   (reader-history (make-repl-history repl-reader-history-size))
   (printer-history (make-repl-history repl-printer-history-size))
-  (input-queue (make-queue) read-only #t))
+  (input-queue (make-serial-queue) read-only #t))
 
 (define (repl? object)
   (and (cmdl? object)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 260d23022..2e4db73bf 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -583,6 +583,7 @@ USA.
   (parent (runtime))
   (export ()
 	  make-queue
+	  make-serial-queue
 	  queue-empty?
 	  queued?/unsafe
 	  enqueue!/unsafe
@@ -1133,6 +1134,8 @@ USA.
   (import (runtime population)
 	  make-serial-population/unsafe
 	  add-to-population!/unsafe)
+  (import (runtime gc-daemons)
+	  add-secondary-gc-daemon!/unsafe)
   (initialization (initialize-package!)))
 
 (define-package (runtime 2d-property)
@@ -3182,6 +3185,8 @@ USA.
 (define-package (runtime population)
   (files "poplat")
   (parent (runtime))
+  (import (runtime gc-daemons)
+	  add-secondary-gc-daemon!/unsafe)
   (export ()
 	  add-to-population!
 	  empty-population!