* Test-case by Sidney Markowitz.
;;;; -*- coding: utf-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
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
;;; 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))
(round-to-dualword
(* (the fixnum (%code-code-size 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)
(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))))))))))))))
(counts (make-array 256 :initial-element 0 :element-type '(unsigned-byte #.sb!vm:n-word-bits))))
(map-allocated-objects
(lambda (obj type size)
(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)
(incf (aref sizes type) size)
(incf (aref counts type)))
space)
(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)))
(sap (truly-the system-area-pointer
(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)))
(incf code-words words)
(dotimes (i words)
(when (zerop (sap-ref-word sap (* i n-word-bytes)))
(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))))
#.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
#.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))
(declare (unsigned-byte total-objects total-bytes))
(map-allocated-objects
(lambda (obj type size)
(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)
(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))
(when (probe-file test)
(delete-file test)))))
(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)
+
;;; 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".)