;;; Copyright (C) 2025 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; .
;;; Commentary:
;;;
;;;
;;; Code:
(define-module (ice-9 weak-tables)
#:use-module (ice-9 ephemerons)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-9)
;; FIXME: Change to #:export when deprecated code removed.
#:replace (make-weak-key-hash-table
weak-key-hash-table?
make-weak-value-hash-table
weak-value-hash-table?
make-doubly-weak-hash-table
doubly-weak-hash-table?)
#:export (weak-key-hash-table-ref
weak-key-hash-table-set!
weak-key-hash-table-remove!
weak-key-hash-table-clear!
weak-key-hash-table-fold
weak-key-hash-table-for-each
weak-key-hash-table-map->list
weak-value-hash-table-ref
weak-value-hash-table-set!
weak-value-hash-table-remove!
weak-value-hash-table-clear!
weak-value-hash-table-fold
weak-value-hash-table-for-each
weak-value-hash-table-map->list
doubly-weak-hash-table-ref
doubly-weak-hash-table-set!
doubly-weak-hash-table-remove!
doubly-weak-hash-table-clear!
doubly-weak-hash-table-fold
doubly-weak-hash-table-for-each
doubly-weak-hash-table-map->list))
;;;
;;; Weak key hash tables are a thin wrapper over ephemeron tables. They
;;; implement weak-key mappings whose values can be updated in place.
;;; They are concurrent and lock-free, but not yet resizable.
;;;
(define-record-type
(%make-weak-key-hash-table find insert! buckets)
%weak-key-hash-table?
(find weak-key-hash-table-find)
(insert! weak-key-hash-table-insert!)
(buckets weak-key-hash-table-buckets))
(define-syntax-rule (primitive=? f prim)
(or (eq? f prim) (eq? f 'prim)))
(define make-weak-key-hash-table
(let ()
(define-syntax-rule (define-accessors find insert! equal? hash)
(begin
(define (find buckets k)
(let ((idx (hash k (ephemeron-table-length buckets))))
(let lp ((chain (ephemeron-table-ref buckets idx)))
(match chain
(#f #f)
(e (if (equal? (ephemeron-key e) k)
e
(lp (ephemeron-next e))))))))
(define (insert! buckets k e)
(let ((idx (hash k (ephemeron-table-length buckets))))
(let retry ((chain (ephemeron-table-ref buckets idx)))
(let walk ((link chain))
(cond
((not link)
;; Key was not in table when we started looking; try
;; to add it.
(let* ((prev (ephemeron-table-try-push! buckets idx e chain)))
(if (eq? prev chain)
;; Success.
(values e #t)
;; Lost a race with another inserter; retry.
(retry prev))))
((equal? (ephemeron-key link) k)
;; Found an existing association; return it.
(values link #f))
(else
;; Chain link for some other key; keep looking.
(walk (ephemeron-next link))))))))))
(define-accessors findq insertq! eq? hashq)
(define-accessors findv insertv! eqv? hashv)
(define-accessors find insert! equal? hash)
(define (compute-accessors %equal? %hash)
(cond
((and (primitive=? %equal? eq?) (primitive=? %hash hashq))
(values findq insertq!))
((and (primitive=? %equal? eqv?) (primitive=? %hash hashv))
(values findv insertv!))
((and (primitive=? %equal? equal?) (primitive=? %hash hash))
(values find insert!))
(else
(define-accessors find insert! %equal? %hash)
(values find insert!))))
(lambda* (#:optional (size 127)
#:key (equal? 'eq?) (hash 'hashq) (initial-size size))
(define-values (find insert!) (compute-accessors equal? hash))
(%make-weak-key-hash-table find insert!
(make-ephemeron-table initial-size)))))
(define* (weak-key-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ find insert! buckets)
(match (find buckets k)
(#f (default k))
(e (ephemeron-value e))))))
(define (weak-key-hash-table-set! table k v)
(match table
(($ find insert! buckets)
(call-with-values (lambda () (insert! buckets k (make-ephemeron k v)))
(lambda (e inserted?)
(unless inserted?
(ephemeron-swap! e v))
(values))))))
(define (weak-key-hash-table-remove! table k)
(match table
(($ find insert! buckets)
(match (find buckets k)
(#f #f)
(e
(ephemeron-mark-dead! e)
#t)))))
(define (weak-key-hash-table-clear! table)
(match table
(($ find insert! buckets)
(let ((len (ephemeron-table-length buckets)))
(let lp ((i 0))
(when (< i len)
(ephemeron-table-clear! buckets i)
(lp (1+ i))))
(values)))))
(define (weak-key-hash-table-fold proc init table)
(match table
(($ find insert! buckets)
(let ((len (ephemeron-table-length buckets)))
(let visit-bucket ((i 0) (seed init))
(cond
((< i len)
(let visit-chain ((chain (ephemeron-table-ref buckets i))
(seed seed))
(if chain
(let ((k (ephemeron-key chain))
(v (ephemeron-value chain)))
(visit-chain (ephemeron-next chain)
(if k
(proc k v seed)
seed)))
(visit-bucket (1+ i) seed))))
(else seed)))))))
(define* (weak-key-hash-table-for-each proc table)
(weak-key-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (weak-key-hash-table-map->list proc table)
(weak-key-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;;;
;;; Weak value hash tables implement a key-value mapping, where each
;;; mapping is in place if and only if the value is otherwise reachable.
;;; They are implemented as a normal hash table whose values are
;;; ephemerons. Because normal hash tables are not concurrent, accesses
;;; to a weak value table are serialized through a lock. On the other
;;; hand, weak value tables are resizeable.
;;;
(define-record-type
(%make-weak-value-hash-table lock find set! remove! store)
%weak-value-hash-table?
(lock weak-value-hash-table-lock)
(find %weak-value-hash-table-find)
(set! %weak-value-hash-table-set!)
(remove! %weak-value-hash-table-remove!)
(store weak-value-hash-table-store))
(define make-weak-value-hash-table
(let ()
(define (make-assoc equal?)
(lambda (alist k)
(let lp ((alist alist))
(match alist
(() #f)
((head . tail)
(if (equal? (car head) k)
head
(lp tail)))))))
(define (compute-accessors %equal? %hash)
(cond
((and (primitive=? %equal? eq?) (primitive=? %hash hashq))
(values hashq-get-handle hashq-set! hashq-remove!))
((and (primitive=? %equal? eqv?) (primitive=? %hash hashv))
(values hashv-get-handle hashv-set! hashv-remove!))
((and (primitive=? %equal? equal?) (primitive=? %hash hash))
(values hash-get-handle hash-set! hash-remove!))
(else
(define assoc (make-assoc %equal?))
(values
(lambda (table k)
(hashx-get-handle %hash assoc table k))
(lambda (table k v)
(hashx-set! %hash assoc table k v))
(lambda (table k)
(hashx-remove! %hash assoc table k))))))
(lambda* (#:optional (size 0)
#:key (equal? 'eq?) (hash 'hashq) (initial-size size))
(define-values (find set! remove!) (compute-accessors equal? hash))
(%make-weak-value-hash-table (make-mutex) find set! remove!
(make-hash-table initial-size)))))
(define* (weak-value-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ lock find set! remove! store)
(with-mutex lock
(match (find store k)
((k . e)
(or (ephemeron-key e)
(begin
;; Ephemeron is dead.
(remove! store k)
(default k))))
(#f (default k)))))))
(define (weak-value-hash-table-set! table k v)
(match table
(($ lock find set! remove! store)
(with-mutex lock
(set! store k (make-ephemeron v #t))))))
(define (weak-value-hash-table-remove! table k)
(match table
(($ lock find set! remove! store)
(with-mutex lock
(remove! store k))
(values))))
(define (weak-value-hash-table-clear! table)
(match table
(($ lock find set! remove! store)
(with-mutex lock
(hash-clear! store))
(values))))
(define (weak-value-hash-table-fold proc init table)
(match table
(($ lock find set! remove! store)
(with-mutex lock
(hash-fold (lambda (k v seed)
(let ((v (ephemeron-key v)))
(if v
(proc k v seed)
seed)))
init table)))))
(define* (weak-value-hash-table-for-each proc table)
(weak-value-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (weak-value-hash-table-map->list proc table)
(weak-value-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;;;
;;; Doubly-weak hash tables implement a key-value mapping, where each
;;; mapping is in place if and only if both the key and the value are
;;; otherwise reachable. They are implemented as a weak key table whose
;;; values are ephemerons. They are concurrent and lock-free but not
;;; resizeable.
;;;
(define-record-type
(%make-doubly-weak-hash-table store)
%doubly-weak-hash-table?
(store doubly-weak-hash-table-store))
(define* (make-doubly-weak-hash-table #:optional (size 127)
#:key (equal? 'eq?) (hash 'hashq)
(initial-size size))
(%make-doubly-weak-hash-table
(make-weak-key-hash-table #:equal? equal? #:hash hash
#:initial-size initial-size)))
(define* (doubly-weak-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ store)
(match (weak-key-hash-table-ref store k)
(#f (default k))
(e (or (ephemeron-key e)
(default k)))))))
(define* (doubly-weak-hash-table-set! table k v)
(match table
(($ store)
(weak-key-hash-table-set! store k (make-ephemeron v #t)))))
(define* (doubly-weak-hash-table-remove! table k)
(match table
(($ store)
(weak-key-hash-table-remove! store k))))
(define* (doubly-weak-hash-table-clear! table)
(match table
(($ store)
(weak-key-hash-table-clear! store))))
(define (weak-value-hash-table-fold proc init table)
(match table
(($ store)
(weak-key-hash-table-fold (lambda (k v seed)
(let ((v (ephemeron-key v)))
(if v
(proc k v seed)
seed)))
init store))))
(define* (doubly-weak-hash-table-for-each proc table)
(doubly-weak-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (doubly-weak-hash-table-map->list proc table)
(doubly-weak-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;; Work around srfi-9's use of define-inlinable. FIXME: Simplify once
;; srfi-9 is simplified.
(define (weak-key-hash-table? x)
(%weak-key-hash-table? x))
(define (weak-value-hash-table? x)
(%weak-value-hash-table? x))
(define (doubly-weak-hash-table? x)
(%doubly-weak-hash-table? x))