X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Froom.lisp;h=c7696b221ed97b733b8bf8c2ae9f9ba6e480c0d6;hb=bf27595fb567015495b7131707cc85af361567fe;hp=a5735e03cc2dbae5f7b14d42311d015b7d061da8;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git

diff --git a/src/code/room.lisp b/src/code/room.lisp
index a5735e0..c7696b2 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -32,10 +32,32 @@
   (let ((widetag (primitive-object-widetag obj))
 	(lowtag (primitive-object-lowtag obj))
 	(name (primitive-object-name obj))
-	(variable (primitive-object-var-length obj))
+	(variable (primitive-object-variable-length-p obj))
 	(size (primitive-object-size obj)))
     (cond
      ((not lowtag))
+     (;; KLUDGE described in dan_b message "Another one for the
+      ;; collection [bug 108]" (sbcl-devel 2004-01-22)
+      ;;
+      ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T))  causes
+      ;;   debugger invoked on a SB-INT:BUG in thread 5911:
+      ;;     failed AVER: "(SAP= CURRENT END)"
+      ;; [WHN: Similar things happened on one but not the other of my
+      ;; machines when I just run ROOM a lot in a loop.]
+      ;;
+      ;; This appears to be due to my [DB] abuse of the primitive
+      ;; object macros to define a thread object that shares a lowtag
+      ;; with fixnums and has no widetag: it looks like the code that
+      ;; generates *META-ROOM-INFO* infers from this that even fixnums
+      ;; are thread-sized - probably undesirable.
+      ;;
+      ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
+      ;; nature of a workaround than a really good fix. I'm not sure
+      ;; what a really good fix is: I /think/ it's probably to remove
+      ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
+      ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
+      ;; for assembly source in the runtime/genesis/*.h files.
+      (eql name 'thread))
      ((not widetag)
       (let ((info (make-room-info :name name
 				  :kind :lowtag))
@@ -50,9 +72,10 @@
 			    :kind :fixed
 			    :length size))))))
 
-(dolist (code (list complex-string-widetag simple-array-widetag
+(dolist (code (list #!+sb-unicode complex-character-string-widetag
+                    complex-base-string-widetag simple-array-widetag
 		    complex-bit-vector-widetag complex-vector-widetag
-		    complex-array-widetag))
+		    complex-array-widetag complex-vector-nil-widetag))
   (setf (svref *meta-room-info* code)
 	(make-room-info :name 'array-header
 			:kind :header)))
@@ -69,29 +92,48 @@
 		 (simple-vector-widetag . 2)
 		 (simple-array-unsigned-byte-2-widetag . -2)
 		 (simple-array-unsigned-byte-4-widetag . -1)
+		 (simple-array-unsigned-byte-7-widetag . 0)
 		 (simple-array-unsigned-byte-8-widetag . 0)
+		 (simple-array-unsigned-byte-15-widetag . 1)
 		 (simple-array-unsigned-byte-16-widetag . 1)
+		 (simple-array-unsigned-byte-31-widetag . 2)
 		 (simple-array-unsigned-byte-32-widetag . 2)
 		 (simple-array-signed-byte-8-widetag . 0)
 		 (simple-array-signed-byte-16-widetag . 1)
+		 (simple-array-unsigned-byte-29-widetag . 2)
 		 (simple-array-signed-byte-30-widetag . 2)
 		 (simple-array-signed-byte-32-widetag . 2)
 		 (simple-array-single-float-widetag . 2)
 		 (simple-array-double-float-widetag . 3)
 		 (simple-array-complex-single-float-widetag . 3)
 		 (simple-array-complex-double-float-widetag . 4)))
-  (let ((name (car stuff))
-	(size (cdr stuff)))
+  (let* ((name (car stuff))
+	 (size (cdr stuff))
+	 (sname (string name)))
     (setf (svref *meta-room-info* (symbol-value name))
-	  (make-room-info :name name
+	  (make-room-info :name (intern (subseq sname
+						0
+						(mismatch sname "-WIDETAG"
+							  :from-end t)))
 			  :kind :vector
 			  :length size))))
 
-(setf (svref *meta-room-info* simple-string-widetag)
-      (make-room-info :name 'simple-string-widetag
+(setf (svref *meta-room-info* simple-base-string-widetag)
+      (make-room-info :name 'simple-base-string
 		      :kind :string
 		      :length 0))
 
+#!+sb-unicode
+(setf (svref *meta-room-info* simple-character-string-widetag)
+      (make-room-info :name 'simple-character-string
+		      :kind :string
+		      :length 2))
+
+(setf (svref *meta-room-info* simple-array-nil-widetag)
+      (make-room-info :name 'simple-array-nil
+		      :kind :fixed
+		      :length 2))
+
 (setf (svref *meta-room-info* code-header-widetag)
       (make-room-info :name 'code
 		      :kind :code))
@@ -100,7 +142,7 @@
       (make-room-info :name 'instance
 		      :kind :instance))
 
-); eval-when (compile eval)
+) ; EVAL-WHEN
 
 (defparameter *room-info* '#.*meta-room-info*)
 (deftype spaces () '(member :static :dynamic :read-only))
@@ -123,7 +165,8 @@
      (values (int-sap read-only-space-start)
 	     (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
     (:dynamic
-     (values (int-sap dynamic-space-start)
+     (values (int-sap #!+gencgc dynamic-space-start 
+		      #!-gencgc (current-dynamic-space-start))
 	     (dynamic-space-free-pointer)))))
 
 ;;; Return the total number of bytes used in SPACE.
@@ -157,7 +200,7 @@
 		 (ash len shift)))))))
 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
-;;; the object, the object's type code, and the objects total size in
+;;; the object, the object's type code, and the object's total size in
 ;;; bytes, including any header and padding.
 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 (defun map-allocated-objects (fun space)
@@ -211,7 +254,8 @@
 			     (:fixed
 			      (aver (or (eql (room-info-length info)
 					       (1+ (get-header-data obj)))
-					  (floatp obj)))
+					(floatp obj)
+					(simple-array-nil-p obj)))
 			      (round-to-dualword
 			       (* (room-info-length info) n-word-bytes)))
 			     ((:vector :string)
@@ -249,10 +293,10 @@
   (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
 	(counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
     (map-allocated-objects
-     #'(lambda (obj type size)
-	 (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
-	 (incf (aref sizes type) size)
-	 (incf (aref counts type)))
+     (lambda (obj type size)
+       (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+       (incf (aref sizes type) size)
+       (incf (aref counts type)))
      space)
 
     (let ((totals (make-hash-table :test 'eq)))
@@ -270,9 +314,9 @@
 			   (list total-size total-count name))))))))
 
       (collect ((totals-list))
-	(maphash #'(lambda (k v)
-		     (declare (ignore k))
-		     (totals-list v))
+	(maphash (lambda (k v)
+		   (declare (ignore k))
+		   (totals-list v))
 		 totals)
 	(sort (totals-list) #'> :key #'first)))))
 
@@ -287,13 +331,13 @@
 	      (gethash (third total) summary))))
 
     (collect ((summary-totals))
-      (maphash #'(lambda (k v)
-		   (declare (ignore k))
-		   (let ((sum 0))
-		     (declare (fixnum sum))
-		     (dolist (space-total v)
-		       (incf sum (first (cdr space-total))))
-		     (summary-totals (cons sum v))))
+      (maphash (lambda (k v)
+		 (declare (ignore k))
+		 (let ((sum 0))
+		   (declare (fixnum sum))
+		   (dolist (space-total v)
+		     (incf sum (first (cdr space-total))))
+		   (summary-totals (cons sum v))))
 	       summary)
 
       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
@@ -316,7 +360,7 @@
 	      (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
 		      name total-bytes total-objects)
 	      (dolist (space (spaces))
-		(format t ", ~D% ~(~A~)"
+		(format t ", ~W% ~(~A~)"
 			(round (* (cdr space) 100) total-bytes)
 			(car space)))
 	      (format t ".~%")
@@ -366,8 +410,8 @@
   (let* ((spaces (if (eq count-spaces t)
 		     '(:static :dynamic :read-only)
 		     count-spaces))
-	 (totals (mapcar #'(lambda (space)
-			     (cons space (type-breakdown space)))
+	 (totals (mapcar (lambda (space)
+			   (cons space (type-breakdown space)))
 			 spaces)))
 
     (dolist (space-total totals)
@@ -388,17 +432,17 @@
     (declare (fixnum code-words no-ops)
 	     (type unsigned-byte total-bytes))
     (map-allocated-objects
-     #'(lambda (obj type size)
- 	 (declare (fixnum size) (optimize (safety 0)))
-	 (when (eql type code-header-widetag)
-	   (incf total-bytes size)
-	   (let ((words (truly-the fixnum (%code-code-size obj)))
-		 (sap (truly-the system-area-pointer
-				 (%primitive code-instructions obj))))
-	     (incf code-words words)
-	     (dotimes (i words)
-	       (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
-		 (incf no-ops))))))
+     (lambda (obj type size)
+       (declare (fixnum size) (optimize (safety 0)))
+       (when (eql type code-header-widetag)
+	 (incf total-bytes size)
+	 (let ((words (truly-the fixnum (%code-code-size obj)))
+	       (sap (truly-the system-area-pointer
+			       (%primitive code-instructions obj))))
+	   (incf code-words words)
+	   (dotimes (i words)
+	     (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
+	       (incf no-ops))))))
      space)
 
     (format t
@@ -417,55 +461,58 @@
     (dolist (space (or spaces '(:read-only :static :dynamic)))
       (declare (inline map-allocated-objects))
       (map-allocated-objects
-       #'(lambda (obj type size)
-	   (declare (fixnum size) (optimize (safety 0)))
-	   (case type
-	     (#.code-header-widetag
-	      (let ((inst-words (truly-the fixnum (%code-code-size obj))))
-		(declare (type fixnum inst-words))
-		(incf non-descriptor-bytes (* inst-words n-word-bytes))
-		(incf descriptor-words
-		      (- (truncate size n-word-bytes) inst-words))))
-	     ((#.bignum-widetag
-	       #.single-float-widetag
-	       #.double-float-widetag
-	       #.simple-string-widetag
-	       #.simple-bit-vector-widetag
-	       #.simple-array-unsigned-byte-2-widetag
-	       #.simple-array-unsigned-byte-4-widetag
-	       #.simple-array-unsigned-byte-8-widetag
-	       #.simple-array-unsigned-byte-16-widetag
-	       #.simple-array-unsigned-byte-32-widetag
-	       #.simple-array-signed-byte-8-widetag
-	       #.simple-array-signed-byte-16-widetag
-	       #.simple-array-signed-byte-30-widetag
-	       #.simple-array-signed-byte-32-widetag
-	       #.simple-array-single-float-widetag
-	       #.simple-array-double-float-widetag
-	       #.simple-array-complex-single-float-widetag
-	       #.simple-array-complex-double-float-widetag)
-	      (incf non-descriptor-headers)
-	      (incf non-descriptor-bytes (- size n-word-bytes)))
-	     ((#.list-pointer-lowtag
-	       #.instance-pointer-lowtag
-	       #.ratio-widetag
-	       #.complex-widetag
-	       #.simple-array-widetag
-	       #.simple-vector-widetag
-	       #.complex-string-widetag
-	       #.complex-bit-vector-widetag
-	       #.complex-vector-widetag
-	       #.complex-array-widetag
-	       #.closure-header-widetag
-	       #.funcallable-instance-header-widetag
-	       #.value-cell-header-widetag
-	       #.symbol-header-widetag
-	       #.sap-widetag
-	       #.weak-pointer-widetag
-	       #.instance-header-widetag)
-	      (incf descriptor-words (truncate size n-word-bytes)))
-	     (t
-	      (error "bogus type: ~D" type))))
+       (lambda (obj type size)
+	 (declare (fixnum size) (optimize (safety 0)))
+	 (case type
+	   (#.code-header-widetag
+	    (let ((inst-words (truly-the fixnum (%code-code-size obj))))
+	      (declare (type fixnum inst-words))
+	      (incf non-descriptor-bytes (* inst-words n-word-bytes))
+	      (incf descriptor-words
+		    (- (truncate size n-word-bytes) inst-words))))
+	   ((#.bignum-widetag
+	     #.single-float-widetag
+	     #.double-float-widetag
+	     #.simple-base-string-widetag
+             #!+sb-unicode #.simple-character-string-widetag
+	     #.simple-array-nil-widetag
+	     #.simple-bit-vector-widetag
+	     #.simple-array-unsigned-byte-2-widetag
+	     #.simple-array-unsigned-byte-4-widetag
+	     #.simple-array-unsigned-byte-8-widetag
+	     #.simple-array-unsigned-byte-16-widetag
+	     #.simple-array-unsigned-byte-32-widetag
+	     #.simple-array-signed-byte-8-widetag
+	     #.simple-array-signed-byte-16-widetag
+	     #.simple-array-signed-byte-30-widetag
+	     #.simple-array-signed-byte-32-widetag
+	     #.simple-array-single-float-widetag
+	     #.simple-array-double-float-widetag
+	     #.simple-array-complex-single-float-widetag
+	     #.simple-array-complex-double-float-widetag)
+	    (incf non-descriptor-headers)
+	    (incf non-descriptor-bytes (- size n-word-bytes)))
+	   ((#.list-pointer-lowtag
+	     #.instance-pointer-lowtag
+	     #.ratio-widetag
+	     #.complex-widetag
+	     #.simple-array-widetag
+	     #.simple-vector-widetag
+	     #.complex-base-string-widetag
+	     #.complex-vector-nil-widetag
+	     #.complex-bit-vector-widetag
+	     #.complex-vector-widetag
+	     #.complex-array-widetag
+	     #.closure-header-widetag
+	     #.funcallable-instance-header-widetag
+	     #.value-cell-header-widetag
+	     #.symbol-header-widetag
+	     #.sap-widetag
+	     #.weak-pointer-widetag
+	     #.instance-header-widetag)
+	    (incf descriptor-words (truncate size n-word-bytes)))
+	   (t
+	    (error "bogus widetag: ~W" type))))
        space))
     (format t "~:D words allocated for descriptor objects.~%"
 	    descriptor-words)
@@ -474,35 +521,35 @@
     (values)))
 
 ;;; Print a breakdown by instance type of all the instances allocated
-;;; in SPACE. If TOP-N is true, print only information for the the
+;;; in SPACE. If TOP-N is true, print only information for the 
 ;;; TOP-N types with largest usage.
 (defun instance-usage (space &key (top-n 15))
   (declare (type spaces space) (type (or fixnum null) top-n))
-  (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
+  (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
   (let ((totals (make-hash-table :test 'eq))
 	(total-objects 0)
 	(total-bytes 0))
     (declare (fixnum total-objects total-bytes))
     (map-allocated-objects
-     #'(lambda (obj type size)
-	 (declare (fixnum size) (optimize (speed 3) (safety 0)))
-	 (when (eql type instance-header-widetag)
-	   (incf total-objects)
-	   (incf total-bytes size)
-	   (let* ((class (layout-class (%instance-ref obj 0)))
-		  (found (gethash class totals)))
-	     (cond (found
-		    (incf (the fixnum (car found)))
-		    (incf (the fixnum (cdr found)) size))
-		   (t
-		    (setf (gethash class totals) (cons 1 size)))))))
+     (lambda (obj type size)
+       (declare (fixnum size) (optimize (speed 3) (safety 0)))
+       (when (eql type instance-header-widetag)
+	 (incf total-objects)
+	 (incf total-bytes size)
+	 (let* ((classoid (layout-classoid (%instance-ref obj 0)))
+		(found (gethash classoid totals)))
+	   (cond (found
+		  (incf (the fixnum (car found)))
+		  (incf (the fixnum (cdr found)) size))
+		 (t
+		  (setf (gethash classoid totals) (cons 1 size)))))))
      space)
 
     (collect ((totals-list))
-      (maphash #'(lambda (class what)
-		   (totals-list (cons (prin1-to-string
-				       (class-proper-name class))
-				      what)))
+      (maphash (lambda (classoid what)
+		 (totals-list (cons (prin1-to-string
+				     (classoid-proper-name classoid))
+				    what)))
 	       totals)
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
 	    (printed-bytes 0)
@@ -515,13 +562,13 @@
 		(objects (cadr what)))
 	    (incf printed-bytes bytes)
 	    (incf printed-objects objects)
-	    (format t "  ~A: ~:D bytes, ~D object~:P.~%" (car what)
+	    (format t "  ~A: ~: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 "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
@@ -529,32 +576,6 @@
 
   (values))
 
-(defun find-holes (&rest spaces)
-  (dolist (space (or spaces '(:read-only :static :dynamic)))
-    (format t "In ~A space:~%" space)
-    (let ((start-addr nil)
-	  (total-bytes 0))
-      (declare (type (or null (unsigned-byte 32)) start-addr)
-	       (type (unsigned-byte 32) total-bytes))
-      (map-allocated-objects
-       #'(lambda (object typecode bytes)
-	   (declare (ignore typecode)
-		    (type (unsigned-byte 32) bytes))
-	   (if (and (consp object)
-		    (eql (car object) 0)
-		    (eql (cdr object) 0))
-	       (if start-addr
-		   (incf total-bytes bytes)
-		   (setf start-addr (sb!di::get-lisp-obj-address object)
-			 total-bytes bytes))
-	       (when start-addr
-		 (format t "~D bytes at #X~X~%" total-bytes start-addr)
-		 (setf start-addr nil))))
-       space)
-      (when start-addr
-	(format t "~D bytes at #X~X~%" total-bytes start-addr))))
-  (values))
-
 ;;;; PRINT-ALLOCATED-OBJECTS
 
 (defun print-allocated-objects (space &key (percent 0) (pages 5)
@@ -581,58 +602,58 @@
 		   (note-conses (car x))
 		   (note-conses (cdr x)))))
 	(map-allocated-objects
-	 #'(lambda (obj obj-type size)
-	     (declare (optimize (safety 0)))
-	     (let ((addr (get-lisp-obj-address obj)))
-	       (when (>= addr start)
-		 (when (if count
-			   (> count-so-far count)
-			   (> pages-so-far pages))
-		   (return-from print-allocated-objects (values)))
-
-		 (unless count
-		   (let ((this-page (* (the (values (unsigned-byte 32) t)
-                                         (truncate addr pagesize))
-				       pagesize)))
-		     (declare (type (unsigned-byte 32) this-page))
-		     (when (/= this-page last-page)
-		       (when (< pages-so-far pages)
-			 ;; FIXME: What is this? (ERROR "Argh..")? or
-			 ;; a warning? or code that can be removed
-			 ;; once the system is stable? or what?
-			 (format stream "~2&**** Page ~D, address ~X:~%"
-				 pages-so-far addr))
-		       (setq last-page this-page)
-		       (incf pages-so-far))))
-
-		 (when (and (or (not type) (eql obj-type type))
-			    (or (not smaller) (<= size smaller))
-			    (or (not larger) (>= size larger)))
-		   (incf count-so-far)
-		   (case type
-		     (#.code-header-widetag
-		      (let ((dinfo (%code-debug-info obj)))
-			(format stream "~&Code object: ~S~%"
-				(if dinfo
-				    (sb!c::compiled-debug-info-name dinfo)
-				    "No debug info."))))
-		     (#.symbol-header-widetag
-		      (format stream "~&~S~%" obj))
-		     (#.list-pointer-lowtag
-		      (unless (gethash obj printed-conses)
-			(note-conses obj)
-			(let ((*print-circle* t)
-			      (*print-level* 5)
-			      (*print-length* 10))
-			  (format stream "~&~S~%" obj))))
-		     (t
-		      (fresh-line stream)
-		      (let ((str (write-to-string obj :level 5 :length 10
-						  :pretty nil)))
-			(unless (eql type instance-header-widetag)
-			  (format stream "~S: " (type-of obj)))
-			(format stream "~A~%"
-				(subseq str 0 (min (length str) 60))))))))))
+	 (lambda (obj obj-type size)
+	   (declare (optimize (safety 0)))
+	   (let ((addr (get-lisp-obj-address obj)))
+	     (when (>= addr start)
+	       (when (if count
+			 (> count-so-far count)
+			 (> pages-so-far pages))
+		 (return-from print-allocated-objects (values)))
+
+	       (unless count
+		 (let ((this-page (* (the (values (unsigned-byte 32) t)
+				       (truncate addr pagesize))
+				     pagesize)))
+		   (declare (type (unsigned-byte 32) this-page))
+		   (when (/= this-page last-page)
+		     (when (< pages-so-far pages)
+		       ;; FIXME: What is this? (ERROR "Argh..")? or
+		       ;; a warning? or code that can be removed
+		       ;; once the system is stable? or what?
+		       (format stream "~2&**** Page ~W, address ~X:~%"
+			       pages-so-far addr))
+		     (setq last-page this-page)
+		     (incf pages-so-far))))
+
+	       (when (and (or (not type) (eql obj-type type))
+			  (or (not smaller) (<= size smaller))
+			  (or (not larger) (>= size larger)))
+		 (incf count-so-far)
+		 (case type
+		   (#.code-header-widetag
+		    (let ((dinfo (%code-debug-info obj)))
+		      (format stream "~&Code object: ~S~%"
+			      (if dinfo
+				  (sb!c::compiled-debug-info-name dinfo)
+				  "No debug info."))))
+		   (#.symbol-header-widetag
+		    (format stream "~&~S~%" obj))
+		   (#.list-pointer-lowtag
+		    (unless (gethash obj printed-conses)
+		      (note-conses obj)
+		      (let ((*print-circle* t)
+			    (*print-level* 5)
+			    (*print-length* 10))
+			(format stream "~&~S~%" obj))))
+		   (t
+		    (fresh-line stream)
+		    (let ((str (write-to-string obj :level 5 :length 10
+						:pretty nil)))
+		      (unless (eql type instance-header-widetag)
+			(format stream "~S: " (type-of obj)))
+		      (format stream "~A~%"
+			      (subseq str 0 (min (length str) 60))))))))))
 	 space))))
   (values))
 
@@ -640,9 +661,14 @@
 
 (defvar *ignore-after* nil)
 
+(defun valid-obj (space x)
+  (or (not (eq space :dynamic))
+      ;; this test looks bogus if the allocator doesn't work linearly,
+      ;; which I suspect is the case for GENCGC.  -- CSR, 2004-06-29
+      (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
+
 (defun maybe-cons (space x stuff)
-  (if (or (not (eq space :dynamic))
-	  (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
+  (if (valid-obj space x)
       (cons x stuff)
       stuff))
 
@@ -652,50 +678,65 @@
 	   (type (or index null) larger smaller type count)
 	   (type (or function null) test)
 	   (inline map-allocated-objects))
-  (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
+  (unless *ignore-after*
+    (setq *ignore-after* (cons 1 2)))
   (collect ((counted 0 1+))
     (let ((res ()))
       (map-allocated-objects
-       #'(lambda (obj obj-type size)
-	   (declare (optimize (safety 0)))
-	   (when (and (or (not type) (eql obj-type type))
-		      (or (not smaller) (<= size smaller))
-		      (or (not larger) (>= size larger))
-		      (or (not test) (funcall test obj)))
-	     (setq res (maybe-cons space obj res))
-	     (when (and count (>= (counted) count))
-	       (return-from list-allocated-objects res))))
+       (lambda (obj obj-type size)
+	 (declare (optimize (safety 0)))
+	 (when (and (or (not type) (eql obj-type type))
+		    (or (not smaller) (<= size smaller))
+		    (or (not larger) (>= size larger))
+		    (or (not test) (funcall test obj)))
+	   (setq res (maybe-cons space obj res))
+	   (when (and count (>= (counted) count))
+	     (return-from list-allocated-objects res))))
        space)
       res)))
 
-(defun list-referencing-objects (space object)
+(defun map-referencing-objects (fun space object)
   (declare (type spaces space) (inline map-allocated-objects))
-  (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
-  (let ((res ()))
-    (flet ((res (x)
-	     (setq res (maybe-cons space x res))))
-      (map-allocated-objects
-       #'(lambda (obj obj-type size)
-	   (declare (optimize (safety 0)) (ignore obj-type size))
-	   (typecase obj
-	     (cons
-	      (when (or (eq (car obj) object) (eq (cdr obj) object))
-		(res obj)))
-	     (instance
-	      (dotimes (i (%instance-length obj))
-		(when (eq (%instance-ref obj i) object)
-		  (res obj)
-		  (return))))
-	     (simple-vector
-	      (dotimes (i (length obj))
-		(when (eq (svref obj i) object)
-		  (res obj)
-		  (return))))
-	     (symbol
-	      (when (or (eq (symbol-name obj) object)
-			(eq (symbol-package obj) object)
-			(eq (symbol-plist obj) object)
-			(eq (symbol-value obj) object))
-		(res obj)))))
-       space))
-    res))
+  (unless *ignore-after*
+    (setq *ignore-after* (cons 1 2)))
+  (flet ((maybe-call (fun obj)
+	   (when (valid-obj space obj)
+	     (funcall fun obj))))
+    (map-allocated-objects
+     (lambda (obj obj-type size)
+       (declare (optimize (safety 0)) (ignore obj-type size))
+       (typecase obj
+	 (cons
+	  (when (or (eq (car obj) object)
+		    (eq (cdr obj) object))
+	    (maybe-call fun obj)))
+	 (instance
+	  (dotimes (i (%instance-length obj))
+	    (when (eq (%instance-ref obj i) object)
+	      (maybe-call fun obj)
+	      (return))))
+	 (code-component
+	  (let ((length (get-header-data obj)))
+	    (do ((i code-constants-offset (1+ i)))
+		((= i length))
+	      (when (eq (code-header-ref obj i) object)
+		(maybe-call fun obj)
+		(return)))))
+	 (simple-vector
+	  (dotimes (i (length obj))
+	    (when (eq (svref obj i) object)
+	      (maybe-call fun obj)
+	      (return))))
+	 (symbol
+	  (when (or (eq (symbol-name obj) object)
+		    (eq (symbol-package obj) object)
+		    (eq (symbol-plist obj) object)
+		    (eq (symbol-value obj) object))
+	    (maybe-call fun obj)))))
+     space)))
+
+(defun list-referencing-objects (space object)
+  (collect ((res))
+    (map-referencing-objects
+     (lambda (obj) (res obj)) space object)
+    (res)))