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