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 (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
  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, 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)