smp: without-interrupts: gc.scm

diff --git a/README.txt b/README.txt
index 1d2f75a110de2c9ba7bc9ef44371b7241125c4ac..fd41be916df22fdff29af16d6e4ef2ddcadca72f 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -1049,9 +1049,37 @@ The hits with accompanying analysis:
        when the thread timer is not running.
 
   gc.scm:56:  (set-interrupt-enables! interrupt-enables))
+       Caller: condition-handler/stack-overflow
   gc.scm:98:     (with-absolutely-no-interrupts
+       Caller: default/purify
   gc.scm:165:  ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
+       Caller: gc-finish
   gc.scm:184:  (with-absolutely-no-interrupts
+       Caller: gc-flip
+
+       OK.  Condition-handler/stack-overflow is just restoring an
+       interrupted machine's mask, and gc-finish is just requesting
+       an after-gc interrupt.  However, default/purify and gc-flip
+       hack the constant-space-queue under the cover of with-
+       absolutely-no-interrupts, which no longer guarantees
+       atomicity.
+
+       Getting default/purify and default/gc-flip to serialize their
+       accesses to the constant-space-queue is a trick because the
+       latter is invoked by the GC interrupt handler.  Perhaps this
+       is why ABSOLUTELY no interrupts were allowed.
+
+       But there is no need for default/gc-flip to remove items from
+       the queue.  The list can just keep growing.  Primitive-purify
+       can be applied to the list repeatedly and it will only move
+       the objects not already in constant space.  It will not even
+       scan a tail that was previously purified.  And flush-
+       purification-queue! can tell that the queue is "empty" when
+       its head is a constant object (per object-constant?).
+
+       Now that the interrupt does not modify the queue, and does not
+       need to grab a mutex or wait for an enqueuer to finish,
+       enqueuers can be serialized in the usual way.
 
   gcfinal.scm:69:  (without-interrupts
   gcfinal.scm:89:    (without-interrupts

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 2ef99639540e99ffcfe641b31e1fd54d312690cb..263e911ddcd404e815041c835f67f792a5cef71d 100644 (file)
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -36,7 +36,7 @@ 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! hook/gc-start default/gc-start)
   (set! hook/gc-finish default/gc-finish)
   (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
@@ -67,49 +67,21 @@ USA.
 (define default-safety-margin)
 \f
 (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."))
+  (or (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-locked 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 +91,7 @@ USA.
   (abort->nearest "Aborting!: the hardware trapped"))
 \f
 (define constant-space-queue)
+(define constant-space-queue-mutex)
 (define hook/gc-start)
 (define hook/gc-finish)
 
@@ -128,14 +101,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 +159,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

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 2fc1282a7a5245effb13e0de74d1d17a4e02f3b0..fb0bc315a68d45aee03c211d0265eada37b1abae 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -574,9 +574,9 @@ USA.
                      (fasload/update-debugging-info! object (car entry))
                      (load/purification-root object)))
                  fasload-purification-queue)))))))
-  (lexical-assignment (->environment '(RUNTIME GARBAGE-COLLECTOR))
-                     'GC-BOOT-LOADING?
-                     #f)
+  (let ((env (->environment '(RUNTIME GARBAGE-COLLECTOR))))
+    (lexical-assignment env 'GC-BOOT-LOADING? #f)
+    (lexical-assignment env 'CONSTANT-SPACE-QUEUE-MUTEX (make-thread-mutex)))
   (set! fasload-purification-queue)
   (newline console-output-port)
   (write-string "purifying..." console-output-port)