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.
 
-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.
-  * 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

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)
-  (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)
-  (declare (type (simple-array * (*)) obj))
   (let ((shift (room-info-length info))
-        (len (+ (length obj)
+        (len (+ (length (the (simple-array * (*)) obj))
                 (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
-                                      (+ (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))
@@ -309,7 +308,8 @@
                 (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)
@@ -338,9 +338,12 @@
                                 (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
-                                    (* (%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))))))))))))
@@ -351,11 +354,11 @@
 ;;; 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)
-       (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)
@@ -395,6 +398,7 @@
       (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))))
@@ -403,13 +407,13 @@
       (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)
-            (declare (fixnum total-objects))
+            (declare (fixnum total-objects total-bytes))
             (collect ((spaces))
               (dolist (space-total space-totals)
                 (let ((total (cdr space-total)))
@@ -441,7 +445,8 @@
                            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.~%"
@@ -495,8 +500,9 @@
        (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)))
@@ -523,7 +529,7 @@
          (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
@@ -587,7 +593,7 @@
   (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)))
@@ -597,8 +603,8 @@
          (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)
@@ -612,7 +618,7 @@
       (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))
@@ -669,7 +675,9 @@
                  (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)

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".)
-"1.0.4.89"
+"1.0.4.90"