Further small optimizations

Author: dpk

srfi/250/hash-tables.scm

@@ -116,22 +116,21 @@
   ((hash-table-type-test-function ht) obj))
 
 (define (%hash-table-bucket-for ht hash key)
-  (let loop ((hash hash))
-    ;;(display hash) (newline)
-    (let* ((bucket
-            (modulo hash
-                    (compact-array-length (hash-table-compact-index ht))))
-           (entry-idx
-            (compact-array-ref (hash-table-compact-index ht) bucket)))
-      (if entry-idx
-          (let ((found-key
-                 (vector-ref (hash-table-keys-vector ht) entry-idx)))
-            (if (and (not (deletion? found-key))
-                     (or (unfilled? found-key)
-                         (hash-table-same? ht key found-key)))
-                bucket
-                (loop (+ hash 1))))
-          bucket))))
+  (let ((n-buckets (compact-array-length (hash-table-compact-index ht))))
+    (let loop ((hash hash))
+      ;;(display hash) (newline)
+      (let* ((bucket (modulo hash n-buckets))
+             (entry-idx
+              (compact-array-ref (hash-table-compact-index ht) bucket)))
+        (if entry-idx
+            (let ((found-key
+                   (vector-ref (hash-table-keys-vector ht) entry-idx)))
+              (if (and (not (deletion? found-key))
+                       (or (unfilled? found-key)
+                           (hash-table-same? ht key found-key)))
+                  bucket
+                  (loop (+ hash 1))))
+            bucket)))))
 
 (define (hash-table-bucket-for-key ht key)
   (%hash-table-bucket-for ht (hash-table-hash ht key) key))
@@ -158,7 +157,7 @@
 (define (hash-table-prune-dead-entries! ht fast?)
   ;; NB only set fast? to #t if you are going to be rehashing all
   ;; entries anyway!
-  (unless (= (hash-table-size ht) (hash-table-next-entry ht))
+  (unless (eqv? (hash-table-size ht) (hash-table-next-entry ht))
     (let loop ((from-idx 0)
                (to-idx 0))
       ;;(display from-idx) (newline) (display to-idx) (newline) (newline)
@@ -178,7 +177,7 @@
                (compact-array-delete! (hash-table-compact-index ht)
                                       (vector-ref (hash-table-values-vector ht) from-idx)))
              (loop (+ from-idx 1) to-idx))
-            ((= from-idx to-idx) (loop (+ from-idx 1) (+ to-idx 1)))
+            ((eqv? from-idx to-idx) (loop (+ from-idx 1) (+ to-idx 1)))
             (else
              (vector-set! (hash-table-keys-vector ht)
                           to-idx
@@ -409,7 +408,7 @@
                        entry-idx *deletion*)
           (vector-set! (hash-table-values-vector ht)
                        entry-idx bucket)
-          (when (= entry-idx (- (hash-table-next-entry ht) 1))
+          (when (eqv? entry-idx (- (hash-table-next-entry ht) 1))
             (hash-table-prune-dead-entries-at-end! ht))
           #t)
         #f)))

srfi/250/internal/r6rs-compact-arrays.scm

@@ -1,29 +1,33 @@
 (define (make-compact-array size)
   (cond ((< size #xFF)
-         (let ((bv (make-bytevector (+ size 1) #xFF)))
+         (let ((bv (make-bytevector (+ size 2) #xFF)))
            (bytevector-u8-set! bv 0 1)
+           (bytevector-u8-set! bv 1 size)
            bv))
         ((< size #xFFFF)
-         (let ((bv (make-bytevector (* 2 (+ size 1)) #xFF)))
+         (let ((bv (make-bytevector (* 2 (+ size 2)) #xFF)))
            (bytevector-u8-set! bv 0 2)
+           (bytevector-u16-native-set! bv 2 size)
            bv))
         ((< size #xFFFFFFFF)
-         (let ((bv (make-bytevector (* 4 (+ size 1)) #xFF)))
+         (let ((bv (make-bytevector (* 4 (+ size 2)) #xFF)))
            (bytevector-u8-set! bv 0 4)
+           (bytevector-u32-native-set! bv 4 size)
            bv))
         (else
-         (let ((bv (make-bytevector (* 8 (+ size 1)) #xFF)))
+         (let ((bv (make-bytevector (* 8 (+ size 2)) #xFF)))
            (bytevector-u8-set! bv 0 8)
+           (bytevector-u64-native-set! bv 8 size)
            bv))))
 
 (define (compact-array-ref sa idx)
-  (define (max-to x n) (if (= x n) #f x))
+  (define (max-to x n) (if (eqv? x n) #f x))
   (assert (bytevector? sa))
   (case (bytevector-u8-ref sa 0)
-    ((1) (max-to (bytevector-u8-ref sa (+ idx 1)) #xFF))
-    ((2) (max-to (bytevector-u16-native-ref sa (* (+ idx 1) 2)) #xFFFF))
-    ((4) (max-to (bytevector-u32-native-ref sa (* (+ idx 1) 4)) #xFFFFFFFF))
-    ((8) (max-to (bytevector-u64-native-ref sa (* (+ idx 1) 8)) #xFFFFFFFFFFFFFFFF))
+    ((1) (max-to (bytevector-u8-ref sa (+ idx 2)) #xFF))
+    ((2) (max-to (bytevector-u16-native-ref sa (* (+ idx 2) 2)) #xFFFF))
+    ((4) (max-to (bytevector-u32-native-ref sa (* (+ idx 2) 4)) #xFFFFFFFF))
+    ((8) (max-to (bytevector-u64-native-ref sa (* (+ idx 2) 8)) #xFFFFFFFFFFFFFFFF))
     (else (assertion-violation 'compact-array-ref "not a compact array" sa))))
 
 (define (compact-array-set? sa idx)
@@ -34,29 +38,42 @@
     (if (>= val n) (assertion-violation 'compact-array-set! "can't store value in compact array, try upgrading it")))
   (assert (bytevector? sa))
   (case (bytevector-u8-ref sa 0)
-    ((1) (check-size #xFF) (bytevector-u8-set! sa (+ idx 1) val))
-    ((2) (check-size #xFFFF) (bytevector-u16-native-set! sa (* (+ idx 1) 2) val))
-    ((4) (check-size #xFFFFFFFF) (bytevector-u32-native-set! sa (* (+ idx 1) 4) val))
-    ((8) (check-size #xFFFFFFFFFFFFFFFF) (bytevector-u64-native-set! sa (* (+ idx 1) 8) val))
+    ((1) (check-size #xFF) (bytevector-u8-set! sa (+ idx 2) val))
+    ((2) (check-size #xFFFF) (bytevector-u16-native-set! sa (* (+ idx 2) 2) val))
+    ((4) (check-size #xFFFFFFFF) (bytevector-u32-native-set! sa (* (+ idx 2) 4) val))
+    ((8) (check-size #xFFFFFFFFFFFFFFFF) (bytevector-u64-native-set! sa (* (+ idx 2) 8) val))
     (else (assertion-violation 'compact-array-set! "not a compact array" sa))))
 
 (define (compact-array-delete! sa idx)
   (assert (bytevector? sa))
   (case (bytevector-u8-ref sa 0)
-    ((1) (bytevector-u8-set! sa (+ idx 1) #xFF))
-    ((2) (bytevector-u16-native-set! sa (* (+ idx 1) 2) #xFFFF))
-    ((4) (bytevector-u32-native-set! sa (* (+ idx 1) 4) #xFFFFFFFF))
-    ((8) (bytevector-u64-native-set! sa (* (+ idx 1) 8) #xFFFFFFFFFFFFFFFF))
+    ((1) (bytevector-u8-set! sa (+ idx 2) #xFF))
+    ((2) (bytevector-u16-native-set! sa (* (+ idx 2) 2) #xFFFF))
+    ((4) (bytevector-u32-native-set! sa (* (+ idx 2) 4) #xFFFFFFFF))
+    ((8) (bytevector-u64-native-set! sa (* (+ idx 2) 8) #xFFFFFFFFFFFFFFFF))
     (else (assertion-violation 'compact-array-delete! "not a compact array" sa))))
 
 (define (compact-array-clear! sa)
   (assert (bytevector? sa))
-  (let ((size (bytevector-u8-ref sa 0)))
+  (let ((elt-size (bytevector-u8-ref sa 0)))
     (bytevector-fill! sa #xFF)
-    (bytevector-u8-set! sa 0 size)))
+    (bytevector-u8-set! sa 0 elt-size)
+    (case elt-size
+      ((1) (bytevector-u8-set! sa 1 (- 2 (bytevector-length sa))))
+      ((2) (bytevector-u16-native-set! sa 2
+                                       (- 2 (div (bytevector-length sa) 2))))
+      ((4) (bytevector-u32-native-set! sa 4
+                                       (- 2 (div (bytevector-length sa) 4))))
+      ((8) (bytevector-u32-native-set! sa 8
+                                       (- 2 (div (bytevector-length sa) 8)))))))
 
 (define (compact-array-copy sa) (bytevector-copy sa))
 
 (define (compact-array-length sa)
   (assert (bytevector? sa))
-  (- (div (bytevector-length sa) (bytevector-u8-ref sa 0)) 1))
+  (case (bytevector-u8-ref sa 0)
+    ((1) (bytevector-u8-ref sa 1))
+    ((2) (bytevector-u16-native-ref sa 2))
+    ((4) (bytevector-u32-native-ref sa 4))
+    ((8) (bytevector-u64-native-ref sa 8))
+    (else (assertion-violation 'compact-array-ref "not a compact array" sa))))