From: Nikodemus Siivola Date: Mon, 16 Apr 2007 04:38:07 +0000 (+0000) Subject: 1.0.4.90: revert 1.0.4.89 changes to ROOM X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=08315e3cd273efbe55f8b85cf1c6e17016fbfd06;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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"