src/code/final.lisp

   1 ;;;; finalization based on weak pointers
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defvar *finalizer-store* nil)
  15
  16 (defvar *finalizer-store-lock*
  17   (sb!thread:make-mutex :name "Finalizer store lock."))
  18
  19 (defun finalize (object function)
  20   #!+sb-doc
  21   "Arrange for the designated FUNCTION to be called when there
  22 are no more references to OBJECT. In a multithreaded environment
  23 the finalizer may run in any thread."
  24   (sb!thread:with-mutex (*finalizer-store-lock*)
  25     (push (cons (make-weak-pointer object) function)
  26           *finalizer-store*))
  27   object)
  28
  29 (defun cancel-finalization (object)
  30   #!+sb-doc
  31   "Cancel any finalization for OBJECT."
  32   ;; Check for NIL to avoid deleting finalizers that are waiting to be
  33   ;; run.
  34   (when object
  35     (sb!thread:with-mutex (*finalizer-store-lock*)
  36       (setf *finalizer-store*
  37             (delete object *finalizer-store*
  38                     :key (lambda (pair)
  39                            (weak-pointer-value (car pair))))))
  40     object))
  41
  42 (defun run-pending-finalizers ()
  43   (let (pending)
  44     (sb!thread:with-mutex (*finalizer-store-lock*)
  45       (setf *finalizer-store*
  46             (delete-if  (lambda (pair)
  47                           (when (null (weak-pointer-value (car pair)))
  48                             (push (cdr pair) pending)
  49                             t))
  50                       *finalizer-store*)))
  51     ;; We want to run the finalizer bodies outside the lock in case
  52     ;; finalization of X causes finalization to be added for Y.
  53     (dolist (fun pending)
  54       (handler-case
  55           (funcall fun)
  56         (error (c)
  57           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
  58   nil)