From 99bc079890ecb736e14eefee6187432edaa90922 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 21 Feb 2015 11:10:31 -0700 Subject: [PATCH] smp: without-interrupts: gcfinal.scm --- README.txt | 13 +++ src/runtime/gcfinal.scm | 174 +++++++++++++++++++++------------------- src/runtime/make.scm | 9 ++- 3 files changed, 109 insertions(+), 87 deletions(-) diff --git a/README.txt b/README.txt index fd41be916..cb39dab51 100644 --- a/README.txt +++ b/README.txt @@ -1082,12 +1082,25 @@ The hits with accompanying analysis: enqueuers can be serialized in the usual way. gcfinal.scm:69: (without-interrupts + Caller: add-to-gc-finalizer! gcfinal.scm:89: (without-interrupts + Caller: remove-from-gc-finalizer! gcfinal.scm:111: (without-interrupts + Caller: remove-all-from-gc-finalizer! gcfinal.scm:129: (without-interrupts + Caller: search-gc-finalizer gcfinal.scm:140: (without-interrupts + Caller: gc-finalizer-elements gcfinal.scm:164: (without-interrupts + Caller: make-gc-finalized-object gcfinal.scm:180: (without-interrupts + Caller: reset-gc-finalizers + + OK. Replaced without-interrupts with with-thread-mutex- + locked. Added a thread-mutex to each finalizer, and one to + serialize access to the list of gc-finalizers. This required + changes to the bootstrap, which now loads/inits thread.scm + (and vector.scm and wind.scm) before gcfinal.scm. gdbm.scm:61: (without-interrupts diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm index b27e0eee3..18b0da65c 100644 --- a/src/runtime/gcfinal.scm +++ b/src/runtime/gcfinal.scm @@ -37,7 +37,8 @@ USA. (object? #f read-only #t) (object-context #f read-only #t) (set-object-context! #f read-only #t) - (items '())) + (mutex #f read-only #t) + items) (define (guarantee-gc-finalizer object procedure) (if (not (gc-finalizer? object)) @@ -56,8 +57,11 @@ USA. object? object-context set-object-context! + (make-thread-mutex) '()))) - (set! gc-finalizers (weak-cons finalizer gc-finalizers)) + (with-thread-mutex-locked gc-finalizers-mutex + (lambda () + (set! gc-finalizers (weak-cons finalizer gc-finalizers)))) finalizer)) (define (add-to-gc-finalizer! finalizer object) @@ -66,14 +70,14 @@ USA. (error:wrong-type-argument object "finalized object" 'ADD-TO-GC-FINALIZER!)) - (without-interrupts - (lambda () - (let ((context ((gc-finalizer-object-context finalizer) object))) - (if (not context) - (error:bad-range-argument object 'ADD-TO-GC-FINALIZER!)) - (set-gc-finalizer-items! finalizer - (cons (weak-cons object context) - (gc-finalizer-items finalizer)))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (let ((context ((gc-finalizer-object-context finalizer) object))) + (if (not context) + (error:bad-range-argument object 'ADD-TO-GC-FINALIZER!)) + (set-gc-finalizer-items! finalizer + (cons (weak-cons object context) + (gc-finalizer-items finalizer)))))) object) (define (remove-from-gc-finalizer! finalizer object) @@ -86,67 +90,67 @@ USA. (error:wrong-type-argument object "finalized object" 'REMOVE-FROM-GC-FINALIZER!)) - (without-interrupts - (lambda () - (let ((context (object-context object))) - (if (not context) - (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) - (let loop ((items (gc-finalizer-items finalizer)) (prev #f)) - (if (not (pair? items)) - (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) - (if (eq? object (weak-car (car items))) - (let ((next (cdr items))) - (if prev - (set-cdr! prev next) - (set-gc-finalizer-items! finalizer next)) - (set-object-context! object #f) - (procedure context)) - (loop (cdr items) items)))))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (let ((context (object-context object))) + (if (not context) + (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) + (let loop ((items (gc-finalizer-items finalizer)) (prev #f)) + (if (not (pair? items)) + (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!)) + (if (eq? object (weak-car (car items))) + (let ((next (cdr items))) + (if prev + (set-cdr! prev next) + (set-gc-finalizer-items! finalizer next)) + (set-object-context! object #f) + (procedure context)) + (loop (cdr items) items)))))))) (define (remove-all-from-gc-finalizer! finalizer) (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!) (let ((procedure (gc-finalizer-procedure finalizer)) (object-context (gc-finalizer-object-context finalizer)) (set-object-context! (gc-finalizer-set-object-context! finalizer))) - (without-interrupts - (lambda () - (let loop () - (let ((items (gc-finalizer-items finalizer))) - (if (pair? items) - (let ((item (car items))) - (set-gc-finalizer-items! finalizer (cdr items)) - (let ((object (weak-car item))) - (let ((context (object-context object))) - (if context - (begin - (if object - (set-object-context! object #f)) - (procedure context))))) - (loop))))))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (let loop () + (let ((items (gc-finalizer-items finalizer))) + (if (pair? items) + (let ((item (car items))) + (set-gc-finalizer-items! finalizer (cdr items)) + (let ((object (weak-car item))) + (let ((context (object-context object))) + (if context + (begin + (if object + (set-object-context! object #f)) + (procedure context))))) + (loop))))))))) (define (search-gc-finalizer finalizer predicate) (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER) - (without-interrupts - (lambda () - (let loop ((items (gc-finalizer-items finalizer))) - (and (pair? items) - (let ((object (weak-car (car items)))) - (if (and object (predicate object)) - object - (loop (cdr items))))))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (let loop ((items (gc-finalizer-items finalizer))) + (and (pair? items) + (let ((object (weak-car (car items)))) + (if (and object (predicate object)) + object + (loop (cdr items))))))))) (define (gc-finalizer-elements finalizer) (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS) - (without-interrupts - (lambda () - (let loop ((items (gc-finalizer-items finalizer)) (objects '())) - (if (pair? items) - (loop (cdr items) - (let ((object (weak-car (car items)))) - (if object - (cons object objects) - objects))) - (reverse! objects)))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (let loop ((items (gc-finalizer-items finalizer)) (objects '())) + (if (pair? items) + (loop (cdr items) + (let ((object (weak-car (car items)))) + (if object + (cons object objects) + objects))) + (reverse! objects)))))) (define (make-gc-finalized-object finalizer get-context context->object) ;; A bunch of hair to permit microcode descriptors be opened with @@ -161,12 +165,12 @@ USA. (get-context p) (let ((context (weak-cdr p))) (let ((object (context->object context))) - (without-interrupts - (lambda () - (weak-set-car! p object) - (set-gc-finalizer-items! - finalizer - (cons p (gc-finalizer-items finalizer))))) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (weak-set-car! p object) + (set-gc-finalizer-items! + finalizer + (cons p (gc-finalizer-items finalizer))))) object))) (lambda () (if (and (not (weak-pair/car? p)) (weak-cdr p)) @@ -174,14 +178,15 @@ USA. ((gc-finalizer-procedure finalizer) (weak-cdr p)) (weak-set-cdr! p #f))))))) -(define gc-finalizers) +(define gc-finalizers '()) +(define gc-finalizers-mutex (make-thread-mutex)) (define (reset-gc-finalizers) - (without-interrupts - (lambda () - (walk-gc-finalizers-list - (lambda (finalizer) - (set-gc-finalizer-items! finalizer '())))))) + (walk-gc-finalizers-list + (lambda (finalizer) + (with-thread-mutex-locked (gc-finalizer-mutex finalizer) + (lambda () + (set-gc-finalizer-items! finalizer '())))))) (define (run-gc-finalizers) (walk-gc-finalizers-list @@ -200,21 +205,22 @@ USA. (loop next prev))))))))) (define (walk-gc-finalizers-list procedure) - (let loop ((finalizers gc-finalizers) (prev #f)) - (if (weak-pair? finalizers) - (let ((finalizer (weak-car finalizers))) - (if finalizer - (begin - (procedure finalizer) - (loop (weak-cdr finalizers) finalizers)) - (let ((next (weak-cdr finalizers))) - (if prev - (weak-set-cdr! prev next) - (set! gc-finalizers next)) - (loop next prev))))))) + (with-thread-mutex-locked gc-finalizers-mutex + (lambda () + (let loop ((finalizers gc-finalizers) (prev #f)) + (if (weak-pair? finalizers) + (let ((finalizer (weak-car finalizers))) + (if finalizer + (begin + (procedure finalizer) + (loop (weak-cdr finalizers) finalizers)) + (let ((next (weak-cdr finalizers))) + (if prev + (weak-set-cdr! prev next) + (set! gc-finalizers next)) + (loop next prev))))))))) (define (initialize-package!) - (set! gc-finalizers '()) (add-gc-daemon! run-gc-finalizers)) (define (initialize-events!) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index fb0bc315a..a6220ac74 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -374,8 +374,12 @@ USA. ("prop1d" . (RUNTIME 1D-PROPERTY)) ("events" . (RUNTIME EVENT-DISTRIBUTOR)) ("gdatab" . (RUNTIME GLOBAL-DATABASE)) + ("vector" . (RUNTIME VECTOR)) + ("thread" . (RUNTIME THREAD)) + ("wind" . (RUNTIME WIND)) ("gcfinal" . (RUNTIME GC-FINALIZER)) - ("string" . (RUNTIME STRING)))) + ("string" . (RUNTIME STRING)) ; First GC-finalizer. + )) (load-files (lambda (files) (do ((files files (cdr files))) @@ -396,6 +400,7 @@ USA. (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t) (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t) (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t) + (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) (package-initialize '(RUNTIME GC-FINALIZER) #f #t) (package-initialize '(RUNTIME STRING) #f #t) @@ -431,8 +436,6 @@ USA. '( ;; Microcode interface ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!) - ((RUNTIME THREAD) INITIALIZE-LOW!) - (RUNTIME WIND) (RUNTIME APPLY) (RUNTIME HASH) ; First GC daemon! (RUNTIME PRIMITIVE-IO) -- 2.25.1