(in-package "SB!IMPL")
-(defvar *objects-pending-finalization* nil)
+(defglobal **finalizer-store** nil)
-(defun finalize (object function)
+(defglobal **finalizer-store-lock**
+ (sb!thread:make-mutex :name "Finalizer store lock."))
+
+(defmacro with-finalizer-store-lock (&body body)
+ `(sb!thread::with-system-mutex (**finalizer-store-lock** :without-gcing t)
+ ,@body))
+
+(defun finalize (object function &key dont-save)
#!+sb-doc
- "Arrange for FUNCTION to be called when there are no more references to
- OBJECT."
- (declare (type function function))
- (sb!sys:without-gcing
- (push (cons (make-weak-pointer object) function)
- *objects-pending-finalization*))
+ "Arrange for the designated FUNCTION to be called when there
+are no more references to OBJECT, including references in
+FUNCTION itself.
+
+If DONT-SAVE is true, the finalizer will be cancelled when
+SAVE-LISP-AND-DIE is called: this is useful for finalizers
+deallocating system memory, which might otherwise be called
+with addresses from the old image.
+
+In a multithreaded environment FUNCTION may be called in any
+thread. In both single and multithreaded environments FUNCTION
+may be called in any dynamic scope: consequences are unspecified
+if FUNCTION is not fully re-entrant.
+
+Errors from FUNCTION are handled and cause a WARNING to be
+signalled in whichever thread the FUNCTION was called in.
+
+Examples:
+
+ ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
+ (let* ((handle (get-handle))
+ (object (make-object handle)))
+ (finalize object (lambda () (release-handle handle)))
+ object)
+
+ ;;; BAD, finalizer refers to object being finalized, causing
+ ;;; it to be retained indefinitely!
+ (let* ((handle (get-handle))
+ (object (make-object handle)))
+ (finalize object
+ (lambda ()
+ (release-handle (object-handle object)))))
+
+ ;;; BAD, not re-entrant!
+ (defvar *rec* nil)
+
+ (defun oops ()
+ (when *rec*
+ (error \"recursive OOPS\"))
+ (let ((*rec* t))
+ (gc))) ; or just cons enough to cause one
+
+ (progn
+ (finalize \"oops\" #'oops)
+ (oops)) ; GC causes re-entry to #'oops due to the finalizer
+ ; -> ERROR, caught, WARNING signalled"
+ (unless object
+ (error "Cannot finalize NIL."))
+ (with-finalizer-store-lock
+ (push (list (make-weak-pointer object) function dont-save)
+ **finalizer-store**))
object)
+(defun deinit-finalizers ()
+ ;; remove :dont-save finalizers
+ (with-finalizer-store-lock
+ (setf **finalizer-store** (delete-if #'third **finalizer-store**)))
+ nil)
+
(defun cancel-finalization (object)
#!+sb-doc
- "Cancel any finalization registers for OBJECT."
+ "Cancel any finalization for OBJECT."
+ ;; Check for NIL to avoid deleting finalizers that are waiting to be
+ ;; run.
(when object
- ;; We check to make sure object isn't nil because if there are any
- ;; broken weak pointers, their value will show up as nil. Therefore,
- ;; they would be deleted from the list, but not finalized. Broken
- ;; weak pointers shouldn't be left in the list, but why take chances?
- (sb!sys:without-gcing
- (setf *objects-pending-finalization*
- (delete object *objects-pending-finalization*
- :key (lambda (pair)
- (values (weak-pointer-value (car pair))))))))
- nil)
+ (with-finalizer-store-lock
+ (setf **finalizer-store**
+ (delete object **finalizer-store**
+ :key (lambda (list)
+ (weak-pointer-value (car list))))))
+ object))
-(defun finalize-corpses ()
- (setf *objects-pending-finalization*
- (delete-if (lambda (pair)
- (multiple-value-bind (object valid)
- (weak-pointer-value (car pair))
- (declare (ignore object))
- (unless valid
- (funcall (cdr pair))
- t)))
- *objects-pending-finalization*))
+(defun run-pending-finalizers ()
+ (let (pending)
+ (with-finalizer-store-lock
+ (setf **finalizer-store**
+ (delete-if (lambda (list)
+ (when (null (weak-pointer-value (car list)))
+ (push (second list) pending)
+ t))
+ **finalizer-store**)))
+ ;; We want to run the finalizer bodies outside the lock in case
+ ;; finalization of X causes finalization to be added for Y.
+ (dolist (fun pending)
+ (handler-case
+ (funcall fun)
+ (error (c)
+ (warn "Error calling finalizer ~S:~% ~S" fun c)))))
nil)
-
-(pushnew 'finalize-corpses *after-gc-hooks*)
projects / sbcl.git / blobdiff