3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (defvar *xref-kinds
* '(:binds
:calls
:sets
:references
:macroexpands
))
16 (defun record-component-xrefs (component)
17 (declare (type component component
))
18 (when (policy *lexenv
* (zerop store-xref-data
))
19 (return-from record-component-xrefs
))
20 (do ((block (block-next (component-head component
)) (block-next block
)))
21 ((null (block-next block
)))
22 (let ((start (block-start block
)))
23 (flet ((handle-node (functional)
24 ;; Record xref information for all nodes in the block.
25 ;; Note that this code can get executed several times
26 ;; for the same block, if the functional is referenced
27 ;; from multiple XEPs.
28 (loop for ctran
= start then
(node-next (ctran-next ctran
))
30 do
(record-node-xrefs (ctran-next ctran
) functional
))
31 ;; Properly record the deferred macroexpansion information
32 ;; that's been stored in the block.
33 (dolist (xref-data (block-macroexpands block
))
34 (record-xref :macroexpands
36 ;; We use the debug-name of the functional
37 ;; as an identifier. This works quite nicely,
38 ;; except for (fast/slow)-methods with non-symbol,
39 ;; non-number eql specializers, for which
40 ;; the debug-name doesn't map exactly
41 ;; to the fdefinition of the method.
45 (call-with-block-external-functionals block
#'handle-node
)))))
47 (defun call-with-block-external-functionals (block fun
)
48 (let* ((functional (block-home-lambda block
))
50 (labels ((local-function-name-p (name)
53 '(flet labels lambda
))))
54 (handle-functional (functional)
55 ;; If a functional looks like a global function (has a
56 ;; XEP, isn't a local function or a lambda) record xref
57 ;; information for it. Otherwise recurse on the
58 ;; home-lambdas of all references to the functional.
59 (when (eq (functional-kind functional
) :external
)
60 (let ((entry (functional-entry-fun functional
)))
62 (let ((name (functional-debug-name entry
)))
63 (unless (local-function-name-p name
)
64 (return-from handle-functional
65 (funcall fun entry
)))))))
66 ;; Recurse only if we haven't already seen the
68 (unless (member functional seen
)
69 (push functional seen
)
70 (dolist (ref (functional-refs functional
))
71 (handle-functional (node-home-lambda ref
))))))
72 (unless (or (eq :deleted
(functional-kind functional
))
73 ;; If the block came from an inlined global
74 ;; function, ignore it.
75 (and (functional-inlinep functional
)
76 (symbolp (functional-debug-name functional
))))
77 (handle-functional functional
)))))
79 (defun record-node-xrefs (node context
)
80 (declare (type node node
))
82 ((or creturn cif entry mv-combination cast exit
))
84 ;; Record references to globals made using SYMBOL-VALUE.
85 (let ((fun (principal-lvar-use (combination-fun node
)))
86 (arg (car (combination-args node
))))
87 (when (and (ref-p fun
) (eq 'symbol-value
(leaf-%source-name
(ref-leaf fun
)))
88 (constant-lvar-p arg
) (symbolp (lvar-value arg
)))
89 (record-xref :references
(lvar-value arg
) context node nil
))))
91 (let ((leaf (ref-leaf node
)))
94 (let* ((name (leaf-debug-name leaf
)))
95 (case (global-var-kind leaf
)
98 (record-xref :references name context node nil
))
101 (record-xref :calls name context node nil
)))))
102 ;; Inlined global function
104 (when (functional-inlinep leaf
)
105 (let ((name (leaf-debug-name leaf
)))
106 ;; FIXME: we should store the original var into the
107 ;; functional when creating inlined-functionals, so that
108 ;; we could just check whether it was a global-var,
109 ;; rather then needing to guess based on the debug-name.
110 (when (or (symbolp name
)
111 ;; Any non-SETF non-symbol names will
112 ;; currently be either non-functions or
115 (equal (car name
) 'setf
)))
116 ;; TODO: a WHO-INLINES xref-kind could be useful
117 (record-xref :calls name context node nil
)))))
118 ;; Reading a constant
120 (record-xref :references
(ref-%source-name node
) context node nil
)))))
121 ;; Setting a special variable
123 (let* ((var (set-var node
)))
124 (when (and (global-var-p var
)
125 (eq :special
(global-var-kind var
)))
127 (leaf-debug-name var
)
131 ;; Binding a special variable
133 (let ((vars (lambda-vars (bind-lambda node
))))
135 (when (lambda-var-specvar var
)
137 (lambda-var-%source-name var
)
142 (defun internal-name-p (what)
143 ;; Don't store XREF information for internals. We define as internal
144 ;; anything named only by symbols from either implementation
145 ;; packages, COMMON-LISP or KEYWORD. The last one is useful for
146 ;; example when dealing with ctors.
149 (every #'internal-name-p what
))
151 (or (eq '.anonymous. what
)
152 (member (symbol-package what
)
153 (load-time-value (list* (find-package "COMMON-LISP")
154 (find-package "KEYWORD")
158 (package-name package
))
160 (list-all-packages)))))))
163 (defun record-xref (kind what context node path
)
164 (unless (internal-name-p what
)
166 (source-path-original-source
168 (node-source-path node
))))))
169 (push (list what path
)
170 (getf (functional-xref context
) kind
)))))
172 (defun record-macroexpansion (what block path
)
173 (unless (internal-name-p what
)
174 (push (cons what path
) (block-macroexpands block
))))
176 ;;; Pack the xref table that was stored for a functional into a more
177 ;;; space-efficient form, and return that packed form.
178 (defun pack-xref-data (xref-data)
180 (let ((array (make-array (length *xref-kinds
*))))
181 (loop for key in
*xref-kinds
*
183 for values
= (remove-duplicates (getf xref-data key
)
185 for flattened
= (reduce #'append values
:from-end t
)
186 collect
(setf (aref array i
)
188 (make-array (length flattened
)
189 :initial-contents flattened
))))