827 lines
32 KiB
Scheme
827 lines
32 KiB
Scheme
;;;;;; Riatables: alternative hash tables -*- Scheme -*-
|
||
;;;;;; Thread-unsafe implementation
|
||
|
||
;;; Taylor Campbell wrote this code; he places it in the public domain.
|
||
|
||
(define-record-type table type/table
|
||
(really-make-table id
|
||
template
|
||
size
|
||
gc-stamp
|
||
bucket-vector)
|
||
table?
|
||
(id table-id)
|
||
(template table-template)
|
||
(size table-size set-table-size!)
|
||
(gc-stamp table-gc-stamp set-table-gc-stamp!)
|
||
(bucket-vector table-bucket-vector set-table-bucket-vector!))
|
||
|
||
(define-record-discloser type/table
|
||
(lambda (table)
|
||
`(,(or (table-type-name table) 'table)
|
||
,@(cond ((table-id table) => list) (else '()))
|
||
,(table-size table))))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Parameters
|
||
|
||
;;; These are just guesses. I ought to fill in better suggestions at
|
||
;;; some point, but these will do for now.
|
||
|
||
;;; The number of buckets to put in freshly created tables.
|
||
|
||
(define initial-bucket-count 10)
|
||
|
||
;;; The next number of buckets to have in a table after PREVIOUS.
|
||
|
||
(define (next-bucket-count previous)
|
||
(+ (* previous 2) 1))
|
||
|
||
;;; The maximum average number of entries to have in a bucket.
|
||
|
||
(define maximum-average-bucket-entries 3)
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Table templates
|
||
|
||
;;; This code is rather too verbose for my tastes. At least there can
|
||
;;; be a DEFINE-TEMPLATE-ACCESSOR macro to reduce code tedium.
|
||
|
||
(define-record-type table-template type/table-template
|
||
(really-make-table-template type-name
|
||
key-predicate
|
||
key-comparator
|
||
key-hasher
|
||
gc-sensitive?
|
||
head-weak?
|
||
tail-weak?
|
||
searcher
|
||
expander)
|
||
table-template?
|
||
(type-name table-template-type-name)
|
||
(key-predicate table-template-key-predicate)
|
||
(key-comparator table-template-key-comparator)
|
||
(key-hasher table-template-key-hasher)
|
||
(gc-sensitive? table-template-gc-sensitive?)
|
||
(head-weak? table-template-head-weak?)
|
||
(tail-weak? table-template-tail-weak?)
|
||
(searcher table-template-searcher)
|
||
(expander table-template-expander))
|
||
|
||
(define-record-discloser type/table-template
|
||
(lambda (t)
|
||
`(table-template ,@(cond ((table-template-type-name t) => list)
|
||
(else '())))))
|
||
|
||
(define-syntax define-template-accessors
|
||
(syntax-rules ()
|
||
((define-template-accessors (table template) ...)
|
||
(begin (define (table t)
|
||
(template (table-template t)))
|
||
...))))
|
||
|
||
(define-template-accessors
|
||
(table-type-name table-template-type-name)
|
||
(table-key-predicate table-template-key-predicate)
|
||
(table-key-comparator table-template-key-comparator)
|
||
(table-key-hasher table-template-key-hasher)
|
||
(table-gc-sensitive? table-template-gc-sensitive?)
|
||
(table-head-weak? table-template-head-weak?)
|
||
(table-tail-weak? table-template-tail-weak?)
|
||
(table-searcher table-template-searcher)
|
||
(table-expander table-template-expander))
|
||
|
||
(define (make-table-template key? key= key-hash
|
||
gc? head-weak? tail-weak?
|
||
type-name)
|
||
(let* ((rehasher (make-table-rehasher key-hash
|
||
gc? head-weak? tail-weak?))
|
||
(hasher (make-table-hasher key-hash gc? rehasher)))
|
||
(really-make-table-template
|
||
type-name
|
||
key? key= key-hash
|
||
gc? head-weak? tail-weak?
|
||
(make-table-searcher key= hasher gc?
|
||
head-weak? tail-weak?)
|
||
(make-table-expander hasher gc?
|
||
head-weak? tail-weak?
|
||
rehasher))))
|
||
|
||
(define (make-weak-table-template key? key= key-hash gc? type-name)
|
||
(make-table-template key? key= key-hash gc? #t #t type-name))
|
||
(define (make-strong-table-template key? key= key-hash gc? type-name)
|
||
(make-table-template key? key= key-hash gc? #f #f type-name))
|
||
|
||
(define (modify-table-template-weakness template head-weak? tail-weak?)
|
||
(make-table-template (table-template-key-predicate template)
|
||
(table-template-key-comparator template)
|
||
(table-template-key-hasher template)
|
||
(table-template-gc-sensitive? template)
|
||
head-weak?
|
||
tail-weak?
|
||
(table-template-type-name template)))
|
||
|
||
(define-syntax define-weakness-modifiers
|
||
(syntax-rules ()
|
||
((define-weakness-modifiers
|
||
(name template head? tail?)
|
||
...)
|
||
(begin (define (name template)
|
||
(modify-table-template-weakness template head? tail?))
|
||
...))))
|
||
|
||
(define-weakness-modifiers
|
||
(weaken-table-template t #t #t)
|
||
(head-weaken-table-template t #t (table-template-tail-weak? t))
|
||
(tail-weaken-table-template t (table-template-head-weak? t) #t)
|
||
(strengthen-table-template t #f #f)
|
||
(head-strengthen-table-template t #f (table-template-tail-weak? t))
|
||
(tail-strengthen-table-template t (table-template-head-weak? t) #f))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Constructors
|
||
|
||
(define (%make-table-from-template template suggested-size id)
|
||
(let ((gc? (table-template-gc-sensitive? template)))
|
||
(really-make-table id
|
||
template
|
||
0
|
||
(and gc? (gc-stamp))
|
||
(make-vector
|
||
(if (and suggested-size
|
||
(> suggested-size
|
||
maximum-average-bucket-entries))
|
||
(quotient suggested-size
|
||
maximum-average-bucket-entries)
|
||
initial-bucket-count)
|
||
(empty-bucket)))))
|
||
|
||
(define (table-constructor template)
|
||
(let ((name `(table-constructor ,template)))
|
||
(lambda size+id
|
||
(receive (suggested-size id)
|
||
(table-cons-options size+id name)
|
||
(%make-table-from-template template suggested-size id)))))
|
||
|
||
(define (make-table-from-template template . size+id)
|
||
(receive (suggested-size id)
|
||
(table-cons-options size+id make-table-from-template)
|
||
(%make-table-from-template template suggested-size id)))
|
||
|
||
(define (table-cons-options options callee)
|
||
(if (null? options)
|
||
(values #f #f)
|
||
(let ((size (car options))
|
||
(more (cdr options)))
|
||
(if (or (integer? size) (not size))
|
||
(if (null? more)
|
||
(values size #f)
|
||
(let ((name (car more))
|
||
(more (cdr more)))
|
||
(if (null? more)
|
||
(values size name)
|
||
(error "extraneous arguments" more callee))))
|
||
(error "invalid table size suggestion argument"
|
||
size
|
||
callee)))))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Main table operations
|
||
|
||
;;; This is a macro so that it gets integrated and debugging info is
|
||
;;; retained about the procedure.
|
||
|
||
(define-syntax define-keyed-table-operation
|
||
(syntax-rules ()
|
||
((define-keyed-table-operation (name table-arg key-arg arg ...)
|
||
(bucket-index-var entry-var)
|
||
body1 body2 ...)
|
||
(define (name table-arg key-arg arg ...)
|
||
(cond ((not (table? table-arg))
|
||
(call-error "invalid table argument" name
|
||
table-arg key-arg arg ...))
|
||
((not ((table-key-predicate table-arg) key-arg))
|
||
(call-error "invalid key argument" name
|
||
table-arg key-arg arg ...))
|
||
(else
|
||
(receive (bucket-index-var entry-var)
|
||
((table-searcher table-arg)
|
||
table-arg key-arg)
|
||
body1 body2 ...)))))))
|
||
|
||
(define-keyed-table-operation (table-entry table key)
|
||
(bucket-index entry)
|
||
(and entry
|
||
(let ((tail-weak? (table-tail-weak? table)))
|
||
(cond ((not tail-weak?)
|
||
(entry-value entry))
|
||
((weak-entry-value entry))
|
||
(else ; Broken weak entry.
|
||
(expunge-entry-from-table! table bucket-index entry)
|
||
#f)))))
|
||
|
||
(define-keyed-table-operation (set-table-entry! table key value)
|
||
(bucket-index entry)
|
||
(cond ((not value)
|
||
(cond (entry
|
||
(expunge-entry-from-table! table bucket-index entry)
|
||
(if (table-tail-weak? table)
|
||
(set-weak-entry-value! entry #f)
|
||
(set-entry-value! entry #f)))))
|
||
(entry
|
||
(if (table-tail-weak? table)
|
||
(set-weak-entry-value! entry #f)
|
||
(set-entry-value! entry #f)))
|
||
(bucket-index
|
||
((table-expander table) table bucket-index key value))))
|
||
|
||
(define-keyed-table-operation (modify-table-entry! table key modifier)
|
||
(bucket-index entry)
|
||
(cond (entry
|
||
;; We don't need to set the entry's value to be #F here: both
|
||
;; of the modifiers will set the entry to #F if MODIFIER
|
||
;; returns it.
|
||
(if (not (if (table-tail-weak? table)
|
||
(modify-weak-entry-value! entry modifier)
|
||
(modify-entry-value! entry modifier)))
|
||
(expunge-entry-from-table! table bucket-index entry)))
|
||
((modifier #f)
|
||
=> (lambda (new-value)
|
||
((table-expander table)
|
||
table bucket-index key new-value)))))
|
||
|
||
(define-keyed-table-operation (pop-table-entry! table key)
|
||
(bucket-index entry)
|
||
(and entry
|
||
(begin (expunge-entry-from-table! table bucket-index entry)
|
||
(if (table-tail-weak? table)
|
||
(weak-entry-value entry)
|
||
(entry-value entry)))))
|
||
|
||
;++ This should also clean out any of the table's broken weak entries.
|
||
|
||
(define (table->alist table)
|
||
(let* ((buckets (table-bucket-vector table))
|
||
(bcount (vector-length buckets))
|
||
(cons-entry
|
||
(let ((head-weak? (table-head-weak? table))
|
||
(tail-weak? (table-tail-weak? table)))
|
||
(cond ((and head-weak? tail-weak?)
|
||
(lambda (entry alist)
|
||
(cond ((weak-entry-key entry)
|
||
=> (lambda (k)
|
||
(cond ((weak-entry-value entry)
|
||
=> (lambda (v)
|
||
(cons (cons k v) alist)))
|
||
(else alist))))
|
||
(else alist))))
|
||
(head-weak?
|
||
(lambda (entry alist)
|
||
(cond ((weak-entry-key entry)
|
||
=> (lambda (k)
|
||
(cons (cons k (entry-value entry))
|
||
alist)))
|
||
(else alist))))
|
||
(tail-weak?
|
||
(lambda (entry alist)
|
||
(cond ((weak-entry-value entry)
|
||
=> (lambda (v)
|
||
(cons (cons (entry-key entry) v)
|
||
alist)))
|
||
(else alist))))
|
||
(else
|
||
(lambda (entry alist)
|
||
(cons (cons (entry-key entry) (entry-value entry))
|
||
alist)))))))
|
||
(let outer-loop ((alist '())
|
||
(i 0))
|
||
(if (= i bcount)
|
||
alist
|
||
(let inner-loop ((alist alist)
|
||
(bucket (vector-ref buckets i)))
|
||
(if (bucket-empty? bucket)
|
||
(outer-loop alist (+ i 1))
|
||
(inner-loop (cons-entry (bucket-entry bucket) alist)
|
||
(bucket-next bucket))))))))
|
||
|
||
(define (walk-table table proc)
|
||
(for-each (lambda (k.v) (proc (car k.v) (cdr k.v)))
|
||
(table->alist table)))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Buckets
|
||
|
||
;;; Buckets are represented as alists, because ASSQ in the Scheme48 VM
|
||
;;; is fast. However, this is no longer useful: using ASSQ was an
|
||
;;; optimization hack that would lose with optimistic concurrency, so
|
||
;;; it is no longer used. A more space-efficient representation could,
|
||
;;; and probably should, be chosen now with no adverse effects on time
|
||
;;; efficiency.
|
||
|
||
;;; All these trivial procedures are procedures, not direct aliases, so
|
||
;;; that the silly Scheme48 automatic procedure integrator, which has
|
||
;;; much too low a threshold and no provision for alias integration,
|
||
;;; will integrate them.
|
||
|
||
(define (empty-bucket) '())
|
||
(define (bucket-empty? bucket) (null? bucket))
|
||
(define (bucket-nonempty? bucket) (pair? bucket))
|
||
|
||
(define (make-bucket entry next) (cons entry next))
|
||
|
||
(define (bucket-entry bucket) (car bucket))
|
||
(define (bucket-next bucket) (cdr bucket))
|
||
(define (set-bucket-next! bucket next) (set-cdr! bucket next))
|
||
|
||
(define (entry-maker head-weak? tail-weak?)
|
||
(cond ((and head-weak? tail-weak?)
|
||
make-weak-entry)
|
||
(head-weak? make-head-weak-entry)
|
||
(tail-weak? make-tail-weak-entry)
|
||
(else make-strong-entry)))
|
||
|
||
(define (make-weak-entry key value)
|
||
(cons (make-weak-pointer key)
|
||
(make-weak-pointer value)))
|
||
(define (make-head-weak-entry key value)
|
||
(cons (make-weak-pointer key) value))
|
||
(define (make-tail-weak-entry key value)
|
||
(cons key (make-weak-pointer value)))
|
||
(define (make-strong-entry key value)
|
||
(cons key value))
|
||
|
||
(define (entry-key entry) (car entry))
|
||
(define (weak-entry-key entry) (weak-pointer-ref (car entry)))
|
||
|
||
(define (entry-value entry) (cdr entry))
|
||
(define (weak-entry-value entry) (weak-pointer-ref (cdr entry)))
|
||
|
||
(define (set-entry-value! entry value)
|
||
(set-cdr! entry value))
|
||
(define (set-weak-entry-value! entry value)
|
||
(set-entry-value! entry (make-weak-pointer value)))
|
||
|
||
;;; If MODIFIER returns #F, the entry is to be deleted. It would seem
|
||
;;; superfluous to set it if it is #F, but the entry, if it is to be
|
||
;;; deleted, needs to be set to #F. This is because of a delicate case
|
||
;;; in thread synchronization:
|
||
;;; - Thread A is rehashing a table; it is in the middle of dumping
|
||
;;; the bucket that contains an entry E, which it has already
|
||
;;; dumped.
|
||
;;; - Thread A is suspended; thread B gets to run.
|
||
;;; - Thread B tries to expunge E from the bucket, but it's absent,
|
||
;;; so it assumes that another thread concurrently deleted it.
|
||
;;; Now the entry E is still in the table, even though thread B thought
|
||
;;; it must have been deleted.
|
||
|
||
(define (modify-entry-value! entry modifier)
|
||
(let ((new-value (modifier (entry-value entry))))
|
||
(set-entry-value! entry new-value)
|
||
new-value))
|
||
(define (modify-weak-entry-value! entry modifier)
|
||
(let ((new-value (modifier (weak-entry-value entry))))
|
||
(set-weak-entry-value! entry new-value)
|
||
new-value))
|
||
|
||
;;; It might be better to write a purely functional, allocation-only
|
||
;;; version of this, to perform as little proposal logging as possible.
|
||
;;; Then again, it might make GCs more frequent.
|
||
;++ But couldn't that be handled by having two versions, one for GC-
|
||
;++ sensitive tables and one for GC-insensitive tables, with the latter
|
||
;++ of which allocation has no problems?
|
||
|
||
(define (expunge-entry-from-bucket! bucket entry)
|
||
(cond ((bucket-empty? bucket) bucket)
|
||
((eq? entry (bucket-entry bucket))
|
||
(bucket-next bucket))
|
||
(else
|
||
(let loop ((b (bucket-next bucket))
|
||
(lag bucket))
|
||
;; It is OK for BUCKET not to contain ENTRY: another thread
|
||
;; may have concurrently deleted it before the call to
|
||
;; EXPUNGE-ENTRY-FROM-BUCKET! but after the search for the
|
||
;; entry.
|
||
(if (bucket-nonempty? b)
|
||
(cond ((eq? (bucket-entry b) entry)
|
||
(set-bucket-next! lag (bucket-next b))
|
||
bucket)
|
||
(else
|
||
(loop (bucket-next b) b))))))))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Bucket operations
|
||
|
||
(define (make-bucket-searcher key= gc? head-weak? tail-weak?)
|
||
((cond ((and gc? (or head-weak? tail-weak?))
|
||
make-gc-weak-bucket-searcher)
|
||
((and head-weak? tail-weak?)
|
||
make-weak-bucket-searcher)
|
||
(head-weak? make-head-weak-bucket-searcher)
|
||
(tail-weak? make-tail-weak-bucket-searcher)
|
||
(else make-strong-bucket-searcher))
|
||
key=))
|
||
|
||
(define-syntax define-bucket-searcher
|
||
(syntax-rules ()
|
||
((define-bucket-searcher name
|
||
entry-var
|
||
(key-var key-expression)
|
||
test)
|
||
(define (name key=)
|
||
(letrec ((expunge-broken-initials
|
||
(lambda (bucket delta)
|
||
(if (bucket-empty? bucket)
|
||
(values bucket delta)
|
||
(let* ((entry-var (bucket-entry bucket))
|
||
(next (bucket-next bucket))
|
||
(key-var key-expression))
|
||
(if test
|
||
(values bucket delta)
|
||
(expunge-broken-initials next
|
||
(+ delta 1)))))))
|
||
(search
|
||
(lambda (bucket lag key delta)
|
||
(if (bucket-empty? bucket)
|
||
(values #f delta)
|
||
(let* ((entry-var (bucket-entry bucket))
|
||
(next (bucket-next bucket))
|
||
(key-var key-expression))
|
||
(cond ((not test)
|
||
(set-bucket-next! lag next)
|
||
(search next lag key (+ delta 1)))
|
||
((key= key-var key)
|
||
(values entry-var delta))
|
||
(else
|
||
(search next bucket key delta))))))))
|
||
(lambda (table index bucket key)
|
||
(receive (bucket* delta)
|
||
(expunge-broken-initials bucket 0)
|
||
(if (positive? delta)
|
||
(vector-set! (table-bucket-vector table)
|
||
index
|
||
bucket*))
|
||
(receive (entry delta)
|
||
(if (bucket-empty? bucket*)
|
||
(values #f delta)
|
||
(let ((entry-var (bucket-entry bucket*))
|
||
(next (bucket-next bucket*)))
|
||
(if (key= key-expression key)
|
||
(values entry-var delta)
|
||
(search next
|
||
bucket*
|
||
key
|
||
delta))))
|
||
(set-table-size! table (- (table-size table) delta))
|
||
entry))))))))
|
||
|
||
(define-bucket-searcher make-weak-bucket-searcher
|
||
entry
|
||
(key (weak-entry-key entry))
|
||
(and key (weak-entry-value entry)))
|
||
|
||
(define-bucket-searcher make-head-weak-bucket-searcher
|
||
entry
|
||
(key (weak-entry-key entry))
|
||
key)
|
||
|
||
(define-bucket-searcher make-tail-weak-bucket-searcher
|
||
entry
|
||
(key (entry-key entry))
|
||
(weak-entry-value entry))
|
||
|
||
;;; This is just like the strong bucket searcher, except that it looks
|
||
;;; at the weak pointer keys' contents, not at the keys themselves.
|
||
;;; This works because, if a key was broken at the last GC, the rehash
|
||
;;; of the table would have cleared it out before calling this.
|
||
|
||
(define (make-gc-weak-bucket-searcher key=)
|
||
(lambda (table index bucket key)
|
||
(let loop ((bucket bucket))
|
||
(if (bucket-empty? bucket)
|
||
#f
|
||
(let ((entry (bucket-entry bucket)))
|
||
(if (key= (weak-entry-key entry) key)
|
||
entry
|
||
(loop (bucket-next bucket))))))))
|
||
|
||
(define (make-strong-bucket-searcher key=)
|
||
;** EXPUNGE WHEN OPTIMISTIC CONCURRENCY IS IMPLEMENTED
|
||
;** (ASSQ doesn't log)
|
||
(if (eq? key= eq?)
|
||
(lambda (table index bucket key) ;+++ Performance hack: ASSQ is
|
||
(assq key bucket)) ;+++ a VM primitive, so fast.
|
||
(letrec ((loop (lambda (table index bucket key)
|
||
(if (bucket-empty? bucket)
|
||
#f
|
||
(let ((entry (bucket-entry bucket)))
|
||
(if (key= (entry-key entry) key)
|
||
entry
|
||
(loop table
|
||
index
|
||
(bucket-next bucket)
|
||
key)))))))
|
||
loop)))
|
||
|
||
|
||
|
||
(define (make-bucket-dumper key-hash head-weak? tail-weak?)
|
||
((cond ((and head-weak? tail-weak?)
|
||
make-weak-bucket-dumper)
|
||
(head-weak? make-head-weak-bucket-dumper)
|
||
(tail-weak? make-tail-weak-bucket-dumper)
|
||
(else make-strong-bucket-dumper))
|
||
key-hash))
|
||
|
||
(define-syntax define-bucket-dumper
|
||
(syntax-rules ()
|
||
((define-bucket-dumper name
|
||
entry-var
|
||
(key-var key-expression)
|
||
test)
|
||
(define (name key-hash)
|
||
(letrec ((loop
|
||
(lambda (buckets index bucket count mod)
|
||
(if (bucket-empty? bucket)
|
||
count
|
||
(let* ((entry-var (bucket-entry bucket))
|
||
(next (bucket-next bucket))
|
||
(key-var key-expression))
|
||
(loop buckets index
|
||
next
|
||
(if test
|
||
(let ((hash (key-hash key-var mod)))
|
||
(if (not (eq? hash index))
|
||
(begin (set-bucket-next!
|
||
bucket
|
||
(vector-ref buckets
|
||
hash))
|
||
(vector-set! buckets
|
||
hash
|
||
bucket)))
|
||
(+ count 1))
|
||
count)
|
||
mod))))))
|
||
(lambda (bucket-vector old-buckets index)
|
||
(loop bucket-vector index
|
||
(vector-ref old-buckets index)
|
||
0
|
||
(vector-length bucket-vector))))))))
|
||
|
||
(define-bucket-dumper make-weak-bucket-dumper
|
||
entry
|
||
(key (weak-entry-key entry))
|
||
(and key (weak-entry-value entry)))
|
||
|
||
(define-bucket-dumper make-head-weak-bucket-dumper
|
||
entry
|
||
(key (weak-entry-key entry))
|
||
key)
|
||
|
||
(define-bucket-dumper make-tail-weak-bucket-dumper
|
||
entry
|
||
(key (entry-key entry))
|
||
(weak-entry-value entry))
|
||
|
||
(define (make-strong-bucket-dumper key-hash)
|
||
(letrec ((loop
|
||
(lambda (buckets index bucket count mod)
|
||
(if (bucket-empty? bucket)
|
||
count
|
||
(let ((next (bucket-next bucket))
|
||
(hash
|
||
(key-hash (entry-key (bucket-entry bucket))
|
||
mod)))
|
||
;; Prevent accidentally creating a circular bucket.
|
||
(if (not (eq? hash index))
|
||
(begin (set-bucket-next! bucket
|
||
(vector-ref buckets
|
||
hash))
|
||
(vector-set! buckets hash bucket)))
|
||
(loop buckets index next (+ count 1) mod))))))
|
||
(lambda (bucket-vector old-buckets index)
|
||
(loop bucket-vector
|
||
index
|
||
(vector-ref old-buckets index)
|
||
0
|
||
(vector-length bucket-vector)))))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Internal hash table procedures
|
||
|
||
(define (make-table-rehasher key-hash gc? head-weak? tail-weak?)
|
||
((if gc?
|
||
make-gc-table-rehasher
|
||
make-stable-table-rehasher)
|
||
(make-bucket-dumper key-hash head-weak? tail-weak?)))
|
||
|
||
;;; GC-sensitive table rehashers have to be very carefully constructed.
|
||
;;; They may not allocate, and it must be absolutely certain whether or
|
||
;;; not they succeeded in hashing immediately following a certain GC
|
||
;;; stamp.
|
||
|
||
(define (make-gc-table-rehasher dump-bucket!)
|
||
(letrec ((attempt-rehash!
|
||
(make-gc-attempted-table-rehasher dump-bucket!))
|
||
(loop (lambda (table new-vector)
|
||
(if (attempt-rehash! table (gc-stamp) new-vector)
|
||
#f
|
||
(loop table new-vector)))))
|
||
(lambda (table stamp new-vector)
|
||
(or (attempt-rehash! table stamp new-vector)
|
||
(loop table new-vector)))))
|
||
|
||
;;; This returns a procedure that tries to copy all the buckets from
|
||
;;; TABLE's existing bucket vector to NEW-VECTOR.
|
||
|
||
(define (make-gc-attempted-table-rehasher dump-bucket!)
|
||
(define (loop table stamp new-vector old-buckets old-length
|
||
i new-size)
|
||
(cond ((not (eq? stamp (gc-stamp)))
|
||
;; Immediately abort, even if we finished copying all of the
|
||
;; buckets, because our efforts were for naught.
|
||
(vector-fill! new-vector (empty-bucket))
|
||
#f)
|
||
((= i old-length)
|
||
;; We succeeded in rehashing and a GC didn't occur to
|
||
;; circumvent us. Of course, a GC could still occur in the
|
||
;; next couple instructions, but that will be caught in the
|
||
;; next table lookup; what is important is that the table
|
||
;; table was completely rehashed safely.
|
||
(set-table-gc-stamp! table stamp)
|
||
(set-table-bucket-vector! table new-vector)
|
||
(set-table-size! table new-size)
|
||
#t)
|
||
(else
|
||
;; Copy the bucket at I & proceed happily. DUMP-BUCKET!
|
||
;; could test the stamp itself, but it's probably a lot
|
||
;; cheaper just to test it after every bucket copied.
|
||
(loop table stamp new-vector old-buckets old-length
|
||
(+ i 1)
|
||
(+ (dump-bucket! new-vector old-buckets i)
|
||
new-size)))))
|
||
(lambda (table stamp new-vector)
|
||
(let ((old-buckets (table-bucket-vector table)))
|
||
(loop table stamp new-vector
|
||
old-buckets
|
||
(vector-length old-buckets)
|
||
0 0))))
|
||
|
||
(define (make-stable-table-rehasher dump-bucket!)
|
||
(lambda (table stamp new-vector)
|
||
(let* ((old-buckets (table-bucket-vector table))
|
||
(old-length (vector-length old-buckets)))
|
||
(do ((i 0 (+ i 1))
|
||
(new-size 0
|
||
(+ (dump-bucket! new-vector old-buckets i)
|
||
new-size)))
|
||
((= i old-length)
|
||
(set-table-bucket-vector! table
|
||
new-vector)
|
||
(set-table-size! table new-size)
|
||
#t)))))
|
||
|
||
(define (make-table-hasher key-hash gc? rehasher)
|
||
(if gc?
|
||
(make-gc-table-hasher key-hash rehasher)
|
||
(lambda (table key)
|
||
(key-hash key (vector-length (table-bucket-vector table))))))
|
||
|
||
(define (make-gc-table-hasher key-hash rehash-table!)
|
||
(letrec ((retry
|
||
(lambda (table key mod new-vector)
|
||
(let* ((hash (key-hash key mod))
|
||
(stamp (gc-stamp)))
|
||
(if (or (eq? (table-gc-stamp table) stamp)
|
||
(rehash-table! table stamp new-vector))
|
||
hash
|
||
(retry table key mod new-vector))))))
|
||
(lambda (table key)
|
||
(let ((mod (vector-length (table-bucket-vector table))))
|
||
(let ((stamp (gc-stamp)))
|
||
(if (eq? (table-gc-stamp table) stamp)
|
||
(let* ((hash (key-hash key mod)))
|
||
(if (eq? (gc-stamp) stamp)
|
||
hash
|
||
;;; These next two calls are duplicated, but it is
|
||
;;; needed so we don't allocate unnecessarily.
|
||
(retry table key mod
|
||
(make-vector mod (empty-bucket)))))
|
||
(retry table key mod
|
||
(make-vector mod (empty-bucket)))))))))
|
||
|
||
(define (make-table-searcher key= table-hash gc? head-weak? tail-weak?)
|
||
(let ((search-bucket (make-bucket-searcher key= gc?
|
||
head-weak? tail-weak?)))
|
||
(lambda (table key)
|
||
(let* ((hash (table-hash table key))
|
||
(bucket-vector (table-bucket-vector table))
|
||
(bucket (vector-ref bucket-vector hash)))
|
||
(values hash (search-bucket table hash bucket key))))))
|
||
|
||
(define (make-table-expander table-hash gc?
|
||
head-weak? tail-weak?
|
||
rehash-table!)
|
||
(let ((make-entry (entry-maker head-weak? tail-weak?))
|
||
(rehash! (if gc?
|
||
(lambda (table new-vector)
|
||
(let loop ((stamp (table-gc-stamp table)))
|
||
(if (rehash-table! table stamp new-vector)
|
||
(values)
|
||
(loop (gc-stamp)))))
|
||
(lambda (table new-vector)
|
||
(rehash-table! table #f new-vector)))))
|
||
(lambda (table cached-hash key value)
|
||
(let* ((hash (if (maybe-expand-table! table rehash!)
|
||
cached-hash
|
||
(table-hash table key)))
|
||
;; Note the LET*: the rehash might set the table's bucket
|
||
;; vector.
|
||
(bucket-vector (table-bucket-vector table)))
|
||
(vector-set! bucket-vector hash
|
||
(make-bucket (make-entry key value)
|
||
(vector-ref bucket-vector hash)))
|
||
(set-table-size! table (+ (table-size table) 1))))))
|
||
|
||
(define (maybe-expand-table! table rehash!)
|
||
(let loop ((first? #t))
|
||
(let ((size (table-size table)))
|
||
(cond ((<= size (* (vector-length (table-bucket-vector table))
|
||
maximum-average-bucket-entries))
|
||
first?)
|
||
(else
|
||
(rehash! table
|
||
(make-vector (next-bucket-count size)
|
||
(empty-bucket)))
|
||
(loop #f))))))
|
||
|
||
(define (expunge-entry-from-table! table bucket-index entry)
|
||
(let ((bucket-vector (table-bucket-vector table)))
|
||
(vector-set! bucket-vector bucket-index
|
||
(expunge-entry-from-bucket!
|
||
(vector-ref bucket-vector bucket-index)
|
||
entry))))
|
||
|
||
|
||
|
||
;;; --------------------
|
||
;;; Various table templates
|
||
|
||
(define-syntax define-table-types
|
||
(syntax-rules ()
|
||
((define-table-types
|
||
(template-name constructor-name template-exp)
|
||
...)
|
||
(begin (begin (define template-name template-exp)
|
||
(define constructor-name
|
||
(table-constructor template-name)))
|
||
...))))
|
||
|
||
(define-table-types
|
||
(object-table-template make-object-table
|
||
(make-strong-table-template (lambda (x) #t) eq?
|
||
modular-descriptor-hash
|
||
#t ; GC-sensitive hash function
|
||
'object-table))
|
||
(weak-object-table-template make-weak-object-table
|
||
(make-weak-table-template (lambda (x) #t) eq?
|
||
modular-descriptor-hash
|
||
#t ; GC-sensitive hash function
|
||
'weak-object-table))
|
||
(string-table-template make-string-table
|
||
(make-strong-table-template string? string=?
|
||
modular-string-hash
|
||
#f ; GC-insensitive hash function
|
||
'string-table))
|
||
(string-ci-table-template make-string-ci-table
|
||
(make-strong-table-template string? string-ci=?
|
||
modular-string-ci-hash
|
||
#f ; GC-insensitive hash function
|
||
'string-ci-table))
|
||
(integer-table-template make-integer-table
|
||
(make-strong-table-template integer? =
|
||
modular-integer-hash
|
||
#f ; GC-insensitive hash function
|
||
'integer-table))
|
||
(symbol-table-template make-symbol-table
|
||
(make-strong-table-template symbol? eq?
|
||
(lambda (sym mod)
|
||
(modular-string-hash
|
||
(symbol->string sym)
|
||
mod))
|
||
#f ; GC-insensitive hash function
|
||
'symbol-table)))
|