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(defglobal **finalizer-store** nil) 15 16(defglobal **finalizer-store-lock** 17 (sb!thread:make-mutex :name "Finalizer store lock.")) 18 19(defmacro with-finalizer-store-lock (&body body) 20 `(sb!thread::with-system-mutex (**finalizer-store-lock** :without-gcing t) 21 ,@body)) 22 23(defun finalize (object function &key dont-save) 24 #!+sb-doc 25 "Arrange for the designated FUNCTION to be called when there 26are no more references to OBJECT, including references in 27FUNCTION itself. 28 29If DONT-SAVE is true, the finalizer will be cancelled when 30SAVE-LISP-AND-DIE is called: this is useful for finalizers 31deallocating system memory, which might otherwise be called 32with addresses from the old image. 33 34In a multithreaded environment FUNCTION may be called in any 35thread. In both single and multithreaded environments FUNCTION 36may be called in any dynamic scope: consequences are unspecified 37if FUNCTION is not fully re-entrant. 38 39Errors from FUNCTION are handled and cause a WARNING to be 40signalled in whichever thread the FUNCTION was called in. 41 42Examples: 43 44 ;;; GOOD, assuming RELEASE-HANDLE is re-entrant. 45 (let* ((handle (get-handle)) 46 (object (make-object handle))) 47 (finalize object (lambda () (release-handle handle))) 48 object) 49 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 55 (lambda () 56 (release-handle (object-handle object))))) 57 58 ;;; BAD, not re-entrant! 59 (defvar *rec* nil) 60 61 (defun oops () 62 (when *rec* 63 (error \"recursive OOPS\")) 64 (let ((*rec* t)) 65 (gc))) ; or just cons enough to cause one 66 67 (progn 68 (finalize \"oops\" #'oops) 69 (oops)) ; GC causes re-entry to #'oops due to the finalizer 70 ; -> ERROR, caught, WARNING signalled" 71 (unless object 72 (error "Cannot finalize NIL.")) 73 (with-finalizer-store-lock 74 (push (list (make-weak-pointer object) function dont-save) 75 **finalizer-store**)) 76 object) 77 78(defun deinit-finalizers () 79 ;; remove :dont-save finalizers 80 (with-finalizer-store-lock 81 (setf **finalizer-store** (delete-if #'third **finalizer-store**))) 82 nil) 83 84(defun cancel-finalization (object) 85 #!+sb-doc 86 "Cancel any finalization for OBJECT." 87 ;; Check for NIL to avoid deleting finalizers that are waiting to be 88 ;; run. 89 (when object 90 (with-finalizer-store-lock 91 (setf **finalizer-store** 92 (delete object **finalizer-store** 93 :key (lambda (list) 94 (weak-pointer-value (car list)))))) 95 object)) 96 97(defun run-pending-finalizers () 98 (let (pending) 99 ;; We want to run the finalizer bodies outside the lock in case 100 ;; finalization of X causes finalization to be added for Y. 101 ;; And to avoid consing we can reuse the deleted conses from the 102 ;; store to build the list of functions. 103 (with-finalizer-store-lock 104 (loop with list = **finalizer-store** 105 with previous 106 for finalizer = (car list) 107 do 108 (unless finalizer 109 (if previous 110 (setf (cdr previous) nil) 111 (setf **finalizer-store** nil)) 112 (return)) 113 unless (weak-pointer-value (car finalizer)) 114 do 115 (psetf pending finalizer 116 (car finalizer) (second finalizer) 117 (cdr finalizer) pending 118 (car list) (cadr list) 119 (cdr list) (cddr list)) 120 else 121 do (setf previous list 122 list (cdr list)))) 123 (dolist (fun pending) 124 (handler-case 125 (funcall fun) 126 (error (c) 127 (warn "Error calling finalizer ~S:~% ~S" fun c))))) 128 nil) 129