From 38155f79acb4f01308b7685834e4c50560a6e8b1 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Tue, 5 Aug 2025 10:07:40 +0200
Subject: Add custom hash table implementation to compare direct
 hash-table-as-set

This uses hash-tables directly instead of creating the hash table from
the lset every time.  It's faster than using srfi-69 because it can be
inlined better.
---
 benchmarks/benchmark.scm | 60 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 59 insertions(+), 1 deletion(-)

(limited to 'benchmarks')

diff --git a/benchmarks/benchmark.scm b/benchmarks/benchmark.scm
index 013db20..541f5db 100644
--- a/benchmarks/benchmark.scm
+++ b/benchmarks/benchmark.scm
@@ -9,7 +9,7 @@
 ;; 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)
+(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"))
@@ -95,6 +95,55 @@
               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
@@ -116,6 +165,15 @@
      (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)
-- 
cgit v1.2.3