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