;;;; Hash Tables
;;; package: (runtime hash-table)
-;;; Integration declarations are carefully placed in this file. If you
-;;; change anything here, make sure that everything expands the way it
-;;; should. In particular, the strong and weak entry accessors should
-;;; be completely open-coded in MAKE-STRONG-TYPE and MAKE-WEAK-TYPE, as
-;;; should the KEY-HASH and KEY=? procedures for strong and weak EQ and
-;;; EQV hash table types. None of the hash table methods should cons
-;;; closures, and we rely on integration declarations, not just Liar's
-;;; cleverness, to guarantee this.
-;;;
-;;; Furthermore, before making any changes, enable type and range
-;;; checks in the two places they are disabled, and run through the
-;;; code and test cases to check that everything is safe before
-;;; disabling them again.
-
(declare (usual-integrations))
\f
;;;; Structures
(define-structure (hash-table-type
(type-descriptor <hash-table-type>)
- (constructor make-table-type)
+ (constructor %make-table-type)
(conc-name table-type-))
(key-hash #f read-only #t)
(key=? #f read-only #t)
(declare (integrate-operator set-datum!))
(declare (ignore make valid? c-w-k c-w-k&d))
(set-datum! entry object))))
-\f
-;;;; Weak table type
-(define (weak-hash-table/constructor key-hash key=?
- #!optional rehash-after-gc?)
- (hash-table-constructor
- (make-weak-hash-table-type key-hash key=?
- (if (default-object? rehash-after-gc?)
- #f
- rehash-after-gc?))))
-
-(define (make-weak-hash-table-type key-hash key=? rehash-after-gc?)
- (guarantee-procedure-of-arity key-hash 2 'MAKE-WEAK-HASH-TABLE-TYPE)
- (guarantee-procedure-of-arity key=? 2 'MAKE-WEAK-HASH-TABLE-TYPE)
- (let ((key-hash (protected-key-hash key-hash)))
- (if rehash-after-gc?
- (make-weak-rehash-type key-hash key=?)
- (make-weak-no-rehash-type key-hash key=?))))
-
-(define (make-weak-rehash-type key-hash key=?)
- (declare (integrate-operator key-hash key=?))
- (make-weak-type key-hash key=? #t (compute-address-hash key-hash)))
-
-(define (make-weak-no-rehash-type key-hash key=?)
- (declare (integrate-operator key-hash key=?))
- (make-weak-type key-hash key=? #f (compute-non-address-hash key-hash)))
-
-(define (make-weak-type key-hash key=? rehash-after-gc? compute-hash!)
+(define (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+ entry-type)
(declare (integrate rehash-after-gc?))
- (declare (integrate-operator key-hash key=? compute-hash!))
+ (declare (integrate-operator key-hash key=? compute-hash! entry-type))
(declare (no-type-checks) (no-range-checks))
- (make-table-type key-hash key=? rehash-after-gc?
- (make-method:get compute-hash! key=? weak-entry-type)
- (make-method:put! compute-hash! key=? weak-entry-type)
- (make-method:modify! compute-hash! key=? weak-entry-type)
- (make-method:remove! compute-hash! key=? weak-entry-type)
- (make-method:clean! weak-entry-type)
- (make-method:rehash! key-hash weak-entry-type)
- (make-method:fold weak-entry-type)
- (make-method:copy-bucket weak-entry-type)))
-
-(define-integrable (%weak-make-entry key datum)
+ (%make-table-type key-hash key=? rehash-after-gc?
+ (make-method:get compute-hash! key=? entry-type)
+ (make-method:put! compute-hash! key=? entry-type)
+ (make-method:modify! compute-hash! key=? entry-type)
+ (make-method:remove! compute-hash! key=? entry-type)
+ (if (eq? entry-type hash-table-entry-type:strong)
+ (named-lambda (method:no-clean! table)
+ (declare (ignore table))
+ unspecific)
+ (make-method:clean! entry-type))
+ (make-method:rehash! key-hash entry-type)
+ (make-method:fold entry-type)
+ (make-method:copy-bucket entry-type)))
+
+(define-integrable (non-weak? object)
;; Use an ordinary pair for objects that aren't pointers or that
;; have unbounded extent.
- (if (or (object-non-pointer? key)
- (number? key)
- (interned-symbol? key))
- (cons key datum)
- (system-pair-cons (ucode-type weak-cons) key datum)))
+ (or (object-non-pointer? object)
+ (number? object)
+ (interned-symbol? object)))
+
+(define-integrable (maybe-weak-cons a d)
+ (if (non-weak? a)
+ (cons a d)
+ (system-pair-cons (ucode-type WEAK-CONS) a d)))
+\f
+;;;; Entries of various flavours
+
+;;; Strong
+
+(define-integrable make-strong-entry cons)
+(define-integrable (strong-entry-valid? entry) entry #t)
+(define-integrable strong-entry-key car)
+(define-integrable strong-entry-datum cdr)
+(define-integrable set-strong-entry-datum! set-cdr!)
+
+(define-integrable (call-with-strong-entry-key entry if-valid if-not-valid)
+ (declare (ignore if-not-valid))
+ (if-valid (strong-entry-key entry) (lambda () unspecific)))
+
+(define-integrable (call-with-strong-entry-key&datum entry if-valid if-not)
+ (declare (ignore if-not))
+ (if-valid (strong-entry-key entry)
+ (strong-entry-datum entry)
+ (lambda () unspecific)))
-(define-integrable (%weak-entry-valid? entry)
+(declare (integrate-operator hash-table-entry-type:strong))
+(define hash-table-entry-type:strong
+ (make-entry-type make-strong-entry
+ strong-entry-valid?
+ call-with-strong-entry-key
+ call-with-strong-entry-key&datum
+ set-strong-entry-datum!))
+
+;;; Key-weak -- if the key is GC'd, the entry is dropped, but the datum
+;;; may be retained arbitrarily long.
+
+(define-integrable (make-key-weak-entry key datum)
+ (maybe-weak-cons key datum))
+
+(define-integrable (key-weak-entry-valid? entry)
(or (pair? entry)
(system-pair-car entry)))
-(define-integrable %weak-entry-key system-pair-car)
-(define-integrable %weak-entry-datum system-pair-cdr)
-(define-integrable %weak-set-entry-datum! system-pair-set-cdr!)
+(define-integrable key-weak-entry-key system-pair-car)
+(define-integrable key-weak-entry-datum system-pair-cdr)
+(define-integrable set-key-weak-entry-datum! system-pair-set-cdr!)
-(define-integrable (%call-with-weak-entry-key entry if-valid if-not-valid)
- (let ((k (%weak-entry-key entry)))
+(define-integrable (call-with-key-weak-entry-key entry if-valid if-not-valid)
+ (let ((k (key-weak-entry-key entry)))
;** Do not integrate K! It must be fetched and saved *before* we
;** determine whether the entry is valid.
(if (or (pair? entry) k)
- (if-valid k)
+ (if-valid k (lambda () (reference-barrier k)))
(if-not-valid))))
-(define-integrable (%call-with-weak-entry-key&datum entry if-valid if-not)
- (let ((k (%weak-entry-key entry)))
+(define-integrable (call-with-key-weak-entry-key&datum entry if-valid if-not)
+ (let ((k (key-weak-entry-key entry)))
;** Do not integrate K! It is OK to integrate D only because these
- ;** are weak pairs, not ephemerons, so D is held strongly anyway.
+ ;** are weak pairs, not ephemerons, so the entry holds D strongly
+ ;** anyway.
(if (or (pair? entry) k)
- (if-valid k (%weak-entry-datum entry))
+ (if-valid k
+ (key-weak-entry-datum entry)
+ (lambda () (reference-barrier k)))
(if-not))))
-(define-integrable weak-entry-type
- (make-entry-type %weak-make-entry
- %weak-entry-valid?
- %call-with-weak-entry-key
- %call-with-weak-entry-key&datum
- %weak-set-entry-datum!))
+(declare (integrate-operator hash-table-entry-type:key-weak))
+(define hash-table-entry-type:key-weak
+ (make-entry-type make-key-weak-entry
+ key-weak-entry-valid?
+ call-with-key-weak-entry-key
+ call-with-key-weak-entry-key&datum
+ set-key-weak-entry-datum!))
\f
-(define-integrable (make-method:clean! entry-type)
- (define (method:clean table)
- (let ((buckets (table-buckets table)))
- (let ((n-buckets (vector-length buckets)))
- (do ((i 0 (fix:+ i 1)))
- ((not (fix:< i n-buckets)))
- (let ()
- (define (scan-head p)
- (if (pair? p)
- (if (entry-valid? entry-type (car p))
- (begin
- (vector-set! buckets i p)
- (scan-tail (cdr p) p))
- (begin
- (decrement-table-count! table)
- (scan-head (cdr p))))
- (vector-set! buckets i p)))
- (define (scan-tail p q)
- (if (pair? p)
- (if (entry-valid? entry-type (car p))
- (scan-tail (cdr p) p)
- (begin
- (decrement-table-count! table)
- (let loop ((p (cdr p)))
- (if (pair? p)
- (if (entry-valid? entry-type (car p))
- (begin
- (set-cdr! q p)
- (scan-tail (cdr p) p))
- (begin
- (decrement-table-count! table)
- (loop (cdr p))))
- (set-cdr! q p)))))))
- (scan-head (vector-ref buckets i)))))))
- method:clean)
+;;; Datum-weak -- if the datum is GC'd, the entry is dropped, but the
+;;; key may be retained arbitrarily long.
+
+(define-integrable (make-datum-weak-entry key datum)
+ (maybe-weak-cons datum key))
+
+(define-integrable (datum-weak-entry-valid? entry)
+ (or (pair? entry)
+ (system-pair-car entry)))
+
+(define-integrable datum-weak-entry-key system-pair-cdr)
+(define-integrable datum-weak-entry-datum system-pair-car)
+(define-integrable set-datum-weak-entry-datum! system-pair-set-car!)
+
+(define-integrable (call-with-datum-weak-entry-key entry if-valid if-not)
+ (let ((d (datum-weak-entry-datum entry)))
+ (if (or (pair? entry) d)
+ (if-valid (datum-weak-entry-key entry)
+ (lambda () (reference-barrier d)))
+ (if-not))))
+
+(define-integrable (call-with-datum-weak-entry-key&datum entry if-valid if-not)
+ (let ((d (datum-weak-entry-datum entry)))
+ (if (or (pair? entry) d)
+ (if-valid (datum-weak-entry-key entry)
+ d
+ (lambda () (reference-barrier d)))
+ (if-not))))
+
+(declare (integrate-operator hash-table-entry-type:datum-weak))
+(define hash-table-entry-type:datum-weak
+ (make-entry-type make-datum-weak-entry
+ datum-weak-entry-valid?
+ call-with-datum-weak-entry-key
+ call-with-datum-weak-entry-key&datum
+ set-datum-weak-entry-datum!))
+
+;;; Key-or-datum-weak -- if either is GC'd, the entry is dropped.
+
+(define-integrable (make-key/datum-weak-entry key datum)
+ (maybe-weak-cons key (maybe-weak-cons datum '())))
+
+(define-integrable (key/datum-weak-entry-valid? entry)
+ (and (system-pair-car entry)
+ (system-pair-car (system-pair-cdr entry))))
+
+(define-integrable key/datum-weak-entry-key system-pair-car)
+(define-integrable (key/datum-weak-entry-datum entry)
+ (system-pair-car (system-pair-cdr entry)))
+
+(define-integrable (set-key/datum-weak-entry-datum! entry object)
+ (system-pair-set-car! (system-pair-cdr entry) object))
+
+(define-integrable (call-with-key/datum-weak-entry-key entry if-valid if-not)
+ (call-with-key/datum-weak-entry-key&datum entry
+ (lambda (k d barrier) d (if-valid k barrier))
+ if-not))
+
+(define-integrable (call-with-key/datum-weak-entry-key&datum entry
+ if-valid
+ if-not)
+ (let ((k (key/datum-weak-entry-key entry))
+ (d (key/datum-weak-entry-datum entry)))
+ (if (and (or (pair? entry) k)
+ (or (pair? (system-pair-cdr entry))
+ d))
+ (if-valid k d (lambda () (reference-barrier k) (reference-barrier d)))
+ (if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key/datum-weak))
+(define hash-table-entry-type:key/datum-weak
+ (make-entry-type make-key/datum-weak-entry
+ key/datum-weak-entry-valid?
+ call-with-key/datum-weak-entry-key
+ call-with-key/datum-weak-entry-key&datum
+ set-key/datum-weak-entry-datum!))
\f
-;;;; Strong table type
+;;; Key-ephemeral -- if the key is GC'd, the entry is dropped.
-(define (strong-hash-table/constructor key-hash key=?
- #!optional rehash-after-gc?)
- (hash-table-constructor
- (make-strong-hash-table-type key-hash key=?
- (if (default-object? rehash-after-gc?)
- #f
- rehash-after-gc?))))
-
-(define (make-strong-hash-table-type key-hash key=? rehash-after-gc?)
- (guarantee-procedure-of-arity key-hash 2 'MAKE-STRONG-HASH-TABLE-TYPE)
- (guarantee-procedure-of-arity key=? 2 'MAKE-STRONG-HASH-TABLE-TYPE)
- (let ((key-hash (protected-key-hash key-hash)))
- (if rehash-after-gc?
- (make-strong-rehash-type key-hash key=?)
- (make-strong-no-rehash-type key-hash key=?))))
-
-(define (make-strong-rehash-type key-hash key=?)
- (declare (integrate-operator key-hash key=?))
- (make-strong-type key-hash key=? #t (compute-address-hash key-hash)))
-
-(define (make-strong-no-rehash-type key-hash key=?)
- (declare (integrate-operator key-hash key=?))
- (make-strong-type key-hash key=? #f (compute-non-address-hash key-hash)))
-
-(define (make-strong-type key-hash key=? rehash-after-gc? compute-hash!)
- (declare (integrate rehash-after-gc?))
- (declare (integrate-operator key-hash key=? compute-hash!))
+(define-integrable make-key-ephemeral-entry make-ephemeron)
+
+(define-integrable (key-ephemeral-entry-valid? entry)
+ (not (ephemeron-broken? entry)))
+
+(define-integrable key-ephemeral-entry-key ephemeron-key)
+(define-integrable key-ephemeral-entry-datum ephemeron-datum)
+(define-integrable set-key-ephemeral-entry-datum! set-ephemeron-datum!)
+
+(define-integrable (call-with-key-ephemeral-entry-key entry if-valid if-not)
+ (let ((k (key-ephemeral-entry-key entry)))
+ (if (key-ephemeral-entry-valid? entry)
+ (if-valid k (lambda () (reference-barrier k)))
+ (if-not))))
+
+(define-integrable (call-with-key-ephemeral-entry-key&datum entry
+ if-valid
+ if-not)
+ (let ((k (key-ephemeral-entry-key entry))
+ (d (key-ephemeral-entry-datum entry)))
+ ;** Do not integrate K or D here. It is tempting to integrate D,
+ ;** but if the caller ignores the barrier, and its last reference
+ ;** to K precedes any reference to D, then the entry may be broken
+ ;** before we read the datum.
+ (if (key-ephemeral-entry-valid? entry)
+ (if-valid k d (lambda () (reference-barrier k)))
+ (if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key-ephemeral))
+(define hash-table-entry-type:key-ephemeral
+ (make-entry-type make-key-ephemeral-entry
+ key-ephemeral-entry-valid?
+ call-with-key-ephemeral-entry-key
+ call-with-key-ephemeral-entry-key&datum
+ set-key-ephemeral-entry-datum!))
+
+;;; Datum-ephemeral -- if the datum is GC'd, the entry is dropped
+
+(define-integrable (make-datum-ephemeral-entry key datum)
+ (make-ephemeron datum key))
+
+(define-integrable (datum-ephemeral-entry-valid? entry)
+ (not (ephemeron-broken? entry)))
+
+(define-integrable datum-ephemeral-entry-key ephemeron-datum)
+(define-integrable datum-ephemeral-entry-datum ephemeron-key)
+(define-integrable set-datum-ephemeral-entry-datum! set-ephemeron-key!)
+
+(define-integrable (call-with-datum-ephemeral-entry-key entry if-valid if-not)
+ (call-with-datum-ephemeral-entry-key&datum entry
+ (lambda (k d barrier) d (if-valid k barrier))
+ if-not))
+
+(define-integrable (call-with-datum-ephemeral-entry-key&datum entry
+ if-valid
+ if-not)
+ (let ((k (datum-ephemeral-entry-key entry))
+ (d (datum-ephemeral-entry-datum entry)))
+ (if (datum-ephemeral-entry-valid? entry)
+ (if-valid k d (lambda () (reference-barrier d)))
+ (if-not))))
+
+(declare (integrate-operator hash-table-entry-type:datum-ephemeral))
+(define hash-table-entry-type:datum-ephemeral
+ (make-entry-type make-datum-ephemeral-entry
+ datum-ephemeral-entry-valid?
+ call-with-datum-ephemeral-entry-key
+ call-with-datum-ephemeral-entry-key&datum
+ set-datum-ephemeral-entry-datum!))
+\f
+;;; Key-and-datum-ephemeral -- the entry is dropped iff both key and
+;;; datum are GC'd.
+
+(define (make-key&datum-ephemeral-entry key datum)
+ (cons (make-ephemeron key datum) (make-ephemeron datum key)))
+
+(define-integrable (key&datum-ephemeral-entry-valid? entry)
+ (not (ephemeron-broken? (car entry))))
+
+(define-integrable (key&datum-ephemeral-entry-key entry)
+ (ephemeron-key (car entry)))
+
+(define-integrable (key&datum-ephemeral-entry-datum entry)
+ (ephemeron-datum (car entry)))
+
+(define (set-key&datum-ephemeral-entry-datum! entry object)
(declare (no-type-checks) (no-range-checks))
- (make-table-type key-hash key=? rehash-after-gc?
- (make-method:get compute-hash! key=? strong-entry-type)
- (make-method:put! compute-hash! key=? strong-entry-type)
- (make-method:modify! compute-hash! key=? strong-entry-type)
- (make-method:remove! compute-hash! key=? strong-entry-type)
- (lambda (table) table unspecific)
- (make-method:rehash! key-hash strong-entry-type)
- (make-method:fold strong-entry-type)
- (make-method:copy-bucket strong-entry-type)))
-
-(define-integrable %strong-make-entry cons)
-(define-integrable (%strong-entry-valid? entry) entry #t)
-(define-integrable %strong-entry-key car)
-(define-integrable %strong-entry-datum cdr)
-(define-integrable %strong-set-entry-datum! set-cdr!)
-
-(define-integrable (%call-with-strong-entry-key entry if-valid if-not-valid)
- if-not-valid ;ignore
- (if-valid (%strong-entry-key entry)))
-
-(define-integrable (%call-with-strong-entry-key&datum entry if-valid if-not)
- if-not ;ignore
- (if-valid (%strong-entry-key entry) (%strong-entry-datum entry)))
-
-(define-integrable strong-entry-type
- (make-entry-type %strong-make-entry
- %strong-entry-valid?
- %call-with-strong-entry-key
- %call-with-strong-entry-key&datum
- %strong-set-entry-datum!))
+ ;; Careful! Don't use this with interrupts enabled, or it won't be
+ ;; atomic.
+ (set-ephemeron-datum! (car entry) object)
+ (set-ephemeron-key! (cdr entry) object))
+
+(define-integrable (call-with-key&datum-ephemeral-entry-key entry
+ if-valid
+ if-not)
+ (let ((k (key&datum-ephemeral-entry-key entry)))
+ (if (key&datum-ephemeral-entry-valid? entry)
+ (if-valid k (lambda () (reference-barrier k)))
+ (if-not))))
+
+(define-integrable (call-with-key&datum-ephemeral-entry-key&datum entry
+ if-valid
+ if-not)
+ (let ((k (key&datum-ephemeral-entry-key entry))
+ (d (key&datum-ephemeral-entry-datum entry)))
+ (if (key&datum-ephemeral-entry-valid? entry)
+ ;; The reference barrier need use only K (or only D), because
+ ;; as long as the entry and one of the key or datum is live,
+ ;; the other of the key or datum will be live too.
+ (if-valid k d (lambda () (reference-barrier k)))
+ (if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key&datum-ephemeral))
+(define hash-table-entry-type:key&datum-ephemeral
+ (make-entry-type make-key&datum-ephemeral-entry
+ key&datum-ephemeral-entry-valid?
+ call-with-key&datum-ephemeral-entry-key
+ call-with-key&datum-ephemeral-entry-key&datum
+ set-key&datum-ephemeral-entry-datum!))
\f
;;;; Methods
-(define-integrable (make-method:get compute-hash! key=? entry-type)
+(define (make-method:get compute-hash! key=? entry-type)
+ (declare (integrate-operator compute-hash! key=? entry-type))
(define (method:get table key default)
- (let loop
- ((p (vector-ref (table-buckets table) (compute-hash! table key))))
- (if (pair? p)
- (call-with-entry-key&datum entry-type (car p)
- (lambda (key* datum)
- (declare (integrate key* datum))
- (if (key=? key* key) datum (loop (cdr p))))
- (lambda () (loop (cdr p))))
- default)))
+ (let ((hash (compute-hash! table key)))
+ ;; Call COMPUTE-HASH! before TABLE-BUCKETS, because computing the
+ ;; hash might trigger rehashing which replaces the bucket vector.
+ (let loop ((p (vector-ref (table-buckets table) hash)))
+ (if (pair? p)
+ (call-with-entry-key&datum entry-type (car p)
+ (lambda (key* datum barrier)
+ (declare (integrate key* datum) (ignore barrier))
+ (if (key=? key* key) datum (loop (cdr p))))
+ (lambda () (loop (cdr p))))
+ default))))
method:get)
-(define-integrable (make-method:put! compute-hash! key=? entry-type)
+(define (make-method:put! compute-hash! key=? entry-type)
+ (declare (integrate-operator compute-hash! key=? entry-type))
(define (method:put! table key datum)
(let ((hash (compute-hash! table key)))
(let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
(if (pair? p)
- (if (call-with-entry-key entry-type (car p)
- (lambda (key*) (declare (integrate key*)) (key=? key* key))
- (lambda () #f))
- (set-entry-datum! entry-type (car p) datum)
- (loop (cdr p) p))
+ (call-with-entry-key entry-type (car p)
+ (lambda (key* barrier)
+ (declare (integrate key* barrier))
+ (if (key=? key* key)
+ (begin (set-entry-datum! entry-type (car p) datum)
+ (barrier))
+ (loop (cdr p) p)))
+ (lambda () (loop (cdr p) p)))
(with-table-locked! table
(lambda ()
(let ((r (cons (make-entry entry-type key datum) '())))
(maybe-grow-table! table)))))))
method:put!)
-(define-integrable (make-method:modify! compute-hash! key=? entry-type)
+(define (make-method:modify! compute-hash! key=? entry-type)
+ (declare (integrate-operator compute-hash! key=? entry-type))
(define (method:modify! table key procedure default)
(let ((hash (compute-hash! table key)))
(let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
(if (pair? p)
(call-with-entry-key&datum entry-type (car p)
- (lambda (key* datum)
- (declare (integrate key* datum))
+ (lambda (key* datum barrier)
+ (declare (integrate key* datum barrier))
(if (key=? key* key)
(with-table-locked! table
(lambda ()
(let ((datum* (procedure datum)))
(set-entry-datum! entry-type (car p) datum*)
+ (barrier)
datum*)))
(loop (cdr p) p)))
(lambda () (loop (cdr p) p)))
datum)))))
method:modify!)
\f
-(define-integrable (make-method:remove! compute-hash! key=? entry-type)
+(define (make-method:remove! compute-hash! key=? entry-type)
+ (declare (integrate-operator compute-hash! key=? entry-type))
(define (method:remove! table key)
(let ((hash (compute-hash! table key)))
(let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
(if (pair? p)
- (if (call-with-entry-key entry-type (car p)
- (lambda (key*) (declare (integrate key*)) (key=? key* key))
- (lambda () #f))
- (with-table-locked! table
- (lambda ()
- (if q
- (set-cdr! q (cdr p))
- (vector-set! (table-buckets table) hash (cdr p)))
- (decrement-table-count! table)
- (maybe-shrink-table! table)))
- (loop (cdr p) p))))))
+ (call-with-entry-key entry-type (car p)
+ (lambda (key* barrier)
+ (declare (integrate key*) (ignore barrier))
+ (if (key=? key* key)
+ (with-table-locked! table
+ (lambda ()
+ (if q
+ (set-cdr! q (cdr p))
+ (vector-set! (table-buckets table) hash (cdr p)))
+ (decrement-table-count! table)
+ (maybe-shrink-table! table)))
+ (loop (cdr p) p)))
+ (lambda () (loop (cdr p) p)))))))
method:remove!)
-(define-integrable (make-method:rehash! key-hash entry-type)
+(define (make-method:clean! entry-type)
+ (declare (integrate-operator entry-type))
+ (define (method:clean! table)
+ (let ((buckets (table-buckets table)))
+ (let ((n-buckets (vector-length buckets)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n-buckets)))
+ (let ()
+ (define (scan-head p)
+ (if (pair? p)
+ (if (entry-valid? entry-type (car p))
+ (begin
+ (vector-set! buckets i p)
+ (scan-tail (cdr p) p))
+ (begin
+ (decrement-table-count! table)
+ (scan-head (cdr p))))
+ (vector-set! buckets i p)))
+ (define (scan-tail p q)
+ (if (pair? p)
+ (if (entry-valid? entry-type (car p))
+ (scan-tail (cdr p) p)
+ (begin
+ (decrement-table-count! table)
+ (let loop ((p (cdr p)))
+ (if (pair? p)
+ (if (entry-valid? entry-type (car p))
+ (begin
+ (set-cdr! q p)
+ (scan-tail (cdr p) p))
+ (begin
+ (decrement-table-count! table)
+ (loop (cdr p))))
+ (set-cdr! q p)))))))
+ (scan-head (vector-ref buckets i)))))))
+ method:clean!)
+\f
+(define (make-method:rehash! key-hash entry-type)
+ (declare (integrate-operator key-hash entry-type))
(define (method:rehash! table entries)
(let ((buckets (table-buckets table)))
(let ((n-buckets (vector-length buckets)))
(if (pair? p)
(let ((q (cdr p)))
(call-with-entry-key entry-type (car p)
- (lambda (key)
- (declare (integrate key))
+ (lambda (key barrier)
+ (declare (integrate key) (ignore barrier))
(let ((hash (key-hash key n-buckets)))
(set-cdr! p (vector-ref buckets hash))
(vector-set! buckets hash p)))
(loop q)))))))
method:rehash!)
-(define-integrable (make-method:fold entry-type)
+(define (make-method:fold entry-type)
+ (declare (integrate-operator entry-type))
(define (method:fold table procedure initial-value)
(let ((buckets (table-buckets table)))
(let ((n-buckets (vector-length buckets)))
(if (pair? p)
(per-entry (cdr p)
(call-with-entry-key&datum entry-type (car p)
- (lambda (key datum)
+ (lambda (key datum barrier)
(declare (integrate key datum))
+ (declare (ignore barrier))
(procedure key datum value))
(lambda () value)))
(per-bucket (fix:+ i 1) value)))
value)))))
method:fold)
-(define-integrable (make-method:copy-bucket entry-type)
+(define (make-method:copy-bucket entry-type)
+ (declare (integrate-operator entry-type))
(define (method:copy-bucket bucket)
(let find-head ((p bucket))
(if (pair? p)
(call-with-entry-key&datum entry-type (car p)
- (lambda (key datum)
- (declare (integrate key datum))
+ (lambda (key datum barrier)
+ (declare (integrate key datum) (ignore barrier))
(let ((head (cons (make-entry entry-type key datum) '())))
(let loop ((p (cdr p)) (previous head))
(if (pair? p)
(loop (cdr p)
(call-with-entry-key&datum entry-type (car p)
- (lambda (key datum)
+ (lambda (key datum barrier)
(declare (integrate key datum))
+ (declare (ignore barrier))
(let ((p*
(cons (make-entry entry-type key datum)
'())))
;;; the garbage collector. REHASH-TABLE! explicitly checks for this
;;; possibility, and rehashes the table again if necessary.
\f
-(define-integrable (compute-non-address-hash key-hash)
+(define (compute-non-address-hash key-hash)
+ (declare (integrate-operator key-hash))
(lambda (table key)
(declare (integrate table key))
(key-hash key (vector-length (table-buckets table)))))
-(define-integrable (compute-address-hash key-hash)
+(define (compute-address-hash key-hash)
+ (declare (integrate-operator key-hash))
(lambda (table key)
(declare (integrate table key))
(let loop ()
entries)))
((not (fix:< i n-buckets)) entries)))))
\f
-;;;; EQ/EQV/EQUAL types
+;;;; EQ/EQV/EQUAL Hashing
-(declare (integrate eq-hash-mod))
-(define (eq-hash-mod key modulus)
- (declare (integrate key modulus))
+(define-integrable (eq-hash-mod key modulus)
(fix:remainder (eq-hash key) modulus))
(define-integrable (eq-hash object)
(fix:not n)
n)))
-(declare (integrate eqv-hash-mod))
(define-integrable (eqv-hash-mod key modulus)
- (declare (integrate key modulus))
(int:remainder (eqv-hash key) modulus))
(define (eqv-hash key)
((%recnum? key) (%recnum->nonneg-int key))
(else (eq-hash key))))
-(declare (integrate equal-hash-mod))
(define-integrable (equal-hash-mod key modulus)
- (declare (integrate key modulus))
(int:remainder (equal-hash key) modulus))
(define (equal-hash key)
(define (int:abs n)
(if (int:negative? n) (int:negate n) n))
\f
-;;;; SRFI-69 compatability
+;;;; Constructing and Open-Coding Types and Constructors
+
+(define (make-hash-table* key-hash key=? rehash-after-gc? entry-type
+ #!optional initial-size)
+ ((hash-table/constructor key-hash key=? rehash-after-gc? entry-type)
+ initial-size))
+
+(define (hash-table/constructor key-hash key=? rehash-after-gc? entry-type)
+ (hash-table-constructor
+ (make-hash-table-type key-hash key=? rehash-after-gc? entry-type)))
+
+(define (make-hash-table-type key-hash key=? rehash-after-gc? entry-type)
+ (hash-table/intern! (follow-memo-crap key-hash key=? rehash-after-gc?)
+ entry-type
+ (lambda ()
+ (let ((constructor
+ (hash-table/get hash-table-type-constructors entry-type #f)))
+ (if constructor
+ (constructor key-hash key=? rehash-after-gc?)
+ (%make-hash-table-type key-hash key=? rehash-after-gc?
+ entry-type))))))
+
+(define (memoize-hash-table-type! key-hash key=? rehash-after-gc? entry-type
+ type)
+ (let ((crap (follow-memo-crap key-hash key=? rehash-after-gc?)))
+ (cond ((hash-table/get crap entry-type #f)
+ => (lambda (type*)
+ (warn "Replacing memoized hash table type:" type type*))))
+ (hash-table/put! crap entry-type type)))
+
+(define (follow-memo-crap key-hash key=? rehash-after-gc?)
+ (define (intern-car! pair generator)
+ (or (car pair) (let ((v (generator))) (set-car! pair v) v)))
+ (define (intern-cdr! pair generator)
+ (or (cdr pair) (let ((v (generator))) (set-cdr! pair v) v)))
+ ((if rehash-after-gc? intern-car! intern-cdr!)
+ (hash-table/intern!
+ (hash-table/intern! memoized-hash-table-types
+ key-hash
+ make-key-ephemeral-eq-hash-table)
+ key=?
+ (lambda () (cons #f #f)))
+ make-key-ephemeral-eq-hash-table))
+\f
+(define (%make-hash-table-type key-hash key=? rehash-after-gc? entry-type)
+ (let ((compute-hash!
+ ((if rehash-after-gc?
+ compute-address-hash
+ compute-non-address-hash)
+ (protected-key-hash key-hash))))
+ ;; Don't integrate COMPUTE-HASH!.
+ (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+ entry-type)))
+
+(define-integrable (open-type-constructor entry-type)
+ (declare (integrate-operator %make-hash-table-type make-table-type))
+ (declare (integrate-operator make-method:get make-method:put!))
+ (declare (integrate-operator make-method:modify! make-method:remove!))
+ (declare (integrate-operator make-method:clean! make-method:rehash!))
+ (declare (integrate-operator make-method:fold make-method:copy-bucket))
+ (lambda (key-hash key=? rehash-after-gc?)
+ (let ((compute-hash!
+ ((if rehash-after-gc?
+ compute-address-hash
+ compute-non-address-hash)
+ (protected-key-hash key-hash))))
+ ;; Don't integrate COMPUTE-HASH!.
+ (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+ entry-type))))
+
+(define-integrable (open-type-constructor! entry-type)
+ (hash-table/put! hash-table-type-constructors
+ entry-type
+ (open-type-constructor entry-type)))
+
+(define-integrable (open-type key-hash key=? rehash-after-gc? entry-type)
+ (declare (integrate-operator %make-hash-table-type make-table-type))
+ (declare (integrate-operator compute-address-hash compute-non-address-hash))
+ (declare (integrate-operator make-method:get make-method:put!))
+ (declare (integrate-operator make-method:modify! make-method:remove!))
+ (declare (integrate-operator make-method:clean! make-method:rehash!))
+ (declare (integrate-operator make-method:fold make-method:copy-bucket))
+ (make-table-type key-hash key=? rehash-after-gc?
+ (if rehash-after-gc?
+ (compute-address-hash key-hash)
+ (compute-non-address-hash key-hash))
+ entry-type))
+
+(define-integrable (open-type! key-hash key=? rehash-after-gc? entry-type)
+ (let ((hash-table-type
+ (open-type key-hash key=? rehash-after-gc? entry-type)))
+ (memoize-hash-table-type! key-hash key=? rehash-after-gc? entry-type
+ hash-table-type)
+ hash-table-type))
+\f
+(define equal-hash-table-type)
+(define key-ephemeral-eq-hash-table-type)
+(define key-weak-eq-hash-table-type)
+(define key-weak-eqv-hash-table-type)
+(define string-hash-table-type)
+(define strong-eq-hash-table-type)
+(define strong-eqv-hash-table-type)
+
+(define hash-table-type-constructors)
+(define memoized-hash-table-types)
+
+(define (initialize-memoized-hash-table-types!)
+ (set! key-ephemeral-eq-hash-table-type
+ (open-type eq-hash-mod eq? #t hash-table-entry-type:key-ephemeral))
+ (set! make-key-ephemeral-eq-hash-table
+ (hash-table-constructor key-ephemeral-eq-hash-table-type))
+ (set! hash-table-type-constructors (make-key-ephemeral-eq-hash-table))
+ (set! memoized-hash-table-types (make-key-ephemeral-eq-hash-table))
+ (memoize-hash-table-type! eq-hash-mod eq? #t
+ hash-table-entry-type:key-ephemeral
+ key-ephemeral-eq-hash-table-type)
+ (open-type-constructor! hash-table-entry-type:strong)
+ (open-type-constructor! hash-table-entry-type:key-weak)
+ (open-type-constructor! hash-table-entry-type:datum-weak)
+ (open-type-constructor! hash-table-entry-type:key/datum-weak)
+ (open-type-constructor! hash-table-entry-type:key-ephemeral)
+ (open-type-constructor! hash-table-entry-type:datum-ephemeral)
+ (open-type-constructor! hash-table-entry-type:key&datum-ephemeral)
+ (let ((make make-hash-table-type)) ;For brevity...
+ (set! equal-hash-table-type
+ (make equal-hash-mod equal? #t hash-table-entry-type:strong))
+ (set! key-weak-eq-hash-table-type ;Open-coded
+ (open-type! eq-hash-mod eq? #t hash-table-entry-type:key-weak))
+ (set! key-weak-eqv-hash-table-type
+ (make eqv-hash-mod eqv? #t hash-table-entry-type:key-weak))
+ (set! string-hash-table-type
+ (make string-hash-mod string=? #t hash-table-entry-type:strong))
+ (set! strong-eq-hash-table-type ;Open-coded
+ (open-type! eq-hash-mod eq? #t hash-table-entry-type:strong))
+ (set! strong-eqv-hash-table-type
+ (make eqv-hash-mod eqv? #t hash-table-entry-type:strong)))
+ unspecific)
+
+(define make-equal-hash-table)
+(define make-key-ephemeral-eq-hash-table)
+(define make-key-weak-eq-hash-table)
+(define make-key-weak-eqv-hash-table)
+(define make-string-hash-table)
+(define make-strong-eq-hash-table)
+(define make-strong-eqv-hash-table)
+
+(define (initialize-hash-table-type-constructors!)
+ (let-syntax ((init
+ (syntax-rules ()
+ ((INIT constructor type)
+ (SET! constructor (HASH-TABLE-CONSTRUCTOR type))))))
+ (init make-equal-hash-table equal-hash-table-type)
+ ;; This is done above.
+ ;; (init make-key-ephemeral-eq-hash-table key-ephemeral-eq-hash-table-type)
+ (init make-key-weak-eq-hash-table key-weak-eq-hash-table-type)
+ (init make-key-weak-eqv-hash-table key-weak-eqv-hash-table-type)
+ (init make-string-hash-table string-hash-table-type)
+ (init make-strong-eq-hash-table strong-eq-hash-table-type)
+ (init make-strong-eqv-hash-table strong-eqv-hash-table-type))
+ unspecific)
+\f
+;;;; Compatibility with SRFI 69 and older MIT Scheme
+
+(define (strong-hash-table/constructor key-hash key=?
+ #!optional rehash-after-gc?)
+ (hash-table/constructor key-hash
+ key=?
+ (if (default-object? rehash-after-gc?)
+ #f
+ rehash-after-gc?)
+ hash-table-entry-type:strong))
+
+(define (weak-hash-table/constructor key-hash key=?
+ #!optional rehash-after-gc?)
+ (hash-table/constructor key-hash
+ key=?
+ (if (default-object? rehash-after-gc?)
+ #f
+ rehash-after-gc?)
+ hash-table-entry-type:key-weak))
(define (make-hash-table #!optional key=? key-hash initial-size)
(%make-hash-table (custom-table-type
initial-size))
(define (custom-table-type key=? key-hash)
- (cond ((and (eq? key=? eq?)
- (or (eq? key-hash eq-hash-mod)
- (eq? key-hash hash-by-identity)))
- strong-eq-hash-table-type)
- ((and (eq? key=? eqv?)
- (eq? key-hash eqv-hash-mod))
- strong-eqv-hash-table-type)
- ((and (eq? key=? equal?)
- (or (eq? key-hash equal-hash-mod)
- (eq? key-hash hash)))
- equal-hash-table-type)
- ((and (eq? key=? string=?)
- (or (eq? key-hash string-hash-mod)
- (eq? key-hash string-hash)
- (eq? key-hash hash)))
- string-hash-table-type)
- ((and (or (eq? key=? string=?)
- (eq? key=? string-ci=?))
- (or (eq? key-hash string-hash-mod)
- (eq? key-hash string-hash)
- (eq? key-hash hash)
- (eq? key-hash string-ci-hash)))
- (make-strong-no-rehash-type (if (eq? key-hash string-hash)
- string-hash-mod
- key-hash)
- key=?))
- (else
- (make-strong-rehash-type key-hash key=?))))
+ (make-hash-table-type key-hash
+ key=?
+ (if (and (or (eq? key=? string=?)
+ (eq? key=? string-ci=?))
+ (or (eq? key-hash string-hash-mod)
+ (eq? key-hash string-hash)
+ (eq? key-hash hash)
+ (eq? key-hash string-ci-hash)))
+ #f ;No rehash needed after GC
+ #t) ;Rehash needed after GC
+ hash-table-entry-type:strong))
(define (alist->hash-table alist #!optional key=? key-hash)
(guarantee-alist alist 'ALIST->HASH-TABLE)
(define address-hash-tables)
-(define weak-eq-hash-table-type)
-(define strong-eq-hash-table-type)
-(define weak-eqv-hash-table-type)
-(define strong-eqv-hash-table-type)
-(define equal-hash-table-type)
-(define string-hash-table-type)
-
-(define make-weak-eq-hash-table)
-(define make-strong-eq-hash-table)
-(define make-weak-eqv-hash-table)
-(define make-strong-eqv-hash-table)
-(define make-equal-hash-table)
-(define make-string-hash-table)
-
-(define (initialize-package!)
+(define (initialize-address-hash-tables!)
(set! address-hash-tables '())
(add-primitive-gc-daemon! mark-address-hash-tables!)
- (let ()
- (declare (integrate-operator make-weak-rehash-type))
- (declare (integrate-operator make-weak-no-rehash-type))
- (declare (integrate-operator make-weak-type))
- (declare (integrate-operator make-strong-rehash-type))
- (declare (integrate-operator make-strong-no-rehash-type))
- (declare (integrate-operator make-strong-type))
- (set! weak-eq-hash-table-type (make-weak-rehash-type eq-hash-mod eq?))
- (set! strong-eq-hash-table-type (make-strong-rehash-type eq-hash-mod eq?))
- (set! weak-eqv-hash-table-type (make-weak-rehash-type eqv-hash-mod eqv?))
- (set! strong-eqv-hash-table-type
- (make-strong-rehash-type eqv-hash-mod eqv?)))
- (set! equal-hash-table-type (make-strong-rehash-type equal-hash-mod equal?))
- (set! string-hash-table-type
- (make-strong-no-rehash-type string-hash-mod string=?))
- (set! make-weak-eq-hash-table (hash-table-constructor eq-hash-table-type))
- (set! make-strong-eq-hash-table
- (hash-table-constructor strong-eq-hash-table-type))
- (set! make-weak-eqv-hash-table (hash-table-constructor eqv-hash-table-type))
- (set! make-strong-eqv-hash-table
- (hash-table-constructor strong-eqv-hash-table-type))
- (set! make-equal-hash-table (hash-table-constructor equal-hash-table-type))
- (set! make-string-hash-table (hash-table-constructor string-hash-table-type))
unspecific)
(define (mark-address-hash-tables!)
(else (error:wrong-type-argument object description procedure))))
(define-integrable (with-table-locked! table thunk)
- table
+ (declare (ignore table))
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(let ((value (thunk)))
(set-interrupt-enables! interrupt-mask)
value)))
(define default-marker
- (list 'DEFAULT-MARKER))
\ No newline at end of file
+ (list 'DEFAULT-MARKER))
+
+(define (initialize-package!)
+ ;; Must come before any address hash tables are created.
+ (initialize-address-hash-tables!)
+ ;; Must come before any hash table types are constructed or used.
+ ;; This constructs an address hash table, however.
+ (initialize-memoized-hash-table-types!)
+ (initialize-hash-table-type-constructors!))
\ No newline at end of file
projects / mit-scheme.git / commitdiff