1.0.21.35: fix build / SAVE-LISP-AND-DIE on non-GENCGC platforms
[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::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
26 are no more references to OBJECT, including references in
27 FUNCTION itself.
28
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.
33
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.
38
39 Errors from FUNCTION are handled and cause a WARNING to be
40 signalled in whichever thread the FUNCTION was called in.
41
42 Examples:
43
44   ;;; good (assumes 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 (lambda () (release-handle (object-handle object)))))
55
56   ;;; bad, not re-entrant
57   (defvar *rec* nil)
58
59   (defun oops ()
60    (when *rec*
61      (error \"recursive OOPS\"))
62    (let ((*rec* t))
63      (gc))) ; or just cons enough to cause one
64
65   (progn
66     (finalize \"oops\" #'oops)
67     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
68             ; -> ERROR, caught, WARNING signalled"
69   (unless object
70     (error "Cannot finalize NIL."))
71   (with-finalizer-store-lock
72     (push (list (make-weak-pointer object) function dont-save)
73           *finalizer-store*))
74   object)
75
76 (defun deinit-finalizers ()
77   ;; remove :dont-save finalizers
78   (with-finalizer-store-lock
79     (setf *finalizer-store* (delete-if #'third *finalizer-store*)))
80   nil)
81
82 (defun cancel-finalization (object)
83   #!+sb-doc
84   "Cancel any finalization for OBJECT."
85   ;; Check for NIL to avoid deleting finalizers that are waiting to be
86   ;; run.
87   (when object
88     (with-finalizer-store-lock
89         (setf *finalizer-store*
90               (delete object *finalizer-store*
91                       :key (lambda (list)
92                              (weak-pointer-value (car list))))))
93     object))
94
95 (defun run-pending-finalizers ()
96   (let (pending)
97     (with-finalizer-store-lock
98         (setf *finalizer-store*
99               (delete-if (lambda (list)
100                            (when (null (weak-pointer-value (car list)))
101                              (push (second list) pending)
102                              t))
103                           *finalizer-store*)))
104     ;; We want to run the finalizer bodies outside the lock in case
105     ;; finalization of X causes finalization to be added for Y.
106     (dolist (fun pending)
107       (handler-case
108           (funcall fun)
109         (error (c)
110           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
111   nil)