0.8.18.13:

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index df09fbe..c7696b2 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -36,6 +36,28 @@
        (size (primitive-object-size obj)))
     (cond
      ((not lowtag))
        (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))
      ((not widetag)
       (let ((info (make-room-info :name name
                                  :kind :lowtag))

@@ -50,9 +72,10 @@
                            :kind :fixed
                            :length size))))))
 
                            :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-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)))
   (setf (svref *meta-room-info* code)
        (make-room-info :name 'array-header
                        :kind :header)))

@@ -69,11 +92,15 @@
                 (simple-vector-widetag . 2)
                 (simple-array-unsigned-byte-2-widetag . -2)
                 (simple-array-unsigned-byte-4-widetag . -1)
                 (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-8-widetag . 0)

+                (simple-array-unsigned-byte-15-widetag . 1)

                 (simple-array-unsigned-byte-16-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-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-signed-byte-30-widetag . 2)
                 (simple-array-signed-byte-32-widetag . 2)
                 (simple-array-single-float-widetag . 2)

@@ -91,11 +118,17 @@
                          :kind :vector
                          :length size))))
 
                          :kind :vector
                          :length size))))
 

-(setf (svref *meta-room-info* simple-string-widetag)
-      (make-room-info :name 'simple-string
+(setf (svref *meta-room-info* simple-base-string-widetag)
+      (make-room-info :name 'simple-base-string

                      :kind :string
                      :length 0))
 
                      :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
 (setf (svref *meta-room-info* simple-array-nil-widetag)
       (make-room-info :name 'simple-array-nil
                      :kind :fixed

@@ -132,7 +165,8 @@
      (values (int-sap read-only-space-start)
             (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
     (:dynamic
      (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.
             (dynamic-space-free-pointer)))))
 
 ;;; Return the total number of bytes used in SPACE.

@@ -166,7 +200,7 @@
                 (ash len shift)))))))
 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
                 (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)
 ;;; bytes, including any header and padding.
 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 (defun map-allocated-objects (fun space)

@@ -439,7 +473,9 @@
           ((#.bignum-widetag
             #.single-float-widetag
             #.double-float-widetag
           ((#.bignum-widetag
             #.single-float-widetag
             #.double-float-widetag

-            #.simple-string-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-bit-vector-widetag
             #.simple-array-unsigned-byte-2-widetag
             #.simple-array-unsigned-byte-4-widetag

@@ -462,7 +498,8 @@
             #.complex-widetag
             #.simple-array-widetag
             #.simple-vector-widetag
             #.complex-widetag
             #.simple-array-widetag
             #.simple-vector-widetag

-            #.complex-string-widetag
+            #.complex-base-string-widetag
+            #.complex-vector-nil-widetag

             #.complex-bit-vector-widetag
             #.complex-vector-widetag
             #.complex-array-widetag
             #.complex-bit-vector-widetag
             #.complex-vector-widetag
             #.complex-array-widetag

@@ -484,7 +521,7 @@
     (values)))
 \f
 ;;; Print a breakdown by instance type of all the instances allocated
     (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))
 ;;; TOP-N types with largest usage.
 (defun instance-usage (space &key (top-n 15))
   (declare (type spaces space) (type (or fixnum null) top-n))

@@ -499,19 +536,19 @@
        (when (eql type instance-header-widetag)
         (incf total-objects)
         (incf total-bytes size)
        (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)))
+        (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
           (cond (found
                  (incf (the fixnum (car found)))
                  (incf (the fixnum (cdr found)) size))
                 (t

-                 (setf (gethash class totals) (cons 1 size)))))))
+                 (setf (gethash classoid totals) (cons 1 size)))))))

      space)
 
     (collect ((totals-list))
      space)
 
     (collect ((totals-list))

-      (maphash (lambda (class what)
+      (maphash (lambda (classoid what)

                 (totals-list (cons (prin1-to-string
                 (totals-list (cons (prin1-to-string

-                                    (class-proper-name class))
+                                    (classoid-proper-name classoid))

                                    what)))
               totals)
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
                                    what)))
               totals)
       (let ((sorted (sort (totals-list) #'> :key #'cddr))

@@ -539,32 +576,6 @@
 
   (values))
 \f
 
   (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)
 ;;;; PRINT-ALLOCATED-OBJECTS
 
 (defun print-allocated-objects (space &key (percent 0) (pages 5)

@@ -650,9 +661,14 @@
 
 (defvar *ignore-after* nil)
 
 
 (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)
 (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))
 
       (cons x stuff)
       stuff))
 

@@ -662,7 +678,8 @@
           (type (or index null) larger smaller type count)
           (type (or function null) test)
           (inline map-allocated-objects))
           (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
   (collect ((counted 0 1+))
     (let ((res ()))
       (map-allocated-objects

@@ -678,34 +695,48 @@
        space)
       res)))
 
        space)
       res)))
 

-(defun list-referencing-objects (space object)
+(defun map-referencing-objects (fun space object)

   (declare (type spaces space) (inline map-allocated-objects))
   (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)))