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   "Arrange for the designated FUNCTION to be called when there
  25 are no more references to OBJECT, including references in
  26 FUNCTION itself.
  27
  28 If DONT-SAVE is true, the finalizer will be cancelled when
  29 SAVE-LISP-AND-DIE is called: this is useful for finalizers
  30 deallocating system memory, which might otherwise be called
  31 with addresses from the old image.
  32
  33 In a multithreaded environment FUNCTION may be called in any
  34 thread. In both single and multithreaded environments FUNCTION
  35 may be called in any dynamic scope: consequences are unspecified
  36 if FUNCTION is not fully re-entrant.
  37
  38 Errors from FUNCTION are handled and cause a WARNING to be
  39 signalled in whichever thread the FUNCTION was called in.
  40
  41 Examples:
  42
  43   ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
  44   (let* ((handle (get-handle))
  45          (object (make-object handle)))
  46    (finalize object (lambda () (release-handle handle)))
  47    object)
  48
  49   ;;; BAD, finalizer refers to object being finalized, causing
  50   ;;; it to be retained indefinitely!
  51   (let* ((handle (get-handle))
  52          (object (make-object handle)))
  53     (finalize object
  54               (lambda ()
  55                 (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)) ; GC causes 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   "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     ;; We want to run the finalizer bodies outside the lock in case
  98     ;; finalization of X causes finalization to be added for Y.
  99     ;; And to avoid consing we can reuse the deleted conses from the
 100     ;; store to build the list of functions.
 101     (with-finalizer-store-lock
 102       (loop with list = **finalizer-store**
 103           with previous
 104           for finalizer = (car list)
 105           do
 106           (unless finalizer
 107             (if previous
 108                 (setf (cdr previous) nil)
 109                 (setf **finalizer-store** nil))
 110             (return))
 111           unless (weak-pointer-value (car finalizer))
 112           do
 113           (psetf pending finalizer
 114                  (car finalizer) (second finalizer)
 115                  (cdr finalizer) pending
 116                  (car list) (cadr list)
 117                  (cdr list) (cddr list))
 118           else
 119           do (setf previous list
 120                    list (cdr list))))
 121     (dolist (fun pending)
 122       (handler-case
 123           (funcall fun)
 124         (error (c)
 125           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
 126   nil)