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