added:
src/ikarus.hash-tables.guardians.ss src/ikarus.hash-tables.rehashing.ss
This commit is contained in:
Abdulaziz Ghuloum
parent
51d512484b
commit
94df957775
|
|
@ -0,0 +1,273 @@
|
|||
|
||||
(library (ikarus hash-tables)
|
||||
(export hash-table? make-hash-table get-hash-table put-hash-table!)
|
||||
(import
|
||||
(ikarus system $vectors)
|
||||
(ikarus system $fx)
|
||||
(except (ikarus) hash-table? make-hash-table
|
||||
get-hash-table put-hash-table!))
|
||||
|
||||
(define-syntax inthash
|
||||
(syntax-rules ()
|
||||
[(_ x) x]))
|
||||
|
||||
|
||||
(define-record ht (g v count threashold rehashed))
|
||||
(define-record lk (key val next))
|
||||
|
||||
(define make-transport-guardian
|
||||
(lambda ()
|
||||
(define loop
|
||||
(lambda (m g)
|
||||
(and m
|
||||
(let ([x (car m)])
|
||||
(if (bwp-object? x)
|
||||
(loop (g) g)
|
||||
(begin (g m) x))))))
|
||||
(let ([g (make-guardian)])
|
||||
(case-lambda
|
||||
[(x) (g (weak-cons x #f))]
|
||||
[() (loop (g) g)]))))
|
||||
|
||||
(define initial-size 8)
|
||||
|
||||
;;; assq-like lookup
|
||||
(define direct-lookup
|
||||
(lambda (x b)
|
||||
(if (fixnum? b)
|
||||
#f
|
||||
(if (eq? x (lk-key b))
|
||||
b
|
||||
(direct-lookup x (lk-next b))))))
|
||||
|
||||
(define rehash-lookup
|
||||
(lambda (h g x)
|
||||
(cond
|
||||
[(g) =>
|
||||
(lambda (b)
|
||||
(re-add! h b)
|
||||
(if (eq? x (lk-key b))
|
||||
b
|
||||
(rehash-lookup h g x)))]
|
||||
[else #f])))
|
||||
|
||||
(define get-bucket-index
|
||||
(lambda (b)
|
||||
(let ([next (lk-next b)])
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next)))))
|
||||
|
||||
(define replace!
|
||||
(lambda (lb x y)
|
||||
(let ([n (lk-next lb)])
|
||||
(cond
|
||||
[(eq? n x)
|
||||
(set-lk-next! lb y)]
|
||||
[else
|
||||
(replace! n x y)]))))
|
||||
|
||||
(define re-add!
|
||||
(lambda (h b)
|
||||
(let ([vec (ht-v h)]
|
||||
[next (lk-next b)])
|
||||
;;; first remove it from its old place
|
||||
(set-ht-rehashed! h (fx+ (ht-rehashed h) 1))
|
||||
(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 ([k (lk-key b)])
|
||||
(let ([ih (inthash (pointer-value k))])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([n ($vector-ref vec idx)])
|
||||
(set-lk-next! b n)
|
||||
($vector-set! vec idx b))))))))
|
||||
|
||||
(define get-hash
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (ht-v 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 (ht-g h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
(lk-val b))]
|
||||
[else v])))))))
|
||||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (ht-v 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 (ht-g h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
(set-lk-val! b v))]
|
||||
[else
|
||||
(let ([bucket (make-lk x v ($vector-ref vec idx))])
|
||||
((ht-g h) bucket)
|
||||
(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-lk-next! bucket ($vector-ref vec idx))
|
||||
($vector-set! vec idx bucket))))
|
||||
(let ([ct (ht-count h)])
|
||||
(set-ht-count! h ($fx+ 1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))))
|
||||
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x (lk-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih (inthash pv)]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next (lk-next b)])
|
||||
(set-lk-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 ($fx+ 1 i) n vec2 mask)))))
|
||||
|
||||
(define enlarge-table
|
||||
(lambda (h)
|
||||
(let* ([vec1 (ht-v h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-ht-v! h vec2))))
|
||||
|
||||
(define make-base-vec
|
||||
(lambda (n)
|
||||
(init-vec (make-vector n) 0 n)))
|
||||
|
||||
(define init-vec
|
||||
(lambda (v i n)
|
||||
(if ($fx= i n)
|
||||
v
|
||||
(begin
|
||||
($vector-set! v i i)
|
||||
(init-vec v ($fx+ 1 i) n)))))
|
||||
|
||||
;;; public interface
|
||||
(define hash-table?
|
||||
(lambda (x) (ht? x)))
|
||||
|
||||
(define make-hash-table
|
||||
(lambda ()
|
||||
(make-ht (make-transport-guardian)
|
||||
(init-vec (make-vector initial-size) 0 initial-size)
|
||||
0
|
||||
initial-size
|
||||
0)))
|
||||
|
||||
(define get-hash-table
|
||||
(lambda (h x v)
|
||||
(if (ht? h)
|
||||
(get-hash h x v)
|
||||
(error 'get-hash-table "~s is not a hash table" h))))
|
||||
|
||||
(define put-hash-table!
|
||||
(lambda (h x v)
|
||||
(if (ht? h)
|
||||
(put-hash! h x v)
|
||||
(error 'put-hash-table! "~s is not a hash table" h))))
|
||||
|
||||
(define hasht-rehash-count
|
||||
(lambda (h)
|
||||
(if (ht? h)
|
||||
(ht-rehashed h)
|
||||
(error 'hasht-rehash-count "~s is not a hash table" h))))
|
||||
|
||||
(define hasht-reset-count!
|
||||
(lambda (h)
|
||||
(if (ht? h)
|
||||
(set-ht-rehashed! h 0)
|
||||
(error 'hasht-rehash-count "~s is not a hash table" h))))
|
||||
)
|
||||
|
||||
#!eof
|
||||
|
||||
(import ght)
|
||||
|
||||
(define (test1)
|
||||
(printf "test1 ...\n")
|
||||
(let ([ls (let f ([i 100000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
||||
(let f ([i 1000])
|
||||
(unless (fx= i 0)
|
||||
(collect)
|
||||
(f (fx- i 1))))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test1 "failed")))
|
||||
ls)))
|
||||
(printf "passed test1\n"))
|
||||
|
||||
(define (test2)
|
||||
(printf "test2 ...\n")
|
||||
(let ([ls (let f ([i 10000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(collect)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test2 "failed")))
|
||||
ls)))
|
||||
(printf "passed test2\n"))
|
||||
|
||||
(define (test3)
|
||||
(printf "test3 ...\n")
|
||||
(let ([ls (let f ([i 10000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x)
|
||||
(collect)
|
||||
(put-hash-table! ht x x))
|
||||
ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test3 "failed")))
|
||||
ls)))
|
||||
(printf "passed test3\n"))
|
||||
|
||||
(define (test-all)
|
||||
(test1)
|
||||
(test2)
|
||||
(test3))
|
||||
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
|
||||
(library (ikarus hash-tables)
|
||||
(export hash-table? make-hash-table get-hash-table put-hash-table!)
|
||||
(import
|
||||
(except (ikarus) hash-table? make-hash-table
|
||||
get-hash-table put-hash-table!))
|
||||
|
||||
(define-syntax inthash
|
||||
(syntax-rules ()
|
||||
[(_ x) x]))
|
||||
|
||||
(define-record hasht (vec count gckey))
|
||||
|
||||
(define stretch
|
||||
(lambda (h v n)
|
||||
(set-hasht-gckey! h (collect-key))
|
||||
(let ([newv (make-vector (fx* n 2) '())]
|
||||
[mask (fx- (* n 2) 1)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(let f ([b (vector-ref v i)])
|
||||
(unless (null? b)
|
||||
(let ([idx (fxlogand (inthash (pointer-value (caar b))) mask)]
|
||||
[next (cdr b)])
|
||||
(set-cdr! b (vector-ref newv idx))
|
||||
(vector-set! newv idx b)
|
||||
(f next)))))
|
||||
(set-hasht-vec! h newv))))
|
||||
|
||||
(define rehash
|
||||
(lambda (h v)
|
||||
(set-hasht-gckey! h (collect-key))
|
||||
(let ([n (vector-length v)])
|
||||
(let f ([i 0])
|
||||
(if (fx= i n)
|
||||
(void)
|
||||
(let ([b (vector-ref v i)])
|
||||
(if (null? b)
|
||||
(f (fx+ i 1))
|
||||
(begin
|
||||
(vector-set! v i '())
|
||||
(let g ([i (fx+ i 1)] [loc (last-pair b)])
|
||||
(if (fx= i n)
|
||||
(let ([mask (fx- n 1)])
|
||||
(void)
|
||||
(let f ([b b])
|
||||
(unless (null? b)
|
||||
(let ([idx (fxlogand (inthash (pointer-value (caar b))) mask)])
|
||||
(let ([next (cdr b)])
|
||||
(set-cdr! b (vector-ref v idx))
|
||||
(vector-set! v idx b)
|
||||
(f next))))))
|
||||
(let ([b (vector-ref v i)])
|
||||
(if (null? b)
|
||||
(g (fx+ i 1) loc)
|
||||
(begin
|
||||
(vector-set! v i '())
|
||||
(set-cdr! loc b)
|
||||
(g (fx+ i 1) (last-pair b)))))))))))))))
|
||||
|
||||
(define get-hash
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx (fxlogand ih (fx- (vector-length vec) 1))])
|
||||
(let ([b (vector-ref vec idx)])
|
||||
(cond
|
||||
[(assq x b) => cdr]
|
||||
[(not (eq? (hasht-gckey h) (collect-key)))
|
||||
(rehash h vec)
|
||||
(get-hash h x v)]
|
||||
[else v])))))))
|
||||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx (fxlogand ih (fx- (vector-length vec) 1))])
|
||||
(let ([b (vector-ref vec idx)])
|
||||
(cond
|
||||
[(assq x b) => (lambda (a) (set-cdr! a v))]
|
||||
[(not (eq? (hasht-gckey h) (collect-key)))
|
||||
(rehash h vec)
|
||||
(put-hash! h x v)]
|
||||
[else
|
||||
(vector-set! vec idx (cons (cons x v) b))
|
||||
(let ([ct (hasht-count h)])
|
||||
(set-hasht-count! h (fxadd1 ct))
|
||||
(let ([n (vector-length vec)])
|
||||
(when (fx> ct n)
|
||||
(stretch h vec n))))])))))))
|
||||
|
||||
;;; public interface
|
||||
(define (hash-table? x) (hasht? x))
|
||||
|
||||
(define (make-hash-table)
|
||||
(make-hasht (make-vector 32 '()) 0 (collect-key)))
|
||||
|
||||
(define get-hash-table
|
||||
(lambda (h x v)
|
||||
(if (hasht? h)
|
||||
(get-hash h x v)
|
||||
(error 'get-hash-table "~s is not a hash table" h))))
|
||||
|
||||
(define put-hash-table!
|
||||
(lambda (h x v)
|
||||
(if (hasht? h)
|
||||
(put-hash! h x v)
|
||||
(error 'put-hash-table! "~s is not a hash table" h))))
|
||||
)
|
||||
|
||||
#!eof
|
||||
|
||||
(import rht)
|
||||
|
||||
(define (test1)
|
||||
(printf "test1 ...\n")
|
||||
(let ([ls (let f ([i 100000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
||||
(let f ([i 1000])
|
||||
(unless (fx= i 0)
|
||||
(collect)
|
||||
(f (fx- i 1))))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test1 "failed")))
|
||||
ls)))
|
||||
(printf "passed test1\n"))
|
||||
|
||||
(define (test2)
|
||||
(printf "test2 ...\n")
|
||||
(let ([ls (let f ([i 10000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(collect)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test2 "failed")))
|
||||
ls)))
|
||||
(printf "passed test2\n"))
|
||||
|
||||
(define (test3)
|
||||
(printf "test3 ...\n")
|
||||
(let ([ls (let f ([i 10000] [ac '()])
|
||||
(cond
|
||||
[(fx= i 0) ac]
|
||||
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (x)
|
||||
(collect)
|
||||
(put-hash-table! ht x x))
|
||||
ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (eq? x (get-hash-table ht x #f))
|
||||
(error 'test3 "failed")))
|
||||
ls)))
|
||||
(printf "passed test3\n"))
|
||||
|
||||
(define (test-all)
|
||||
(test1)
|
||||
(test2)
|
||||
(test3))
|
||||
Loading…
Reference in New Issue