/[cmucl]/src/compiler/xref.lisp
ViewVC logotype

Contents of /src/compiler/xref.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Fri Mar 19 15:19:01 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.6: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; xref.lisp -- a cross-reference facility for CMUCL
2 ;;;
3 ;;; Author: Eric Marsden <emarsden@laas.fr>
4 ;;;
5 (ext:file-comment
6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/xref.lisp,v 1.7 2010/03/19 15:19:01 rtoy Rel $")
7 ;;
8 ;; This code was written as part of the CMUCL project and has been
9 ;; placed in the public domain.
10 ;;
11 ;;
12 ;; The cross-referencing facility provides the ability to discover
13 ;; information such as which functions call which other functions and
14 ;; in which program contexts a given global variables may be used. The
15 ;; cross-referencer maintains a database of cross-reference
16 ;; information which can be queried by the user to provide answers to
17 ;; questions like:
18 ;;
19 ;; - the program contexts where a given function may be called,
20 ;; either directly or indirectly (via its function-object).
21 ;;
22 ;; - the program contexts where a global variable (ie a dynamic
23 ;; variable or a constant variable -- something declared with
24 ;; DEFVAR or DEFPARAMETER or DEFCONSTANT) may be read, or bound, or
25 ;; modified.
26 ;;
27 ;; More details are available in "Cross-Referencing Facility" chapter
28 ;; of the CMUCL User's Manual.
29 ;;
30 ;;
31 ;; Missing functionality:
32 ;;
33 ;; - maybe add macros EXT:WITH-XREF.
34 ;;
35 ;; - in (defun foo (x) (flet ((bar (y) (+ x y))) (bar 3))), we want to see
36 ;; FOO calling (:internal BAR FOO)
37 ;;
38 ;; The cross-reference facility is implemented by walking the IR1
39 ;; representation that is generated by CMUCL when compiling (for both
40 ;; native and byte-compiled code, and irrespective of whether you're
41 ;; compiling from a file, from a stream, or interactively from the
42 ;; listener).
43
44
45 (in-package :xref)
46 (intl:textdomain "cmucl")
47
48 (export '(init-xref-database
49 register-xref
50 who-calls
51 who-references
52 who-binds
53 who-sets
54 who-macroexpands
55 who-subclasses
56 who-superclasses
57 who-specializes
58 make-xref-context
59 xref-context-name
60 xref-context-file
61 xref-context-source-path
62 invalidate-xrefs-for-namestring
63 find-xrefs-for-pathname))
64
65
66 (defstruct (xref-context
67 (:print-function %print-xref-context)
68 (:make-load-form-fun :just-dump-it-normally))
69 name
70 (file *compile-file-truename*)
71 (source-path nil))
72
73 (defun %print-xref-context (s stream d)
74 (declare (ignore d))
75 (cond (*print-readably*
76 (format stream "#S(xref::xref-context :name '~S ~_ :file ~S ~_ :source-path '~A)"
77 (xref-context-name s)
78 (xref-context-file s)
79 (xref-context-source-path s)))
80 (t
81 (format stream "#<xref-context ~S~@[ in ~S~]>"
82 (xref-context-name s)
83 (xref-context-file s)))))
84
85
86 ;; program contexts where a globally-defined function may be called at runtime
87 (defvar *who-calls* (make-hash-table :test #'eq))
88
89 (defvar *who-is-called* (make-hash-table :test #'eq))
90
91 ;; program contexts where a global variable may be referenced
92 (defvar *who-references* (make-hash-table :test #'eq))
93
94 ;; program contexts where a global variable may be bound
95 (defvar *who-binds* (make-hash-table :test #'eq))
96
97 ;; program contexts where a global variable may be set
98 (defvar *who-sets* (make-hash-table :test #'eq))
99
100 ;; program contexts where a global variable may be set
101 (defvar *who-macroexpands* (make-hash-table :test #'eq))
102
103 ;; you can print these conveniently with code like
104 ;; (maphash (lambda (k v) (format t "~S <-~{ ~S~^,~}~%" k v)) xref::*who-sets*)
105 ;; or
106 ;; (maphash (lambda (k v) (format t "~S <-~% ~@<~@;~S~^~%~:>~%" k v)) xref::*who-calls*)
107
108
109 (defun register-xref (type target context)
110 (declare (type xref-context context))
111 (let ((database (ecase type
112 (:calls *who-calls*)
113 (:called *who-is-called*)
114 (:references *who-references*)
115 (:binds *who-binds*)
116 (:sets *who-sets*)
117 (:macroexpands *who-macroexpands*))))
118 (if (gethash target database)
119 (pushnew context (gethash target database) :test 'equalp)
120 (setf (gethash target database) (list context)))
121 context))
122
123 ;; INIT-XREF-DATABASE -- interface
124 ;;
125 (defun init-xref-database ()
126 "Reinitialize the cross-reference database."
127 (setf *who-calls* (make-hash-table :test #'eq))
128 (setf *who-is-called* (make-hash-table :test #'eq))
129 (setf *who-references* (make-hash-table :test #'eq))
130 (setf *who-binds* (make-hash-table :test #'eq))
131 (setf *who-sets* (make-hash-table :test #'eq))
132 (setf *who-macroexpands* (make-hash-table :test #'eq))
133 (values))
134
135
136 ;; WHO-CALLS -- interface
137 ;;
138 (defun who-calls (function-name &key (reverse nil))
139 "Return a list of those program contexts where a globally-defined
140 function may be called at runtime."
141 (if reverse
142 (gethash function-name *who-is-called*)
143 (gethash function-name *who-calls*)))
144
145 ;; WHO-REFERENCES -- interface
146 ;;
147 (defun who-references (global-variable)
148 "Return a list of those program contexts where GLOBAL-VARIABLE
149 may be referenced at runtime."
150 (declare (type symbol global-variable))
151 (gethash global-variable *who-references*))
152
153 ;; WHO-BINDS -- interface
154 ;;
155 (defun who-binds (global-variable)
156 "Return a list of those program contexts where GLOBAL-VARIABLE may
157 be bound at runtime."
158 (declare (type symbol global-variable))
159 (gethash global-variable *who-binds*))
160
161 ;; WHO-SETS -- interface
162 ;;
163 (defun who-sets (global-variable)
164 "Return a list of those program contexts where GLOBAL-VARIABLE may
165 be set at runtime."
166 (declare (type symbol global-variable))
167 (gethash global-variable *who-sets*))
168
169
170 (defun who-macroexpands (macro)
171 (declare (type symbol macro))
172 (gethash macro *who-macroexpands*))
173
174
175 ;; introspection functions from the CLOS metaobject protocol
176
177 ;; WHO-SUBCLASSES -- interface
178 ;;
179 (defun who-subclasses (class)
180 (pcl::class-direct-subclasses class))
181
182 ;; WHO-SUPERCLASSES -- interface
183 ;;
184 (defun who-superclasses (class)
185 (pcl::class-direct-superclasses class))
186
187 ;; WHO-SPECIALIZES -- interface
188 ;;
189 ;; generic functions defined for this class
190 (defun who-specializes (class)
191 (pcl::specializer-direct-methods class))
192
193 ;; Go through all the databases and remove entries from that that
194 ;; reference the given Namestring.
195 (defun invalidate-xrefs-for-namestring (namestring)
196 (labels ((matching-context (ctx)
197 (equal namestring (if (pathnamep (xref-context-file ctx))
198 (namestring (xref-context-file ctx))
199 (xref-context-file ctx))))
200 (invalidate-for-database (db)
201 (maphash (lambda (target contexts)
202 (let ((valid-contexts (remove-if #'matching-context contexts)))
203 (if (null valid-contexts)
204 (remhash target db)
205 (setf (gethash target db) valid-contexts))))
206 db)))
207 (dolist (db (list *who-calls* *who-is-called* *who-references* *who-binds*
208 *who-sets* *who-macroexpands*))
209 (invalidate-for-database db))))
210
211 ;; Look in Db for entries that reference the supplied Pathname and
212 ;; return a list of all the matches. Each element of the list is a
213 ;; list of the target followed by the entries.
214 (defun find-xrefs-for-pathname (db pathname)
215 (let ((entries '()))
216 (maphash #'(lambda (target contexts)
217 (let ((matches '()))
218 (dolist (ctx contexts)
219 (when (equal pathname (xref-context-file ctx))
220 (push ctx matches)))
221 (push (list target matches) entries)))
222 (ecase db
223 (:calls *who-calls*)
224 (:called *who-is-called*)
225 (:references *who-references*)
226 (:binds *who-binds*)
227 (:sets *who-sets*)
228 (:macroexpands *who-macroexpands*)))
229 entries))
230
231 (in-package :compiler)
232
233 (defun lambda-contains-calls-p (clambda)
234 (declare (type clambda clambda))
235 (some #'lambda-p (lambda-dfo-dependencies clambda)))
236
237 (defun prettiest-caller-name (lambda-node toplevel-name)
238 (cond
239 ((not lambda-node)
240 (list :anonymous toplevel-name))
241
242 ;; LET and FLET bindings introduce new unnamed LAMBDA nodes.
243 ;; If the home slot contains a lambda with a nice name, we use
244 ;; that; otherwise fall back on the toplevel-name.
245 ((or (not (eq (lambda-home lambda-node) lambda-node))
246 (lambda-contains-calls-p lambda-node))
247 (let ((home (lambda-name (lambda-home lambda-node)))
248 (here (lambda-name lambda-node)))
249 (cond ((and home here)
250 (list :internal home here))
251 ((symbolp here) here)
252 ((symbolp home) home)
253 (t
254 (or here home toplevel-name)))))
255
256 ((and (listp (lambda-name lambda-node))
257 (eq :macro (first (lambda-name lambda-node))))
258 (lambda-name lambda-node))
259
260 ;; a reference from a macro is named (:macro name)
261 #+nil
262 ((eql 0 (search "defmacro" toplevel-name :test 'char-equal))
263 (list :macro (subseq toplevel-name 9)))
264
265 ;; probably "Top-Level Form"
266 ((stringp (lambda-name lambda-node))
267 (lambda-name lambda-node))
268
269 ;; probably (setf foo)
270 ((listp (lambda-name lambda-node))
271 (lambda-name lambda-node))
272
273 (t
274 ;; distinguish between nested functions (FLET/LABELS) and
275 ;; global functions by checking whether the node has a HOME
276 ;; slot that is different from itself. Furthermore, a LABELS
277 ;; node at the first level inside a lambda may have a
278 ;; self-referential home slot, but still be internal.
279 (cond ((not (eq (lambda-home lambda-node) lambda-node))
280 (list :internal
281 (lambda-name (lambda-home lambda-node))
282 (lambda-name lambda-node)))
283 ((lambda-contains-calls-p lambda-node)
284 (list :internal/calls
285 (lambda-name (lambda-home lambda-node))
286 (lambda-name lambda-node)))
287 (t (lambda-name lambda-node))))))
288
289
290 ;; RECORD-NODE-XREFS -- internal
291 ;;
292 ;; TOPLEVEL-NAME is an indication of the name of the COMPONENT that
293 ;; contains this node, or NIL if it was really "Top-Level Form".
294 (defun record-node-xrefs (node toplevel-name)
295 (declare (type node node))
296 (let ((context (xref:make-xref-context)))
297 (when *compile-file-truename*
298 (setf (xref:xref-context-source-path context)
299 (reverse
300 (source-path-original-source
301 (node-source-path node)))))
302 (typecase node
303 (ref
304 (let* ((leaf (ref-leaf node))
305 (lexenv (ref-lexenv node))
306 (lambda (lexenv-lambda lexenv))
307 (home (node-home-lambda node))
308 (caller (or (and home (lambda-name home))
309 (prettiest-caller-name lambda toplevel-name))))
310
311 (setf (xref:xref-context-name context) caller)
312 (typecase leaf
313 ;; a reference to a LEAF of type GLOBAL-VAR
314 (global-var
315 (let ((called (global-var-name leaf)))
316 ;; a reference to #'C::%SPECIAL-BIND means that we are
317 ;; binding a special variable. The information on which
318 ;; variable is being bound, and within which function, is
319 ;; available in the ref's LEXENV object.
320 (cond ((eq called 'c::%special-bind)
321 (setf (xref:xref-context-name context) (caar (lexenv-blocks lexenv)))
322 (xref:register-xref :binds (caar (lexenv-variables lexenv)) context))
323 ;; we're not interested in lexical environments
324 ;; that have no name; they are mostly due to code
325 ;; inserted by the compiler (eg calls to %VERIFY-ARGUMENT-COUNT)
326 ((not caller)
327 :no-caller)
328 ;; we're not interested in lexical environments
329 ;; named "Top-Level Form".
330 ((and (stringp caller)
331 (string= "Top-Level Form" caller))
332 :top-level-form)
333 ((not (eq 'original-source-start (first (node-source-path node))))
334 #+nil
335 (format *debug-io* "~&Ignoring compiler-generated call with source-path ~A~%"
336 (node-source-path node))
337 :compiler-generated)
338 ((not called)
339 :no-called)
340 ((eq :global-function (global-var-kind leaf))
341 (xref:register-xref :calls called context)
342 (xref:register-xref :called caller context))
343 ((eq :special (global-var-kind leaf))
344 (xref:register-xref :references called context)))))
345 ;; a reference to a LEAF of type CONSTANT
346 (constant
347 (let ((called (constant-name leaf)))
348 (and called
349 (not (eq called t)) ; ignore references to trivial variables
350 caller
351 (not (and (stringp caller) (string= "Top-Level Form" caller)))
352 (xref:register-xref :references called context)))))))
353
354 ;; a variable is being set
355 (cset
356 (let* ((variable (set-var node))
357 (lexenv (set-lexenv node)))
358 (and (global-var-p variable)
359 (eq :special (global-var-kind variable))
360 (let* ((lblock (first (lexenv-blocks lexenv)))
361 (user (or (and lblock (car lblock)) toplevel-name))
362 (used (global-var-name variable)))
363 (setf (xref:xref-context-name context) user)
364 (and user used (xref:register-xref :sets used context))))))
365
366 ;; nodes of type BIND are used to bind symbols to LAMBDA objects
367 ;; (including for macros), but apparently not for bindings of
368 ;; variables.
369 (bind
370 t))))
371
372
373 ;; RECORD-COMPONENT-XREFS -- internal
374 ;;
375 (defun record-component-xrefs (component)
376 (declare (type component component))
377 (do ((block (block-next (component-head component)) (block-next block)))
378 ((null (block-next block)))
379 (let ((fun (block-home-lambda block))
380 (name (component-name component))
381 (this-cont (block-start block))
382 (last (block-last block)))
383 (unless (eq :deleted (functional-kind fun))
384 (loop
385 (let ((node (continuation-next this-cont)))
386 (record-node-xrefs node name)
387 (let ((cont (node-cont node)))
388 (when (eq node last) (return))
389 (setq this-cont cont))))))))
390
391 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5