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)