1.0.28.41: make MAKE-ARRAY transforms co-operate with FILL better

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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 21bbfb9..328ca45 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
 

@@ -186,8 +189,7 @@
 ;;; platforms with 64-bit word size.
 #!-sb-fluid (declaim (inline round-to-dualword))
 (defun round-to-dualword (size)
 ;;; platforms with 64-bit word 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))

@@ -215,7 +217,7 @@
               ;; will be a short. On platforms with larger ones, it'll
               ;; be an int.
               (bytes-used (unsigned
               ;; will be a short. On platforms with larger ones, it'll
               ;; be an int.
               (bytes-used (unsigned

-                           #.(if (typep sb!vm:gencgc-page-size
+                           #.(if (typep sb!vm:gencgc-page-bytes

                                         '(unsigned-byte 16))
                                  16
                                  32)))
                                         '(unsigned-byte 16))
                                  16
                                  32)))

@@ -227,126 +229,149 @@
 
 ;;; 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)))
-     (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))))))))))))
+  (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-page-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-page-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)))
+                  ((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))))
+                     (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

@@ -354,11 +379,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)) (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)

@@ -398,7 +423,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))))

@@ -407,13 +432,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)))

@@ -445,8 +470,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.~%"

@@ -497,12 +522,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))

        (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)))

@@ -526,11 +551,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))

          (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))))

@@ -548,7 +573,7 @@
              #.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-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

@@ -574,7 +599,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))

@@ -593,15 +618,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)))
+       (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))

@@ -618,7 +645,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))

@@ -793,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)))