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 (defglobal **finalizer-store
** nil
)
16 (defglobal **finalizer-store-lock
**
17 (sb!thread
:make-mutex
:name
"Finalizer store lock."))
19 (defmacro with-finalizer-store-lock
(&body body
)
20 `(sb!thread
::with-system-mutex
(**finalizer-store-lock
** :without-gcing t
)
23 (defun finalize (object function
&key dont-save
)
25 "Arrange for the designated FUNCTION to be called when there
26 are no more references to OBJECT, including references in
29 If DONT-SAVE is true, the finalizer will be cancelled when
30 SAVE-LISP-AND-DIE is called: this is useful for finalizers
31 deallocating system memory, which might otherwise be called
32 with addresses from the old image.
34 In a multithreaded environment FUNCTION may be called in any
35 thread. In both single and multithreaded environments FUNCTION
36 may be called in any dynamic scope: consequences are unspecified
37 if FUNCTION is not fully re-entrant.
39 Errors from FUNCTION are handled and cause a WARNING to be
40 signalled in whichever thread the FUNCTION was called in.
44 ;;; good (assumes RELEASE-HANDLE is re-entrant)
45 (let* ((handle (get-handle))
46 (object (make-object handle)))
47 (finalize object (lambda () (release-handle handle)))
50 ;;; bad, finalizer refers to object being finalized, causing
51 ;;; it to be retained indefinitely
52 (let* ((handle (get-handle))
53 (object (make-object handle)))
54 (finalize object (lambda () (release-handle (object-handle object)))))
56 ;;; bad, not re-entrant
61 (error \"recursive OOPS\"))
63 (gc))) ; or just cons enough to cause one
66 (finalize \"oops\" #'oops)
67 (oops)) ; causes GC and re-entry to #'oops due to the finalizer
68 ; -> ERROR, caught, WARNING signalled"
70 (error "Cannot finalize NIL."))
71 (with-finalizer-store-lock
72 (push (list (make-weak-pointer object
) function dont-save
)
76 (defun deinit-finalizers ()
77 ;; remove :dont-save finalizers
78 (with-finalizer-store-lock
79 (setf **finalizer-store
** (delete-if #'third
**finalizer-store
**)))
82 (defun cancel-finalization (object)
84 "Cancel any finalization for OBJECT."
85 ;; Check for NIL to avoid deleting finalizers that are waiting to be
88 (with-finalizer-store-lock
89 (setf **finalizer-store
**
90 (delete object
**finalizer-store
**
92 (weak-pointer-value (car list
))))))
95 (defun run-pending-finalizers ()
97 (with-finalizer-store-lock
98 (setf **finalizer-store
**
99 (delete-if (lambda (list)
100 (when (null (weak-pointer-value (car list
)))
101 (push (second list
) pending
)
103 **finalizer-store
**)))
104 ;; We want to run the finalizer bodies outside the lock in case
105 ;; finalization of X causes finalization to be added for Y.
106 (dolist (fun pending
)
110 (warn "Error calling finalizer ~S:~% ~S" fun c
)))))