Guile-hoot/lib/hoot/hashtables.scm

;;; Hoot hashtables
;;; Copyright (C) 2023, 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; R6RS-inspired hashtables.
;;;
;;; Code:

(library (hoot hashtables)
  (export hashq
          hashv
          hash

          make-hashtable
          make-eq-hashtable
          make-eqv-hashtable
          hashtable?
          hashtable-hash
          hashtable-equiv
          hashtable-size
          hashtable-ref
          hashtable-set!
          hashtable-delete!
          hashtable-clear!
          hashtable-contains?
          hashtable-copy
          hashtable-keys
          hashtable-values
          hashtable-for-each
          hashtable-fold

          make-weak-key-hashtable
          weak-key-hashtable?
          weak-key-hashtable-ref
          weak-key-hashtable-set!
          weak-key-hashtable-delete!)
  (import (hoot primitives)
          (hoot pairs)
          (hoot numbers)
          (hoot bitwise)
          (hoot bitvectors)
          (hoot bytevectors)
          (hoot eq)
          (hoot equal)
          (hoot procedures)
          (hoot values)
          (hoot vectors)
          (hoot lists)
          (hoot records)
          (hoot strings)
          (hoot write)
          (hoot match)
          (hoot errors)
          (hoot cond-expand))

  (cond-expand
   (guile-vm
    (define (hashq key size) (guile:hashq key size))
    (define (hashv key size) (guile:hashv key size))
    (define (hash key size) (guile:hash key size)))
   (hoot
    (define (string-hash str)
      (%inline-wasm
       '(func (param $str (ref eq)) (result i64)
              (i64.extend_i32_u
               (call $string-hash
                     (struct.get $string $str
                                 (ref.cast $string (local.get $str))))))
       str))

    (define (%hashq key)
      (%inline-wasm
       '(func (param $key (ref eq)) (result i64)
              (i64.extend_i32_u
               (call $hashq (local.get $key))))
       key))

    (define (%hashv key)
      (if (number? key)
          ;; Use hashq for integers, otherwise convert to a string and
          ;; hash that.
          (if (integer? key)
              (if (exact? key)
                  (%hashq key)
                  (%hashq (exact key)))
              (string-hash (number->string key)))
          (%hashq key)))

    (define (%hash key)
      ;; Simple, non-commutative hash code combiner.
      (define (combine-hashes h1 h2)
        (logxor (ash h1 5) h2))
      ;; For hashing records:
      (define (assq-ref alist k)
        (and (pair? alist)
             (if (eq? (caar alist) k)
                 (cdar alist)
                 (assq-ref (cdr alist) k))))
      (define (record-nfields record)
        (%struct-ref (%struct-vtable record) 0))
      (define (record-properties record)
        (%struct-ref (%struct-vtable record) 4))
      (define (record-opaque? record)
        (assq-ref (record-properties record) 'opaque))
      ;; This recursive hashing algorithm with effort limit is inspired
      ;; by Chez Scheme.
      (define (hash key k)
        (let ((k (- k 1)))
          (cond
           ((<= k 0) ; out of hash juice :(
            (values (%hashv key) 0))
           ((string? key)
            (values (string-hash key) k))
           ((pair? key)
            (let ((k/2 (ash (+ k 1) -1)))
              (call-with-values (lambda () (hash (car key) k/2))
                (lambda (h1 k*)
                  (call-with-values (lambda () (hash (cdr key) (+ (- k k/2) k*)))
                    (lambda (h2 k)
                      (values (combine-hashes h1 h2) k)))))))
           ((vector? key)
            (let ((seed #xbeadcafe))
              (let lp ((i 0) (h seed) (k k))
                (if (and (< i (vector-length key)) (> k 0))
                    (let ((k/2 (ash (+ k 1) -1)))
                      (call-with-values (lambda () (hash (vector-ref key i) k/2))
                        (lambda (h* k*)
                          (lp (+ i 1) (combine-hashes h h*) (+ (- k k/2) k*)))))
                    (values h k)))))
           ((bytevector? key)
            (values (%inline-wasm
                     '(func (param $bv (ref eq)) (result i64)
                            (i64.extend_i32_u
                             (call $hash-bytevector
                                   (ref.cast $bytevector (local.get $bv)))))
                     key)
                    k))
           ((bitvector? key)
            (values (%inline-wasm
                     '(func (param $bv (ref eq)) (result i64)
                            (i64.extend_i32_u
                             (call $hash-bitvector
                                   (ref.cast $bitvector (local.get $bv)))))
                     key)
                    k))
           ((record? key)
            (if (record-opaque? key)
                (values (%hashq key) k)
                (let ((nfields (record-nfields key))
                      (seed #xfacefeed))
                  (let lp ((i 0) (h seed) (k k))
                    (if (and (< i nfields) (> k 0))
                        (let ((k/2 (ash k -1)))
                          (call-with-values (lambda ()
                                              (hash (%struct-ref key i) k/2))
                            (lambda (h* k*)
                              (lp (+ i 1) (combine-hashes h h*) (+ (- k k/2) k*)))))
                        (values h k))))))
           (else
            (values (%hashv key) k)))))
      (call-with-values (lambda () (hash key 64))
        (lambda (hash-code k)
          hash-code)))

    (define max-hash-size (1- (ash 1 32)))

    (define (hashq key size)
      (check-size size max-hash-size 'hashq)
      (modulo (%hashq key) size))

    (define (hashv key size)
      (check-size size max-hash-size 'hashv)
      (modulo (%hashv key) size))

    (define (hash key size)
      (check-size size max-hash-size 'hash)
      (modulo (%hash key) size))))

  ;; Numbers taken from https://planetmath.org/goodhashtableprimes
  (define %bucket-sizes
    #(53 97 193 389 769 1543 3079 6151 12289 24593 98317 196613 393241 786433 1572869))

  (define %min-buckets 53)

  (define (lower-bound k)
    (quotient k 4))

  (define (upper-bound k)
    (quotient (* k 9) 10))

  (define (optimal-buckets k)
    (let ((last (- (vector-length %bucket-sizes) 1)))
      (let lp ((idx 0))
        (if (= idx last)
            (vector-ref %bucket-sizes last)
            (let ((size (vector-ref %bucket-sizes idx)))
              (if (> k (upper-bound size))
                  (lp (+ idx 1))
                  size))))))

  (define-record-type <hashtable>
    #:printer (lambda (table port)
                (display "#<hashtable size: " port)
                (display (hashtable-size table) port)
                (display ">" port))
    (%make-hashtable hash equiv size buckets lower upper)
    hashtable?
    (hash hashtable-hash)
    (equiv hashtable-equiv)
    (size hashtable-size set-hashtable-size!)
    (buckets hashtable-buckets set-hashtable-buckets!)
    ;; Lower and upper bounds for growing/shrinking
    (lower hashtable-lower set-hashtable-lower!)
    (upper hashtable-upper set-hashtable-upper!))

  (define* (make-hashtable #:optional (hash hash) (equiv equal?))
    "Return a new, empty hashtable that uses the hash procedure @var{hash}
and equivalence procedure @var{equiv}."
    (%make-hashtable hash equiv 0 (make-vector %min-buckets '())
                     0 (upper-bound %min-buckets)))

  (define (make-eq-hashtable)
    "Return a new, empty hashtable that uses @code{eq?} as the equivalence
function and hashes keys accordingly."
    (make-hashtable hashq eq?))

  (define (make-eqv-hashtable)
    "Return a new, empty hashtable that uses @code{eqv?} as the equivalence
function and hashes keys accordingly."
    (make-hashtable hashv eqv?))

  (define* (hashtable-ref table key #:optional default)
    "Return the value associated with @var{key} in @var{table}, or
@var{default} if there is no such association."
    (let ((hash (hashtable-hash table))
          (equiv? (hashtable-equiv table))
          (buckets (hashtable-buckets table)))
      (let lp ((chain (vector-ref buckets (hash key (vector-length buckets)))))
        (match chain
          (() default)
          (((other-key . val) . rest)
           (if (equiv? key other-key)
               val
               (lp rest)))))))

  (define (hashtable-resize! table k)
    (let ((old (hashtable-buckets table))
          (new (make-vector k '()))
          (hash (hashtable-hash table)))
      (set-hashtable-lower! table (if (eq? k %min-buckets) 0 (lower-bound k)))
      (set-hashtable-upper! table (upper-bound k))
      (set-hashtable-buckets! table new)
      ;; Rehash all key/value pairs.
      (do ((idx 0 (+ idx 1)))
          ((= idx (vector-length old)))
        (let lp ((chain (vector-ref old idx)))
          (match chain
            (() (values))
            (((and link (key . _)) . rest)
             (let ((new-idx (hash key k)))
               (vector-set! new new-idx (cons link (vector-ref new new-idx)))
               (lp rest))))))))

  (define (hashtable-resize-maybe! table)
    (let ((size (hashtable-size table))
          (lower (hashtable-lower table))
          (upper (hashtable-upper table)))
      (when (or (< size lower) (> size upper))
        (hashtable-resize! table (optimal-buckets size)))))

  (define (hashtable-set! table key val)
    "Associate @{val} with @var{key} in @var{table}, potentially
overwriting any previous association with @var{key}."
    (let* ((hash (hashtable-hash table))
           (equiv? (hashtable-equiv table))
           (size (hashtable-size table))
           (buckets (hashtable-buckets table))
           (idx (hash key (vector-length buckets)))
           (chain (vector-ref buckets idx)))
      (let lp ((chain* chain))
        (match chain*
          (()
           (vector-set! buckets idx (cons (cons key val) chain))
           (set-hashtable-size! table (+ size 1))
           (hashtable-resize-maybe! table))
          (((and link (other-key . _)) . rest)
           (if (equiv? key other-key)
               (set-cdr! link val)
               (lp rest))))))
    (values))

  (define (hashtable-delete! table key)
    "Remove the association with @var{key} in @var{table}, if one exists."
    (let* ((hash (hashtable-hash table))
           (equiv? (hashtable-equiv table))
           (size (hashtable-size table))
           (buckets (hashtable-buckets table))
           (idx (hash key (vector-length buckets))))
      (vector-set! buckets idx
                   (let lp ((chain (vector-ref buckets idx)))
                     (match chain
                       (() '())
                       (((and link (other-key . _)) . rest)
                        (if (equiv? key other-key)
                            (begin
                              (set-hashtable-size! table (- size 1))
                              rest)
                            (cons link (lp rest)))))))
      (hashtable-resize-maybe! table))
    (values))

  (define* (hashtable-clear! table)
    "Remove all items from @var{table}."
    (vector-fill! (hashtable-buckets table) '())
    (set-hashtable-size! table 0)
    (values))

  (define (hashtable-contains? table key)
    "Return #t if @var{key} has an associated value in @var{table}."
    (let ((hash (hashtable-hash table))
          (equiv? (hashtable-equiv table))
          (buckets (hashtable-buckets table)))
      (let lp ((chain (vector-ref buckets (hash key (vector-length buckets)))))
        (match chain
          (() #f)
          (((other-key . _) . rest)
           (or (equiv? key other-key) (lp rest)))))))

  (define* (hashtable-copy table)
    "Return a copy of @var{table}."
    (let* ((buckets (hashtable-buckets table))
           (k (vector-length buckets))
           (buckets* (make-vector k))
           (table* (%make-hashtable (hashtable-hash table)
                                    (hashtable-equiv table)
                                    (hashtable-size table)
                                    buckets*
                                    (hashtable-lower table)
                                    (hashtable-upper table))))
      (do ((i 0 (+ i 1)))
          ((= i k))
        (vector-set! buckets* i
                     (map (lambda (link)
                            (cons (car link) (cdr link)))
                          (vector-ref buckets i))))
      table*))

  (define (hashtable-keys table)
    "Return a list of keys in @var{table}."
    (hashtable-fold (lambda (key val result)
                      (cons key result))
                    '() table))

  (define (hashtable-values table)
    "Return a list of values in @var{table}."
    (hashtable-fold (lambda (key val result)
                      (cons val result))
                    '() table))

  (define (hashtable-for-each proc table)
    "Apply @var{proc} to each key/value association in @var{table}.
Each call is of the form @code{(proc key value)}."
    (let ((buckets (hashtable-buckets table)))
      (do ((idx 0 (+ idx 1)))
          ((= idx (vector-length buckets)))
        (let lp ((chain (vector-ref buckets idx)))
          (match chain
            (() (values))
            (((key . val) . rest)
             (proc key val)
             (lp rest)))))))

  (define (hashtable-fold proc init table)
    "Accumulate a result by applying @var{proc} with each key/value
association in @var{table} and the result of the previous @var{proc}
call.  Each call is of the form @code{(proc key value prev)}.  For the
first call, @code{prev} is the initial value @var{init}."
    (let ((buckets (hashtable-buckets table)))
      (let bucket-lp ((idx 0) (result init))
        (if (< idx (vector-length buckets))
            (bucket-lp (+ idx 1)
                       (let chain-lp ((chain (vector-ref buckets idx))
                                      (result result))
                         (match chain
                           (() result)
                           (((key . val) . rest)
                            (chain-lp rest (proc key val result))))))
            result))))

  ;; Weak key hashtables
  (define (make-weak-key-hashtable)
    (%inline-wasm
     '(func (result (ref eq))
            (struct.new $weak-table
                        (i32.const 0)
                        (call $make-weak-map)))))

  (define (weak-key-hashtable? obj)
    (%inline-wasm
     '(func (param $obj (ref eq)) (result (ref eq))
            (if (ref eq)
                (ref.test $weak-table (local.get $obj))
                (then (ref.i31 (i32.const 17)))
                (else (ref.i31 (i32.const 1)))))
     obj))

  (define* (weak-key-hashtable-ref table key #:optional default)
    (check-type table weak-key-hashtable? 'weak-key-hashtable-ref)
    (%inline-wasm
     '(func (param $table (ref eq)) (param $key (ref eq))
            (param $default (ref eq)) (result (ref eq))
            (call $weak-map-get
                  (struct.get $weak-table $val
                              (ref.cast $weak-table (local.get $table)))
                  (local.get $key)
                  (local.get $default)))
     table key default))

  (define (weak-key-hashtable-set! table key value)
    (check-type table weak-key-hashtable? 'weak-key-hashtable-set!)
    (%inline-wasm
     '(func (param $table (ref eq)) (param $key (ref eq)) (param $val (ref eq))
            (call $weak-map-set
                  (struct.get $weak-table $val
                              (ref.cast $weak-table (local.get $table)))
                  (local.get $key)
                  (local.get $val)))
     table key value))

  (define (weak-key-hashtable-delete! table key)
    (check-type table weak-key-hashtable? 'weak-key-hashtable-delete!)
    (%inline-wasm
     '(func (param $table (ref eq)) (param $key (ref eq))
            (call $weak-map-delete
                  (struct.get $weak-table $val
                              (ref.cast $weak-table (local.get $table)))
                  (local.get $key))
            (drop))
     table key)))