blob: 013db20eb06e827b24d3b393a1cbe674cae0e97a (
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
|
;;
;; 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) srfi-1 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)))
;;;;;;;;;;;;
;; 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)))
((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))))
|
