blob: 541f5db9b820f5fac623d064760487b353b5b0f5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
;;
;; Simple benchmarking program to compare set-difference on hash
;; tables, lsets and slsets.
;;
;; Note that the tests for slsets is severely disadvantaged because
;; the hash tables are created with the size of the set, which
;; normally would not be the case because you can't predict ahead of
;; time how big it would get. Also, the symbols have a short string
;; value which makes hashing fast. Slsets don't care about the symbol
;; size and don't need a preallocated size.
(import (chicken fixnum) (chicken string) (chicken process-context) (only srfi-1 lset-difference) srfi-69 slsets)
(unless (= (length (command-line-arguments)) 2)
(error "Need impl name (one of lset, slset, symbolset or srfi-69) and set size"))
(define impl (string->symbol (car (command-line-arguments))))
(define size (string->number (cadr (command-line-arguments))))
(define-inline (list-tabulate n fun)
(let lp ((i 0)
(res '()))
(if (= i n)
res
(lp (add1 i)
(cons (fun i) res)))))
(define lst (list-tabulate size (lambda (i) (string->symbol (conc "x" i)))))
(define lst (list-tabulate size (lambda (i) (string->symbol (conc "y" i)))))
;; Super-hacky way to determine impact of caching the hash value in a symbol.
;; We abuse the symbol's toplevel value slot to store the hash. A slightly
;; cleaner but slower implementation could use the plist to store it.
;; Oddly enough, the impact seems very minor.
(define symbol-cache? #f)
(define-inline (filter pred lst)
(let lp ((lst lst)
(res '()))
(cond ((null? lst) (reverse res))
((not (pred (car lst))) (lp (cdr lst) res))
(else (lp (cdr lst) (cons (car lst) res))))))
;;;;;;;;;;;;
;;; Quick and dirty hash table as used in CHICKEN internally
;;;;;;;;;;;;
(define hash-symbol
(let ((cache-s #f)
(cache-h #f)
;; NOTE: All low-level hash tables share the same randomization factor
(rand (##core#inline "C_rand" #x10000)))
(lambda (s n)
(cond ((not (##core#inline "C_unboundvaluep" (##sys#slot s 0))) ; Repeated here for cached-srfi-69
(##core#inline "C_fixnum_modulo" (##sys#slot s 0) n))
((eq? s cache-s)
(##core#inline "C_fixnum_modulo" cache-h n))
(else
(let ((bv (##sys#slot s 1)))
(set! cache-s s)
(set! cache-h (##core#inline "C_u_i_bytevector_hash" bv 0 (fx- (##sys#size bv) 1) rand))
(when symbol-cache?
(##sys#setslot s 0 cache-h))
(##core#inline "C_fixnum_modulo" cache-h n)))))))
(define-inline (fast-hash-symbol s n)
(if (not (##core#inline "C_unboundvaluep" (##sys#slot s 0)))
(##core#inline "C_fixnum_modulo" (##sys#slot s 0) n)
(hash-symbol s n)))
(define (make-my-hash-table #!optional (size 301))
(make-vector size '()))
(define (my-hash-table-ref ht key)
(let loop ((bucket (##sys#slot ht (fast-hash-symbol key (##sys#size ht)))))
(and (not (eq? '() bucket))
(if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
(##sys#slot (##sys#slot bucket 0) 1)
(loop (##sys#slot bucket 1))))))
(define (my-hash-table-set! ht key val)
(let* ((k (fast-hash-symbol key (##sys#size ht)))
(ib (##sys#slot ht k)))
(let loop ((bucket ib))
(if (eq? '() bucket)
(##sys#setslot ht k (cons (cons key val) ib))
(if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
(##sys#setslot (##sys#slot bucket 0) 1 val)
(loop (##sys#slot bucket 1)))))))
(define (symbolset-difference ls . lss)
(let ((seen (make-my-hash-table size)))
(for-each (lambda (lst)
(for-each (lambda (x) (my-hash-table-set! seen x #t)) lst))
lss)
(filter (lambda (x) (not (my-hash-table-ref seen x))) ls)))
;;;;;
(define (my-hash-table-delete! ht key)
(let* ((k (fast-hash-symbol key (##sys#size ht)))
(ib (##sys#slot ht k)))
(let loop ((bucket ib)
(prev #f))
(if (eq? '() bucket)
(void)
(if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
(if prev
(##sys#setslot prev 1 (##sys#slot bucket 1))
(##sys#setslot ht k (##sys#slot bucket 1)))
(loop (##sys#slot bucket 1) bucket))))))
(define (my-hash-table-walk ht fun)
(let loop ((i (##sys#size ht)))
(when (fx> i 0)
(for-each (lambda (x)
(fun (##sys#slot x 0) (##sys#slot x 1)))
(##sys#slot ht (fx- i 1)))
(loop (fx- i 1)))))
(define (alist-copy x)
(let lp ((x x)
(res '()))
(if (null? x)
res
(lp (cdr x) (cons (cons (car (car x)) (cdr (car x))) res)))))
(define (my-hash-table-copy ht)
(let ((new-ht (make-my-hash-table (##sys#size ht))))
(let loop ((i (##sys#size ht)))
(when (fx> i 0)
(##sys#setslot new-ht (fx- i 1) (alist-copy (##sys#slot ht (fx- i 1))))
(loop (fx- i 1))))
new-ht))
(define (my-hash-table-difference ht1 ht2)
#;(let ((result (my-hash-table-copy ht1)))
(my-hash-table-walk ht2 (lambda (k v)
(my-hash-table-delete! result k)))
result)
(let ((result (make-my-hash-table size)))
(my-hash-table-walk ht2 (lambda (k v)
(when (my-hash-table-ref ht1 k)
(my-hash-table-set! result k v))))))
;;;;;;;;;;;;
;; For comparison, a bit strange
(define (srfi-69-hash-table-difference ht1 ht2)
(let ((result (hash-table-copy ht1)))
(hash-table-walk ht2 (lambda (k v)
(hash-table-delete! result k)))
result))
;;;;;;;;;;;;
(let lp ((i 10000))
(case impl
((lset)
(lset-difference eq? lst (cons 'aha lst)))
((slset)
(slset-difference lst (cons 'aha lst)))
((symbolset cached-symbolset)
(when (eq? impl 'cached-symbolset)
(set! symbol-cache? #t))
(symbolset-difference lst (cons 'aha lst)))
((hash-table cached-hash-table)
(when (pair? lst)
(when (eq? impl 'cached-hash-table)
(set! symbol-cache? #t))
(let ((ht (make-my-hash-table size)))
(begin
(for-each (lambda (x) (my-hash-table-set! ht x #t)) lst)
(set! lst ht))))
(my-hash-table-difference lst lst))
((srfi-69 cached-srfi-69)
(when (pair? lst)
(when (eq? impl 'cached-srfi-69)
(set! symbol-cache? #t))
(let ((ht (make-hash-table eq? (if (eq? impl 'cached-srfi-69) hash-symbol symbol-hash) size)))
(begin
(for-each (lambda (x) (hash-table-set! ht x #t)) lst)
(set! lst ht))))
(srfi-69-hash-table-difference lst lst))
(else (error "Unknown impl" impl)))
(unless (zero? i)
(lp (sub1 i))))
|
