* Handling weak-pairs is now generational, fixing performance
problems when guardians were used to implement hash tables.
This commit is contained in:
Abdulaziz Ghuloum
parent
123e2f9e10
commit
1cd2b8acfc
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
|
@ -369,6 +369,7 @@ ik_collect(int mem_req, ikpcb* pcb){
|
|||
#ifndef NDEBUG
|
||||
verify_integrity(pcb, "entry");
|
||||
#endif
|
||||
|
||||
{ /* ACCOUNTING */
|
||||
int bytes = ((int)pcb->allocation_pointer) -
|
||||
((int)pcb->heap_base);
|
||||
|
|
@ -409,6 +410,7 @@ ik_collect(int mem_req, ikpcb* pcb){
|
|||
*/
|
||||
|
||||
scan_dirty_pages(&gc);
|
||||
|
||||
collect_stack(&gc, pcb->frame_pointer, pcb->frame_base - wordsize);
|
||||
pcb->next_k = add_object(&gc, pcb->next_k, "next_k");
|
||||
pcb->symbol_table = add_object(&gc, pcb->symbol_table, "symbol_table");
|
||||
|
|
@ -826,7 +828,6 @@ forward_guardians(gc_t* gc){
|
|||
ik_munmap(cache, sizeof(ik_ptr_page));
|
||||
cache = next;
|
||||
}
|
||||
//exit(-1);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -851,7 +852,15 @@ empty_dropped_guardians(gc_t* gc){
|
|||
ref(a, off_cdr) = false_object;
|
||||
ref(tc, off_cdr) = a;
|
||||
pcb->dirty_vector[page_index(tc)] = -1;
|
||||
pcb->dirty_vector[page_index(d)] = -1;
|
||||
//pcb->dirty_vector[page_index(d)] = -1;
|
||||
{
|
||||
int dgen = pcb->segment_vector[page_index(d)] & gen_mask;
|
||||
if( (dgen > (pcb->segment_vector[page_index(obj)] & gen_mask))
|
||||
||
|
||||
(dgen > (pcb->segment_vector[page_index(a)] & gen_mask))){
|
||||
pcb->dirty_vector[page_index(d)] = -1;
|
||||
}
|
||||
}
|
||||
}
|
||||
ik_ptr_page* next = src->next;
|
||||
ik_munmap(src, sizeof(ik_ptr_page));
|
||||
|
|
@ -1628,9 +1637,10 @@ fix_weak_pointers(gc_t* gc){
|
|||
int collect_gen = gc->collect_gen;
|
||||
while(i < hi_idx){
|
||||
unsigned int t = segment_vec[i];
|
||||
if((t & type_mask) == weak_pairs_type){
|
||||
int gen = t & gen_mask;
|
||||
if(gen > collect_gen){
|
||||
if((t & (type_mask|new_gen_mask)) ==
|
||||
(weak_pairs_type|new_gen_tag)){
|
||||
//int gen = t & gen_mask;
|
||||
if (1) { //(gen > collect_gen){
|
||||
ikp p = (ikp)(i << pageshift);
|
||||
ikp q = p + pagesize;
|
||||
while(p < q){
|
||||
|
|
@ -1640,13 +1650,22 @@ fix_weak_pointers(gc_t* gc){
|
|||
if(tag != immediate_tag){
|
||||
ikp fst = ref(x, -tag);
|
||||
if(fst == forward_ptr){
|
||||
ref(p, 0) = ref(x, wordsize-tag); }
|
||||
else {
|
||||
ref(p, 0) = ref(x, wordsize-tag);
|
||||
} else {
|
||||
int x_gen = segment_vec[page_index(x)] & gen_mask;
|
||||
if(x_gen <= collect_gen){
|
||||
ref(p, 0) = bwp_object; } } } }
|
||||
p += (2*wordsize); } } }
|
||||
i++; } }
|
||||
ref(p, 0) = bwp_object;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
p += (2*wordsize);
|
||||
}
|
||||
}
|
||||
}
|
||||
i++;
|
||||
}
|
||||
}
|
||||
|
||||
static unsigned int dirty_mask[generation_count] = {
|
||||
0x88888888,
|
||||
|
|
@ -1750,38 +1769,6 @@ scan_dirty_code_page(gc_t* gc, int page_idx, unsigned int mask){
|
|||
dirty_vec[page_idx] = new_d;
|
||||
}
|
||||
|
||||
/* scanning dirty weak pointers should add the cdrs of the pairs
|
||||
* but leave the cars unmodified. The dirty mask is also kept
|
||||
* unmodified so that the after-pass fixes it.
|
||||
*/
|
||||
|
||||
static void
|
||||
scan_dirty_weak_pointers_page(gc_t* gc, int page_idx, int mask){
|
||||
unsigned int* dirty_vec = gc->pcb->dirty_vector;
|
||||
unsigned int d = dirty_vec[page_idx];
|
||||
unsigned int masked_d = d & mask;
|
||||
ikp p = (ikp)(page_idx << pageshift);
|
||||
int j;
|
||||
for(j=0; j<cards_per_page; j++){
|
||||
if(masked_d & (0xF << (j*meta_dirty_shift))){
|
||||
/* dirty card */
|
||||
ikp q = p + cardsize;
|
||||
while(p < q){
|
||||
ikp x = ref(p, wordsize);
|
||||
if(is_fixnum(x) || tagof(x) == immediate_tag){
|
||||
/* do nothing */
|
||||
} else {
|
||||
ikp y = add_object(gc, x, "nothing3");
|
||||
ref(p, wordsize) = y;
|
||||
}
|
||||
p += (2*wordsize);
|
||||
}
|
||||
} else {
|
||||
p += cardsize;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1813,11 +1800,9 @@ scan_dirty_pages(gc_t* gc){
|
|||
segment_vec = pcb->segment_vector;
|
||||
}
|
||||
else if (type == weak_pairs_type){
|
||||
if((t & gen_mask) > collect_gen){
|
||||
scan_dirty_weak_pointers_page(gc, i, mask);
|
||||
dirty_vec = pcb->dirty_vector;
|
||||
segment_vec = pcb->segment_vector;
|
||||
}
|
||||
scan_dirty_pointers_page(gc, i, mask);
|
||||
dirty_vec = pcb->dirty_vector;
|
||||
segment_vec = pcb->segment_vector;
|
||||
}
|
||||
else if (type == code_type){
|
||||
if((t & gen_mask) > collect_gen){
|
||||
|
|
@ -1879,8 +1864,9 @@ fix_new_pages(gc_t* gc){
|
|||
int i = lo_idx;
|
||||
while(i < hi_idx){
|
||||
unsigned int t = segment_vec[i];
|
||||
if((t & new_gen_mask) ||
|
||||
((t & type_mask) == weak_pairs_type)){
|
||||
// if((t & new_gen_mask) ||
|
||||
// ((t & type_mask) == weak_pairs_type)){
|
||||
if(t & new_gen_mask){
|
||||
segment_vec[i] = t & ~new_gen_mask;
|
||||
int page_gen = t & old_gen_mask;
|
||||
if(((t & type_mask) == pointers_type) ||
|
||||
|
|
|
|||
|
|
@ -1,273 +0,0 @@
|
|||
|
||||
(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))
|
||||
|
||||
|
|
@ -1,174 +0,0 @@
|
|||
|
||||
(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))
|
||||
|
|
@ -1,222 +0,0 @@
|
|||
|
||||
(library (ikarus hash-tables)
|
||||
(export hash-table? make-hash-table get-hash-table put-hash-table!)
|
||||
(import
|
||||
(ikarus system $pairs)
|
||||
(ikarus system $vectors)
|
||||
(ikarus system $tcbuckets)
|
||||
(ikarus system $fx)
|
||||
(except (ikarus) hash-table? make-hash-table get-hash-table
|
||||
put-hash-table!))
|
||||
|
||||
(define-record hasht (vec count tc))
|
||||
|
||||
;;; 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-syntax inthash
|
||||
(syntax-rules ()
|
||||
[(_ x) x]))
|
||||
|
||||
#;(define-syntax inthash
|
||||
(syntax-rules ()
|
||||
[(_ x) ($fxinthash x)]))
|
||||
|
||||
#;(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 (hasht-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 (hasht-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 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
|
||||
[(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($tcbucket-val b))]
|
||||
[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
|
||||
[(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
(let ([bucket
|
||||
($make-tcbucket (hasht-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 ([ct (hasht-count h)])
|
||||
(set-hasht-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 (hasht-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-hasht-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
|
||||
(define (hash-table? x) (hasht? x))
|
||||
|
||||
(define (make-hash-table)
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make-hasht (make-base-vec 32) 0 tc))))
|
||||
|
||||
(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))))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue