245 lines
7.8 KiB
Scheme
245 lines
7.8 KiB
Scheme
|
|
||
|
|
(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc dlink))])
|
||
|
|
;;; accessors
|
||
|
|
(define get-vec (record-field-accessor hash-rtd 0))
|
||
|
|
(define set-vec! (record-field-mutator hash-rtd 0))
|
||
|
|
(define get-count (record-field-accessor hash-rtd 1))
|
||
|
|
(define set-count! (record-field-mutator hash-rtd 1))
|
||
|
|
(define get-tc (record-field-accessor hash-rtd 2))
|
||
|
|
(define get-dlink (record-field-accessor hash-rtd 3))
|
||
|
|
;;; implementation
|
||
|
|
|
||
|
|
;;; directly from Dybvig's paper
|
||
|
|
(define tc-pop
|
||
|
|
(lambda (tc)
|
||
|
|
(let ([x ($car tc)])
|
||
|
|
(if (eq? x ($cdr tc))
|
||
|
|
#f
|
||
|
|
(let ([v ($car x)])
|
||
|
|
($set-car! tc ($cdr x))
|
||
|
|
($set-car! x #f)
|
||
|
|
($set-cdr! x #f)
|
||
|
|
v)))))
|
||
|
|
|
||
|
|
(define inthash
|
||
|
|
(lambda (key)
|
||
|
|
;static int inthash(int key) { /* from Bob Jenkin's */
|
||
|
|
; key += ~(key << 15);
|
||
|
|
; key ^= (key >> 10);
|
||
|
|
; key += (key << 3);
|
||
|
|
; key ^= (key >> 6);
|
||
|
|
; key += ~(key << 11);
|
||
|
|
; key ^= (key >> 16);
|
||
|
|
; return key;
|
||
|
|
;}
|
||
|
|
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
|
||
|
|
[key ($fxlogxor key ($fxsra key 10))]
|
||
|
|
[key ($fx+ key ($fxsll key 3))]
|
||
|
|
[key ($fxlogxor key ($fxsra key 6))]
|
||
|
|
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
|
||
|
|
[key ($fxlogxor key ($fxsra key 16))])
|
||
|
|
key)))
|
||
|
|
|
||
|
|
;;; assq-like lookup
|
||
|
|
(define direct-lookup
|
||
|
|
(lambda (x b)
|
||
|
|
(if (fixnum? b)
|
||
|
|
#f
|
||
|
|
(if (eq? x ($tcbucket-key b))
|
||
|
|
b
|
||
|
|
(direct-lookup x ($tcbucket-next b))))))
|
||
|
|
|
||
|
|
(define rehash-lookup
|
||
|
|
(lambda (h tc x)
|
||
|
|
(cond
|
||
|
|
[(tc-pop tc) =>
|
||
|
|
(lambda (b)
|
||
|
|
(if (eq? ($tcbucket-next b) #f)
|
||
|
|
(rehash-lookup h tc x)
|
||
|
|
(begin
|
||
|
|
(re-add! h b)
|
||
|
|
(if (eq? x ($tcbucket-key b))
|
||
|
|
b
|
||
|
|
(rehash-lookup h tc x)))))]
|
||
|
|
[else #f])))
|
||
|
|
|
||
|
|
(define get-bucket-index
|
||
|
|
(lambda (b)
|
||
|
|
(let ([next ($tcbucket-next b)])
|
||
|
|
(if (fixnum? next)
|
||
|
|
next
|
||
|
|
(get-bucket-index next)))))
|
||
|
|
|
||
|
|
(define replace!
|
||
|
|
(lambda (lb x y)
|
||
|
|
(let ([n ($tcbucket-next lb)])
|
||
|
|
(cond
|
||
|
|
[(eq? n x)
|
||
|
|
($set-tcbucket-next! lb y)
|
||
|
|
(void)]
|
||
|
|
[else
|
||
|
|
(replace! n x y)]))))
|
||
|
|
|
||
|
|
(define re-add!
|
||
|
|
(lambda (h b)
|
||
|
|
(let ([vec (get-vec h)]
|
||
|
|
[next ($tcbucket-next b)])
|
||
|
|
;;; first remove it from its old place
|
||
|
|
(let ([idx
|
||
|
|
(if (fixnum? next)
|
||
|
|
next
|
||
|
|
(get-bucket-index next))])
|
||
|
|
(let ([fst ($vector-ref vec idx)])
|
||
|
|
(cond
|
||
|
|
[(eq? fst b)
|
||
|
|
($vector-set! vec idx next)]
|
||
|
|
[else
|
||
|
|
(replace! fst b next)])))
|
||
|
|
;;; reset the tcbucket-tconc FIRST
|
||
|
|
($set-tcbucket-tconc! b (get-tc h))
|
||
|
|
;;; then add it to the new place
|
||
|
|
(let ([k ($tcbucket-key b)])
|
||
|
|
(let ([ih (inthash (pointer-value k))])
|
||
|
|
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||
|
|
(let ([n ($vector-ref vec idx)])
|
||
|
|
($set-tcbucket-next! b n)
|
||
|
|
($vector-set! vec idx b)
|
||
|
|
(void))))))))
|
||
|
|
|
||
|
|
|
||
|
|
;(define hash-remove!
|
||
|
|
; (lambda (h x)
|
||
|
|
; (let ([vec (get-vec h)]
|
||
|
|
; [next ($tcbucket-next b)])
|
||
|
|
; ;;; first remove it from its old place
|
||
|
|
; (let ([idx
|
||
|
|
; (if (fixnum? next)
|
||
|
|
; next
|
||
|
|
; (get-bucket-index next))])
|
||
|
|
; (let ([fst ($vector-ref vec idx)])
|
||
|
|
; (cond
|
||
|
|
; [(eq? fst b)
|
||
|
|
; ($vector-set! vec idx next)]
|
||
|
|
; [else
|
||
|
|
; (replace! fst b next)]))))
|
||
|
|
; (let ([b1 ($tcbucket-dlink-next b)]
|
||
|
|
; [b2 ($tcbucket-dlink-prev b)])
|
||
|
|
; ($set-tcbucket-dlink-next! b2 b1)
|
||
|
|
; ($set-tcbucket-dlink-prev! b1 b2)
|
||
|
|
; (void))))
|
||
|
|
|
||
|
|
(define get-hash
|
||
|
|
(lambda (h x v)
|
||
|
|
(let ([pv (pointer-value x)]
|
||
|
|
[vec (get-vec h)])
|
||
|
|
(let ([ih (inthash pv)])
|
||
|
|
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||
|
|
(let ([b ($vector-ref vec idx)])
|
||
|
|
(cond
|
||
|
|
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||
|
|
=>
|
||
|
|
(lambda (b)
|
||
|
|
($tcbucket-val b))]
|
||
|
|
[else v])))))))
|
||
|
|
|
||
|
|
|
||
|
|
(define put-hash!
|
||
|
|
(lambda (h x v)
|
||
|
|
(let ([pv (pointer-value x)]
|
||
|
|
[vec (get-vec h)])
|
||
|
|
(let ([ih (inthash pv)])
|
||
|
|
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||
|
|
(let ([b ($vector-ref vec idx)])
|
||
|
|
(cond
|
||
|
|
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||
|
|
=>
|
||
|
|
(lambda (b)
|
||
|
|
($set-tcbucket-val! b v)
|
||
|
|
(void))]
|
||
|
|
[else
|
||
|
|
(let ([bucket
|
||
|
|
($make-tcbucket (get-tc h) x v ($vector-ref vec idx))])
|
||
|
|
(if ($fx= (pointer-value x) pv)
|
||
|
|
($vector-set! vec idx bucket)
|
||
|
|
(let* ([ih (inthash (pointer-value x))]
|
||
|
|
[idx
|
||
|
|
($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||
|
|
($set-tcbucket-next! bucket ($vector-ref vec idx))
|
||
|
|
($vector-set! vec idx bucket)))
|
||
|
|
(let ([b1 (get-dlink h)])
|
||
|
|
(let ([b2 ($tcbucket-dlink-next b1)])
|
||
|
|
($set-tcbucket-dlink-next! bucket b2)
|
||
|
|
($set-tcbucket-dlink-prev! bucket b1)
|
||
|
|
($set-tcbucket-dlink-next! b1 bucket)
|
||
|
|
($set-tcbucket-dlink-prev! b2 bucket))))
|
||
|
|
(let ([ct (get-count h)])
|
||
|
|
(set-count! h ($fxadd1 ct))
|
||
|
|
(when ($fx> ct ($vector-length vec))
|
||
|
|
(enlarge-table h)))])))))))
|
||
|
|
|
||
|
|
(define insert-b
|
||
|
|
(lambda (b vec mask)
|
||
|
|
(let* ([x ($tcbucket-key b)]
|
||
|
|
[pv (pointer-value x)]
|
||
|
|
[ih (inthash pv)]
|
||
|
|
[idx ($fxlogand ih mask)]
|
||
|
|
[next ($tcbucket-next b)])
|
||
|
|
($set-tcbucket-next! b ($vector-ref vec idx))
|
||
|
|
($vector-set! vec idx b)
|
||
|
|
(unless (fixnum? next)
|
||
|
|
(insert-b next vec mask)))))
|
||
|
|
|
||
|
|
(define move-all
|
||
|
|
(lambda (vec1 i n vec2 mask)
|
||
|
|
(unless ($fx= i n)
|
||
|
|
(let ([b ($vector-ref vec1 i)])
|
||
|
|
(unless (fixnum? b)
|
||
|
|
(insert-b b vec2 mask))
|
||
|
|
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||
|
|
|
||
|
|
(define enlarge-table
|
||
|
|
(lambda (h)
|
||
|
|
(let* ([vec1 (get-vec h)]
|
||
|
|
[n1 ($vector-length vec1)]
|
||
|
|
[n2 ($fxsll n1 1)]
|
||
|
|
[vec2 (make-base-vec n2)])
|
||
|
|
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||
|
|
(set-vec! h vec2))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define init-vec
|
||
|
|
(lambda (v i n)
|
||
|
|
(if ($fx= i n)
|
||
|
|
v
|
||
|
|
(begin
|
||
|
|
($vector-set! v i i)
|
||
|
|
(init-vec v ($fxadd1 i) n)))))
|
||
|
|
|
||
|
|
(define make-base-vec
|
||
|
|
(lambda (n)
|
||
|
|
(init-vec (make-vector n) 0 n)))
|
||
|
|
|
||
|
|
;;; public interface
|
||
|
|
(primitive-set! 'hash-table? (record-predicate hash-rtd))
|
||
|
|
(primitive-set! 'make-hash-table
|
||
|
|
(let ([make (record-constructor hash-rtd)])
|
||
|
|
(lambda ()
|
||
|
|
(let ([x (cons #f #f)])
|
||
|
|
(let ([tc (cons x x)])
|
||
|
|
(make (make-base-vec 32) 0 tc
|
||
|
|
(let ([b ($make-tcbucket tc #f #f #f)])
|
||
|
|
($set-tcbucket-dlink-next! b b)
|
||
|
|
($set-tcbucket-dlink-prev! b b)
|
||
|
|
b)))))))
|
||
|
|
(primitive-set! 'get-hash-table
|
||
|
|
(lambda (h x v)
|
||
|
|
(if (hash-table? h)
|
||
|
|
(get-hash h x v)
|
||
|
|
(error 'get-hash-table "~s is not a hash table" h))))
|
||
|
|
(primitive-set! 'put-hash-table!
|
||
|
|
(lambda (h x v)
|
||
|
|
(if (hash-table? h)
|
||
|
|
(put-hash! h x v)
|
||
|
|
(error 'put-hash-table! "~s is not a hash table" h)))))
|