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
)
24 "Arrange for the designated FUNCTION to be called when there
25 are no more references to OBJECT, including references in
28 If DONT-SAVE is true, the finalizer will be cancelled when
29 SAVE-LISP-AND-DIE is called: this is useful for finalizers
30 deallocating system memory, which might otherwise be called
31 with addresses from the old image.
33 In a multithreaded environment FUNCTION may be called in any
34 thread. In both single and multithreaded environments FUNCTION
35 may be called in any dynamic scope: consequences are unspecified
36 if FUNCTION is not fully re-entrant.
38 Errors from FUNCTION are handled and cause a WARNING to be
39 signalled in whichever thread the FUNCTION was called in.
43 ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
44 (let* ((handle (get-handle))
45 (object (make-object handle)))
46 (finalize object (lambda () (release-handle handle)))
49 ;;; BAD, finalizer refers to object being finalized, causing
50 ;;; it to be retained indefinitely!
51 (let* ((handle (get-handle))
52 (object (make-object handle)))
55 (release-handle (object-handle object)))))
57 ;;; BAD, not re-entrant!
62 (error \"recursive OOPS\"))
64 (gc))) ; or just cons enough to cause one
67 (finalize \"oops\" #'oops)
68 (oops)) ; GC causes re-entry to #'oops due to the finalizer
69 ; -> ERROR, caught, WARNING signalled"
71 (error "Cannot finalize NIL."))
72 (with-finalizer-store-lock
73 (push (list (make-weak-pointer object
) function dont-save
)
77 (defun deinit-finalizers ()
78 ;; remove :dont-save finalizers
79 (with-finalizer-store-lock
80 (setf **finalizer-store
** (delete-if #'third
**finalizer-store
**)))
83 (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 ;; We want to run the finalizer bodies outside the lock in case
98 ;; finalization of X causes finalization to be added for Y.
99 ;; And to avoid consing we can reuse the deleted conses from the
100 ;; store to build the list of functions.
101 (with-finalizer-store-lock
102 (loop with list
= **finalizer-store
**
104 for finalizer
= (car list
)
108 (setf (cdr previous
) nil
)
109 (setf **finalizer-store
** nil
))
111 unless
(weak-pointer-value (car finalizer
))
113 (psetf pending finalizer
114 (car finalizer
) (second finalizer
)
115 (cdr finalizer
) pending
116 (car list
) (cadr list
)
117 (cdr list
) (cddr list
))
119 do
(setf previous list
121 (dolist (fun pending
)
125 (warn "Error calling finalizer ~S:~% ~S" fun c
)))))