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 &key dont-save)
  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 If DONT-SAVE is true, the finalizer will be cancelled when
  31 SAVE-LISP-AND-DIE is called: this is useful for finalizers
  32 deallocating system memory, which might otherwise be called
  33 with addresses from the old image.
  34
  35 In a multithreaded environment FUNCTION may be called in any
  36 thread. In both single and multithreaded environments FUNCTION
  37 may be called in any dynamic scope: consequences are unspecified
  38 if FUNCTION is not fully re-entrant.
  39
  40 Errors from FUNCTION are handled and cause a WARNING to be
  41 signalled in whichever thread the FUNCTION was called in.
  42
  43 Examples:
  44
  45   ;;; good (assumes RELEASE-HANDLE is re-entrant)
  46   (let* ((handle (get-handle))
  47          (object (make-object handle)))
  48    (finalize object (lambda () (release-handle handle)))
  49    object)
  50
  51   ;;; bad, finalizer refers to object being finalized, causing
  52   ;;; it to be retained indefinitely
  53   (let* ((handle (get-handle))
  54          (object (make-object handle)))
  55     (finalize object (lambda () (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)) ; causes GC and 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   #!+sb-doc
  85   "Cancel any finalization for OBJECT."
  86   ;; Check for NIL to avoid deleting finalizers that are waiting to be
  87   ;; run.
  88   (when object
  89     (with-finalizer-store-lock
  90         (setf *finalizer-store*
  91               (delete object *finalizer-store*
  92                       :key (lambda (list)
  93                              (weak-pointer-value (car list))))))
  94     object))
  95
  96 (defun run-pending-finalizers ()
  97   (let (pending)
  98     (with-finalizer-store-lock
  99         (setf *finalizer-store*
 100               (delete-if (lambda (list)
 101                            (when (null (weak-pointer-value (car list)))
 102                              (push (second list) pending)
 103                              t))
 104                           *finalizer-store*)))
 105     ;; We want to run the finalizer bodies outside the lock in case
 106     ;; finalization of X causes finalization to be added for Y.
 107     (dolist (fun pending)
 108       (handler-case
 109           (funcall fun)
 110         (error (c)
 111           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
 112   nil)