(eval-when (:compile-toplevel :load-toplevel :execute)
(def!struct (room-info (:make-load-form-fun just-dump-it-normally))
- ;; The name of this type.
+ ;; the name of this type
(name nil :type symbol)
- ;; Kind of type (how we determine length).
- (kind (required-argument)
+ ;; kind of type (how we determine length)
+ (kind (missing-arg)
:type (member :lowtag :fixed :header :vector
:string :code :closure :instance))
- ;; Length if fixed-length, shift amount for element size if :VECTOR.
+ ;; length if fixed-length, shift amount for element size if :VECTOR
(length nil :type (or fixnum null))))
(eval-when (:compile-toplevel :execute)
(let ((widetag (primitive-object-widetag obj))
(lowtag (primitive-object-lowtag obj))
(name (primitive-object-name obj))
- (variable (primitive-object-variable-length obj))
+ (variable (primitive-object-variable-length-p obj))
(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-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-array-widetag complex-vector-nil-widetag))
(setf (svref *meta-room-info* code)
(make-room-info :name 'array-header
:kind :header)))
(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)
(simple-array-double-float-widetag . 3)
(simple-array-complex-single-float-widetag . 3)
(simple-array-complex-double-float-widetag . 4)))
- (let ((name (car stuff))
- (size (cdr stuff)))
+ (let* ((name (car stuff))
+ (size (cdr stuff))
+ (sname (string name)))
(setf (svref *meta-room-info* (symbol-value name))
- (make-room-info :name name
+ (make-room-info :name (intern (subseq sname
+ 0
+ (mismatch sname "-WIDETAG"
+ :from-end t)))
:kind :vector
:length size))))
-(setf (svref *meta-room-info* simple-string-widetag)
- (make-room-info :name 'simple-string-widetag
+(setf (svref *meta-room-info* simple-base-string-widetag)
+ (make-room-info :name 'simple-base-string
: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
+ :length 2))
+
(setf (svref *meta-room-info* code-header-widetag)
(make-room-info :name 'code
:kind :code))
(make-room-info :name 'instance
:kind :instance))
-); eval-when (compile eval)
+) ; EVAL-WHEN
(defparameter *room-info* '#.*meta-room-info*)
(deftype spaces () '(member :static :dynamic :read-only))
(values (int-sap read-only-space-start)
(int-sap (* *read-only-space-free-pointer* n-word-bytes))))
(:dynamic
- (values (int-sap dynamic-space-start)
+ (values (int-sap #!+gencgc dynamic-space-start
+ #!-gencgc (current-dynamic-space-start))
(dynamic-space-free-pointer)))))
;;; Return the total number of bytes used in SPACE.
(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)
(:fixed
(aver (or (eql (room-info-length info)
(1+ (get-header-data obj)))
- (floatp obj)))
+ (floatp obj)
+ (simple-array-nil-p obj)))
(round-to-dualword
(* (room-info-length info) n-word-bytes)))
((:vector :string)
(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 (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
- (incf (aref sizes type) size)
- (incf (aref counts type)))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+ (incf (aref sizes type) size)
+ (incf (aref counts type)))
space)
(let ((totals (make-hash-table :test 'eq)))
(list total-size total-count name))))))))
(collect ((totals-list))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (totals-list v))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (totals-list v))
totals)
(sort (totals-list) #'> :key #'first)))))
(gethash (third total) summary))))
(collect ((summary-totals))
- (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))))
+ (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))))
summary)
(format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
(format t "~%~A:~% ~:D bytes, ~:D object~:P"
name total-bytes total-objects)
(dolist (space (spaces))
- (format t ", ~D% ~(~A~)"
+ (format t ", ~W% ~(~A~)"
(round (* (cdr space) 100) total-bytes)
(car space)))
(format t ".~%")
(let* ((spaces (if (eq count-spaces t)
'(:static :dynamic :read-only)
count-spaces))
- (totals (mapcar #'(lambda (space)
- (cons space (type-breakdown space)))
+ (totals (mapcar (lambda (space)
+ (cons space (type-breakdown space)))
spaces)))
(dolist (space-total totals)
(declare (fixnum code-words no-ops)
(type unsigned-byte total-bytes))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
- (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))))
- (incf code-words words)
- (dotimes (i words)
- (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
- (incf no-ops))))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (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))))
+ (incf code-words words)
+ (dotimes (i words)
+ (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
+ (incf no-ops))))))
space)
(format t
(dolist (space (or spaces '(:read-only :static :dynamic)))
(declare (inline map-allocated-objects))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
- (case type
- (#.code-header-widetag
- (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
- (- (truncate size n-word-bytes) inst-words))))
- ((#.bignum-widetag
- #.single-float-widetag
- #.double-float-widetag
- #.simple-string-widetag
- #.simple-bit-vector-widetag
- #.simple-array-unsigned-byte-2-widetag
- #.simple-array-unsigned-byte-4-widetag
- #.simple-array-unsigned-byte-8-widetag
- #.simple-array-unsigned-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-32-widetag
- #.simple-array-single-float-widetag
- #.simple-array-double-float-widetag
- #.simple-array-complex-single-float-widetag
- #.simple-array-complex-double-float-widetag)
- (incf non-descriptor-headers)
- (incf non-descriptor-bytes (- size n-word-bytes)))
- ((#.list-pointer-lowtag
- #.instance-pointer-lowtag
- #.ratio-widetag
- #.complex-widetag
- #.simple-array-widetag
- #.simple-vector-widetag
- #.complex-string-widetag
- #.complex-bit-vector-widetag
- #.complex-vector-widetag
- #.complex-array-widetag
- #.closure-header-widetag
- #.funcallable-instance-header-widetag
- #.value-cell-header-widetag
- #.symbol-header-widetag
- #.sap-widetag
- #.weak-pointer-widetag
- #.instance-header-widetag)
- (incf descriptor-words (truncate size n-word-bytes)))
- (t
- (error "bogus type: ~D" type))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (case type
+ (#.code-header-widetag
+ (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
+ (- (truncate size n-word-bytes) inst-words))))
+ ((#.bignum-widetag
+ #.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
+ #.simple-array-unsigned-byte-4-widetag
+ #.simple-array-unsigned-byte-8-widetag
+ #.simple-array-unsigned-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-32-widetag
+ #.simple-array-single-float-widetag
+ #.simple-array-double-float-widetag
+ #.simple-array-complex-single-float-widetag
+ #.simple-array-complex-double-float-widetag)
+ (incf non-descriptor-headers)
+ (incf non-descriptor-bytes (- size n-word-bytes)))
+ ((#.list-pointer-lowtag
+ #.instance-pointer-lowtag
+ #.ratio-widetag
+ #.complex-widetag
+ #.simple-array-widetag
+ #.simple-vector-widetag
+ #.complex-base-string-widetag
+ #.complex-vector-nil-widetag
+ #.complex-bit-vector-widetag
+ #.complex-vector-widetag
+ #.complex-array-widetag
+ #.closure-header-widetag
+ #.funcallable-instance-header-widetag
+ #.value-cell-header-widetag
+ #.symbol-header-widetag
+ #.sap-widetag
+ #.weak-pointer-widetag
+ #.instance-header-widetag)
+ (incf descriptor-words (truncate size n-word-bytes)))
+ (t
+ (error "bogus widetag: ~W" type))))
space))
(format t "~:D words allocated for descriptor objects.~%"
descriptor-words)
(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))
- (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
+ (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space)
(let ((totals (make-hash-table :test 'eq))
(total-objects 0)
(total-bytes 0))
(declare (fixnum total-objects total-bytes))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (speed 3) (safety 0)))
- (when (eql type instance-header-widetag)
- (incf total-objects)
- (incf total-bytes size)
- (let* ((class (layout-class (%instance-ref obj 0)))
- (found (gethash class totals)))
- (cond (found
- (incf (the fixnum (car found)))
- (incf (the fixnum (cdr found)) size))
- (t
- (setf (gethash class totals) (cons 1 size)))))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)))
+ (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)))
+ (cond (found
+ (incf (the fixnum (car found)))
+ (incf (the fixnum (cdr found)) size))
+ (t
+ (setf (gethash classoid totals) (cons 1 size)))))))
space)
(collect ((totals-list))
- (maphash #'(lambda (class what)
- (totals-list (cons (prin1-to-string
- (class-proper-name class))
- what)))
+ (maphash (lambda (classoid what)
+ (totals-list (cons (prin1-to-string
+ (classoid-proper-name classoid))
+ what)))
totals)
(let ((sorted (sort (totals-list) #'> :key #'cddr))
(printed-bytes 0)
(objects (cadr what)))
(incf printed-bytes bytes)
(incf printed-objects objects)
- (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
+ (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what)
bytes objects)))
(let ((residual-objects (- total-objects printed-objects))
(residual-bytes (- total-bytes printed-bytes)))
(unless (zerop residual-objects)
- (format t " Other types: ~:D bytes, ~D object~:P.~%"
+ (format t " Other types: ~:D bytes, ~:D object~:P.~%"
residual-bytes residual-objects))))
(format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
(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)
type larger smaller count
(stream *standard-output*))
- (declare (type (integer 0 99) percent) (type sb!c::index pages)
+ (declare (type (integer 0 99) percent) (type index pages)
(type stream stream) (type spaces space)
- (type (or sb!c::index null) type larger smaller count))
+ (type (or index null) type larger smaller count))
(multiple-value-bind (start-sap end-sap) (space-bounds space)
(let* ((space-start (sap-int start-sap))
(space-end (sap-int end-sap))
(note-conses (car x))
(note-conses (cdr x)))))
(map-allocated-objects
- #'(lambda (obj obj-type size)
- (declare (optimize (safety 0)))
- (let ((addr (get-lisp-obj-address obj)))
- (when (>= addr start)
- (when (if count
- (> count-so-far count)
- (> pages-so-far pages))
- (return-from print-allocated-objects (values)))
-
- (unless count
- (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)
- ;; FIXME: What is this? (ERROR "Argh..")? or
- ;; a warning? or code that can be removed
- ;; once the system is stable? or what?
- (format stream "~2&**** Page ~D, address ~X:~%"
- pages-so-far addr))
- (setq last-page this-page)
- (incf pages-so-far))))
-
- (when (and (or (not type) (eql obj-type type))
- (or (not smaller) (<= size smaller))
- (or (not larger) (>= size larger)))
- (incf count-so-far)
- (case type
- (#.code-header-widetag
- (let ((dinfo (%code-debug-info obj)))
- (format stream "~&Code object: ~S~%"
- (if dinfo
- (sb!c::compiled-debug-info-name dinfo)
- "No debug info."))))
- (#.symbol-header-widetag
- (format stream "~&~S~%" obj))
- (#.list-pointer-lowtag
- (unless (gethash obj printed-conses)
- (note-conses obj)
- (let ((*print-circle* t)
- (*print-level* 5)
- (*print-length* 10))
- (format stream "~&~S~%" obj))))
- (t
- (fresh-line stream)
- (let ((str (write-to-string obj :level 5 :length 10
- :pretty nil)))
- (unless (eql type instance-header-widetag)
- (format stream "~S: " (type-of obj)))
- (format stream "~A~%"
- (subseq str 0 (min (length str) 60))))))))))
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (let ((addr (get-lisp-obj-address obj)))
+ (when (>= addr start)
+ (when (if count
+ (> count-so-far count)
+ (> pages-so-far pages))
+ (return-from print-allocated-objects (values)))
+
+ (unless count
+ (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)
+ ;; FIXME: What is this? (ERROR "Argh..")? or
+ ;; a warning? or code that can be removed
+ ;; once the system is stable? or what?
+ (format stream "~2&**** Page ~W, address ~X:~%"
+ pages-so-far addr))
+ (setq last-page this-page)
+ (incf pages-so-far))))
+
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger)))
+ (incf count-so-far)
+ (case type
+ (#.code-header-widetag
+ (let ((dinfo (%code-debug-info obj)))
+ (format stream "~&Code object: ~S~%"
+ (if dinfo
+ (sb!c::compiled-debug-info-name dinfo)
+ "No debug info."))))
+ (#.symbol-header-widetag
+ (format stream "~&~S~%" obj))
+ (#.list-pointer-lowtag
+ (unless (gethash obj printed-conses)
+ (note-conses obj)
+ (let ((*print-circle* t)
+ (*print-level* 5)
+ (*print-length* 10))
+ (format stream "~&~S~%" obj))))
+ (t
+ (fresh-line stream)
+ (let ((str (write-to-string obj :level 5 :length 10
+ :pretty nil)))
+ (unless (eql type instance-header-widetag)
+ (format stream "~S: " (type-of obj)))
+ (format stream "~A~%"
+ (subseq str 0 (min (length str) 60))))))))))
space))))
(values))
\f
(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))
(defun list-allocated-objects (space &key type larger smaller count
test)
(declare (type spaces space)
- (type (or sb!c::index null) larger smaller type count)
+ (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
- #'(lambda (obj obj-type size)
- (declare (optimize (safety 0)))
- (when (and (or (not type) (eql obj-type type))
- (or (not smaller) (<= size smaller))
- (or (not larger) (>= size larger))
- (or (not test) (funcall test obj)))
- (setq res (maybe-cons space obj res))
- (when (and count (>= (counted) count))
- (return-from list-allocated-objects res))))
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger))
+ (or (not test) (funcall test obj)))
+ (setq res (maybe-cons space obj res))
+ (when (and count (>= (counted) count))
+ (return-from list-allocated-objects res))))
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