vlist performance improvements; allocate vhash data inline

* module/ice-9/vlist.scm (make-block): If we are making a hash table,
  allocate it inline with the contents.  Otherwise don't even add a
  pointer to the block.
  (block-hash-table?): New internal accessor.
  (block-ref*): Remove.  Vhash entries are no longer wrapped.
  (block-ref):
  (block-hash-table-next-offset):
  (block-hash-table-set-next-offset!):
  (block-hash-table-ref):
  (block-hash-table-set!):
  (block-hash-table-add!): Adapt to take content vector explicitly, and
  to expect the hash table inline with the contents.  Some of these
  accessors are new.  Adapt callers.
  (assert-vlist): New helper.
  (vlist-cons): Update comment.
  (vhash?): Update scheme to allocate the hash table and chain links
  inline with the contents.
  (%vhash-fold*, %vhash-assoc): Rewrite to be more performant.

1 files changed, 159 insertions, 142 deletions

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 22ef285f3..a09b374bc 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -70,15 +70,15 @@
   (make-fluid 2))
 
 (define-inlinable (make-block base offset size hash-tab?)
-  ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
-  ;; at OFFSET.  If HASH-TAB? is true, a "hash table" is also added.
-  ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
-
-  ;; XXX: We could improve locality here by having a single vector but currently
-  ;; the extra arithmetic outweighs the benefits (!).
-  (vector (make-vector size)
-          base offset size 0
-          (and hash-tab? (make-vector size #f))))
+  ;; Return a block (and block descriptor) of SIZE elements pointing to
+  ;; BASE at OFFSET.  If HASH-TAB? is true, we also reserve space for a
+  ;; "hash table".  Note: We use `next-free' instead of `last-used' as
+  ;; suggested by Bagwell.
+  (if hash-tab?
+      (vector (make-vector (* size 3) #f)
+              base offset size 0)
+      (vector (make-vector size)
+              base offset size 0)))
 
 (define-syntax-rule (define-block-accessor name index)
   (define-inlinable (name block)
@@ -89,7 +89,9 @@
 (define-block-accessor block-offset 2)
 (define-block-accessor block-size 3)
 (define-block-accessor block-next-free 4)
-(define-block-accessor block-hash-table 5)
+
+(define-inlinable (block-hash-table? block)
+  (< (block-size block) (vector-length (block-content block))))
 
 (define-inlinable (set-block-next-free! block next-free)
   (vector-set! block 4 next-free))
@@ -103,20 +105,35 @@
          (vector-set! (block-content block) offset value)
          #t)))
 
-(define-inlinable (block-ref block offset)
-  (vector-ref (block-content block) offset))
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+  (vector-ref content offset))
+
+;; Return the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-next-offset content size offset)
+  (vector-ref content (+ size size offset)))
 
-(define-inlinable (block-ref* block offset)
-  (let ((v (block-ref block offset)))
-    (if (block-hash-table block)
-        (car v) ;; hide the vhash link
-        v)))
+;; Save the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-set-next-offset! content size offset
+                                                     next-offset)
+  (vector-set! content (+ size size offset) next-offset))
 
-(define-inlinable (block-hash-table-ref block offset)
-  (vector-ref (block-hash-table block) offset))
+;; Returns the index of the last entry stored in CONTENT with
+;; SIZE-modulo hash value KHASH.
+(define-inlinable (block-hash-table-ref content size khash)
+  (vector-ref content (+ size khash)))
 
-(define-inlinable (block-hash-table-set! block offset value)
-  (vector-set! (block-hash-table block) offset value))
+(define-inlinable (block-hash-table-set! content size khash offset)
+  (vector-set! content (+ size khash) offset))
+
+;; Add hash table information for the item recently added at OFFSET,
+;; with SIZE-modulo hash KHASH.
+(define-inlinable (block-hash-table-add! content size khash offset)
+  (block-hash-table-set-next-offset! content size offset
+                                     (block-hash-table-ref content size khash))
+  (block-hash-table-set! content size khash offset))
 
 (define block-null
   ;; The null block.
@@ -143,13 +160,10 @@
                           (lambda (vl port)
                             (cond ((vlist-null? vl)
                                    (format port "#<vlist ()>"))
-                                  ((block-hash-table (vlist-base vl))
+                                  ((vhash? vl)
                                    (format port "#<vhash ~x ~a pairs>"
                                            (object-address vl)
-                                           (vhash-fold (lambda (k v r)
-                                                         (+ 1 r))
-                                                       0
-                                                       vl)))
+                                           (vlist-length vl)))
                                   (else
                                    (format port "#<vlist ~a>"
                                            (vlist->list vl))))))
@@ -159,9 +173,19 @@
   ;; The empty vlist.
   (make-vlist block-null 0))
 
+;; Asserting that something is a vlist is actually a win if your next
+;; step is to call record accessors, because that causes CSE to
+;; eliminate the type checks in those accessors.
+;;
+(define-inlinable (assert-vlist val)
+  (unless (vlist? val)
+    (throw 'wrong-type-arg
+           #f
+           "Not a vlist: ~S"
+           (list val)
+           (list val))))
+
 (define-inlinable (block-cons item vlist hash-tab?)
-  (unless (vlist? vlist)
-    (error "Expected a vlist:" vlist))
   (let ((base (vlist-base vlist))
         (offset (1+ (vlist-offset vlist))))
     (cond
@@ -186,21 +210,24 @@
 (define (vlist-cons item vlist)
   "Return a new vlist with @var{item} as its head and @var{vlist} as its
 tail."
-  ;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
-  ;; doesn't box ITEM so that it can have the hidden "next" link used by
-  ;; vhash items, and it passes `#f' as the HASH-TAB? argument to
-  ;; `block-cons'.  However, inserting all the checks here has an important
-  ;; performance penalty, hence this choice.
+  ;; Note: Although the result of `vlist-cons' on a vhash is a valid
+  ;; vlist, it is not a valid vhash.  The new item does not get a hash
+  ;; table entry.  If we allocate a new block, the new block will not
+  ;; have a hash table.  Perhaps we can do something more sensible here,
+  ;; but this is a hot function, so there are performance impacts.
+  (assert-vlist vlist)
   (block-cons item vlist #f))
 
 (define (vlist-head vlist)
   "Return the head of @var{vlist}."
+  (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
-    (block-ref* base offset)))
+    (block-ref (block-content base) offset)))
 
 (define (vlist-tail vlist)
   "Return the tail of @var{vlist}."
+  (assert-vlist vlist)
   (let ((base   (vlist-base vlist))
         (offset (vlist-offset vlist)))
     (if (> offset 0)
@@ -210,6 +237,7 @@ tail."
 
 (define (vlist-null? vlist)
   "Return true if @var{vlist} is empty."
+  (assert-vlist vlist)
   (let ((base (vlist-base vlist)))
     (and (not (block-base base))
          (= 0 (block-size base)))))
@@ -226,6 +254,7 @@ tail."
 (define (vlist-fold proc init vlist)
   "Fold over @var{vlist}, calling @var{proc} for each element."
   ;; FIXME: Handle multiple lists.
+  (assert-vlist vlist)
   (let loop ((base   (vlist-base vlist))
              (offset (vlist-offset vlist))
              (result init))
@@ -235,19 +264,18 @@ tail."
                (done? (< next 0)))
           (loop (if done? (block-base base) base)
                 (if done? (block-offset base) next)
-                (proc (block-ref* base offset) result))))))
+                (proc (block-ref (block-content base) offset) result))))))
 
 (define (vlist-fold-right proc init vlist)
   "Fold over @var{vlist}, calling @var{proc} for each element, starting from
 the last element."
-  (define len (vlist-length vlist))
-
-  (let loop ((index  (1- len))
+  (assert-vlist vlist)
+  (let loop ((index  (1- (vlist-length vlist)))
              (result init))
     (if (< index 0)
         result
         (loop (1- index)
-              (proc (vlist-ref vlist index) result)))))
+          (proc (vlist-ref vlist index) result)))))
 
 (define (vlist-reverse vlist)
   "Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@@ -267,11 +295,12 @@ order."
 
 (define (vlist-ref vlist index)
   "Return the element at index @var{index} in @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((index   index)
              (base    (vlist-base vlist))
              (offset  (vlist-offset vlist)))
     (if (<= index offset)
-        (block-ref* base (- offset index))
+        (block-ref (block-content base) (- offset index))
         (loop (- index offset 1)
               (block-base base)
               (block-offset base)))))
@@ -279,6 +308,7 @@ order."
 (define (vlist-drop vlist count)
   "Return a new vlist that does not contain the @var{count} first elements of
 @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((count  count)
              (base   (vlist-base vlist))
              (offset (vlist-offset vlist)))
@@ -319,6 +349,7 @@ satisfy @var{pred}."
 
 (define (vlist-length vlist)
   "Return the length of @var{vlist}."
+  (assert-vlist vlist)
   (let loop ((base (vlist-base vlist))
              (len  (vlist-offset vlist)))
     (if (eq? base block-null)
@@ -371,98 +402,94 @@ details."
 ;; associated with K1 and K2, respectively.  The resulting layout is a
 ;; follows:
 ;;
-;;     ,--------------------.
-;;     | ,-> (K1 . V1) ---. |
-;;     | |                | |
-;;     | |   (K2 . V2) <--' |
-;;     | |                  |
-;;     +-|------------------+
-;;     | |                  |
-;;     | |                  |
-;;     | `-- O <---------------H
-;;     |                    |
-;;     `--------------------'
+;;             ,--------------------.
+;;            0| ,-> (K1 . V1)      | Vlist array
+;;            1| |                  |
+;;            2| |   (K2 . V2)      |
+;;            3| |                  |
+;;        size +-|------------------+
+;;            0| |                  | Hash table
+;;            1| |                  |
+;;            2| +-- O <------------- H
+;;            3| |                  |
+;;    size * 2 +-|------------------+
+;;            0| `-> 2              | Chain links
+;;            1|                    |
+;;            2|    #f              |
+;;            3|                    |
+;;    size * 3 `--------------------'
+;;
+;; The backing store for the vhash is partitioned into three areas: the
+;; vlist part, the hash table part, and the chain links part.  In this
+;; example we have a hash H which, when indexed into the hash table
+;; part, indicates that a value with this hash can be found at offset 0
+;; in the vlist part.  The corresponding index (in this case, 0) of the
+;; chain links array holds the index of the next element in this block
+;; with this hash value, or #f if we reached the end of the chain.
 ;;
-;; The bottom part is the "hash table" part of the vhash, as returned by
-;; `block-hash-table'; the other half is the data part.  O is the offset of
-;; the first value associated with a key that hashes to H in the data part.
-;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
-;; link is handled by `block-ref'.
-
-;; This API potentially requires users to repeat which hash function and which
-;; equality predicate to use.  This can lead to unpredictable results if they
-;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
-;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 .  OTOH, two
-;; arguments can be made in favor of this API:
+;; This API potentially requires users to repeat which hash function and
+;; which equality predicate to use.  This can lead to unpredictable
+;; results if they are used in consistenly, e.g., between `vhash-cons'
+;; and `vhash-assoc', which is undesirable, as argued in
+;; http://savannah.gnu.org/bugs/?22159 .  OTOH, two arguments can be
+;; made in favor of this API:
 ;;
 ;;  - It's consistent with how alists are handled in SRFI-1.
 ;;
-;;  - In practice, users will probably consistenly use either the `q', the `v',
-;;    or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
-;;    argument), i.e., they will rarely explicitly pass a hash function or
-;;    equality predicate.
+;;  - In practice, users will probably consistenly use either the `q',
+;;    the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
+;;    without any optional argument), i.e., they will rarely explicitly
+;;    pass a hash function or equality predicate.
 
 (define (vhash? obj)
   "Return true if @var{obj} is a hash list."
   (and (vlist? obj)
-       (let ((base (vlist-base obj)))
-         (and base
-              (vector? (block-hash-table base))))))
+       (block-hash-table? (vlist-base obj))))
 
 (define* (vhash-cons key value vhash #:optional (hash hash))
   "Return a new hash list based on @var{vhash} where @var{key} is associated
 with @var{value}.  Use @var{hash} to compute @var{key}'s hash."
-  (let* ((key+value (cons key value))
-         (entry     (cons key+value #f))
-         (vlist     (block-cons entry vhash #t))
-         (base      (vlist-base vlist))
-         (khash     (hash key (block-size base))))
-
-    (let ((o (block-hash-table-ref base khash)))
-      (if o (set-cdr! entry o)))
-
-    (block-hash-table-set! base khash
-                           (vlist-offset vlist))
-
-    vlist))
+  (assert-vlist vhash)
+  ;; We should also assert that it is a hash table.  Need to check the
+  ;; performance impacts of that.  Also, vlist-null is a valid hash
+  ;; table, which does not pass vhash?.  A bug, perhaps.
+  (let* ((vhash     (block-cons (cons key value) vhash #t))
+         (base      (vlist-base vhash))
+         (offset    (vlist-offset vhash))
+         (size      (block-size base))
+         (khash     (hash key size))
+         (content   (block-content base)))
+    (block-hash-table-add! content size khash offset)
+    vhash))
 
 (define vhash-consq (cut vhash-cons <> <> <> hashq))
 (define vhash-consv (cut vhash-cons <> <> <> hashv))
 
 (define-inlinable (%vhash-fold* proc init key vhash equal? hash)
   ;; Fold over all the values associated with KEY in VHASH.
-  (define khash
-    (let ((size (block-size (vlist-base vhash))))
-      (and (> size 0) (hash key size))))
-
-  (let loop ((base       (vlist-base vhash))
-             (khash      khash)
-             (offset     (and khash
-                              (block-hash-table-ref (vlist-base vhash)
-                                                    khash)))
-             (max-offset (vlist-offset vhash))
-             (result     init))
-
-    (let ((answer (and offset (block-ref base offset))))
-      (cond ((and (pair? answer)
-                  (<= offset max-offset)
-                  (let ((answer-key (caar answer)))
-                    (equal? key answer-key)))
-             (let ((result      (proc (cdar answer) result))
-                   (next-offset (cdr answer)))
-               (loop base khash next-offset max-offset result)))
-            ((and (pair? answer) (cdr answer))
-             =>
-             (lambda (next-offset)
-               (loop base khash next-offset max-offset result)))
-            (else
-             (let ((next-base (block-base base)))
-               (if (and next-base (> (block-size next-base) 0))
-                   (let* ((khash  (hash key (block-size next-base)))
-                          (offset (block-hash-table-ref next-base khash)))
-                     (loop next-base khash offset (block-offset base)
-                           result))
-                   result)))))))
+  (define (visit-block base max-offset result)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash))
+                 (result result))
+        (if offset
+            (loop (block-hash-table-next-offset content size offset)
+                  (if (and (<= offset max-offset)
+                           (equal? key (car (block-ref content offset))))
+                      (proc (cdr (block-ref content offset)) result)
+                      result))
+            (let ((next-block (block-base base)))
+              (if (> (block-size next-block) 0)
+                  (visit-block next-block (block-offset base) result)
+                  result))))))
+
+  (assert-vlist vhash)
+  (if (> (block-size (vlist-base vhash)) 0)
+      (visit-block (vlist-base vhash)
+                   (vlist-offset vhash)
+                   init)
+      init))
 
 (define* (vhash-fold* proc init key vhash
                       #:optional (equal? equal?) (hash hash))
@@ -485,34 +512,24 @@ value of @var{result} for the first call to @var{proc}."
   ;; associated with KEY is found or when the end-of-list is reached.  Inline to
   ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
   ;; the `eq?'  subr.
-  (define khash
-    (let ((size (block-size (vlist-base vhash))))
-      (and (> size 0) (hash key size))))
-
-  (let loop ((base       (vlist-base vhash))
-             (khash      khash)
-             (offset     (and khash
-                              (block-hash-table-ref (vlist-base vhash)
-                                                    khash)))
-             (max-offset (vlist-offset vhash)))
-    (let ((answer (and offset (block-ref base offset))))
-      (cond ((and (pair? answer)
-                  (<= offset max-offset)
-                  (let ((answer-key (caar answer)))
-                    (equal? key answer-key)))
-             (car answer))
-            ((and (pair? answer) (cdr answer))
-             =>
-             (lambda (next-offset)
-               (loop base khash next-offset max-offset)))
-            (else
-             (let ((next-base (block-base base)))
-               (and next-base
-                    (> (block-size next-base) 0)
-                    (let* ((khash  (hash key (block-size next-base)))
-                           (offset (block-hash-table-ref next-base khash)))
-                      (loop next-base khash offset
-                            (block-offset base))))))))))
+  (define (visit-block base max-offset)
+    (let* ((size (block-size base))
+           (content (block-content base))
+           (khash (hash key size)))
+      (let loop ((offset (block-hash-table-ref content size khash)))
+        (if offset
+            (if (and (<= offset max-offset)
+                     (equal? key (car (block-ref content offset))))
+                (block-ref content offset)
+                (loop (block-hash-table-next-offset content size offset)))
+            (let ((next-block (block-base base)))
+              (and (> (block-size next-block) 0)
+                   (visit-block next-block (block-offset base))))))))
+
+  (assert-vlist vhash)
+  (and (> (block-size (vlist-base vhash)) 0)
+       (visit-block (vlist-base vhash)
+                    (vlist-offset vhash))))
 
 (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
   "Return the first key/value pair from @var{vhash} whose key is equal to