mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-07 04:30:18 +02:00
8280c8485f
* libguile/weak-table.c: * libguile/weak-table.h: Remove. * libguile.h: Remove weak-table.h include. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (modinclude_HEADERS): Remove weak-table.[ch]. * libguile/evalext.c: * libguile/fluids.c: * libguile/hash.c: * libguile/init.c: * libguile/print.c: * libguile/scm.h: Remove uses of weak-table.h and free up the tc7. * libguile/hashtab.c: * libguile/hashtab.h: Add deprecated shims to dispatch to (ice-9 weak-tables) when working on weak tables. * module/ice-9/weak-tables.scm: New implementation. Embeds the hash and equality functions in the table itself. * module/ice-9/object-properties.scm: * module/ice-9/poe.scm: * module/ice-9/popen.scm: * module/ice-9/source-properties.scm: * module/language/cps/compile-bytecode.scm: * module/language/ecmascript/array.scm: * module/language/ecmascript/function.scm: * module/oop/goops/save.scm: * module/srfi/srfi-18.scm: * module/srfi/srfi-69.scm: * module/system/base/types.scm: * module/system/base/types/internal.scm: * module/system/foreign.scm: * module/system/vm/assembler.scm: * test-suite/tests/gc.test: * test-suite/tests/hash.test: * test-suite/tests/srfi-69.test: * test-suite/tests/types.test: * test-suite/tests/weaks.test: Update to use new, non-deprecated weak tables API.
381 lines
13 KiB
Scheme
381 lines
13 KiB
Scheme
;;; 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
|
||
;;; <http://www.gnu.org/licenses/>.
|
||
|
||
;;; 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 <weak-key-hash-table>
|
||
(%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
|
||
(($ <weak-key-hash-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
|
||
(($ <weak-key-hash-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
|
||
(($ <weak-key-hash-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
|
||
(($ <weak-key-hash-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
|
||
(($ <weak-key-hash-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 <weak-value-hash-table>
|
||
(%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
|
||
(($ <weak-value-hash-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
|
||
(($ <weak-value-hash-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
|
||
(($ <weak-value-hash-table> lock find set! remove! store)
|
||
(with-mutex lock
|
||
(remove! store k))
|
||
(values))))
|
||
|
||
(define (weak-value-hash-table-clear! table)
|
||
(match table
|
||
(($ <weak-value-hash-table> lock find set! remove! store)
|
||
(with-mutex lock
|
||
(hash-clear! store))
|
||
(values))))
|
||
|
||
(define (weak-value-hash-table-fold proc init table)
|
||
(match table
|
||
(($ <weak-value-hash-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 <doubly-weak-hash-table>
|
||
(%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
|
||
(($ <doubly-weak-hash-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
|
||
(($ <doubly-weak-hash-table> store)
|
||
(weak-key-hash-table-set! store k (make-ephemeron v #t)))))
|
||
|
||
(define* (doubly-weak-hash-table-remove! table k)
|
||
(match table
|
||
(($ <doubly-weak-hash-table> store)
|
||
(weak-key-hash-table-remove! store k))))
|
||
|
||
(define* (doubly-weak-hash-table-clear! table)
|
||
(match table
|
||
(($ <doubly-weak-hash-table> store)
|
||
(weak-key-hash-table-clear! store))))
|
||
|
||
(define (weak-value-hash-table-fold proc init table)
|
||
(match table
|
||
(($ <doubly-weak-hash-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))
|