1.0.4.45: workaround for bug #412 & undefined variable cleanup
[sbcl.git] / src / compiler / xref.lisp
1 ;;;; xref facility
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!C")
13
14 (defvar *xref-kinds* '(:binds :calls :sets :references :macroexpands))
15
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* ((this-cont (block-start block))
23            (last (block-last block)))
24       (flet ((handle-node (functional)
25                ;; Record xref information for all nodes in the block.
26                ;; Note that this code can get executed several times
27                ;; for the same block, if the functional is referenced
28                ;; from multiple XEPs.
29                (loop for node = (ctran-next this-cont)
30                      then (ctran-next (node-next node))
31                      until (eq node last)
32                      do (record-node-xrefs node functional))
33                ;; Properly record the deferred macroexpansion information
34                ;; that's been stored in the block.
35                (dolist (xref-data (block-macroexpands block))
36                  (record-xref :macroexpands
37                               (car xref-data)
38                               ;; We use the debug-name of the functional
39                               ;; as an identifier. This works quite nicely,
40                               ;; except for (fast/slow)-methods with non-symbol,
41                               ;; non-number eql specializers, for which
42                               ;; the debug-name doesn't map exactly
43                               ;; to the fdefinition of the method.
44                               functional
45                               nil
46                               (cdr xref-data)))))
47         (call-with-block-external-functionals block #'handle-node)))))
48
49 (defun call-with-block-external-functionals (block fun)
50   (let* ((functional (block-home-lambda block))
51          (seen nil))
52     (labels ((local-function-name-p (name)
53                (and (consp name)
54                     (member (car name)
55                             '(flet labels lambda))))
56              (handle-functional (functional)
57                ;; If a functional looks like a global function (has a
58                ;; XEP, isn't a local function or a lambda) record xref
59                ;; information for it. Otherwise recurse on the
60                ;; home-lambdas of all references to the functional.
61                (when (eq (functional-kind functional) :external)
62                  (let ((entry (functional-entry-fun functional)))
63                    (when entry
64                      (let ((name (functional-debug-name entry)))
65                        (unless (local-function-name-p name)
66                          (return-from handle-functional
67                            (funcall fun entry)))))))
68                ;; Recurse only if we haven't already seen the
69                ;; functional.
70                (unless (member functional seen)
71                  (push functional seen)
72                  (dolist (ref (functional-refs functional))
73                    (handle-functional (node-home-lambda ref))))))
74       (unless (or (eq :deleted (functional-kind functional))
75                   ;; If the block came from an inlined global
76                   ;; function, ignore it.
77                   (and (functional-inlinep functional)
78                        (symbolp (functional-debug-name functional))))
79         (handle-functional functional)))))
80
81 (defun record-node-xrefs (node context)
82   (declare (type node node))
83   (etypecase node
84     ((or creturn cif entry mv-combination cast))
85     (combination
86      ;; Record references to globals made using SYMBOL-VALUE.
87      (let ((fun (principal-lvar-use (combination-fun node)))
88            (arg (car (combination-args node))))
89        (when (and (ref-p fun) (eq 'symbol-value (leaf-%source-name (ref-leaf fun)))
90                   (constant-lvar-p arg) (symbolp (lvar-value arg)))
91          (record-xref :references (lvar-value arg) context node nil))))
92     (ref
93      (let ((leaf (ref-leaf node)))
94        (typecase leaf
95          (global-var
96           (let* ((name (leaf-debug-name leaf)))
97             (case (global-var-kind leaf)
98               ;; Reading a special
99               (:special
100                (record-xref :references name context node nil))
101               ;; Calling a function
102               (:global-function
103                (record-xref :calls name context node nil)))))
104          ;; Inlined global function
105          (clambda
106           (when (functional-inlinep leaf)
107             (let ((name (leaf-debug-name leaf)))
108               ;; FIXME: we should store the original var into the
109               ;; functional when creating inlined-functionals, so that
110               ;; we could just check whether it was a global-var,
111               ;; rather then needing to guess based on the debug-name.
112               (when (or (symbolp name)
113                         ;; Any non-SETF non-symbol names will
114                         ;; currently be either non-functions or
115                         ;; internals.
116                         (and (consp name)
117                              (equal (car name) 'setf)))
118                 ;; TODO: a WHO-INLINES xref-kind could be useful
119                 (record-xref :calls name context node nil)))))
120          ;; Reading a constant
121          (constant
122           (let* ((name (constant-%source-name leaf)))
123             (record-xref :references name context node nil))))))
124     ;; Setting a special variable
125     (cset
126      (let* ((var (set-var node)))
127        (when (and (global-var-p var)
128                   (eq :special (global-var-kind var)))
129          (record-xref :sets
130                       (leaf-debug-name var)
131                       context
132                       node
133                       nil))))
134     ;; Binding a special variable
135     (bind
136      (let ((vars (lambda-vars (bind-lambda node))))
137        (dolist (var vars)
138          (when (lambda-var-specvar var)
139            (record-xref :binds
140                         (lambda-var-%source-name var)
141                         context
142                         node
143                         nil)))))))
144
145 (defun internal-name-p (what)
146   ;; Don't store XREF information for internals. We define as internal
147   ;; anything named only by symbols from either implementation
148   ;; packages, COMMON-LISP or KEYWORD. The last one is useful for
149   ;; example when dealing with ctors.
150   (typecase what
151     (list
152      (every #'internal-name-p what))
153     (symbol
154      (member (symbol-package what)
155              (load-time-value (list* (find-package "COMMON-LISP")
156                                      (find-package "KEYWORD")
157                                      (remove-if-not
158                                       (lambda (package)
159                                         (= (mismatch "SB!"
160                                                      (package-name package))
161                                            3))
162                                       (list-all-packages))))))
163     (t t)))
164
165 (defun record-xref (kind what context node path)
166   (unless (internal-name-p what)
167     (let ((path (reverse
168                  (source-path-original-source
169                   (or path
170                       (node-source-path node))))))
171       (push (list what path)
172             (getf (functional-xref context) kind)))))
173
174 (defun record-macroexpansion (what block path)
175   (unless (internal-name-p what)
176     (push (cons what path) (block-macroexpands block))))
177
178 ;;; Pack the xref table that was stored for a functional into a more
179 ;;; space-efficient form, and return that packed form.
180 (defun pack-xref-data (xref-data)
181   (when xref-data
182     (let ((array (make-array (length *xref-kinds*))))
183       (loop for key in *xref-kinds*
184             for i from 0
185             for values = (remove-duplicates (getf xref-data key)
186                                             :test #'equal)
187             for flattened = (reduce #'append values :from-end t)
188             collect (setf (aref array i)
189                           (when flattened
190                             (make-array (length flattened)
191                                         :initial-contents flattened))))
192       array)))