From 64fb1f750762dad66255d941292283b92ce9a078 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 26 Jul 2004 10:15:39 +0000 Subject: [PATCH] 0.8.13.1: Implement MAP-REFERENCING-OBJECTS, and make the implementation of LIST-REFERENCING-OBJECTS use it. ... note potential badness of cutoff point in space search. (could this be the problem in ROOM T?) Improvements to stale-symbols script. ... if there is more than one reference, don't bother chasing all the others down; ... closures can contain stuff; ... print symbols and references a little more nicely. --- contrib/stale-symbols.lisp | 99 ++++++++++++++++++++++++-------------------- src/code/room.lisp | 88 ++++++++++++++++++++++++--------------- version.lisp-expr | 2 +- 3 files changed, 110 insertions(+), 79 deletions(-) diff --git a/contrib/stale-symbols.lisp b/contrib/stale-symbols.lisp index 02823d4..374e836 100644 --- a/contrib/stale-symbols.lisp +++ b/contrib/stale-symbols.lisp @@ -3,8 +3,6 @@ ;;; ;;; 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. @@ -23,67 +21,80 @@ ;;; 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 "#" + (format stream "#" (sb-c::compiled-debug-fun-name obj))) + ((sb-kernel:code-component-p obj) + (format stream "#" + (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))) diff --git a/src/code/room.lisp b/src/code/room.lisp index fdebda6..3ba28fd 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -193,7 +193,7 @@ (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) @@ -653,9 +653,14 @@ (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)) @@ -665,7 +670,8 @@ (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 @@ -681,34 +687,48 @@ 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))) diff --git a/version.lisp-expr b/version.lisp-expr index 1ced0ec..291ae7a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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".) -"0.8.13" +"0.8.13.1" -- 1.7.10.4