From: Matt Birkholz Date: Sat, 21 Feb 2015 01:05:21 +0000 (-0700) Subject: smp: without-interrupts: gc.scm X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=967c2cd5961252cc738719287cbb928c3fd36d84;p=mit-scheme.git smp: without-interrupts: gc.scm --- diff --git a/README.txt b/README.txt index 1d2f75a11..fd41be916 100644 --- 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 2ef996395..263e911dd 100644 --- 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) (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")) (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 2fc1282a7..fb0bc315a 100644 --- 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)