Port to x86-64 versions of Windows

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 31e6275..8331d71 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -10,6 +10,9 @@
 ;;;; files for more information.
 
 (in-package "SB!VM")
 ;;;; files for more information.
 
 (in-package "SB!VM")

+
+(declaim (special sb!vm:*read-only-space-free-pointer*
+                  sb!vm:*static-space-free-pointer*))

 \f
 ;;;; type format database
 
 \f
 ;;;; type format database
 

@@ -36,28 +39,6 @@
         (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))

@@ -88,8 +69,10 @@
       (make-room-info :name 'closure
                       :kind :closure))
 
       (make-room-info :name 'closure
                       :kind :closure))
 

+;; FIXME: This looks rather brittle. Can we get more of these numbers
+;; from somewhere sensible?

 (dolist (stuff '((simple-bit-vector-widetag . -3)
 (dolist (stuff '((simple-bit-vector-widetag . -3)

-                 (simple-vector-widetag . 2)
+                 (simple-vector-widetag . #.sb!vm:word-shift)

                  (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-2-widetag . -2)
                  (simple-array-unsigned-byte-4-widetag . -1)
                  (simple-array-unsigned-byte-7-widetag . 0)

@@ -98,15 +81,13 @@
                  (simple-array-unsigned-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-31-widetag . 2)
                  (simple-array-unsigned-byte-32-widetag . 2)
                  (simple-array-unsigned-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-31-widetag . 2)
                  (simple-array-unsigned-byte-32-widetag . 2)

-                 (simple-array-unsigned-byte-60-widetag . 3)
+                 (simple-array-unsigned-fixnum-widetag . #.sb!vm:word-shift)

                  (simple-array-unsigned-byte-63-widetag . 3)
                  (simple-array-unsigned-byte-64-widetag . 3)
                  (simple-array-signed-byte-8-widetag . 0)
                  (simple-array-signed-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-63-widetag . 3)
                  (simple-array-unsigned-byte-64-widetag . 3)
                  (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-fixnum-widetag . #.sb!vm:word-shift)

                  (simple-array-signed-byte-32-widetag . 2)
                  (simple-array-signed-byte-32-widetag . 2)

-                 (simple-array-signed-byte-61-widetag . 3)

                  (simple-array-signed-byte-64-widetag . 3)
                  (simple-array-single-float-widetag . 2)
                  (simple-array-double-float-widetag . 3)
                  (simple-array-signed-byte-64-widetag . 3)
                  (simple-array-single-float-widetag . 2)
                  (simple-array-double-float-widetag . 3)

@@ -148,6 +129,10 @@
       (make-room-info :name 'instance
                       :kind :instance))
 
       (make-room-info :name 'instance
                       :kind :instance))
 

+(setf (svref *meta-room-info* funcallable-instance-header-widetag)
+      (make-room-info :name 'funcallable-instance
+                      :kind :closure))
+

 ) ; EVAL-WHEN
 
 (defparameter *room-info* '#.*meta-room-info*)
 ) ; EVAL-WHEN
 
 (defparameter *room-info* '#.*meta-room-info*)

@@ -166,10 +151,10 @@
   (ecase space
     (:static
      (values (int-sap static-space-start)
   (ecase space
     (:static
      (values (int-sap static-space-start)

-             (int-sap (* *static-space-free-pointer* n-word-bytes))))
+             (int-sap (ash *static-space-free-pointer* n-fixnum-tag-bits))))

     (:read-only
      (values (int-sap read-only-space-start)
     (:read-only
      (values (int-sap read-only-space-start)

-             (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
+             (int-sap (ash *read-only-space-free-pointer* n-fixnum-tag-bits))))

     (:dynamic
      (values (int-sap (current-dynamic-space-start))
              (dynamic-space-free-pointer)))))
     (:dynamic
      (values (int-sap (current-dynamic-space-start))
              (dynamic-space-free-pointer)))))

@@ -179,11 +164,12 @@
   (multiple-value-bind (start end) (space-bounds space)
     (- (sap-int end) (sap-int start))))
 
   (multiple-value-bind (start end) (space-bounds space)
     (- (sap-int end) (sap-int start))))
 

-;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
+;;; Round SIZE (in bytes) up to the next dualword boundary. A dualword
+;;; is eight bytes on platforms with 32-bit word size and 16 bytes on
+;;; platforms with 64-bit word size.

 #!-sb-fluid (declaim (inline round-to-dualword))
 (defun round-to-dualword (size)
 #!-sb-fluid (declaim (inline round-to-dualword))
 (defun round-to-dualword (size)

-  (declare (fixnum size))
-  (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
+  (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))

 
 ;;; Return the total size of a vector in bytes, including any pad.
 #!-sb-fluid (declaim (inline vector-total-size))
 
 ;;; Return the total size of a vector in bytes, including any pad.
 #!-sb-fluid (declaim (inline vector-total-size))

@@ -193,157 +179,180 @@
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))

-    (declare (type (integer -3 3) shift))

     (round-to-dualword
      (+ (* vector-data-offset n-word-bytes)
     (round-to-dualword
      (+ (* vector-data-offset n-word-bytes)

-        (the fixnum
-             (if (minusp shift)
-                 (ash (the fixnum
-                           (+ len (the fixnum
-                                       (1- (the fixnum (ash 1 (- shift)))))))
-                      shift)
-                 (ash len shift)))))))
+        (if (minusp shift)
+            (ash (+ len (1- (ash 1 (- shift))))
+                 shift)
+            (ash len shift))))))

 
 ;;; Access to the GENCGC page table for better precision in
 ;;; MAP-ALLOCATED-OBJECTS
 #!+gencgc
 (progn
 
 ;;; Access to the GENCGC page table for better precision in
 ;;; MAP-ALLOCATED-OBJECTS
 #!+gencgc
 (progn

-  (define-alien-type nil
+  (define-alien-type (struct page)

       (struct page
       (struct page

-              (flags unsigned-int)
-              (gen int)
-              (bytes-used int)
-              (start long)))
+              (start signed)
+              ;; On platforms with small enough GC pages, this field
+              ;; will be a short. On platforms with larger ones, it'll
+              ;; be an int.
+              (bytes-used (unsigned
+                           #.(if (typep sb!vm:gencgc-card-bytes
+                                        '(unsigned-byte 16))
+                                 16
+                                 32)))
+              (flags (unsigned 8))
+              (gen (signed 8))))

   (declaim (inline find-page-index))
   (declaim (inline find-page-index))

-  (define-alien-routine "find_page_index" long (index long))
-  (define-alien-variable "page_table"
-      (array (struct page)
-             #.(truncate (- dynamic-space-end
-                            dynamic-space-start)
-                         sb!vm:gencgc-page-size))))
+  (define-alien-routine "find_page_index" long (index signed))
+  (define-alien-variable "page_table" (* (struct page))))

 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in
 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in

-;;; bytes, including any header and padding.
+;;; bytes, including any header and padding. CAREFUL makes
+;;; MAP-ALLOCATED-OBJECTS slightly more accurate, but a lot slower: it
+;;; is intended for slightly more demanding uses of heap groveling
+;;; then ROOM.

 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))

-(defun map-allocated-objects (fun space)
+(defun map-allocated-objects (fun space &optional careful)

   (declare (type function fun) (type spaces space))
   (declare (type function fun) (type spaces space))

-  (without-gcing
-   (multiple-value-bind (start end) (space-bounds space)
-     (declare (type system-area-pointer start end))
-     (declare (optimize (speed 3) (safety 0)))
-     (let ((current start)
-           #!+gencgc (skip-tests-until-addr 0))
-       (labels ((maybe-finish-mapping ()
-                  (unless (sap< current end)
-                    (aver (sap= current end))
-                    (return-from map-allocated-objects)))
-                ;; GENCGC doesn't allocate linearly, which means that the
-                ;; dynamic space can contain large blocks zeros that get
-                ;; accounted as conses in ROOM (and slow down other
-                ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
-                ;; check the GC page structure for the current address.
-                ;; If the page is free or the address is beyond the page-
-                ;; internal allocation offset (bytes-used) skip to the
-                ;; next page immediately.
-                (maybe-skip-page ()
-                  #!+gencgc
-                  (when (eq space :dynamic)
-                    (loop with page-mask = #.(1- sb!vm:gencgc-page-size)
-                          for addr of-type sb!vm:word = (sap-int current)
-                          while (>= addr skip-tests-until-addr)
-                          do
-                          ;; For some reason binding PAGE with LET
-                          ;; conses like mad (but gives no compiler notes...)
-                          ;; Work around the problem with SYMBOL-MACROLET
-                          ;; instead of trying to figure out the real
-                          ;; issue. -- JES, 2005-05-17
-                          (symbol-macrolet
-                              ((page (deref page-table
-                                            (find-page-index addr))))
-                            ;; Don't we have any nicer way to access C struct
-                            ;; bitfields?
-                            (let ((alloc-flag (ldb (byte 3 2)
-                                                   (slot page 'flags)))
-                                   (bytes-used (slot page 'bytes-used)))
-                              ;; If the page is not free and the current
-                              ;; pointer is still below the allocation offset
-                              ;; of the page
-                              (when (and (not (zerop alloc-flag))
-                                         (<= (logand page-mask addr)
-                                             bytes-used))
-                                ;; Don't bother testing again until we
-                                ;; get past that allocation offset
-                                (setf skip-tests-until-addr
-                                      (+ (logandc2 addr page-mask)
-                                         (the fixnum bytes-used)))
-                                ;; And then continue with the scheduled
-                                ;; mapping
-                                (return-from maybe-skip-page))
-                              ;; Move CURRENT to start of next page
-                              (setf current (int-sap (+ (logandc2 addr page-mask)
-                                                        sb!vm:gencgc-page-size)))
-                              (maybe-finish-mapping)))))))
-         (declare (inline maybe-finish-mapping maybe-skip-page))
-         (loop
-             (maybe-finish-mapping)
-             (maybe-skip-page)
-           (let* ((header (sap-ref-word current 0))
-                  (header-widetag (logand header #xFF))
-                  (info (svref *room-info* header-widetag)))
-             (cond
-               ((or (not info)
-                    (eq (room-info-kind info) :lowtag))
-                (let ((size (* cons-size n-word-bytes)))
-                  (funcall fun
-                           (make-lisp-obj (logior (sap-int current)
-                                                  list-pointer-lowtag))
-                           list-pointer-lowtag
-                           size)
-                  (setq current (sap+ current size))))
-               ((eql header-widetag closure-header-widetag)
-                (let* ((obj (make-lisp-obj (logior (sap-int current)
-                                                   fun-pointer-lowtag)))
-                       (size (round-to-dualword
-                              (* (the fixnum (1+ (get-closure-length obj)))
-                                 n-word-bytes))))
-                  (funcall fun obj header-widetag size)
-                  (setq current (sap+ current size))))
-               ((eq (room-info-kind info) :instance)
-                (let* ((obj (make-lisp-obj
-                             (logior (sap-int current) instance-pointer-lowtag)))
-                       (size (round-to-dualword
-                              (* (+ (%instance-length obj) 1) n-word-bytes))))
-                  (declare (fixnum size))
-                  (funcall fun obj header-widetag size)
-                  (aver (zerop (logand size lowtag-mask)))
-                  (setq current (sap+ current size))))
-               (t
-                (let* ((obj (make-lisp-obj
-                             (logior (sap-int current) other-pointer-lowtag)))
-                       (size (ecase (room-info-kind info)
-                               (:fixed
-                                (aver (or (eql (room-info-length info)
-                                               (1+ (get-header-data obj)))
-                                          (floatp obj)
-                                          (simple-array-nil-p obj)))
-                                (round-to-dualword
-                                 (* (room-info-length info) n-word-bytes)))
-                               ((:vector :string)
-                                (vector-total-size obj info))
-                               (:header
-                                (round-to-dualword
-                                 (* (1+ (get-header-data obj)) n-word-bytes)))
-                               (:code
-                                (+ (the fixnum
-                                     (* (get-header-data obj) n-word-bytes))
-                                   (round-to-dualword
-                                    (* (the fixnum (%code-code-size obj))
-                                       n-word-bytes)))))))
-                  (declare (fixnum size))
-                  (funcall fun obj header-widetag size)
-                  (aver (zerop (logand size lowtag-mask)))
-                  (setq current (sap+ current size))))))))))))
+  (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
+  (flet ((make-obj (tagged-address)
+           (if careful
+               (make-lisp-obj tagged-address nil)
+               (values (%make-lisp-obj tagged-address) t))))
+    ;; Inlining MAKE-OBJ reduces consing on platforms where dynamic
+    ;; space extends past fixnum range.
+    (declare (inline make-obj))
+    (without-gcing
+      (multiple-value-bind (start end) (space-bounds space)
+        (declare (type system-area-pointer start end))
+        (declare (optimize (speed 3)))
+        (let ((current start)
+              #!+gencgc
+              (skip-tests-until-addr 0))
+          (labels ((maybe-finish-mapping ()
+                     (unless (sap< current end)
+                       (aver (sap= current end))
+                       (return-from map-allocated-objects)))
+                   ;; GENCGC doesn't allocate linearly, which means that the
+                   ;; dynamic space can contain large blocks zeros that get
+                   ;; accounted as conses in ROOM (and slow down other
+                   ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
+                   ;; check the GC page structure for the current address.
+                   ;; If the page is free or the address is beyond the page-
+                   ;; internal allocation offset (bytes-used) skip to the
+                   ;; next page immediately.
+                   (maybe-skip-page ()
+                     #!+gencgc
+                     (when (eq space :dynamic)
+                       (loop with page-mask = #.(1- sb!vm:gencgc-card-bytes)
+                             for addr of-type sb!vm:word = (sap-int current)
+                             while (>= addr skip-tests-until-addr)
+                             do
+                             ;; For some reason binding PAGE with LET
+                             ;; conses like mad (but gives no compiler notes...)
+                             ;; Work around the problem with SYMBOL-MACROLET
+                             ;; instead of trying to figure out the real
+                             ;; issue. -- JES, 2005-05-17
+                             (symbol-macrolet
+                                 ((page (deref page-table
+                                               (find-page-index addr))))
+                               ;; Don't we have any nicer way to access C struct
+                               ;; bitfields?
+                               (let ((alloc-flag (ldb (byte 3 2)
+                                                      (slot page 'flags)))
+                                     (bytes-used (slot page 'bytes-used)))
+                                 ;; If the page is not free and the current
+                                 ;; pointer is still below the allocation offset
+                                 ;; of the page
+                                 (when (and (not (zerop alloc-flag))
+                                            (< (logand page-mask addr)
+                                               bytes-used))
+                                   ;; Don't bother testing again until we
+                                   ;; get past that allocation offset
+                                   (setf skip-tests-until-addr
+                                         (+ (logandc2 addr page-mask) bytes-used))
+                                   ;; And then continue with the
+                                   ;; scheduled mapping
+                                   (return-from maybe-skip-page))
+                                 ;; Move CURRENT to start of next page.
+                                 (setf current (int-sap (+ (logandc2 addr page-mask)
+                                                           sb!vm:gencgc-card-bytes)))
+                                 (maybe-finish-mapping))))))
+                   (maybe-map (obj obj-tag n-obj-bytes &optional (ok t))
+                     (let ((next (typecase n-obj-bytes
+                                   (fixnum (sap+ current n-obj-bytes))
+                                   (integer (sap+ current n-obj-bytes)))))
+                       ;; If this object would take us past END, it must
+                       ;; be either bogus, or it has been allocated after
+                       ;; the call to M-A-O.
+                       (cond ((and ok next (sap<= next end))
+                              (funcall fun obj obj-tag n-obj-bytes)
+                              (setf current next))
+                             (t
+                              (setf current (sap+ current n-word-bytes)))))))
+            (declare (inline maybe-finish-mapping maybe-skip-page maybe-map))
+            (loop
+              (maybe-finish-mapping)
+              (maybe-skip-page)
+              (let* ((header (sap-ref-word current 0))
+                     (header-widetag (logand header #xFF))
+                     (info (svref *room-info* header-widetag)))
+                (cond
+                  ((or (not info)
+                       (eq (room-info-kind info) :lowtag))
+                   (multiple-value-bind (obj ok)
+                       (make-obj (logior (sap-int current) list-pointer-lowtag))
+                     (maybe-map obj
+                                list-pointer-lowtag
+                                (* cons-size n-word-bytes)
+                                ok)))
+                  ((eq (room-info-kind info) :closure)
+                   (let* ((obj (%make-lisp-obj (logior (sap-int current)
+                                                       fun-pointer-lowtag)))
+                          (size (round-to-dualword
+                                 (* (the fixnum (1+ (get-closure-length obj)))
+                                    n-word-bytes))))
+                     (maybe-map obj header-widetag size)))
+                  ((eq (room-info-kind info) :instance)
+                   (let* ((obj (%make-lisp-obj
+                                (logior (sap-int current) instance-pointer-lowtag)))
+                          (size (round-to-dualword
+                                 (* (+ (%instance-length obj) 1) n-word-bytes))))
+                     (aver (zerop (logand size lowtag-mask)))
+                     (maybe-map obj header-widetag size)))
+                  (t
+                   (multiple-value-bind (obj ok)
+                       (make-obj (logior (sap-int current) other-pointer-lowtag))
+                     (let ((size (when ok
+                                   (ecase (room-info-kind info)
+                                     (:fixed
+                                      (aver (or (eql (room-info-length info)
+                                                     (1+ (get-header-data obj)))
+                                                (floatp obj)
+                                                (simple-array-nil-p obj)))
+                                      (round-to-dualword
+                                       (* (room-info-length info) n-word-bytes)))
+                                     ((:vector :string)
+                                      (vector-total-size obj info))
+                                     (:header
+                                      (round-to-dualword
+                                       (* (1+ (get-header-data obj)) n-word-bytes)))
+                                     (:code
+                                      (+ (the fixnum
+                                           (* (get-header-data obj) n-word-bytes))
+                                         (round-to-dualword
+                                          (* (the fixnum (%code-code-size obj))
+                                             n-word-bytes))))))))
+                       (macrolet ((frob ()
+                                    '(progn
+                                      (when size (aver (zerop (logand size lowtag-mask))))
+                                      (maybe-map obj header-widetag size))))
+                         (typecase size
+                           (fixnum (frob))
+                           (word (frob))
+                           (null (frob))))))))))))))))

 
 \f
 ;;;; MEMORY-USAGE
 
 \f
 ;;;; MEMORY-USAGE

@@ -351,11 +360,11 @@
 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 ;;; allocated in Space.
 (defun type-breakdown (space)
 ;;; Return a list of 3-lists (bytes object type-name) for the objects
 ;;; allocated in Space.
 (defun type-breakdown (space)

-  (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
-        (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
+  (let ((sizes (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))
+        (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))

     (map-allocated-objects
      (lambda (obj type size)
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+       (declare (word size) (optimize (speed 3)) (ignore obj))

        (incf (aref sizes type) size)
        (incf (aref counts type)))
      space)
        (incf (aref sizes type) size)
        (incf (aref counts type)))
      space)

@@ -395,7 +404,7 @@
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))

-                   (declare (fixnum sum))
+                   (declare (unsigned-byte sum))

                    (dolist (space-total v)
                      (incf sum (first (cdr space-total))))
                    (summary-totals (cons sum v))))
                    (dolist (space-total v)
                      (incf sum (first (cdr space-total))))
                    (summary-totals (cons sum v))))

@@ -404,13 +413,13 @@
       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
       (let ((summary-total-bytes 0)
             (summary-total-objects 0))
       (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
       (let ((summary-total-bytes 0)
             (summary-total-objects 0))

-        (declare (fixnum summary-total-bytes summary-total-objects))
+        (declare (unsigned-byte summary-total-bytes summary-total-objects))

         (dolist (space-totals
                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
           (let ((total-objects 0)
                 (total-bytes 0)
                 name)
         (dolist (space-totals
                  (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
           (let ((total-objects 0)
                 (total-bytes 0)
                 name)

-            (declare (fixnum total-objects total-bytes))
+            (declare (unsigned-byte total-objects total-bytes))

             (collect ((spaces))
               (dolist (space-total space-totals)
                 (let ((total (cdr space-total)))
             (collect ((spaces))
               (dolist (space-total space-totals)
                 (let ((total (cdr space-total)))

@@ -442,8 +451,8 @@
                            0))
          (reported-bytes 0)
          (reported-objects 0))
                            0))
          (reported-bytes 0)
          (reported-objects 0))

-    (declare (fixnum total-objects total-bytes cutoff-point reported-objects
-                     reported-bytes))
+    (declare (unsigned-byte total-objects total-bytes cutoff-point reported-objects
+                            reported-bytes))

     (loop for (bytes objects name) in types do
       (when (<= bytes cutoff-point)
         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"
     (loop for (bytes objects name) in types do
       (when (<= bytes cutoff-point)
         (format t "  ~10:D bytes for ~9:D other object~2:*~P.~%"

@@ -494,12 +503,12 @@
              (type unsigned-byte total-bytes))
     (map-allocated-objects
      (lambda (obj type size)
              (type unsigned-byte total-bytes))
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (safety 0)))

        (when (eql type code-header-widetag)
        (when (eql type code-header-widetag)

-         (incf total-bytes size)

          (let ((words (truly-the fixnum (%code-code-size obj)))
          (let ((words (truly-the fixnum (%code-code-size obj)))

-               (sap (truly-the system-area-pointer
-                               (%primitive code-instructions obj))))
+               (sap (%primitive code-instructions obj))
+               (size size))
+           (declare (fixnum size))
+           (incf total-bytes size)

            (incf code-words words)
            (dotimes (i words)
              (when (zerop (sap-ref-word sap (* i n-word-bytes)))
            (incf code-words words)
            (dotimes (i words)
              (when (zerop (sap-ref-word sap (* i n-word-bytes)))

@@ -523,11 +532,11 @@
       (declare (inline map-allocated-objects))
       (map-allocated-objects
        (lambda (obj type size)
       (declare (inline map-allocated-objects))
       (map-allocated-objects
        (lambda (obj type size)

-         (declare (fixnum size) (optimize (safety 0)))

          (case type
            (#.code-header-widetag
          (case type
            (#.code-header-widetag

-            (let ((inst-words (truly-the fixnum (%code-code-size obj))))
-              (declare (type fixnum inst-words))
+            (let ((inst-words (truly-the fixnum (%code-code-size obj)))
+                  (size size))
+              (declare (type fixnum size inst-words))

               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words
                     (- (truncate size n-word-bytes) inst-words))))
               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words
                     (- (truncate size n-word-bytes) inst-words))))

@@ -545,7 +554,6 @@
              #.simple-array-unsigned-byte-32-widetag
              #.simple-array-signed-byte-8-widetag
              #.simple-array-signed-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-signed-byte-32-widetag
              #.simple-array-single-float-widetag
              #.simple-array-double-float-widetag

@@ -571,7 +579,7 @@
              #.sap-widetag
              #.weak-pointer-widetag
              #.instance-header-widetag)
              #.sap-widetag
              #.weak-pointer-widetag
              #.instance-header-widetag)

-            (incf descriptor-words (truncate size n-word-bytes)))
+            (incf descriptor-words (truncate (the fixnum size) n-word-bytes)))

            (t
             (error "bogus widetag: ~W" type))))
        space))
            (t
             (error "bogus widetag: ~W" type))))
        space))

@@ -590,15 +598,17 @@
   (let ((totals (make-hash-table :test 'eq))
         (total-objects 0)
         (total-bytes 0))
   (let ((totals (make-hash-table :test 'eq))
         (total-objects 0)
         (total-bytes 0))

-    (declare (fixnum total-objects total-bytes))
+    (declare (unsigned-byte total-objects total-bytes))

     (map-allocated-objects
      (lambda (obj type size)
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (fixnum size) (optimize (speed 3) (safety 0)))
+       (declare (optimize (speed 3)))

        (when (eql type instance-header-widetag)
          (incf total-objects)
        (when (eql type instance-header-widetag)
          (incf total-objects)

-         (incf total-bytes size)

          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
          (let* ((classoid (layout-classoid (%instance-ref obj 0)))

-                (found (gethash classoid totals)))
+                (found (gethash classoid totals))
+                (size size))
+           (declare (fixnum size))
+           (incf total-bytes size)

            (cond (found
                   (incf (the fixnum (car found)))
                   (incf (the fixnum (cdr found)) size))
            (cond (found
                   (incf (the fixnum (car found)))
                   (incf (the fixnum (cdr found)) size))

@@ -615,7 +625,7 @@
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
             (printed-bytes 0)
             (printed-objects 0))
       (let ((sorted (sort (totals-list) #'> :key #'cddr))
             (printed-bytes 0)
             (printed-objects 0))

-        (declare (fixnum printed-bytes printed-objects))
+        (declare (unsigned-byte printed-bytes printed-objects))

         (dolist (what (if top-n
                           (subseq sorted 0 (min (length sorted) top-n))
                           sorted))
         (dolist (what (if top-n
                           (subseq sorted 0 (min (length sorted) top-n))
                           sorted))

@@ -664,7 +674,6 @@
                    (note-conses (cdr x)))))
         (map-allocated-objects
          (lambda (obj obj-type size)
                    (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
            (let ((addr (get-lisp-obj-address obj)))
              (when (>= addr start)
                (when (if count

@@ -745,7 +754,6 @@
     (let ((res ()))
       (map-allocated-objects
        (lambda (obj obj-type size)
     (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))
          (when (and (or (not type) (eql obj-type type))
                     (or (not smaller) (<= size smaller))
                     (or (not larger) (>= size larger))

@@ -756,6 +764,26 @@
        space)
       res)))
 
        space)
       res)))
 

+;;; Calls FUNCTION with all object that have (possibly conservative)
+;;; references to them on current stack.
+(defun map-stack-references (function)
+  (let ((end
+         (sb!di::descriptor-sap
+          #!+stack-grows-downward-not-upward *control-stack-end*
+          #!-stack-grows-downward-not-upward *control-stack-start*))
+        (sp (current-sp))
+        (seen nil))
+    (loop until #!+stack-grows-downward-not-upward (sap> sp end)
+                #!-stack-grows-downward-not-upward (sap< sp end)
+          do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
+               (when (and ok (typep obj '(not (or fixnum character))))
+                 (unless (member obj seen :test #'eq)
+                   (funcall function obj)
+                   (push obj seen))))
+             (setf sp
+                   #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
+                   #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
+

 (defun map-referencing-objects (fun space object)
   (declare (type spaces space) (inline map-allocated-objects))
   (unless *ignore-after*
 (defun map-referencing-objects (fun space object)
   (declare (type spaces space) (inline map-allocated-objects))
   (unless *ignore-after*

@@ -765,7 +793,7 @@
              (funcall fun obj))))
     (map-allocated-objects
      (lambda (obj obj-type size)
              (funcall fun obj))))
     (map-allocated-objects
      (lambda (obj obj-type size)

-       (declare (optimize (safety 0)) (ignore obj-type size))
+       (declare (ignore obj-type size))

        (typecase obj
          (cons
           (when (or (eq (car obj) object)
        (typecase obj
          (cons
           (when (or (eq (car obj) object)

@@ -792,7 +820,8 @@
           (when (or (eq (symbol-name obj) object)
                     (eq (symbol-package obj) object)
                     (eq (symbol-plist obj) object)
           (when (or (eq (symbol-name obj) object)
                     (eq (symbol-package obj) object)
                     (eq (symbol-plist obj) object)

-                    (eq (symbol-value obj) object))
+                    (and (boundp obj)
+                         (eq (symbol-value obj) object)))

             (maybe-call fun obj)))))
      space)))
 
             (maybe-call fun obj)))))
      space)))