X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fgc.lisp;h=98c4e4c8594669c257bf93f6707e2f2e134fefee;hb=f1b3993e92da7522403803d5f9a187ae28f90a73;hp=eabb4b4d9dfdb09f688eff7155bb9d980d8baf4d;hpb=95110584db3224cf61b774f1402a71a79e61432f;p=sbcl.git

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index eabb4b4..98c4e4c 100644
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -83,10 +83,14 @@
 		      :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
@@ -116,15 +120,10 @@
 ;;; 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 ()
@@ -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.")
 
-(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.
 
@@ -230,28 +223,28 @@ and submit it as a patch."
 
 ;;; 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)))
-  ;; 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*)
-      (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)