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
  36   (let* ((handle (get-handle))
  37          (object (make-object handle)))
  38    ;; assumes RELEASE-HANDLE is re-entrant
  39    (finalize object (lambda () (release-handle handle)))
  40    object)
  41
  42   ;;; bad, finalizer refers to object being finalized, causing
  43   ;;; it to be retained indefinitely
  44   (let* ((handle (get-handle))
  45          (object (make-object handle)))
  46     (finalize object (lambda () (release-handle (object-handle object)))))
  47
  48   ;;; bad, not re-entrant
  49   (defvar *rec* nil)
  50
  51   (defun oops ()
  52    (when *rec*
  53      (error \"recursive OOPS\"))
  54    (let ((*rec* t))
  55      (gc))) ; or just cons enough to cause one
  56
  57   (progn
  58     (finalize \"oops\" #'oops)
  59     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
  60             ; -> ERROR, caught, WARNING signalled"
  61   (sb!sys:without-gcing
  62       (sb!thread:with-mutex (*finalizer-store-lock*)
  63         (push (cons (make-weak-pointer object) function)
  64               *finalizer-store*)))
  65   object)
  66
  67 (defun cancel-finalization (object)
  68   #!+sb-doc
  69   "Cancel any finalization for OBJECT."
  70   ;; Check for NIL to avoid deleting finalizers that are waiting to be
  71   ;; run.
  72   (when object
  73     (sb!sys:without-gcing
  74         (sb!thread:with-mutex (*finalizer-store-lock*)
  75           (setf *finalizer-store*
  76                 (delete object *finalizer-store*
  77                         :key (lambda (pair)
  78                                (weak-pointer-value (car pair)))))))
  79     object))
  80
  81 (defun run-pending-finalizers ()
  82   (let (pending)
  83     (sb!sys:without-gcing
  84         (sb!thread:with-mutex (*finalizer-store-lock*)
  85           (setf *finalizer-store*
  86                 (delete-if  (lambda (pair)
  87                               (when (null (weak-pointer-value (car pair)))
  88                                 (push (cdr pair) pending)
  89                                 t))
  90                             *finalizer-store*))))
  91     ;; We want to run the finalizer bodies outside the lock in case
  92     ;; finalization of X causes finalization to be added for Y.
  93     (dolist (fun pending)
  94       (handler-case
  95           (funcall fun)
  96         (error (c)
  97           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
  98   nil)