From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 23 Jun 2015 18:42:13 +0000 (-0700)
Subject: Remove with-absolutely-no-interrupts from runtime/gc.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~47
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4781c478630f3c19373aea69cca3d2efac8154ee;p=mit-scheme.git

Remove with-absolutely-no-interrupts from runtime/gc.scm.

Default/purify and default/gc-flip modified the constant-space-queue
under the cover of with-absolutely-no-interrupts, which is no longer
atomic.  Serializing these procedures is a trick because the latter is
invoked by the GC interrupt.  (Thus ABSOLUTELY no interrupts were
allowed?)

But there is no need for default/gc-flip to remove items from the
queue.  Flush-purification-queue! will know that its queue is "empty"
when its head is in constant space.  Thus the interrupt no longer
modifies the queue, and the queuing process is serialized in the usual
way.

Since primitive-purify cannot fail for lack of space, ancient error
signals and retry loops are also eliminated.
---

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 2ef996395..6693fcc60 100644
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -36,7 +36,8 @@ USA.
   (set! hook/stack-overflow default/stack-overflow)
   (set! hook/hardware-trap default/hardware-trap)
   (set! default-safety-margin 4500)
-  (set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
+  (set! constant-space-queue '())
+  (set! constant-space-queue-mutex (make-thread-mutex))
   (set! hook/gc-start default/gc-start)
   (set! hook/gc-finish default/gc-finish)
   (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
@@ -67,49 +68,21 @@ USA.
 (define default-safety-margin)
 
 (define (default/gc-flip safety-margin)
-  (let ((try-queue
-	 (lambda (queue pure?)
-	   (let ((items (cdr queue)))
-	     (and (pair? items)
-		  (let ((result
-			 (purify-internal (if (pair? (cdr items))
-					      items
-					      (car items))
-					  pure?
-					  safety-margin)))
-		    (and (pair? result)
-			 (begin
-			   (if (car result)
-			       (set-cdr! queue '())
-			       (begin
-				 (set-cdr! queue (cdr items))
-				 (queued-purification-failure)))
-			   (cdr result)))))))))
-    (or (try-queue constant-space-queue #f)
-	(gc-flip-internal safety-margin))))
-
-(define (queued-purification-failure)
-  (warn "Unable to purify all queued items; dequeuing one."))
+  (if (and (not (eq? '() constant-space-queue))
+	   (not (object-constant? constant-space-queue)))
+      (purify-internal constant-space-queue safety-margin)
+      (gc-flip-internal safety-margin)))
 
 (define (default/purify item pure-space? queue?)
   pure-space?
-  (if (not (object-constant? item))
+  (if (and (not (eq? 'NON-POINTER (object-gc-type item)))
+	   (not (object-constant? item)))
       (if queue?
-	  (with-absolutely-no-interrupts
+	  (with-thread-mutex-lock constant-space-queue-mutex
 	    (lambda ()
-	      (set-cdr! constant-space-queue
-			(cons item (cdr constant-space-queue)))
+	      (set! constant-space-queue (cons item constant-space-queue))
 	      unspecific))
-	  (let loop ()
-	    (let ((result
-		   (purify-internal item #f default-safety-margin)))
-	      (cond ((not (pair? result))
-		     ;; Wrong phase -- try again.
-		     (gc-flip)
-		     (loop))
-		    ((not (car result))
-		     (error "PURIFY: not enough room in constant space"
-			    item))))))))
+	  (purify-internal item default-safety-margin))))
 
 (define (default/stack-overflow)
   (abort->nearest "Aborting!: maximum recursion depth exceeded"))
@@ -119,6 +92,7 @@ USA.
   (abort->nearest "Aborting!: the hardware trapped"))
 
 (define constant-space-queue)
+(define constant-space-queue-mutex)
 (define hook/gc-start)
 (define hook/gc-finish)
 
@@ -128,14 +102,12 @@ USA.
       (gc-finish start-value space-remaining)
       space-remaining)))
 
-(define (purify-internal item pure-space? safety-margin)
-  pure-space?
+(define (purify-internal item safety-margin)
   (let ((start-value (hook/gc-start)))
     (let ((result
 	   ((ucode-primitive primitive-purify) item #f safety-margin)))
-      (if result
-	  (gc-finish start-value (cdr result)))
-      result)))
+      (gc-finish start-value (cdr result))
+      (cdr result))))
 
 (define (default/gc-start)
   #f)
@@ -188,10 +160,9 @@ USA.
 		       safety-margin)))))
 
 (define (flush-purification-queue!)
-  (if (pair? (cdr constant-space-queue))
-      (begin
-	(gc-flip)
-	(flush-purification-queue!))))
+  (if (and (not (eq? '() constant-space-queue))
+	   (not (object-constant? constant-space-queue)))
+      (gc-flip)))
 
 (define (purify item #!optional pure-space? queue?)
   ;; Purify an item -- move it into pure space and clean everything by