1.0.9.18: Instrument COMPUTE-CALLING-FRAME for non-x86 with /noshow0.
[sbcl.git] / src / code / final.lisp
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 (defvar *finalizer-store* nil)
15
16 (defvar *finalizer-store-lock*
17   (sb!thread:make-mutex :name "Finalizer store lock."))
18
19 (defmacro with-finalizer-store-lock (&body body)
20   `(sb!thread::call-with-system-mutex (lambda () ,@body)
21                                       *finalizer-store-lock*
22                                       t))
23
24 (defun finalize (object function &key dont-save)
25   #!+sb-doc
26   "Arrange for the designated FUNCTION to be called when there
27 are no more references to OBJECT, including references in
28 FUNCTION itself.
29
30 If DONT-SAVE is true, the finalizer will be cancelled when
31 SAVE-LISP-AND-DIE is called: this is useful for finalizers
32 deallocating system memory, which might otherwise be called
33 with addresses from the old image.
34
35 In a multithreaded environment FUNCTION may be called in any
36 thread. In both single and multithreaded environments FUNCTION
37 may be called in any dynamic scope: consequences are unspecified
38 if FUNCTION is not fully re-entrant.
39
40 Errors from FUNCTION are handled and cause a WARNING to be
41 signalled in whichever thread the FUNCTION was called in.
42
43 Examples:
44
45   ;;; good (assumes RELEASE-HANDLE is re-entrant)
46   (let* ((handle (get-handle))
47          (object (make-object handle)))
48    (finalize object (lambda () (release-handle handle)))
49    object)
50
51   ;;; bad, finalizer refers to object being finalized, causing
52   ;;; it to be retained indefinitely
53   (let* ((handle (get-handle))
54          (object (make-object handle)))
55     (finalize object (lambda () (release-handle (object-handle object)))))
56
57   ;;; bad, not re-entrant
58   (defvar *rec* nil)
59
60   (defun oops ()
61    (when *rec*
62      (error \"recursive OOPS\"))
63    (let ((*rec* t))
64      (gc))) ; or just cons enough to cause one
65
66   (progn
67     (finalize \"oops\" #'oops)
68     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
69             ; -> ERROR, caught, WARNING signalled"
70   (unless object
71     (error "Cannot finalize NIL."))
72   (with-finalizer-store-lock
73     (push (list (make-weak-pointer object) function dont-save)
74           *finalizer-store*))
75   object)
76
77 (defun deinit-finalizers ()
78   ;; remove :dont-save finalizers
79   (with-finalizer-store-lock
80     (setf *finalizer-store* (delete-if #'third *finalizer-store*)))
81   nil)
82
83 (defun cancel-finalization (object)
84   #!+sb-doc
85   "Cancel any finalization for OBJECT."
86   ;; Check for NIL to avoid deleting finalizers that are waiting to be
87   ;; run.
88   (when object
89     (with-finalizer-store-lock
90         (setf *finalizer-store*
91               (delete object *finalizer-store*
92                       :key (lambda (list)
93                              (weak-pointer-value (car list))))))
94     object))
95
96 (defun run-pending-finalizers ()
97   (let (pending)
98     (with-finalizer-store-lock
99         (setf *finalizer-store*
100               (delete-if (lambda (list)
101                            (when (null (weak-pointer-value (car list)))
102                              (push (second list) pending)
103                              t))
104                           *finalizer-store*)))
105     ;; We want to run the finalizer bodies outside the lock in case
106     ;; finalization of X causes finalization to be added for Y.
107     (dolist (fun pending)
108       (handler-case
109           (funcall fun)
110         (error (c)
111           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
112   nil)