From 236ff428ec33a3c55a7c2248027aaad3c19588ff Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 26 Nov 2007 17:37:03 +0000 Subject: [PATCH] 1.0.12.1: more bogus FIXNUM declarations in ROOM * Test-case by Sidney Markowitz. --- NEWS | 4 ++++ src/code/room.lisp | 40 +++++++++++++++++++++++----------------- tests/stream.impure.lisp | 6 ++++++ version.lisp-expr | 2 +- 4 files changed, 34 insertions(+), 18 deletions(-) diff --git a/NEWS b/NEWS index 76e2308fd..e5cba1441 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.13 relative to sbcl-1.0.12: + * bug fix: more bogus fixnum declarations in ROOM implementation + have been fixed. + changes in sbcl-1.0.12 relative to sbcl-1.0.11: * new feature: MAKE-HASH-TABLE now experimentally accepts a :SYNCHRONIZED argument, which makes the hash-table safe for diff --git a/src/code/room.lisp b/src/code/room.lisp index 21234dcdc..d1813360d 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -186,8 +186,7 @@ ;;; 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)) @@ -342,10 +341,14 @@ (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)))))))))))) + (macrolet ((frob () + `(progn + (aver (zerop (logand size lowtag-mask))) + (setq current (sap+ current size))))) + (etypecase size + (fixnum (frob)) + (word (frob)))))))))))))) ;;;; MEMORY-USAGE @@ -357,7 +360,7 @@ (counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits)))) (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) @@ -496,12 +499,13 @@ (type unsigned-byte total-bytes)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size)) (when (eql type code-header-widetag) - (incf total-bytes size) (let ((words (truly-the fixnum (%code-code-size obj))) (sap (truly-the system-area-pointer - (%primitive code-instructions obj)))) + (%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))) @@ -525,11 +529,11 @@ (declare (inline map-allocated-objects)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size)) (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)))) @@ -547,7 +551,7 @@ #.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 @@ -573,7 +577,7 @@ #.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)) @@ -595,12 +599,14 @@ (declare (unsigned-byte total-objects total-bytes)) (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) - (incf total-bytes size) (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)) diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index 2db66068f..a45561de0 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -442,4 +442,10 @@ (when (probe-file test) (delete-file test))))) +;; ROOM used to bail out when there were object with bignum bytes in +;; them. Test by Sidney Markowitz. +(defparameter *large-array* + (make-array (- (truncate most-positive-fixnum 4) 2))) +(room) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 6355173c9..b561f2449 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.12" +"1.0.12.1" -- 2.11.4.GIT