From: Matt Birkholz Date: Tue, 24 Feb 2015 23:25:42 +0000 (-0700) Subject: smp: without-interrupts: hashtb.scm X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7f0c85a0b9d14958f8c308d12670bf100301cf55;p=mit-scheme.git smp: without-interrupts: hashtb.scm --- diff --git a/README.txt b/README.txt index 4ace9794d..3ea117383 100644 --- a/README.txt +++ b/README.txt @@ -1181,7 +1181,24 @@ The hits with accompanying analysis: weak and key weak hash table types. hashtb.scm:1381: (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + Caller: with-table-locked! hashtb.scm:1383: (set-interrupt-enables! interrupt-mask) + Caller: with-table-locked! + + OK. The luser is charged with serializing accesses (not just + modification, because of lazy rehashing). Locking at this + level seems over-the-top, especially RIGHT after locking up + the default-hash-table (above), which uses two of these hash + tables to implement object-hash and object-unhash. Any + locking added here would be superfluous to the locking now + performed there. + + A mutex WAS added to serialize access to the weak list of + address-hash-tables, as in geneqht.scm. + + No other changes to hashtb.scm are considered necessary, + except to make explicit that the former with-table-locked! + wrappers are now all about staving off inopportune aborts. infutl.scm:90: (without-interrupts infutl.scm:98: (without-interrupts diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm index 946a6d85a..ebcfa88b8 100644 --- a/src/runtime/hashtb.scm +++ b/src/runtime/hashtb.scm @@ -107,7 +107,7 @@ USA. (set-table-initial-size-in-effect?! table #t))) (reset-table! table) (if (table-type-rehash-after-gc? type) - (set! address-hash-tables (weak-cons table address-hash-tables))) + (record-address-hash-table! table))) table))) (define (hash-table/type table) @@ -151,7 +151,7 @@ USA. (define (hash-table/clean! table) (guarantee-hash-table table 'HASH-TABLE/CLEAN!) - (with-table-locked! table + (without-interruption (lambda () ((table-type-method:clean! (table-type table)) table) (maybe-shrink-table! table)))) @@ -199,7 +199,7 @@ USA. (<= x 1))) "real number between 0 (exclusive) and 1 (inclusive)" 'SET-HASH-TABLE/REHASH-THRESHOLD!))) - (with-table-locked! table + (without-interruption (lambda () (set-table-rehash-threshold! table threshold) (new-size! table (table-grow-size table)))))) @@ -219,7 +219,7 @@ USA. (else #f))) "real number > 1 or exact integer >= 1" 'SET-HASH-TABLE/REHASH-SIZE!))) - (with-table-locked! table + (without-interruption (lambda () (set-table-rehash-size! table size) (reset-shrink-size! table) @@ -241,7 +241,7 @@ USA. (define (hash-table/clear! table) (guarantee-hash-table table 'HASH-TABLE/CLEAR!) - (with-table-locked! table + (without-interruption (lambda () (if (not (table-initial-size-in-effect? table)) (set-table-grow-size! table minimum-size)) @@ -623,13 +623,13 @@ USA. (declare (integrate key* barrier)) (if (key=? key* key) (begin - (with-table-locked! table + (without-interruption (lambda () (set-entry-datum! entry-type (car p) datum))) (barrier)) (loop (cdr p) p))) (lambda () (loop (cdr p) p))) - (with-table-locked! table + (without-interruption (lambda () (let ((r (cons (make-entry entry-type key datum) '()))) (if q @@ -650,7 +650,7 @@ USA. (declare (integrate key* datum barrier)) (if (key=? key* key) (let ((datum* (procedure datum))) - (with-table-locked! table + (without-interruption (lambda () (set-entry-datum! entry-type (car p) datum*))) (barrier) @@ -658,7 +658,7 @@ USA. (loop (cdr p) p))) (lambda () (loop (cdr p) p))) (let ((datum (procedure default))) - (with-table-locked! table + (without-interruption (lambda () (let ((r (cons (make-entry entry-type key datum) '()))) (if q @@ -679,7 +679,7 @@ USA. (lambda (key* barrier) (declare (integrate key*) (ignore barrier)) (if (key=? key* key) - (with-table-locked! table + (without-interruption (lambda () (if q (set-cdr! q (cdr p)) @@ -948,7 +948,7 @@ USA. (error:datum-out-of-range object))) (define (rehash-table! table) - (with-table-locked! table + (without-interruption (lambda () (let ((entries (extract-table-entries! table))) (set-table-needs-rehash?! table #f) @@ -1322,7 +1322,7 @@ USA. (define (hash-table-copy table) (guarantee-hash-table table 'HASH-TABLE-COPY) - (with-table-locked! table + (without-interruption (lambda () (let ((table* (copy-table table)) (type (table-type table))) @@ -1330,7 +1330,7 @@ USA. (vector-map (table-type-method:copy-bucket type) (table-buckets table))) (if (table-type-rehash-after-gc? type) - (set! address-hash-tables (weak-cons table* address-hash-tables))) + (record-address-hash-table! table*)) table*)))) (define (hash-table-merge! table1 table2) @@ -1352,12 +1352,28 @@ USA. ;;;; Miscellany (define address-hash-tables) +(define address-hash-tables-mutex) (define (initialize-address-hash-tables!) (set! address-hash-tables '()) + (set! address-hash-tables-mutex (make-thread-mutex)) (add-primitive-gc-daemon! mark-address-hash-tables!) unspecific) +(define (record-address-hash-table! table) + (with-thread-mutex-locked address-hash-tables-mutex + (lambda () + (set! address-hash-tables (weak-cons table address-hash-tables)) + unspecific))) + +;; Mark-address-hash-tables! might run during record-address-hash- +;; table! (in the primitive GC daemon) and thus modify the address- +;; hash-tables list (splicing out pairs whose weak cars have turned to +;; #f). The set! in record-address-hash-table! may then write the old +;; value, before the splice, restoring the old pairs behind the new +;; one. Fortunately no harm is done. The cars of the restored pairs +;; are all #f and will be spliced out again eventually. + (define (mark-address-hash-tables!) (let loop ((previous #f) (tables address-hash-tables)) (if (system-pair? tables) @@ -1368,7 +1384,7 @@ USA. (begin (if previous (system-pair-set-cdr! previous (system-pair-cdr tables)) - (set! address-hash-tables (system-pair-cdr tables))) + (set! address-hash-tables (system-pair-cdr tables))) (loop previous (system-pair-cdr tables))))))) (define (check-arg object default predicate description procedure) @@ -1376,12 +1392,7 @@ USA. ((not object) default) (else (error:wrong-type-argument object description procedure)))) -(define-integrable (with-table-locked! table thunk) - (declare (ignore table)) - (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (let ((value (thunk))) - (set-interrupt-enables! interrupt-mask) - value))) +(define-integrable without-interruption with-thread-events-blocked) (define default-marker (list 'DEFAULT-MARKER))