blob: 21d3c43ca2168d5d56428f35a48331e861313c38 (
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
|
;;
;; 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)))))
(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)
(if (eq? s cache-s)
(##core#inline "C_fixnum_modulo" cache-h n)
(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))
(##core#inline "C_fixnum_modulo" cache-h 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 (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 (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)
(symbolset-difference lst (cons 'aha lst)))
((srfi-69)
(when (pair? lst)
(let ((ht (make-hash-table eq? 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))))
|
