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 (defmacro with-finalizer-store-lock (&body body)
  20   `(sb!thread::call-with-system-mutex (lambda () ,@body)
  21                                       *finalizer-store-lock*
  22                                       t))
  23
  24 (defun finalize (object function)
  25   #!+sb-doc
  26   "Arrange for the designated FUNCTION to be called when there
  27 are no more references to OBJECT, including references in
  28 FUNCTION itself.
  29
  30 In a multithreaded environment FUNCTION may be called in any
  31 thread. In both single and multithreaded environments FUNCTION
  32 may be called in any dynamic scope: consequences are unspecified
  33 if FUNCTION is not fully re-entrant.
  34
  35 Errors from FUNCTION are handled and cause a WARNING to be
  36 signalled in whichever thread the FUNCTION was called in.
  37
  38 Examples:
  39
  40   ;;; good (assumes RELEASE-HANDLE is re-entrant)
  41   (let* ((handle (get-handle))
  42          (object (make-object handle)))
  43    (finalize object (lambda () (release-handle handle)))
  44    object)
  45
  46   ;;; bad, finalizer refers to object being finalized, causing
  47   ;;; it to be retained indefinitely
  48   (let* ((handle (get-handle))
  49          (object (make-object handle)))
  50     (finalize object (lambda () (release-handle (object-handle object)))))
  51
  52   ;;; bad, not re-entrant
  53   (defvar *rec* nil)
  54
  55   (defun oops ()
  56    (when *rec*
  57      (error \"recursive OOPS\"))
  58    (let ((*rec* t))
  59      (gc))) ; or just cons enough to cause one
  60
  61   (progn
  62     (finalize \"oops\" #'oops)
  63     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
  64             ; -> ERROR, caught, WARNING signalled"
  65   (with-finalizer-store-lock
  66       (push (cons (make-weak-pointer object) function)
  67             *finalizer-store*))
  68   object)
  69
  70 (defun cancel-finalization (object)
  71   #!+sb-doc
  72   "Cancel any finalization for OBJECT."
  73   ;; Check for NIL to avoid deleting finalizers that are waiting to be
  74   ;; run.
  75   (when object
  76     (with-finalizer-store-lock
  77         (setf *finalizer-store*
  78               (delete object *finalizer-store*
  79                       :key (lambda (pair)
  80                              (weak-pointer-value (car pair))))))
  81     object))
  82
  83 (defun run-pending-finalizers ()
  84   (let (pending)
  85     (with-finalizer-store-lock
  86         (setf *finalizer-store*
  87               (delete-if  (lambda (pair)
  88                             (when (null (weak-pointer-value (car pair)))
  89                               (push (cdr pair) pending)
  90                               t))
  91                           *finalizer-store*)))
  92     ;; We want to run the finalizer bodies outside the lock in case
  93     ;; finalization of X causes finalization to be added for Y.
  94     (dolist (fun pending)
  95       (handler-case
  96           (funcall fun)
  97         (error (c)
  98           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
  99   nil)