1.0.28.65: fix compiling with *PROFILE-HASH-CACHE* set to T

[sbcl.git] / src / code / final.lisp

diff --git a/src/code/final.lisp b/src/code/final.lisp
index d6619ed..8b21939 100644 (file)
--- a/src/code/final.lisp
+++ b/src/code/final.lisp
@@ -17,16 +17,20 @@
   (sb!thread:make-mutex :name "Finalizer store lock."))
 
 (defmacro with-finalizer-store-lock (&body body)
-  `(sb!thread::call-with-system-mutex (lambda () ,@body)
-                                      *finalizer-store-lock*
-                                      t))
+  `(sb!thread::with-system-mutex (*finalizer-store-lock* :without-gcing t)
+     ,@body))
 
-(defun finalize (object function)
+(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.
 
+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
@@ -62,11 +66,19 @@ Examples:
     (finalize \"oops\" #'oops)
     (oops)) ; causes GC and re-entry to #'oops due to the finalizer
             ; -> ERROR, caught, WARNING signalled"
+  (unless object
+    (error "Cannot finalize NIL."))
   (with-finalizer-store-lock
-      (push (cons (make-weak-pointer object) function)
-            *finalizer-store*))
+    (push (list (make-weak-pointer object) function dont-save)
+          *finalizer-store*))
   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."
@@ -76,18 +88,18 @@ Examples:
     (with-finalizer-store-lock
         (setf *finalizer-store*
               (delete object *finalizer-store*
-                      :key (lambda (pair)
-                             (weak-pointer-value (car pair))))))
+                      :key (lambda (list)
+                             (weak-pointer-value (car list))))))
     object))
 
 (defun run-pending-finalizers ()
   (let (pending)
     (with-finalizer-store-lock
         (setf *finalizer-store*
-              (delete-if  (lambda (pair)
-                            (when (null (weak-pointer-value (car pair)))
-                              (push (cdr pair) pending)
-                              t))
+              (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.