mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-27 13:30:31 +02:00
4c76332570
* module/ice-9/guardians.scm (make-atomic-fifo): Instead of transferring the last element to the outbox, just return it.
102 lines
3.1 KiB
Scheme
102 lines
3.1 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:
|
||
;;;
|
||
;;; This is an implementation of guardians as described in:
|
||
;;;
|
||
;;; R. Kent Dybvig, Carl Bruggeman, and David Eby. "Guardians in a
|
||
;;; Generation-Based Garbage Collector." PLDI 1993.
|
||
;;; https://dl.acm.org/doi/abs/10.1145/173262.155110
|
||
;;;
|
||
;;; Our implementation is terms of Whippet's multi-priority finalizers:
|
||
;;; https://wingolog.org/archives/2024/07/22/finalizers-guardians-phantom-references-et-cetera
|
||
;;;
|
||
;;; Specifically, all guardian finalizers will run before any "normal"
|
||
;;; finalizer runs, so guarded objects that are returned to Scheme
|
||
;;; aren't finalized yet.
|
||
;;;
|
||
;;; Code:
|
||
|
||
|
||
(define-module (ice-9 guardians)
|
||
#:use-module (system finalizers)
|
||
#:use-module (ice-9 atomic)
|
||
#:use-module (ice-9 match)
|
||
#:replace (make-guardian))
|
||
|
||
(define (immediate? x)
|
||
(cond
|
||
((exact-integer? x) (<= most-negative-fixnum x most-positive-fixnum))
|
||
((char? x) #t)
|
||
((eq? x #f) #t)
|
||
((eq? x #nil) #t)
|
||
((eq? x '()) #t)
|
||
((eq? x #t) #t)
|
||
((unspecified? x) #t)
|
||
((eof-object? x) #t)
|
||
(else #f)))
|
||
|
||
(define (heap-object? x)
|
||
(not (immediate? x)))
|
||
|
||
(define (make-atomic-fifo)
|
||
(define inbox (make-atomic-box '()))
|
||
(define outbox (make-atomic-box '()))
|
||
(define (push! x)
|
||
(let lp ((in (atomic-box-ref inbox)))
|
||
(let ((prev (atomic-box-compare-and-swap! inbox in (cons x in))))
|
||
(if (eq? prev in)
|
||
(values)
|
||
(lp prev)))))
|
||
(define (transfer! in out)
|
||
(match in
|
||
(() (values))
|
||
((x) x)
|
||
((x . in*)
|
||
(let* ((out* (cons x out))
|
||
(out** (atomic-box-compare-and-swap! outbox out out*)))
|
||
(if (eq? out out**)
|
||
(transfer! in* out*)
|
||
(transfer! in out**))))))
|
||
(define (pop!)
|
||
(let lp ((out (atomic-box-ref outbox)))
|
||
(match out
|
||
((head . tail)
|
||
(let ((prev (atomic-box-compare-and-swap! outbox out tail)))
|
||
(if (eq? prev out)
|
||
head
|
||
(lp prev))))
|
||
(()
|
||
(match (atomic-box-swap! inbox '())
|
||
(() #f)
|
||
(in
|
||
(transfer! in '())))))))
|
||
(values push! pop!))
|
||
|
||
(define (make-guardian)
|
||
(define-values (push! pop!) (make-atomic-fifo))
|
||
(define (guard! obj)
|
||
(when (heap-object? obj)
|
||
(add-finalizer! obj push! %guardian-finalizer-priority)))
|
||
(define guardian
|
||
(case-lambda
|
||
(()
|
||
(pop!))
|
||
((obj)
|
||
(guard! obj)
|
||
(values))))
|
||
guardian)
|