0.8alpha.0.8:

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 90a7ece..6c8625a 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -32,7 +32,7 @@
   (let ((widetag (primitive-object-widetag obj))
        (lowtag (primitive-object-lowtag obj))
        (name (primitive-object-name obj))
   (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))
        (size (primitive-object-size obj)))
     (cond
      ((not lowtag))

@@ -80,18 +80,27 @@
                 (simple-array-double-float-widetag . 3)
                 (simple-array-complex-single-float-widetag . 3)
                 (simple-array-complex-double-float-widetag . 4)))
                 (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))
     (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)
                          :kind :vector
                          :length size))))
 
 (setf (svref *meta-room-info* simple-string-widetag)

-      (make-room-info :name 'simple-string-widetag
+      (make-room-info :name 'simple-string

                      :kind :string
                      :length 0))
 
                      :kind :string
                      :length 0))
 

+(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))
 (setf (svref *meta-room-info* code-header-widetag)
       (make-room-info :name 'code
                      :kind :code))

@@ -100,7 +109,7 @@
       (make-room-info :name 'instance
                      :kind :instance))
 
       (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))
 
 (defparameter *room-info* '#.*meta-room-info*)
 (deftype spaces () '(member :static :dynamic :read-only))

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

@@ -211,7 +221,8 @@
                             (:fixed
                              (aver (or (eql (room-info-length info)
                                               (1+ (get-header-data obj)))
                             (: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)
                              (round-to-dualword
                               (* (room-info-length info) n-word-bytes)))
                             ((:vector :string)

@@ -489,19 +500,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))