1 ;;;; finalization based on weak pointers
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 (defvar *finalizer-store* nil)
16 (defvar *finalizer-store-lock*
17 (sb!thread:make-mutex :name "Finalizer store lock."))
19 (defmacro with-finalizer-store-lock (&body body)
20 `(sb!thread::call-with-system-mutex (lambda () ,@body)
21 *finalizer-store-lock*
24 (defun finalize (object function)
26 "Arrange for the designated FUNCTION to be called when there
27 are no more references to OBJECT, including references in
30 In a multithreaded environment FUNCTION may be called in any
31 thread. In both single and multithreaded environments FUNCTION
32 may be called in any dynamic scope: consequences are unspecified
33 if FUNCTION is not fully re-entrant.
35 Errors from FUNCTION are handled and cause a WARNING to be
36 signalled in whichever thread the FUNCTION was called in.
40 ;;; good (assumes RELEASE-HANDLE is re-entrant)
41 (let* ((handle (get-handle))
42 (object (make-object handle)))
43 (finalize object (lambda () (release-handle handle)))
46 ;;; bad, finalizer refers to object being finalized, causing
47 ;;; it to be retained indefinitely
48 (let* ((handle (get-handle))
49 (object (make-object handle)))
50 (finalize object (lambda () (release-handle (object-handle object)))))
52 ;;; bad, not re-entrant
57 (error \"recursive OOPS\"))
59 (gc))) ; or just cons enough to cause one
62 (finalize \"oops\" #'oops)
63 (oops)) ; causes GC and re-entry to #'oops due to the finalizer
64 ; -> ERROR, caught, WARNING signalled"
65 (with-finalizer-store-lock
66 (push (cons (make-weak-pointer object) function)
70 (defun cancel-finalization (object)
72 "Cancel any finalization for OBJECT."
73 ;; Check for NIL to avoid deleting finalizers that are waiting to be
76 (with-finalizer-store-lock
77 (setf *finalizer-store*
78 (delete object *finalizer-store*
80 (weak-pointer-value (car pair))))))
83 (defun run-pending-finalizers ()
85 (with-finalizer-store-lock
86 (setf *finalizer-store*
87 (delete-if (lambda (pair)
88 (when (null (weak-pointer-value (car pair)))
89 (push (cdr pair) pending)
92 ;; We want to run the finalizer bodies outside the lock in case
93 ;; finalization of X causes finalization to be added for Y.
98 (warn "Error calling finalizer ~S:~% ~S" fun c)))))