0.8.19.5:

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

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index e048d8d..98c4e4c 100644 (file)
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -83,10 +83,14 @@
                      :print-summary nil))
 
 (defun room-maximal-info ()
                      :print-summary nil))
 
 (defun room-maximal-info ()

-  (room-minimal-info)
-  (sb!vm:memory-usage :count-spaces '(:static :dynamic))
-  (sb!vm:instance-usage :dynamic :top-n 10)
-  (sb!vm:instance-usage :static :top-n 10))
+  ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
+  (room-intermediate-info)
+  ;; old way, could be restored when bug 344 fixed:
+  ;;x (room-minimal-info)
+  ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
+  ;;x (sb!vm:instance-usage :dynamic :top-n 10)
+  ;;x (sb!vm:instance-usage :static :top-n 10)
+  )

 
 (defun room (&optional (verbosity :default))
   #!+sb-doc
 
 (defun room (&optional (verbosity :default))
   #!+sb-doc

@@ -116,15 +120,10 @@
 ;;; allocated and never freed.)
 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
 (defvar *n-bytes-freed-or-purified* 0)
 ;;; allocated and never freed.)
 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
 (defvar *n-bytes-freed-or-purified* 0)

-(push (lambda ()
-       (setf *n-bytes-freed-or-purified* 0))
-      ;; KLUDGE: It's probably not quite safely right either to do
-      ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
-      ;; worse, something which depended on (GET-BYTES-CONSED), might
-      ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
-      ;; it's probably not a big problem, and there seems to be no
-      ;; other obvious time to do it. -- WHN 2001-07-30
-      *after-save-initializations*)
+(defun gc-reinit ()
+  (gc-on)
+  (gc)
+  (setf *n-bytes-freed-or-purified* 0))

 
 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 (defun get-bytes-consed ()
 
 (declaim (ftype (function () unsigned-byte) get-bytes-consed))
 (defun get-bytes-consed ()

@@ -152,12 +151,6 @@ and submit it as a patch."
   The functions are run with interrupts disabled and all other threads
   paused.  They should take no arguments.")
 
   The functions are run with interrupts disabled and all other threads
   paused.  They should take no arguments.")
 

-(defvar *gc-run-time* 0
-  #!+sb-doc
-  "the total CPU time spent doing garbage collection (as reported by
-   GET-INTERNAL-RUN-TIME)")
-(declaim (type index *gc-run-time*))
-

 ;;;; The following specials are used to control when garbage
 ;;;; collection occurs.
 
 ;;;; The following specials are used to control when garbage
 ;;;; collection occurs.
 

@@ -186,9 +179,6 @@ and submit it as a patch."
 (declaim (type (or index null) *gc-trigger*))
 (defvar *gc-trigger* nil)
 
 (declaim (type (or index null) *gc-trigger*))
 (defvar *gc-trigger* nil)
 

-;;; When >0, inhibits garbage collection.
-(defvar *gc-inhibit*) ; initialized in cold init
-

 ;;; When T, indicates that a GC should have happened but did not due to 
 ;;; *GC-INHIBIT*. 
 (defvar *need-to-collect-garbage* nil) ; initialized in cold init
 ;;; When T, indicates that a GC should have happened but did not due to 
 ;;; *GC-INHIBIT*. 
 (defvar *need-to-collect-garbage* nil) ; initialized in cold init

@@ -233,28 +223,28 @@ and submit it as a patch."
 
 ;;; For GENCGC all generations < GEN will be GC'ed.
 
 
 ;;; For GENCGC all generations < GEN will be GC'ed.
 

-(defvar *already-in-gc* nil "System is running SUB-GC")
-(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
+(defvar *already-in-gc* 
+  (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")

 
 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))
 
 (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage)))

-  ;; catch attempts to gc recursively or during post-hooks and ignore them
-  (when (sb!thread::mutex-value *gc-mutex*)  (return-from sub-gc nil))
-  (sb!thread:with-mutex (*gc-mutex* :wait-p nil)
+  (let ((me (sb!thread:current-thread-id)))
+    (when (eql (sb!thread::mutex-value *already-in-gc*) me) 
+      (return-from sub-gc nil))

     (setf *need-to-collect-garbage* t)
     (when (zerop *gc-inhibit*)
     (setf *need-to-collect-garbage* t)
     (when (zerop *gc-inhibit*)

-      (without-interrupts
-       (gc-stop-the-world)
-       (collect-garbage gen)
-       (incf *n-bytes-freed-or-purified*
-            (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
-       (setf *need-to-collect-garbage* nil)
-       (gc-start-the-world))
-      (scrub-control-stack)
-      (setf *need-to-collect-garbage* nil)
-      (dolist (h *after-gc-hooks*) (carefully-funcall h))))
-  (values))
-       
-
+      (loop
+       (sb!thread:with-mutex (*already-in-gc*)
+        (unless *need-to-collect-garbage* (return-from sub-gc nil))
+        (without-interrupts
+         (gc-stop-the-world)
+         (collect-garbage gen)
+         (incf *n-bytes-freed-or-purified*
+               (max 0 (- pre-gc-dynamic-usage (dynamic-usage))))
+         (scrub-control-stack)
+         (setf *need-to-collect-garbage* nil)
+         (dolist (h *after-gc-hooks*) (carefully-funcall h))
+         (gc-start-the-world))
+        (sb!thread::reap-dead-threads))))))

 
 ;;; This is the user-advertised garbage collection function.
 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
 
 ;;; This is the user-advertised garbage collection function.
 (defun gc (&key (gen 0) (full nil) &allow-other-keys)