1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / src / code / final.lisp
blobcfa36f1dba686f94c4daae37f504563c9fab543e
1 ;;;; finalization based on weak pointers
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.
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)
21 ,@body))
23 (defun finalize (object function &key dont-save)
24 #!+sb-doc
25 "Arrange for the designated FUNCTION to be called when there
26 are no more references to OBJECT, including references in
27 FUNCTION itself.
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.
42 Examples:
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)
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)))))
58 ;;; BAD, not re-entrant!
59 (defvar *rec* nil)
61 (defun oops ()
62 (when *rec*
63 (error \"recursive OOPS\"))
64 (let ((*rec* t))
65 (gc))) ; or just cons enough to cause one
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)
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)
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))
97 (defun run-pending-finalizers ()
98 (let (pending)
99 (with-finalizer-store-lock
100 (setf **finalizer-store**
101 (delete-if (lambda (list)
102 (when (null (weak-pointer-value (car list)))
103 (push (second list) pending)
105 **finalizer-store**)))
106 ;; We want to run the finalizer bodies outside the lock in case
107 ;; finalization of X causes finalization to be added for Y.
108 (dolist (fun pending)
109 (handler-case
110 (funcall fun)
111 (error (c)
112 (warn "Error calling finalizer ~S:~% ~S" fun c)))))
113 nil)