1.0.24.17: grab-bag of fixes to make hpux-os smile

[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)