1.0.8.8: restore reuse-sap value after incomplete writes in FROB-OUTPUT-LATER

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

diff --git a/src/code/final.lisp b/src/code/final.lisp
index 945cd5e..d6619ed 100644 (file)
--- a/src/code/final.lisp
+++ b/src/code/final.lisp
@@ -13,11 +13,16 @@
 
 (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."))
 

+(defmacro with-finalizer-store-lock (&body body)
+  `(sb!thread::call-with-system-mutex (lambda () ,@body)
+                                      *finalizer-store-lock*
+                                      t))
+

 (defun finalize (object function)
 (defun finalize (object function)

-  #!+sb-doc 
+  #!+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.

@@ -32,10 +37,9 @@ signalled in whichever thread the FUNCTION was called in.
 
 Examples:
 
 
 Examples:
 

-  ;;; good
+  ;;; good (assumes RELEASE-HANDLE is re-entrant)

   (let* ((handle (get-handle))
          (object (make-object handle)))
   (let* ((handle (get-handle))
          (object (make-object handle)))

-   ;; assumes RELEASE-HANDLE is re-entrant

    (finalize object (lambda () (release-handle handle)))
    object)
 
    (finalize object (lambda () (release-handle handle)))
    object)
 

@@ -49,19 +53,18 @@ 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*)))
+  (with-finalizer-store-lock
+      (push (cons (make-weak-pointer object) function)
+            *finalizer-store*))

   object)
 
 (defun cancel-finalization (object)
   object)
 
 (defun cancel-finalization (object)

@@ -70,29 +73,27 @@ Examples:
   ;; Check for NIL to avoid deleting finalizers that are waiting to be
   ;; run.
   (when 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 (pair)
+                             (weak-pointer-value (car pair))))))

     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 (pair)
+                            (when (null (weak-pointer-value (car pair)))
+                              (push (cdr pair) 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)