1.0.4.90: revert 1.0.4.89 changes to ROOM

 * Cleaned up version conses too much.

 * Record the bug .89 was supposed to fix.

diff --git a/BUGS b/BUGS
index 34cebd6..a7e6412 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1793,5 +1793,17 @@ WORKAROUND:
   disabled on those platforms. Since x86 does not exhibit any problems
   the problem is probably with the new FP implementation.
 
   disabled on those platforms. Since x86 does not exhibit any problems
   the problem is probably with the new FP implementation.
 

-412: deletion of global variable references in safe code
-  fixed in 1.0.4.45.
+413: type-errors in ROOM
+
+  (defvar *a* (make-array (expt 2 27)))
+  (room)
+
+  Causes a type-error on 32bit SBCL, as various byte-counts in ROOM
+  implementation overrun fixnums. 
+
+  This was fixed in 1.0.4.89, but the patch was reverted as it caused
+  ROOM to cons sufficiently to make running it in a loop deadly on
+  GENCGC: newly allocated objects survived to generation 1, where next
+  call to ROOM would see them, and allocate even more...
+
+  Reported by Faré Rideau on sbcl-devel.

diff --git a/NEWS b/NEWS
index 7d0d88c..a16f505 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -22,8 +22,6 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4:
     to global variables using SYMBOL-VALUE and a constant argument.
   * enhancement: SIGINT now causes a specific condition
     SB-SYS:INTERACTIVE-INTERRUPT to be signalled.
     to global variables using SYMBOL-VALUE and a constant argument.
   * enhancement: SIGINT now causes a specific condition
     SB-SYS:INTERACTIVE-INTERRUPT to be signalled.

-  * bug fix: ROOM sometimes failed with a type-error due to byte-counts
-    not fitting into a fixnum. (reported by Faré Rideau)

   * bug fix: ADJUST-ARRAY is now interrupt-safe.
   * bug fix: adding and removing fd-handlers is now interrupt-safe.
   * bug fix: inlined calls to C now ensure 16byte stack alignment on
   * bug fix: ADJUST-ARRAY is now interrupt-safe.
   * bug fix: adding and removing fd-handlers is now interrupt-safe.
   * bug fix: inlined calls to C now ensure 16byte stack alignment on

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 803e1e7..21bbfb9 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -186,16 +186,14 @@
 ;;; 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 (unsigned-byte size))
-  (ldb (byte n-word-bits 0)
-       (logand (+ size lowtag-mask) (lognot lowtag-mask))))
+  (declare (fixnum size))
+  (logand (the fixnum (+ 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))
 (defun vector-total-size (obj info)
 
 ;;; Return the total size of a vector in bytes, including any pad.
 #!-sb-fluid (declaim (inline vector-total-size))
 (defun vector-total-size (obj info)

-  (declare (type (simple-array * (*)) obj))

   (let ((shift (room-info-length info))
   (let ((shift (room-info-length info))

-        (len (+ (length obj)
+        (len (+ (length (the (simple-array * (*)) obj))

                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))

@@ -280,7 +278,8 @@
                                 ;; Don't bother testing again until we
                                 ;; get past that allocation offset
                                 (setf skip-tests-until-addr
                                 ;; Don't bother testing again until we
                                 ;; get past that allocation offset
                                 (setf skip-tests-until-addr

-                                      (+ (logandc2 addr page-mask) bytes-used))
+                                      (+ (logandc2 addr page-mask)
+                                         (the fixnum bytes-used)))

                                 ;; And then continue with the scheduled
                                 ;; mapping
                                 (return-from maybe-skip-page))
                                 ;; And then continue with the scheduled
                                 ;; mapping
                                 (return-from maybe-skip-page))

@@ -309,7 +308,8 @@
                 (let* ((obj (make-lisp-obj (logior (sap-int current)
                                                    fun-pointer-lowtag)))
                        (size (round-to-dualword
                 (let* ((obj (make-lisp-obj (logior (sap-int current)
                                                    fun-pointer-lowtag)))
                        (size (round-to-dualword

-                              (* (1+ (get-closure-length obj)) n-word-bytes))))
+                              (* (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)
                   (funcall fun obj header-widetag size)
                   (setq current (sap+ current size))))
                ((eq (room-info-kind info) :instance)

@@ -338,9 +338,12 @@
                                 (round-to-dualword
                                  (* (1+ (get-header-data obj)) n-word-bytes)))
                                (:code
                                 (round-to-dualword
                                  (* (1+ (get-header-data obj)) n-word-bytes)))
                                (:code

-                                (+ (* (get-header-data obj) n-word-bytes)
+                                (+ (the fixnum
+                                     (* (get-header-data obj) n-word-bytes))

                                    (round-to-dualword
                                    (round-to-dualword

-                                    (* (%code-code-size obj) n-word-bytes)))))))
+                                    (* (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))))))))))))
                   (funcall fun obj header-widetag size)
                   (aver (zerop (logand size lowtag-mask)))
                   (setq current (sap+ current size))))))))))))

@@ -351,11 +354,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))
+  (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))

         (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
     (map-allocated-objects
      (lambda (obj type size)
         (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
     (map-allocated-objects
      (lambda (obj type size)

-       (declare (index type) (optimize (speed 3)) (ignore obj))
+       (declare (fixnum 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,6 +398,7 @@
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))
       (maphash (lambda (k v)
                  (declare (ignore k))
                  (let ((sum 0))

+                   (declare (fixnum 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))))

@@ -403,13 +407,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-objects))
+        (declare (fixnum 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))
+            (declare (fixnum 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)))

@@ -441,7 +445,8 @@
                            0))
          (reported-bytes 0)
          (reported-objects 0))
                            0))
          (reported-bytes 0)
          (reported-objects 0))

-    (declare (fixnum total-objects cutoff-point reported-objects))
+    (declare (fixnum 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.~%"

@@ -495,8 +500,9 @@
        (declare (fixnum size))
        (when (eql type code-header-widetag)
          (incf total-bytes size)
        (declare (fixnum size))
        (when (eql type code-header-widetag)
          (incf total-bytes size)

-         (let ((words (%code-code-size obj))
-               (sap (code-instructions obj)))
+         (let ((words (truly-the fixnum (%code-code-size obj)))
+               (sap (truly-the system-area-pointer
+                               (%primitive code-instructions obj))))

            (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,7 +529,7 @@
          (declare (fixnum size))
          (case type
            (#.code-header-widetag
          (declare (fixnum size))
          (case type
            (#.code-header-widetag

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

               (declare (type fixnum inst-words))
               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words
               (declare (type fixnum inst-words))
               (incf non-descriptor-bytes (* inst-words n-word-bytes))
               (incf descriptor-words

@@ -587,7 +593,7 @@
   (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))
+    (declare (fixnum total-objects total-bytes))

     (map-allocated-objects
      (lambda (obj type size)
        (declare (fixnum size) (optimize (speed 3)))
     (map-allocated-objects
      (lambda (obj type size)
        (declare (fixnum size) (optimize (speed 3)))

@@ -597,8 +603,8 @@
          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
                 (found (gethash classoid totals)))
            (cond (found
          (let* ((classoid (layout-classoid (%instance-ref obj 0)))
                 (found (gethash classoid totals)))
            (cond (found

-                  (incf (car found))
-                  (incf (cdr found) size))
+                  (incf (the fixnum (car found)))
+                  (incf (the fixnum (cdr found)) size))

                  (t
                   (setf (gethash classoid totals) (cons 1 size)))))))
      space)
                  (t
                   (setf (gethash classoid totals) (cons 1 size)))))))
      space)

@@ -612,7 +618,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-objects))
+        (declare (fixnum 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))

@@ -669,7 +675,9 @@
                  (return-from print-allocated-objects (values)))
 
                (unless count
                  (return-from print-allocated-objects (values)))
 
                (unless count

-                 (let ((this-page (* (truncate addr pagesize) pagesize)))
+                 (let ((this-page (* (the (values (unsigned-byte 32) t)
+                                       (truncate addr pagesize))
+                                     pagesize)))

                    (declare (type (unsigned-byte 32) this-page))
                    (when (/= this-page last-page)
                      (when (< pages-so-far pages)
                    (declare (type (unsigned-byte 32) this-page))
                    (when (/= this-page last-page)
                      (when (< pages-so-far pages)

diff --git a/version.lisp-expr b/version.lisp-expr
index 61aeec1..fbcba94 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"1.0.4.89"
+"1.0.4.90"