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     (with-finalizer-store-lock
 100         (setf **finalizer-store**
 101               (delete-if (lambda (list)
 102                            (when (null (weak-pointer-value (car list)))
 103                              (push (second list) pending)
 104                              t))
 105                          **finalizer-store**)))
 106     ;; We want to run the finalizer bodies outside the lock in case
 107     ;; finalization of X causes finalization to be added for Y.
 108     (dolist (fun pending)
 109       (handler-case
 110           (funcall fun)
 111         (error (c)
 112           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
 113   nil)