Guile-hoot/module/hoot/hashtables.scm

;;; Hoot hashtables
;;; Copyright (C) 2023 David Thompson <dave@spritely.institute>
;;; Copyright (C) 2023 Robin Templeton <robin@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 make-eq-hashtable
          make-eqv-hashtable
          make-hashtable

          hashtable?
          hashtable-size
          hashtable-ref
          hashtable-set!
          hashtable-delete!
          hashtable-contains?
          hashtable-update!
          hashtable-copy
          hashtable-clear!
          hashtable-keys
          hashtable-entries
          hashtable-for-each

          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 eq)
          (hoot procedures)
          (hoot values)
          (hoot vectors)
          (hoot lists)
          (hoot errors))

  (define* (make-eq-hashtable)
    (%inline-wasm
     '(func (result (ref eq))
            (call $make-hash-table))))

  (define* (make-eqv-hashtable)
    (raise (make-unimplemented-error 'make-eqv-hashtable)))

  (define* (make-hashtable hash-function equiv)
    (raise (make-unimplemented-error 'make-hashtable)))

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

  (define (hashtable-size hashtable)
    (check-type hashtable hashtable? 'hashtable-size)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (result (ref eq))
            (call $i32->fixnum
                  (struct.get $hash-table $size (local.get $table))))
     hashtable))

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

  (define (hashtable-set! hashtable key obj)
    (check-type hashtable hashtable? 'hashtable-set!)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (param $key (ref eq))
            (param $val (ref eq))
            (result (ref eq))
            (call $hashq-update
                  (local.get $table)
                  (local.get $key)
                  (local.get $val)
                  (local.get $val)))
     hashtable key obj)
    (values))

  (define (hashtable-delete! hashtable key)
    (check-type hashtable hashtable? 'hashtable-delete!)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (param $key (ref eq))
            (call $hashq-delete! (local.get $table) (local.get $key)))
     hashtable key)
    (values))

  (define (hashtable-contains? hashtable key)
    (check-type hashtable hashtable? 'hashtable-contains?)
    (pair? (%hashq-get-handle hashtable key)))

  (define (hashtable-update! hashtable key proc default)
    (check-type hashtable hashtable? 'hashtable-update!)
    (check-type proc procedure? 'hashtable-update!)
    (let ((handle (%hashq-get-handle hashtable key)))
      (if (pair? handle)
          (set-cdr! handle (proc (cdr handle)))
          (hashtable-set! hashtable key (proc default))))
    (values))

  (define* (hashtable-copy hashtable)
    (check-type hashtable hashtable? 'hashtable-copy)
    (let ((hashtable* (make-eq-hashtable)))
      (hashtable-for-each (lambda (k v)
                            (hashtable-set! hashtable* k v))
                          hashtable)
      hashtable*))

  (define* (hashtable-clear! hashtable)
    (check-type hashtable hashtable? 'hashtable-clear!)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (struct.set $hash-table
                        $size
                        (local.get $table)
                        (i32.const 0))
            (array.fill $raw-scmvector
                        (struct.get $hash-table $buckets
                                    (local.get $table))
                        (i32.const 0)
                        (ref.i31 (i32.const 13))
                        (array.len (struct.get $hash-table $buckets
                                               (local.get $table)))))
     hashtable)
    (values))

  (define (hashtable-keys hashtable)
    (check-type hashtable hashtable? 'hashtable-keys)
    (list->vector
     (%hash-fold (lambda (k v seed) (cons k seed))
                 '()
                 hashtable)))

  (define (hashtable-entries hashtable)
    (check-type hashtable hashtable? 'hashtable-entries)
    (list->vector
     (%hash-fold (lambda (k v seed) (cons v seed))
                 '()
                 hashtable)))

  ;; TODO: non-eq hashtables
  (define (hashtable-equivalence-function hashtable)
    (check-type hashtable hashtable? 'hashtable-equivalence-function)
    eq?)

  ;; TODO: non-eq hashtables
  (define (hashtable-hash-function hashtable)
    (check-type hashtable hashtable? 'hashtable-hash-function)
    %hashq)

  (define (equal-hash obj)
    (raise (make-unimplemented-error 'equal-hash)))

  (define (string-hash string)
    (raise (make-unimplemented-error 'string-hash)))

  (define (string-ci-hash string)
    (raise (make-unimplemented-error 'string-ci-hash)))

  (define (symbol-hash symbol)
    (raise (make-unimplemented-error 'symbol-hash)))

  (define (hashtable-for-each proc hashtable)
    (check-type proc procedure? 'hashtable-for-each)
    (check-type hashtable hashtable? 'hashtable-for-each)
    (let ((len (%buckets-length hashtable)))
      (do ((i 0 (1+ i)))
          ((= i len) (values))
        (for-each (lambda (handle)
                    (proc (car handle) (cdr handle)))
                  (%bucket-ref hashtable i)))))

  (define (%hashq-get-handle table key)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (param $key (ref eq))
            (result (ref eq))
            (call $hashq-lookup/default
                  (local.get $table)
                  (local.get $key)
                  (ref.i31 (i32.const 1))))
     table key))

  (define (%hashq key size)
    (%inline-wasm
     '(func (param $v (ref eq))
            (result (ref eq))
            (call $i32->fixnum (call $hashq (local.get $v))))
     key))

  (define (%buckets-length table)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (result (ref eq))
            (call $i32->fixnum
                  (array.len (struct.get $hash-table
                                         $buckets
                                         (local.get $table)))))
     table))

  (define (%bucket-ref table i)
    (%inline-wasm
     '(func (param $table (ref $hash-table))
            (param $i i32)
            (result (ref eq))
            (array.get $raw-scmvector
                       (struct.get $hash-table
                                   $buckets
                                   (local.get $table))
                       (local.get $i)))
     table i))

  (define (%hash-fold-handles proc init table)
    (let ((len (%buckets-length table)))
      (let loop ((i 0)
                 (seed init))
        (if (= i len)
            seed
            (loop (1+ i)
                  (fold proc seed (%bucket-ref table i)))))))

  (define (%hash-fold proc init table)
    (%hash-fold-handles (lambda (h seed) (proc (car h) (cdr h) seed))
                        init
                        table))

  ;; 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)))