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::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 (assumes 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 (lambda () (release-handle (object-handle object)))))
  55
  56   ;;; bad, not re-entrant
  57   (defvar *rec* nil)
  58
  59   (defun oops ()
  60    (when *rec*
  61      (error \"recursive OOPS\"))
  62    (let ((*rec* t))
  63      (gc))) ; or just cons enough to cause one
  64
  65   (progn
  66     (finalize \"oops\" #'oops)
  67     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
  68             ; -> ERROR, caught, WARNING signalled"
  69   (unless object
  70     (error "Cannot finalize NIL."))
  71   (with-finalizer-store-lock
  72     (push (list (make-weak-pointer object) function dont-save)
  73           *finalizer-store*))
  74   object)
  75
  76 (defun deinit-finalizers ()
  77   ;; remove :dont-save finalizers
  78   (with-finalizer-store-lock
  79     (setf *finalizer-store* (delete-if #'third *finalizer-store*)))
  80   nil)
  81
  82 (defun cancel-finalization (object)
  83   #!+sb-doc
  84   "Cancel any finalization for OBJECT."
  85   ;; Check for NIL to avoid deleting finalizers that are waiting to be
  86   ;; run.
  87   (when object
  88     (with-finalizer-store-lock
  89         (setf *finalizer-store*
  90               (delete object *finalizer-store*
  91                       :key (lambda (list)
  92                              (weak-pointer-value (car list))))))
  93     object))
  94
  95 (defun run-pending-finalizers ()
  96   (let (pending)
  97     (with-finalizer-store-lock
  98         (setf *finalizer-store*
  99               (delete-if (lambda (list)
 100                            (when (null (weak-pointer-value (car list)))
 101                              (push (second list) pending)
 102                              t))
 103                           *finalizer-store*)))
 104     ;; We want to run the finalizer bodies outside the lock in case
 105     ;; finalization of X causes finalization to be added for Y.
 106     (dolist (fun pending)
 107       (handler-case
 108           (funcall fun)
 109         (error (c)
 110           (warn "Error calling finalizer ~S:~%  ~S" fun c)))))
 111   nil)