Initial implementation of slsets egg

This implements sets of symbols *as lists*, like in the srfi-1 lset
operations.  It maintains the benefit of using lists for everything,
but not having to pay the quadratic performance penalty that srfi-1
entails.  We achieve this by using plist operations to "mark" items
so we have to visit the list "set" only a fixed number of times.

1 files changed, 110 insertions, 0 deletions

diff --git a/benchmarks/benchmark.scm b/benchmarks/benchmark.scm
new file mode 100644
index 0000000..21d3c43
--- /dev/null
+++ b/benchmarks/benchmark.scm
@@ -0,0 +1,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))))