0.8.16.2: TYPE-ERROR for ERROR

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 43f552e..cf18258 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -193,7 +193,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)
@@ -513,7 +513,7 @@
     (values)))
 \f
 ;;; 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))
@@ -568,32 +568,6 @@
 
   (values))
 \f
-(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))
-\f
 ;;;; PRINT-ALLOCATED-OBJECTS
 
 (defun print-allocated-objects (space &key (percent 0) (pages 5)
@@ -679,9 +653,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))
 
@@ -691,7 +670,8 @@
           (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
@@ -707,34 +687,48 @@
        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)))