diff --git a/code/room.lisp b/code/room.lisp
index ac299bc2ed5f0f7e63ca0415e044bf29d37821d0..092bb5b338b8addaff445602ddd1e92c1dc18c50 100644
--- a/code/room.lisp
+++ b/code/room.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.35 2006/06/30 18:41:22 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.36 2006/07/20 16:19:35 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -123,6 +123,17 @@
 (declaim (type fixnum *static-space-free-pointer*
 	       *read-only-space-free-pointer* ))
 
+#+gencgc
+(eval-when (compile load eval)
+  ;; This had better match the value in gencgc.h!!!!
+  (defconstant gencgc-page-size
+    #+sparc (* 4 8192)
+    #+ppc (* 4 4096)
+    #-(or sparc ppc) 4096))
+
+#+gencgc
+(def-alien-variable last-free-page c-call:unsigned-int)
+    
 (defun space-bounds (space)
   (declare (type spaces space))
   (ecase space
@@ -133,7 +144,17 @@
      (values (int-sap (read-only-space-start))
 	     (int-sap (* *read-only-space-free-pointer* word-bytes))))
     (:dynamic
+     ;; DYNAMIC-SPACE-FREE-POINTER isn't quite right here for sparc
+     ;; and ppc with gencgc.  We really want the last free page, which
+     ;; is stored in *allocation-pointer* on x86, but sparc and ppc
+     ;; don't have *allocation-pointer*, so grab the value directly
+     ;; from last-free-page.
      (values (int-sap (current-dynamic-space-start))
+	     #+(and gencgc (or sparc ppc))
+	     (int-sap (truly-the (unsigned-byte 32)
+				 (+ (current-dynamic-space-start)
+				    (the (unsigned-byte 32) (* gencgc-page-size last-free-page)))))
+	     #-(and gencgc (or sparc ppc))
 	     (dynamic-space-free-pointer)))))
 
 ;;; SPACE-BYTES  --  Internal
@@ -181,6 +202,18 @@
 		      shift)
 		 (ash len shift)))))))
 
+;;; Access to the GENCGC page table for better precision in
+;;; MAP-ALLOCATED-OBJECTS.
+#+gencgc
+(progn
+  (declaim (inline find-page-index get-page-table-info))
+  (def-alien-routine "find_page_index" c-call:int
+    (addr c-call:long))
+  (def-alien-routine get-page-table-info c-call:void
+    (page c-call:int)
+    (flags c-call:int :out)
+    (bytes c-call:int :out))
+  )
 
 ;;; MAP-ALLOCATED-OBJECTS  --  Interface
 ;;;
@@ -189,6 +222,7 @@
 ;;; including any header and padding.
 ;;;
 (declaim (maybe-inline map-allocated-objects))
+#+nil
 (defun map-allocated-objects (fun space)
   (declare (type function fun) (type spaces space))
   (without-gcing
@@ -273,6 +307,122 @@
 	#+nil
 	prev))))
 
+(defun map-allocated-objects (fun space)
+  (declare (type function fun) (type spaces space))
+  (without-gcing
+   (multiple-value-bind (start end)
+       (space-bounds space)
+     (declare (type system-area-pointer start end))
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((skip-tests-until-addr 0)
+	   (current start))
+       (declare (type (unsigned-byte 31) skip-tests-until-addr))
+       (labels
+	   ((maybe-finish-mapping ()
+	      (unless (sap< current end)
+		(return-from map-allocated-objects)))
+	    ;; GENCGC doesn't allocate linearly, which means that the
+	    ;; dynamic space can contain large blocks of zeros that
+	    ;; get accounted as conses in ROOM (and slow down other
+	    ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
+	    ;; check the GC page structure for the current address.
+	    ;; If the page is free or the address is beyond the page-
+	    ;; internal allocation offset (bytes-used) skip to the
+	    ;; next page immediately.
+	    (maybe-skip-page ()
+	      #+gencgc
+	      (when (eq space :dynamic)
+		(let ((tested (>= (sap-int current) skip-tests-until-addr)))
+		  (loop with page-mask = (1- gencgc-page-size)
+		     for addr of-type (unsigned-byte 32) = (sap-int current)
+		     while (>= addr skip-tests-until-addr)
+		     do
+		     (multiple-value-bind (ret flags bytes-used)
+			 (get-page-table-info (find-page-index addr))
+		       (declare (ignore ret))
+		       (let ((alloc-flag (logand flags #x40)))
+			 ;; If the page is not free and the current
+			 ;; pointer is still below the allocation
+			 ;; offset of the page
+			 (when (and (not (zerop alloc-flag))
+				    (<= (logand page-mask addr)
+					bytes-used))
+			   ;; Don't bother testing again until we get
+			   ;; past that allocation offset
+			   (setf skip-tests-until-addr
+				 (+ (logandc2 addr page-mask)
+				    (the fixnum bytes-used)))
+			   ;; And then continue with the scheduled mapping
+			   (return-from maybe-skip-page))
+			 ;; Move CURRENT to start of next page
+			 (setf current (int-sap (+ (logandc2 addr page-mask)
+						   gencgc-page-size)))
+			 (maybe-finish-mapping)))))))
+	    (next (size)
+	      (let ((c (etypecase size
+			 (fixnum (sap+ current size))
+			 (memory-size (sap+ current size)))))
+		(setf current c))))
+	 (declare (inline next))
+	 (loop
+	    (maybe-finish-mapping)
+	    (maybe-skip-page)
+	    (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)
+		   (next 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)
+		   (next size)))
+		((eq (room-info-kind info) :instance)
+		 (let* ((obj (make-lisp-obj
+			      (logior (sap-int current) instance-pointer-type)))
+			(size (round-to-dualword
+			       (* (+ (%instance-length obj) 1) word-bytes))))
+		   (declare (type memory-size size))
+		   (funcall fun obj header-type size)
+		   (assert (zerop (logand size lowtag-mask)))
+		   (next 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 (%code-code-size obj))
+					word-bytes)))))))
+		   (declare (type memory-size size))
+		   (funcall fun obj header-type size)
+		   (assert (zerop (logand size lowtag-mask)))
+		   (next size)))))))))))
+
 
 ;;;; MEMORY-USAGE:
 
diff --git a/lisp/gencgc.c b/lisp/gencgc.c
index 59e725776ceeb9070dee2606b418335e1c62f5a7..2e5e2cd8abc1ef18d4ed1e7f31a4642192000c36 100644
--- a/lisp/gencgc.c
+++ b/lisp/gencgc.c
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997, 1998, 1999.
  *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.72 2006/07/18 23:28:48 rtoy Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.73 2006/07/20 16:19:35 rtoy Exp $
  *
  */
 
@@ -505,8 +505,11 @@ unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS - 1;
  * ALLOCATION_POINTER which is used by the room function to limit its
  * search of the heap. XX Gencgc obviously needs to be better
  * integrated with the lisp code.
+ *
+ * Except on sparc and ppc, there's no ALLOCATION_POINTER, so it's
+ * never updated.  So make this available (non-static).
  */
-static int last_free_page;
+int last_free_page;
 
 
 
@@ -7495,3 +7498,14 @@ print_bytes_allocated_sum(void)
      */
 #endif
 }
+
+/*
+ * Let Lisp get at the page table entry and return the flags and the
+ * bytes used
+ */
+void
+get_page_table_info(int page, int* flags, int* bytes)
+{
+    *flags = page_table[page].flags;
+    *bytes = page_table[page].bytes_used;
+}