projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.29.49: silence compiler note for type-checks from MAKE-INSTANCE in safe code
[sbcl.git]
/
src
/
code
/
final.lisp
diff --git
a/src/code/final.lisp
b/src/code/final.lisp
index
15a45a6
..
8b21939
100644
(file)
--- a/
src/code/final.lisp
+++ b/
src/code/final.lisp
@@
-13,15
+13,24
@@
(defvar *finalizer-store* nil)
(defvar *finalizer-store* nil)
-(defvar *finalizer-store-lock*
+(defvar *finalizer-store-lock*
(sb!thread:make-mutex :name "Finalizer store lock."))
(sb!thread:make-mutex :name "Finalizer store lock."))
-(defun finalize (object function)
- #!+sb-doc
+(defmacro with-finalizer-store-lock (&body body)
+ `(sb!thread::with-system-mutex (*finalizer-store-lock* :without-gcing t)
+ ,@body))
+
+(defun finalize (object function &key dont-save)
+ #!+sb-doc
"Arrange for the designated FUNCTION to be called when there
are no more references to OBJECT, including references in
FUNCTION itself.
"Arrange for the designated FUNCTION to be called when there
are no more references to OBJECT, including references in
FUNCTION itself.
+If DONT-SAVE is true, the finalizer will be cancelled when
+SAVE-LISP-AND-DIE is called: this is useful for finalizers
+deallocating system memory, which might otherwise be called
+with addresses from the old image.
+
In a multithreaded environment FUNCTION may be called in any
thread. In both single and multithreaded environments FUNCTION
may be called in any dynamic scope: consequences are unspecified
In a multithreaded environment FUNCTION may be called in any
thread. In both single and multithreaded environments FUNCTION
may be called in any dynamic scope: consequences are unspecified
@@
-48,50
+57,55
@@
Examples:
(defvar *rec* nil)
(defun oops ()
(defvar *rec* nil)
(defun oops ()
- (when *rec*
+ (when *rec*
(error \"recursive OOPS\"))
(let ((*rec* t))
(gc))) ; or just cons enough to cause one
(error \"recursive OOPS\"))
(let ((*rec* t))
(gc))) ; or just cons enough to cause one
- (progn
+ (progn
(finalize \"oops\" #'oops)
(oops)) ; causes GC and re-entry to #'oops due to the finalizer
; -> ERROR, caught, WARNING signalled"
(finalize \"oops\" #'oops)
(oops)) ; causes GC and re-entry to #'oops due to the finalizer
; -> ERROR, caught, WARNING signalled"
- (sb!sys:without-gcing
- (sb!thread:with-mutex (*finalizer-store-lock*)
- (push (cons (make-weak-pointer object) function)
- *finalizer-store*)))
+ (unless object
+ (error "Cannot finalize NIL."))
+ (with-finalizer-store-lock
+ (push (list (make-weak-pointer object) function dont-save)
+ *finalizer-store*))
object)
object)
+(defun deinit-finalizers ()
+ ;; remove :dont-save finalizers
+ (with-finalizer-store-lock
+ (setf *finalizer-store* (delete-if #'third *finalizer-store*)))
+ nil)
+
(defun cancel-finalization (object)
#!+sb-doc
"Cancel any finalization for OBJECT."
;; Check for NIL to avoid deleting finalizers that are waiting to be
;; run.
(when object
(defun cancel-finalization (object)
#!+sb-doc
"Cancel any finalization for OBJECT."
;; Check for NIL to avoid deleting finalizers that are waiting to be
;; run.
(when object
- (sb!sys:without-gcing
- (sb!thread:with-mutex (*finalizer-store-lock*)
- (setf *finalizer-store*
- (delete object *finalizer-store*
- :key (lambda (pair)
- (weak-pointer-value (car pair)))))))
+ (with-finalizer-store-lock
+ (setf *finalizer-store*
+ (delete object *finalizer-store*
+ :key (lambda (list)
+ (weak-pointer-value (car list))))))
object))
(defun run-pending-finalizers ()
(let (pending)
object))
(defun run-pending-finalizers ()
(let (pending)
- (sb!sys:without-gcing
- (sb!thread:with-mutex (*finalizer-store-lock*)
- (setf *finalizer-store*
- (delete-if (lambda (pair)
- (when (null (weak-pointer-value (car pair)))
- (push (cdr pair) pending)
- t))
- *finalizer-store*))))
+ (with-finalizer-store-lock
+ (setf *finalizer-store*
+ (delete-if (lambda (list)
+ (when (null (weak-pointer-value (car list)))
+ (push (second list) pending)
+ t))
+ *finalizer-store*)))
;; We want to run the finalizer bodies outside the lock in case
;; finalization of X causes finalization to be added for Y.
(dolist (fun pending)
(handler-case
;; We want to run the finalizer bodies outside the lock in case
;; finalization of X causes finalization to be added for Y.
(dolist (fun pending)
(handler-case
- (funcall fun)
- (error (c)
- (warn "Error calling finalizer ~S:~% ~S" fun c)))))
+ (funcall fun)
+ (error (c)
+ (warn "Error calling finalizer ~S:~% ~S" fun c)))))
nil)
nil)