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