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
(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)
(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))))
(<= 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))))))
(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)
(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))
(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
(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)
(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
(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))
(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)
(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)))
(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)
;;;; 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)
(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)
((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))
projects / mit-scheme.git / commitdiff