diff --git a/code/room.lisp b/code/room.lisp
index cd86d6dfd1a34eef31f66cf20c423a46eae7921d..3018ab994b734d679bbfab280d3c04ed6d9b81fb 100644
--- a/code/room.lisp
+++ b/code/room.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.9 1991/04/23 17:01:34 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.10 1991/05/04 16:58:11 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.9 1991/04/23 17:01:34 ram Exp $
-;;; 
 ;;; Heap grovelling memory usage stuff.
 ;;; 
 (in-package "VM")
@@ -122,6 +120,14 @@
      (values (int-sap (current-dynamic-space-start))
 	     (dynamic-space-free-pointer)))))
 
+;;; SPACE-BYTES  --  Internal
+;;;
+;;;    Return the total number of bytes used in Space.
+;;;
+(defun space-bytes (space)
+  (multiple-value-bind (start end)
+		       (space-bounds space)
+    (- (sap-int end) (sap-int start))))
 
 ;;; ROUND-TO-DUALWORD  --  Internal
 ;;;
@@ -165,77 +171,81 @@
 (proclaim '(maybe-inline map-allocated-objects))
 (defun map-allocated-objects (fun space)
   (declare (type function fun) (type spaces space))
-  (multiple-value-bind (start end)
-		       (space-bounds space)
-    (declare (optimize (speed 3) (safety 0)))
-    (let ((current start)
-	  (prev nil))
-      (loop
-	(let* ((header (sap-ref-32 current 0))
-	       (header-type (logand header #xFF))
-	       (info (svref *room-info* header-type)))
-	  (cond
-	   ((or (not info)
-		(eq (room-info-kind info) :lowtag))
-	    (let ((size (* cons-size word-bytes)))
-	      (funcall fun
-		       (make-lisp-obj (logior (sap-int current)
-					      list-pointer-type))
-		       list-pointer-type
-		       size)
-	      (setq current (sap+ current size))))
-	   ((eql header-type closure-header-type)
-	    (let* ((obj (make-lisp-obj (logior (sap-int current)
-					       function-pointer-type)))
-		   (size (round-to-dualword
-			  (* (the fixnum (1+ (get-closure-length obj)))
-			     word-bytes))))
-	      (funcall fun obj header-type size)
-	      (setq current (sap+ current size))))
-	   ((eq (room-info-kind info) :structure)
-	    (let* ((obj (make-lisp-obj
-			 (logior (sap-int current) structure-pointer-type)))
-		   (size (round-to-dualword
-			  (* (+ (c::structure-length obj) 1) word-bytes))))
-	      (declare (fixnum size))
-	      (funcall fun obj header-type size)
-	      (assert (zerop (logand size lowtag-mask)))
-	      (when (> size 200000) (break "Implausible size, prev ~S" prev))
-	      (setq prev current)
-	      (setq current (sap+ current size))))
-	   (t
-	    (let* ((obj (make-lisp-obj
-			 (logior (sap-int current) other-pointer-type)))
-		   (size (ecase (room-info-kind info)
-			   (:fixed
-			    (assert (or (eql (room-info-length info)
-					     (1+ (get-header-data obj)))
-					(floatp obj)))
-			    (round-to-dualword
-			     (* (room-info-length info) word-bytes)))
-			   ((:vector :string)
-			    (vector-total-size obj info))
-			   (:header
-			    (round-to-dualword
-			     (* (1+ (get-header-data obj)) word-bytes)))
-			   (:code
-			    (+ (the fixnum
-				    (* (get-header-data obj) word-bytes))
-			       (round-to-dualword
-				(* (the fixnum
-					(%primitive code-code-size obj))
-				   word-bytes)))))))
-	      (declare (fixnum size))
-	      (funcall fun obj header-type size)
-	      (assert (zerop (logand size lowtag-mask)))
-	      (when (> size 200000) (break "Implausible size, prev ~S" prev))
-	      (setq prev current)
-	      (setq current (sap+ current size))))))
-	(unless (pointer< current end)
-	  (assert (not (pointer> current end)))
-	  (return)))
-
-      prev)))
+  (without-gcing
+    (multiple-value-bind (start end)
+			 (space-bounds space)
+      (declare (optimize (speed 3) (safety 0)))
+      (let ((current start)
+	    (prev nil))
+	(loop
+	  (let* ((header (sap-ref-32 current 0))
+		 (header-type (logand header #xFF))
+		 (info (svref *room-info* header-type)))
+	    (cond
+	     ((or (not info)
+		  (eq (room-info-kind info) :lowtag))
+	      (let ((size (* cons-size word-bytes)))
+		(funcall fun
+			 (make-lisp-obj (logior (sap-int current)
+						list-pointer-type))
+			 list-pointer-type
+			 size)
+		(setq current (sap+ current size))))
+	     ((eql header-type closure-header-type)
+	      (let* ((obj (make-lisp-obj (logior (sap-int current)
+						 function-pointer-type)))
+		     (size (round-to-dualword
+			    (* (the fixnum (1+ (get-closure-length obj)))
+			       word-bytes))))
+		(funcall fun obj header-type size)
+		(setq current (sap+ current size))))
+	     ((eq (room-info-kind info) :structure)
+	      (let* ((obj (make-lisp-obj
+			   (logior (sap-int current) structure-pointer-type)))
+		     (size (round-to-dualword
+			    (* (+ (c::structure-length obj) 1) word-bytes))))
+		(declare (fixnum size))
+		(funcall fun obj header-type size)
+		(assert (zerop (logand size lowtag-mask)))
+		#+nil
+		(when (> size 200000) (break "Implausible size, prev ~S" prev))
+		(setq prev current)
+		(setq current (sap+ current size))))
+	     (t
+	      (let* ((obj (make-lisp-obj
+			   (logior (sap-int current) other-pointer-type)))
+		     (size (ecase (room-info-kind info)
+			     (:fixed
+			      (assert (or (eql (room-info-length info)
+					       (1+ (get-header-data obj)))
+					  (floatp obj)))
+			      (round-to-dualword
+			       (* (room-info-length info) word-bytes)))
+			     ((:vector :string)
+			      (vector-total-size obj info))
+			     (:header
+			      (round-to-dualword
+			       (* (1+ (get-header-data obj)) word-bytes)))
+			     (:code
+			      (+ (the fixnum
+				      (* (get-header-data obj) word-bytes))
+				 (round-to-dualword
+				  (* (the fixnum
+					  (%primitive code-code-size obj))
+				     word-bytes)))))))
+		(declare (fixnum size))
+		(funcall fun obj header-type size)
+		(assert (zerop (logand size lowtag-mask)))
+		#+nil
+		(when (> size 200000)
+		  (break "Implausible size, prev ~S" prev))
+		(setq prev current)
+		(setq current (sap+ current size))))))
+	  (unless (pointer< current end)
+	    (assert (not (pointer> current end)))
+	    (return)))
+	
+	prev))))
 
 
 ;;;; MEMORY-USAGE:
@@ -330,15 +340,49 @@
 		summary-total-bytes summary-total-objects)))))
 
 
+;;; REPORT-SPACE-TOTAL  --  Internal
+;;;
+;;;    Report object usage for a single space.
+;;;
+(defun report-space-total (space-total cutoff)
+  (declare (list space-total) (type (or single-float null) cutoff))
+  (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
+  (let* ((types (cdr space-total))
+	 (total-bytes (reduce #'+ (mapcar #'first types)))
+	 (total-objects (reduce #'+ (mapcar #'second types)))
+	 (cutoff-point (if cutoff
+			   (truncate (* (float total-bytes) cutoff))
+			   0))
+	 (reported-bytes 0)
+	 (reported-objects 0))
+    (declare (fixnum total-objects total-bytes cutoff-point reported-objects
+		     reported-bytes))
+    (loop for (bytes objects name) in types do
+      (when (<= bytes cutoff-point)
+	(format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
+		(- total-bytes reported-bytes)
+		(- total-objects reported-objects))
+	(return))
+      (incf reported-bytes bytes)
+      (incf reported-objects objects)
+      (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
+	      bytes objects name))
+    (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
+	    total-bytes total-objects (car space-total))))
+
+
 ;;; MEMORY-USAGE  --  Public
 ;;;
 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
-			  (print-summary t))
+			  (print-summary t) cutoff)
   "Print out information about the heap memory in use.  :Print-Spaces is a list
   of the spaces to print detailed information for.  :Count-Spaces is a list of
   the spaces to scan.  For either one, T means all spaces (:Static, :Dyanmic
   and :Read-Only.)  If :Print-Summary is true, then summary information will be
-  printed.  The defaults print only summary information for dynamic space."
+  printed.  The defaults print only summary information for dynamic space.
+  If true, Cutoff is a fraction of the usage in a report below which types will
+  be combined as OTHER."
+  (declare (type (or single-float null) cutoff))
   (let* ((spaces (if (eq count-spaces t)
 		     '(:static :dynamic :read-only)
 		     count-spaces))
@@ -349,17 +393,7 @@
     (dolist (space-total totals)
       (when (or (eq print-spaces t)
 		(member (car space-total) print-spaces))
-	(format t "~2&Breakdown for ~(~A~) space:~2%" (car space-total))
-	(let ((total-objects 0)
-	      (total-bytes 0))
-	  (declare (fixnum total-objects total-bytes))
-	  (dolist (total (cdr space-total))
-	    (incf total-bytes (first total))
-	    (incf total-objects (second total))
-	    (format t "~%~A:~%    ~:D bytes, ~:D object~:P.~%"
-		    (third total) (first total) (second total)))
-	  (format t "~%Space total:~%    ~:D bytes, ~:D object~:P.~%"
-		  total-bytes total-objects))))
+	(report-space-total space-total cutoff)))
 
     (when print-summary (print-summary spaces totals)))
 
@@ -467,6 +501,7 @@
   "Print a breakdown by structure type of all the structures allocated in
   Space.  If TOP-N is true, print only information for the the TOP-N types with
   largest usage."
+  (format t "~2&~@[Top ~D ~]~(~A~) structure types:~%" top-n space)
   (let ((totals (make-hash-table :test #'eq))
 	(total-objects 0)
 	(total-bytes 0))
@@ -501,17 +536,17 @@
 		(objects (cadr what)))
 	    (incf printed-bytes bytes)
 	    (incf printed-objects objects)
-	    (format t "~S: ~:D bytes, ~D object~:P.~%" (car what)
+	    (format t "  ~S: ~:D bytes, ~D object~:P.~%" (car what)
 		    bytes objects)))
 
 	(let ((residual-objects (- total-objects printed-objects))
 	      (residual-bytes (- total-bytes printed-bytes)))
 	  (unless (zerop residual-objects)
-	    (format t "Other types: ~:D bytes, ~D: object~:P.~%"
+	    (format t "  Other types: ~:D bytes, ~D: object~:P.~%"
 		    residual-bytes residual-objects))))
 
-      (format t "Structure total: ~:D bytes, ~:D object~:P.~%"
-	      total-bytes total-objects)))
+      (format t "  ~:(~A~) structure total: ~:D bytes, ~:D object~:P.~%"
+	      space total-bytes total-objects)))
 
   (values))