Fix make-array transforms.

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

diff --git a/src/code/final.lisp b/src/code/final.lisp
index 15a45a6..cfa36f1 100644 (file)
--- a/src/code/final.lisp
+++ b/src/code/final.lisp
@@ -11,17 +11,26 @@
 
 (in-package "SB!IMPL")
 
-(defvar *finalizer-store* nil)
+(defglobal **finalizer-store** nil)
 
-(defvar *finalizer-store-lock* 
+(defglobal **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.
 
+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
@@ -32,66 +41,73 @@ signalled in whichever thread the FUNCTION was called in.
 
 Examples:
 
-  ;;; good (assumes RELEASE-HANDLE is re-entrant)
+  ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
   (let* ((handle (get-handle))
          (object (make-object handle)))
    (finalize object (lambda () (release-handle handle)))
    object)
 
-  ;;; bad, finalizer refers to object being finalized, causing
-  ;;; it to be retained indefinitely
+  ;;; 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)))))
+    (finalize object
+              (lambda ()
+                (release-handle (object-handle object)))))
 
-  ;;; bad, not re-entrant
+  ;;; BAD, not re-entrant!
   (defvar *rec* nil)
 
   (defun oops ()
-   (when *rec* 
+   (when *rec*
      (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
+    (oops)) ; GC causes 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)
 
+(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
-    (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)
-    (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
-         (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)