1.0.4.76: add a new style-warning for duplicate CASE keys
[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 (defun finalize (object function)
20   #!+sb-doc
21   "Arrange for the designated FUNCTION to be called when there
22 are no more references to OBJECT, including references in
23 FUNCTION itself.
24
25 In a multithreaded environment FUNCTION may be called in any
26 thread. In both single and multithreaded environments FUNCTION
27 may be called in any dynamic scope: consequences are unspecified
28 if FUNCTION is not fully re-entrant.
29
30 Errors from FUNCTION are handled and cause a WARNING to be
31 signalled in whichever thread the FUNCTION was called in.
32
33 Examples:
34
35   ;;; good (assumes RELEASE-HANDLE is re-entrant)
36   (let* ((handle (get-handle))
37          (object (make-object handle)))
38    (finalize object (lambda () (release-handle handle)))
39    object)
40
41   ;;; bad, finalizer refers to object being finalized, causing
42   ;;; it to be retained indefinitely
43   (let* ((handle (get-handle))
44          (object (make-object handle)))
45     (finalize object (lambda () (release-handle (object-handle object)))))
46
47   ;;; bad, not re-entrant
48   (defvar *rec* nil)
49
50   (defun oops ()
51    (when *rec*
52      (error \"recursive OOPS\"))
53    (let ((*rec* t))
54      (gc))) ; or just cons enough to cause one
55
56   (progn
57     (finalize \"oops\" #'oops)
58     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
59             ; -> ERROR, caught, WARNING signalled"
60   (sb!sys:without-gcing
61       (sb!thread:with-mutex (*finalizer-store-lock*)
62         (push (cons (make-weak-pointer object) function)
63               *finalizer-store*)))
64   object)
65
66 (defun cancel-finalization (object)
67   #!+sb-doc
68   "Cancel any finalization for OBJECT."
69   ;; Check for NIL to avoid deleting finalizers that are waiting to be
70   ;; run.
71   (when object
72     (sb!sys:without-gcing
73         (sb!thread:with-mutex (*finalizer-store-lock*)
74           (setf *finalizer-store*
75                 (delete object *finalizer-store*
76                         :key (lambda (pair)
77                                (weak-pointer-value (car pair)))))))
78     object))
79
80 (defun run-pending-finalizers ()
81   (let (pending)
82     (sb!sys:without-gcing
83         (sb!thread:with-mutex (*finalizer-store-lock*)
84           (setf *finalizer-store*
85                 (delete-if  (lambda (pair)
86                               (when (null (weak-pointer-value (car pair)))
87                                 (push (cdr pair) pending)
88                                 t))
89                             *finalizer-store*))))
90     ;; We want to run the finalizer bodies outside the lock in case
91     ;; finalization of X causes finalization to be added for Y.
92     (dolist (fun pending)
93       (handler-case
94           (funcall fun)
95         (error (c)
96           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
97   nil)