;;; -*- Mode: Scheme -*-

;;;; Resource Finalization

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define-record-type <handle>
    (%make-handle weak-pointer descriptor)
    handle?
  (descriptor handle.descriptor set-handle.descriptor!)
  (weak-pointer handle.weak-pointer))

;;; SYNC: This must be synchronized with s48-stubber.h.

(define handle-descriptor-offset 0)

(define (make-handle object descriptor)
  (%make-handle (make-weak-pointer object) descriptor))

(define (allocate-handle object)
  (make-handle object #f))

(define (handle.broken? handle)
  (not (weak-pointer-ref (handle.weak-pointer handle))))

(define (handle.object handle)
  (weak-pointer-ref (handle.weak-pointer handle)))

(define-syntax with-finalized-objects
  (syntax-rules ()
    ((WITH-FINALIZED-OBJECTS finalizer-expression
         ((object-variable handle-variable object-expression)
          ...)
         initialization
       body0 body1+ ...)
     (LET ((FINALIZER finalizer-expression))
       (LET ((handle-variable (ALLOCATE-HANDLE object-expression))
             ...)
         (FINALIZER/ADD-HANDLE! FINALIZER handle-variable)
         ...
         (LET () initialization)
         ((FINALIZER.SET-OBJECT-DESCRIPTOR! FINALIZER)
          (HANDLE.OBJECT handle-variable)
          (HANDLE.DESCRIPTOR handle-variable))
         ...
         (LET ((object-variable (HANDLE.OBJECT handle-variable))
               ...)
           body0 body1+ ...))))))

;;;; Finalizers

;;; Finalizers are generalized over the internal associative data
;;; structure mapping descriptors to handles.  In this way we could
;;; use, for instance, weak hash tables, for fast lookup, if we so
;;; desire, rather than lists.

(define-record-type <finalizer>
    (%make-finalizer procedure predicate set-object-descriptor!
                     association lookup insert! delete! clear! clean)
    finalizer?
  (procedure finalizer.procedure)
  (predicate finalizer.predicate)
  (set-object-descriptor! finalizer.set-object-descriptor!)
  (association finalizer.association)
  (lookup finalizer.lookup)
  (insert! finalizer.insert!)
  (delete! finalizer.delete!)
  (clear! finalizer.clear!)
  (clean finalizer.clean))

(define (make-finalizer procedure predicate set-object-descriptor!
                        association lookup insert! delete! clear! clean)
  (let ((finalizer
         (%make-finalizer procedure predicate set-object-descriptor!
                          association lookup insert! delete! clear! clean)))
    (add-finalizer finalizer)
    finalizer))

;++ This should use identity-based hash tables rather than lists.

(define (make-default-finalizer procedure predicate set-object-descriptor!)
  (make-list-finalizer procedure predicate set-object-descriptor!))

;;; This is a simpler form of the WITH-FINALIZED-OBJECTS macro above.

(define (make-finalized finalizer object initialization)
  (let ((handle (allocate-handle object)))
    (finalizer/add-handle! finalizer handle)
    (initialization handle)
    ((finalizer.set-object-descriptor! finalizer)
     object
     (handle.descriptor handle))
    object))

(define (with-object-referenced object procedure)
  (dynamic-wind (lambda () (no-op object))
                procedure
                (lambda () (no-op object))))

;;;;; Finalizer Synchronization

(define the-finalizers (cons 'SENTINEL '()))

(define (with-the-finalizers-locked procedure)
  (with-interrupts-inhibited procedure))

(define (with-finalizer-locked finalizer procedure)
  finalizer                             ;ignore
  (with-interrupts-inhibited procedure))

(define (add-finalizer finalizer)
  (with-the-finalizers-locked
    (lambda ()
      (set-cdr! the-finalizers
                (cons (make-weak-pointer finalizer)
                      (cdr the-finalizers))))))

(define (clean-the-finalizers)
  (let ((finalizers '()))
    (with-the-finalizers-locked
      (lambda ()
        (walk-losing-list the-finalizers
          (lambda (weak-entry win lose)
            (let ((finalizer (weak-pointer-ref weak-entry)))
              (if finalizer
                  (win (lambda (stop go)
                         (set! finalizers (cons finalizer finalizers))
                         (go)))
                  (lose (lambda (stop go) (go))))))
          (lambda () (values)))))
    (for-each finalizer/clean finalizers)))

(define (with-finalizer-transaction finalizer procedure)
  (let ((descriptors '()))
    (receive results
             (with-finalizer-locked finalizer
               (lambda ()
                 (procedure
                  (lambda (descriptor)
                    (set! descriptors (cons descriptor descriptors))))))
      (for-each (finalizer.procedure finalizer) descriptors)
      (apply values results))))

;;;;; Finalizer Operations

(define (finalizer/add-object! finalizer object descriptor)
  (if (not ((finalizer.predicate finalizer) object))
      (error "Invalid object for finalizer:" object finalizer))
  (with-finalizer-locked finalizer
    (lambda ()
      ((finalizer.insert! finalizer)
       (finalizer.association finalizer)
       (make-handle object descriptor)))))

(define (finalizer/add-handle! finalizer handle)
  (let ((object (handle.object handle)))
    (if (not ((finalizer.predicate finalizer) object))
        (error "Handle has invalid object for finalizer:"
               handle object finalizer)))
  (with-finalizer-locked finalizer
    (lambda ()
      ((finalizer.insert! finalizer)
       (finalizer.association finalizer)
       handle))))

(define (finalizer/remove-object! finalizer object)
  (if (not ((finalizer.predicate finalizer) object))
      (error "Invalid object for finalizer:" object finalizer))
  (with-finalizer-transaction finalizer
    (lambda (procedure)
      ((finalizer.delete! finalizer)
       (finalizer.association finalizer)
       object
       procedure
       (finalizer.set-object-descriptor! finalizer)))))

(define (finalizer/clear! finalizer)
  (with-finalizer-transaction finalizer
    (lambda (procedure)
      ((finalizer.clear! finalizer)
       (finalizer.association finalizer)
       procedure
       (finalizer.set-object-descriptor! finalizer)))))

(define (finalizer/find-object finalizer descriptor)
  (with-finalizer-transaction finalizer
    (lambda (procedure)
      ((finalizer.lookup finalizer)
       (finalizer.association finalizer)
       descriptor
       procedure))))

(define (finalizer/clean finalizer)
  (with-finalizer-transaction finalizer
    (lambda (procedure)
      ((finalizer.clean finalizer)
       (finalizer.association finalizer)
       procedure))))

;;;;; List-Based finalizers

(define (make-list-finalizer procedure predicate set-object-descriptor!)
  (make-finalizer procedure predicate set-object-descriptor!
                  (cons 'SENTINEL '())
                  list-finalizer/lookup
                  list-finalizer/insert!
                  list-finalizer/delete!
                  list-finalizer/clear!
                  list-finalizer/clean))

(define (list-finalizer/lookup association descriptor procedure)
  (walk-losing-list association
    (lambda (handle win lose)
      (let ((object (handle.object handle))
            (descriptor* (handle.descriptor handle)))
        (if object
            (win (lambda (stop go)
                   (if (eqv? descriptor* descriptor)
                       (stop (lambda () object))
                       (go))))
            (begin (procedure descriptor*) (lose (lambda (stop go) (go)))))))
    (lambda () #f)))

;++ Ought we really not to worry about duplicates?

(define (list-finalizer/insert! association handle)
  (set-cdr! association (cons handle (cdr association))))

(define (list-finalizer/delete! association object procedure
                                set-object-descriptor!)
  (walk-losing-list association
    (lambda (handle win lose)
      (let ((object* (handle.object handle))
            (descriptor (handle.descriptor handle)))
        (cond ((eqv? object* object)
               (lose (lambda (stop go)
                       (set-object-descriptor! object #f)
                       (procedure descriptor)
                       (stop (lambda () (values))))))
              ((not object*)
               (procedure descriptor)
               (lose (lambda (stop go) (go))))
              (else
               (win (lambda (stop go) (go)))))))
    (lambda () (values))))

(define (list-finalizer/clear! association procedure set-object-descriptor!)
  (let loop ((handles
              (let ((handles (cdr association)))
                (set-cdr! association '())
                handles)))
    (if (pair? handles)
        (let ((handle (car handles)) (handles* (cdr handles)))
          (cond ((handle.object handle)
                 => (lambda (object)
                      (set-object-descriptor! object #f))))
          (procedure (handle.descriptor handle))
          (loop handles*)))))

(define (list-finalizer/clean association procedure)
  (walk-losing-list association
    (lambda (handle win lose)
      (if (handle.object handle)
          (win (lambda (stop go) (go)))
          (lose (lambda (stop go)
                  (procedure (handle.descriptor handle))
                  (go)))))
    (lambda () (values))))

;;;; Randomness

;;; This is the procedural abstraction of the traversal of a losing
;;; list, i.e. a list whose elements we may wish to throw away as we go
;;; through them.  Because Scheme48's compiler sucks, though, we can't
;;; rely on this for sensitive internal routines, so there is a
;;; horrible awful macro implementing the same idea on the next page.
;;; The procedural implementation exists for the sake of clarity and
;;; checking correctness.  The macro assumes some ridiculous
;;; constraints on the form of invocations.

;; (define (walk-losing-list list element-procedure end-procedure)
;;   (define (scan-in previous list)
;;     (if (pair? list)
;;         (let ((element (car list))
;;               (list* (cdr list)))
;;           (element-procedure
;;            element
;;            (lambda (receiver)           ;winner
;;              (receiver (lambda (end) (end))
;;                        (lambda () (scan-in list list*))))
;;            (lambda (receiver)           ;loser
;;              (receiver (lambda (end) (set-cdr! previous list*) (end))
;;                        (lambda () (scan-out previous list*))))))
;;         (end-procedure)))
;;   (define (scan-out previous list)
;;     (if (pair? list)
;;         (let ((element (car list))
;;               (list* (cdr list)))
;;           (element-procedure
;;            element
;;            (lambda (receiver)           ;winner
;;              (set-cdr! previous list*)
;;              (receiver (lambda (end) (end))
;;                        (lambda () (scan-in list list*))))
;;            (lambda (receiver)           ;loser
;;              (receiver (lambda (end) (set-cdr! previous list*) (end))
;;                        (lambda () (scan-out previous list*))))))
;;         (begin (set-cdr! previous '()) (end-procedure))))
;;   (scan-in list (cdr list)))

(define-syntax walk-losing-list
  (syntax-rules (LAMBDA)
    ((WALK-LOSING-LIST the-list
       (LAMBDA (element winner loser) element-body0 element-body1+ ...)
       (LAMBDA () end-body0 end-body1+ ...))
     (LET ()
       (DEFINE (SCAN-IN PREVIOUS LIST)
         (IF (PAIR? LIST)
             (LET ((element (CAR LIST)) (LIST* (CDR LIST)))
               (LET-SYNTAX
                   ((winner
                     (SYNTAX-RULES (LAMBDA)
                       ((winner (LAMBDA (?STOP ?GO) . ?WIN-BODY))
                        (LET-SYNTAX
                            ((?STOP
                              (SYNTAX-RULES (LAMBDA)
                                ((?STOP (LAMBDA () . ??END)) (BEGIN . ??END))))
                             (?GO
                              (SYNTAX-RULES () ((?GO) (SCAN-IN LIST LIST*)))))
                          . ?WIN-BODY))))
                    (loser
                     (SYNTAX-RULES ()
                       ((loser (LAMBDA (?STOP ?GO) . ?LOSE-BODY))
                        (LET-SYNTAX ((?STOP
                                      (SYNTAX-RULES (LAMBDA)
                                        ((?STOP (LAMBDA () . ??END))
                                         (BEGIN (SET-CDR! PREVIOUS LIST*)
                                                . ??END))))
                                     (?GO
                                      (SYNTAX-RULES ()
                                        ((?GO) (SCAN-OUT PREVIOUS LIST*)))))
                          . ?LOSE-BODY)))))
                 element-body0 element-body1+ ...))
             (BEGIN end-body0 end-body1+ ...)))
       (DEFINE (SCAN-OUT PREVIOUS LIST)
         (IF (PAIR? LIST)
             (LET ((element (CAR LIST)) (LIST* (CDR LIST)))
               (LET-SYNTAX
                   ((winner
                     (SYNTAX-RULES (LAMBDA)
                       ((winner (LAMBDA (?STOP ?GO) . ?WIN-BODY))
                        (BEGIN (SET-CDR! PREVIOUS LIST)
                               (LET-SYNTAX
                                   ((?STOP (SYNTAX-RULES (LAMBDA)
                                             ((?STOP (LAMBDA () . ??END))
                                              (BEGIN . ??END))))
                                    (?GO
                                     (SYNTAX-RULES ()
                                       ((?GO) (SCAN-IN LIST LIST*)))))
                                 . ?WIN-BODY)))))
                    (loser
                     (SYNTAX-RULES (LAMBDA)
                       ((loser (LAMBDA (?STOP ?GO) . ?LOSE-BODY))
                        (LET-SYNTAX ((?STOP (SYNTAX-RULES (LAMBDA)
                                              ((?STOP (LAMBDA () . ??END))
                                               (BEGIN (SET-CDR! PREVIOUS LIST*)
                                                      . ??END))))
                                     (?GO
                                      (SYNTAX-RULES ()
                                        ((?GO) (SCAN-OUT PREVIOUS LIST*)))))
                          . ?LOSE-BODY)))))
                 element-body0 element-body1+ ...))
             (BEGIN (SET-CDR! PREVIOUS LIST) end-body0 end-body1+ ...)))
       (SCAN-IN THE-LIST (CDR THE-LIST))))))

;;; Set it off.

(call-after-gc! clean-the-finalizers)