0.8.8.26:

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index df09fbe..43f552e 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,9 @@
                            :kind :fixed
                            :length size))))))
 
                            :kind :fixed
                            :length size))))))
 

-(dolist (code (list complex-string-widetag simple-array-widetag
+(dolist (code (list 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 +91,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,8 +117,8 @@
                          :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))
 

@@ -132,7 +158,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.

@@ -439,7 +466,8 @@
           ((#.bignum-widetag
             #.single-float-widetag
             #.double-float-widetag
           ((#.bignum-widetag
             #.single-float-widetag
             #.double-float-widetag

-            #.simple-string-widetag
+            #.simple-base-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 +490,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

@@ -499,19 +528,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))