(size (primitive-object-size obj)))
(cond
((not lowtag))
+ (;; KLUDGE described in dan_b message "Another one for the
+ ;; collection [bug 108]" (sbcl-devel 2004-01-22)
+ ;;
+ ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T)) causes
+ ;; debugger invoked on a SB-INT:BUG in thread 5911:
+ ;; failed AVER: "(SAP= CURRENT END)"
+ ;; [WHN: Similar things happened on one but not the other of my
+ ;; machines when I just run ROOM a lot in a loop.]
+ ;;
+ ;; This appears to be due to my [DB] abuse of the primitive
+ ;; object macros to define a thread object that shares a lowtag
+ ;; with fixnums and has no widetag: it looks like the code that
+ ;; generates *META-ROOM-INFO* infers from this that even fixnums
+ ;; are thread-sized - probably undesirable.
+ ;;
+ ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
+ ;; nature of a workaround than a really good fix. I'm not sure
+ ;; what a really good fix is: I /think/ it's probably to remove
+ ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
+ ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
+ ;; for assembly source in the runtime/genesis/*.h files.
+ (eql name 'thread))
((not widetag)
(let ((info (make-room-info :name name
:kind :lowtag))
(simple-vector-widetag . 2)
(simple-array-unsigned-byte-2-widetag . -2)
(simple-array-unsigned-byte-4-widetag . -1)
+ (simple-array-unsigned-byte-7-widetag . 0)
(simple-array-unsigned-byte-8-widetag . 0)
+ (simple-array-unsigned-byte-15-widetag . 1)
(simple-array-unsigned-byte-16-widetag . 1)
+ (simple-array-unsigned-byte-31-widetag . 2)
(simple-array-unsigned-byte-32-widetag . 2)
(simple-array-signed-byte-8-widetag . 0)
(simple-array-signed-byte-16-widetag . 1)
+ (simple-array-unsigned-byte-29-widetag . 2)
(simple-array-signed-byte-30-widetag . 2)
(simple-array-signed-byte-32-widetag . 2)
(simple-array-single-float-widetag . 2)
(values))
\f
-(defun find-holes (&rest spaces)
- (dolist (space (or spaces '(:read-only :static :dynamic)))
- (format t "In ~A space:~%" space)
- (let ((start-addr nil)
- (total-bytes 0))
- (declare (type (or null (unsigned-byte 32)) start-addr)
- (type (unsigned-byte 32) total-bytes))
- (map-allocated-objects
- (lambda (object typecode bytes)
- (declare (ignore typecode)
- (type (unsigned-byte 32) bytes))
- (if (and (consp object)
- (eql (car object) 0)
- (eql (cdr object) 0))
- (if start-addr
- (incf total-bytes bytes)
- (setf start-addr (sb!di::get-lisp-obj-address object)
- total-bytes bytes))
- (when start-addr
- (format t "~:D bytes at #X~X~%" total-bytes start-addr)
- (setf start-addr nil))))
- space)
- (when start-addr
- (format t "~:D bytes at #X~X~%" total-bytes start-addr))))
- (values))
-\f
;;;; PRINT-ALLOCATED-OBJECTS
(defun print-allocated-objects (space &key (percent 0) (pages 5)