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