(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))
:kind :fixed
:length size))))))
-(dolist (code (list complex-base-string-widetag simple-array-widetag
+(dolist (code (list #!+sb-unicode complex-character-string-widetag
+ complex-base-string-widetag simple-array-widetag
complex-bit-vector-widetag complex-vector-widetag
complex-array-widetag complex-vector-nil-widetag))
(setf (svref *meta-room-info* code)
(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)
:kind :string
:length 0))
+#!+sb-unicode
+(setf (svref *meta-room-info* simple-character-string-widetag)
+ (make-room-info :name 'simple-character-string
+ :kind :string
+ :length 2))
+
(setf (svref *meta-room-info* simple-array-nil-widetag)
(make-room-info :name 'simple-array-nil
:kind :fixed
(ash len shift)))))))
;;; Iterate over all the objects allocated in SPACE, calling FUN with
-;;; the object, the object's type code, and the objects total size in
+;;; the object, the object's type code, and the object's total size in
;;; bytes, including any header and padding.
#!-sb-fluid (declaim (maybe-inline map-allocated-objects))
(defun map-allocated-objects (fun space)
#.single-float-widetag
#.double-float-widetag
#.simple-base-string-widetag
+ #!+sb-unicode #.simple-character-string-widetag
#.simple-array-nil-widetag
#.simple-bit-vector-widetag
#.simple-array-unsigned-byte-2-widetag
(values)))
\f
;;; Print a breakdown by instance type of all the instances allocated
-;;; in SPACE. If TOP-N is true, print only information for the the
+;;; in SPACE. If TOP-N is true, print only information for the
;;; TOP-N types with largest usage.
(defun instance-usage (space &key (top-n 15))
(declare (type spaces space) (type (or fixnum null) top-n))
(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)
(defvar *ignore-after* nil)
+(defun valid-obj (space x)
+ (or (not (eq space :dynamic))
+ ;; this test looks bogus if the allocator doesn't work linearly,
+ ;; which I suspect is the case for GENCGC. -- CSR, 2004-06-29
+ (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*))))
+
(defun maybe-cons (space x stuff)
- (if (or (not (eq space :dynamic))
- (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
+ (if (valid-obj space x)
(cons x stuff)
stuff))
(type (or index null) larger smaller type count)
(type (or function null) test)
(inline map-allocated-objects))
- (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
+ (unless *ignore-after*
+ (setq *ignore-after* (cons 1 2)))
(collect ((counted 0 1+))
(let ((res ()))
(map-allocated-objects
space)
res)))
-(defun list-referencing-objects (space object)
+(defun map-referencing-objects (fun space object)
(declare (type spaces space) (inline map-allocated-objects))
- (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
- (let ((res ()))
- (flet ((res (x)
- (setq res (maybe-cons space x res))))
- (map-allocated-objects
- (lambda (obj obj-type size)
- (declare (optimize (safety 0)) (ignore obj-type size))
- (typecase obj
- (cons
- (when (or (eq (car obj) object) (eq (cdr obj) object))
- (res obj)))
- (instance
- (dotimes (i (%instance-length obj))
- (when (eq (%instance-ref obj i) object)
- (res obj)
- (return))))
- (simple-vector
- (dotimes (i (length obj))
- (when (eq (svref obj i) object)
- (res obj)
- (return))))
- (symbol
- (when (or (eq (symbol-name obj) object)
- (eq (symbol-package obj) object)
- (eq (symbol-plist obj) object)
- (eq (symbol-value obj) object))
- (res obj)))))
- space))
- res))
+ (unless *ignore-after*
+ (setq *ignore-after* (cons 1 2)))
+ (flet ((maybe-call (fun obj)
+ (when (valid-obj space obj)
+ (funcall fun obj))))
+ (map-allocated-objects
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)) (ignore obj-type size))
+ (typecase obj
+ (cons
+ (when (or (eq (car obj) object)
+ (eq (cdr obj) object))
+ (maybe-call fun obj)))
+ (instance
+ (dotimes (i (%instance-length obj))
+ (when (eq (%instance-ref obj i) object)
+ (maybe-call fun obj)
+ (return))))
+ (code-component
+ (let ((length (get-header-data obj)))
+ (do ((i code-constants-offset (1+ i)))
+ ((= i length))
+ (when (eq (code-header-ref obj i) object)
+ (maybe-call fun obj)
+ (return)))))
+ (simple-vector
+ (dotimes (i (length obj))
+ (when (eq (svref obj i) object)
+ (maybe-call fun obj)
+ (return))))
+ (symbol
+ (when (or (eq (symbol-name obj) object)
+ (eq (symbol-package obj) object)
+ (eq (symbol-plist obj) object)
+ (eq (symbol-value obj) object))
+ (maybe-call fun obj)))))
+ space)))
+
+(defun list-referencing-objects (space object)
+ (collect ((res))
+ (map-referencing-objects
+ (lambda (obj) (res obj)) space object)
+ (res)))
projects / sbcl.git / blobdiff