X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffinal.lisp;h=945cd5ec0ddae0560970af82fd7c300cfbd8f3a6;hb=7861e493d9ba821f82471b81bed0223d8033a001;hp=1fdffda1ba1e1239f63f2adfcd4f86a98a1c6844;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/final.lisp b/src/code/final.lisp
index 1fdffda..945cd5e 100644
--- a/src/code/final.lisp
+++ b/src/code/final.lisp
@@ -9,48 +9,90 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
-(in-package "SB!EXT")
+(in-package "SB!IMPL")
 
-(file-comment
-  "$Header$")
+(defvar *finalizer-store* nil)
 
-(defvar *objects-pending-finalization* nil)
+(defvar *finalizer-store-lock* 
+  (sb!thread:make-mutex :name "Finalizer store lock."))
 
 (defun finalize (object function)
-  #!+sb-doc
-  "Arrange for FUNCTION to be called when there are no more references to
-   OBJECT."
-  (declare (type function function))
+  #!+sb-doc 
+  "Arrange for the designated FUNCTION to be called when there
+are no more references to OBJECT, including references in
+FUNCTION itself.
+
+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
+if FUNCTION is not fully re-entrant.
+
+Errors from FUNCTION are handled and cause a WARNING to be
+signalled in whichever thread the FUNCTION was called in.
+
+Examples:
+
+  ;;; good
+  (let* ((handle (get-handle))
+         (object (make-object handle)))
+   ;; assumes RELEASE-HANDLE is re-entrant
+   (finalize object (lambda () (release-handle handle)))
+   object)
+
+  ;;; bad, finalizer refers to object being finalized, causing
+  ;;; it to be retained indefinitely
+  (let* ((handle (get-handle))
+         (object (make-object handle)))
+    (finalize object (lambda () (release-handle (object-handle object)))))
+
+  ;;; bad, not re-entrant
+  (defvar *rec* nil)
+
+  (defun oops ()
+   (when *rec* 
+     (error \"recursive OOPS\"))
+   (let ((*rec* t))
+     (gc))) ; or just cons enough to cause one
+
+  (progn 
+    (finalize \"oops\" #'oops)
+    (oops)) ; causes GC and re-entry to #'oops due to the finalizer
+            ; -> ERROR, caught, WARNING signalled"
   (sb!sys:without-gcing
-   (push (cons (make-weak-pointer object) function)
-	 *objects-pending-finalization*))
+      (sb!thread:with-mutex (*finalizer-store-lock*)
+	(push (cons (make-weak-pointer object) function)
+	      *finalizer-store*)))
   object)
 
 (defun cancel-finalization (object)
   #!+sb-doc
-  "Cancel any finalization registers for OBJECT."
+  "Cancel any finalization for OBJECT."
+  ;; Check for NIL to avoid deleting finalizers that are waiting to be
+  ;; run.
   (when object
-    ;; We check to make sure object isn't nil because if there are any
-    ;; broken weak pointers, their value will show up as nil. Therefore,
-    ;; they would be deleted from the list, but not finalized. Broken
-    ;; weak pointers shouldn't be left in the list, but why take chances?
     (sb!sys:without-gcing
-     (setf *objects-pending-finalization*
-	   (delete object *objects-pending-finalization*
-		   :key #'(lambda (pair)
-			    (values (weak-pointer-value (car pair))))))))
-  nil)
+	(sb!thread:with-mutex (*finalizer-store-lock*)
+	  (setf *finalizer-store*
+		(delete object *finalizer-store*
+			:key (lambda (pair) 
+			       (weak-pointer-value (car pair)))))))
+    object))
 
-(defun finalize-corpses ()
-  (setf *objects-pending-finalization*
-	(delete-if #'(lambda (pair)
-		       (multiple-value-bind (object valid)
-			   (weak-pointer-value (car pair))
-			 (declare (ignore object))
-			 (unless valid
-			   (funcall (cdr pair))
-			   t)))
-		   *objects-pending-finalization*))
+(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*))))
+    ;; 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)))))
   nil)
-
-(pushnew 'finalize-corpses *after-gc-hooks*)