0.7.5.15:
[sbcl.git] / 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*)