;;;
;;; Known deficiencies:
;;;
-;;; * flags CATCH tags as stale;
-;;; * flags constants (under certain circumstances) as stale;
;;; * output is not necessarily terribly clear;
;;; * takes a long time (several hours on CSR's 300MHz x86 desktop) to
;;; run.
;;; only one reference that looks like it is likely from the internals
;;; of a package-related datastructure, the name of the symbol and its
;;; package is displayed.
+;;;
;;; The "references to that symbol" are found using the function
-;;; VM::LIST-REFERENCING-OBJECTS. Consider for example a function that
-;;; uses the value of a symbol. The code-object for that function
+;;; SB-VM::MAP-REFERENCING-OBJECTS. Consider for example a function
+;;; that uses the value of a symbol. The code-object for that function
;;; contains a reference to the symbol, so that a call to SYMBOL-VALUE
;;; can be made at runtime. The data structures corresponding to a
;;; package must maintain a list of its exported an imported symbols.
;;; They contain a hashtable, which contains a vector, which contains
-;;; symbols. So all exported symbols will have at least one referencing
-;;; object: a vector related to some package.
-;;;
-;;; Limitations: these routines will provide a number of false
-;;; positives (symbols that are not actually stale). Throw/catch tags
-;;; are displayed, but are not stale. It displays the names of
-;;; restarts. Worse, it displays the names of CMUCL-internal constants.
-;;; These symbols that name constants are not referenced from anywhere
-;;; except the package datastructures because the compiler can
-;;; substitute their value wherever they're used in the CMUCL source
-;;; code, without keeping a reference to the symbol hanging around.
-;;; There are also a number of PCL-related symbols that are displayed,
-;;; but probably used internally by PCL.
+;;; symbols. So all exported symbols will have at least one
+;;; referencing object: a vector related to some package.
;;;
-;;; Moral: the output of these routines must be checked carefully
-;;; before going on a code deletion spree.
+;;; Limitations: these routines may provide a number of false
+;;; positives (symbols that are not actually stale). There are also a
+;;; number of PCL-related symbols that are displayed, but probably
+;;; used internally by PCL. Moral: the output of these routines must
+;;; be checked carefully before going on a code deletion spree.
(defun print-stale-reference (obj stream)
(cond ((vectorp obj)
(format stream "vector (probable package internals)"))
((sb-c::compiled-debug-fun-p obj)
- (format stream "#<compiled-debug-fun ~a>"
+ (format stream "#<compiled-debug-fun ~A>"
(sb-c::compiled-debug-fun-name obj)))
+ ((sb-kernel:code-component-p obj)
+ (format stream "#<code ~A>"
+ (let ((dinfo (sb-kernel:%code-debug-info obj)))
+ (cond
+ ((eq dinfo :bogus-lra) "BOGUS-LRA")
+ (t (sb-c::debug-info-name dinfo))))))
(t
(format stream "~w" obj))))
+(defun external-symbol-p (obj)
+ (declare (type symbol obj))
+ (let ((package (symbol-package obj)))
+ (and package
+ (eq (nth-value 1 (find-symbol (symbol-name obj) package))
+ :external))))
+
(defun find-stale-objects ()
(dolist (space '(:static :dynamic :read-only))
(sb-vm::map-allocated-objects
(lambda (obj type size)
(declare (optimize (safety 0))
(ignore size))
- (when (eql type sb-vm:symbol-header-widetag)
- (ignore-errors
- (let ((read-only-space-refs (sb-vm::list-referencing-objects :read-only obj))
- (static-space-refs (sb-vm::list-referencing-objects :static obj))
- (dynamic-space-refs (sb-vm::list-referencing-objects :dynamic obj)))
- (when (>= 1 (+ (length read-only-space-refs)
- (length static-space-refs)
- (length dynamic-space-refs)))
- (format t "Symbol ~a::~a~%"
- (and (symbol-package obj)
- (package-name (symbol-package obj)))
- (symbol-name obj))
- (unless (null read-only-space-refs)
- (princ " Reference in read-only space: ")
- (print-stale-reference (car read-only-space-refs) t)
- (terpri))
- (unless (null static-space-refs)
- (princ " Reference in static space: ")
- (print-stale-reference (car static-space-refs) t)
- (terpri))
- (unless (null dynamic-space-refs)
- (princ " Reference in dynamic space: ")
- (print-stale-reference (car dynamic-space-refs) t)
- (terpri)))))))
+ (block mapper
+ (when (eql type sb-vm:symbol-header-widetag)
+ (ignore-errors
+ (let ((refs (let ((res nil)
+ (count 0))
+ (dolist (space '(:static :dynamic :read-only))
+ (sb-vm::map-referencing-objects
+ (lambda (o)
+ (when (> (incf count) 1)
+ (return-from mapper nil))
+ (push (cons space o) res))
+ space obj))
+ res)))
+ (let ((externalp (external-symbol-p obj)))
+ (format t "~:[S~;External s~]ymbol ~:[#~;~:*~A:~]~2:*~:[:~;~]~*~A~%"
+ externalp
+ (and (symbol-package obj)
+ (package-name (symbol-package obj)))
+ (symbol-name obj)))
+ (if (null refs)
+ (progn (princ " No references found") (terpri))
+ (progn
+ (ecase (caar refs)
+ (:read-only
+ (princ " Reference in read-only space: "))
+ (:static
+ (princ " Reference in static space: "))
+ (:dynamic
+ (princ " Reference in dynamic space: ")))
+ (print-stale-reference (cdar refs) t)
+ (terpri))))))))
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)
(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 / commitdiff