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 *objects-pending-finalization* nil)
  15
  16 (defun finalize (object function)
  17   #!+sb-doc
  18   "Arrange for FUNCTION to be called when there are no more references to
  19    OBJECT."
  20   (declare (type function function))
  21   (sb!sys:without-gcing
  22    (push (cons (make-weak-pointer object) function)
  23          *objects-pending-finalization*))
  24   object)
  25
  26 (defun cancel-finalization (object)
  27   #!+sb-doc
  28   "Cancel any finalization registers for OBJECT."
  29   (when object
  30     ;; We check to make sure object isn't nil because if there are any
  31     ;; broken weak pointers, their value will show up as nil. Therefore,
  32     ;; they would be deleted from the list, but not finalized. Broken
  33     ;; weak pointers shouldn't be left in the list, but why take chances?
  34     (sb!sys:without-gcing
  35      (setf *objects-pending-finalization*
  36            (delete object *objects-pending-finalization*
  37                    :key #'(lambda (pair)
  38                             (values (weak-pointer-value (car pair))))))))
  39   nil)
  40
  41 (defun finalize-corpses ()
  42   (setf *objects-pending-finalization*
  43         (delete-if #'(lambda (pair)
  44                        (multiple-value-bind (object valid)
  45                            (weak-pointer-value (car pair))
  46                          (declare (ignore object))
  47                          (unless valid
  48                            (funcall (cdr pair))
  49                            t)))
  50                    *objects-pending-finalization*))
  51   nil)
  52
  53 (pushnew 'finalize-corpses *after-gc-hooks*)