1.0.21.14: fix CHECK-FASL-HEADER buglet
[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 ((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))
29                      while 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
35                               (car xref-data)
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.
42                               functional
43                               nil
44                               (cdr xref-data)))))
45         (call-with-block-external-functionals block #'handle-node)))))
46
47 (defun call-with-block-external-functionals (block fun)
48   (let* ((functional (block-home-lambda block))
49          (seen nil))
50     (labels ((local-function-name-p (name)
51                (and (consp name)
52                     (member (car 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)))
61                    (when entry
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
67                ;; functional.
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)))))
78
79 (defun record-node-xrefs (node context)
80   (declare (type node node))
81   (etypecase node
82     ((or creturn cif entry mv-combination cast exit))
83     (combination
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))))
90     (ref
91      (let ((leaf (ref-leaf node)))
92        (typecase leaf
93          (global-var
94           (let* ((name (leaf-debug-name leaf)))
95             (case (global-var-kind leaf)
96               ;; Reading a special
97               (:special
98                (record-xref :references name context node nil))
99               ;; Calling a function
100               (:global-function
101                (record-xref :calls name context node nil)))))
102          ;; Inlined global function
103          (clambda
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
113                         ;; internals.
114                         (and (consp name)
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
119          (constant
120           (record-xref :references (ref-%source-name node) context node nil)))))
121     ;; Setting a special variable
122     (cset
123      (let* ((var (set-var node)))
124        (when (and (global-var-p var)
125                   (eq :special (global-var-kind var)))
126          (record-xref :sets
127                       (leaf-debug-name var)
128                       context
129                       node
130                       nil))))
131     ;; Binding a special variable
132     (bind
133      (let ((vars (lambda-vars (bind-lambda node))))
134        (dolist (var vars)
135          (when (lambda-var-specvar var)
136            (record-xref :binds
137                         (lambda-var-%source-name var)
138                         context
139                         node
140                         nil)))))))
141
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.
147   (typecase what
148     (list
149      (every #'internal-name-p what))
150     (symbol
151      (or (eq '.anonymous. what)
152          (member (symbol-package what)
153                  (load-time-value (list* (find-package "COMMON-LISP")
154                                          (find-package "KEYWORD")
155                                          (remove-if-not
156                                           (lambda (package)
157                                             (= (mismatch "SB!"
158                                                          (package-name package))
159                                                3))
160                                           (list-all-packages)))))))
161     (t t)))
162
163 (defun record-xref (kind what context node path)
164   (unless (internal-name-p what)
165     (let ((path (reverse
166                  (source-path-original-source
167                   (or path
168                       (node-source-path node))))))
169       (push (list what path)
170             (getf (functional-xref context) kind)))))
171
172 (defun record-macroexpansion (what block path)
173   (unless (internal-name-p what)
174     (push (cons what path) (block-macroexpands block))))
175
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)
179   (when xref-data
180     (let ((array (make-array (length *xref-kinds*))))
181       (loop for key in *xref-kinds*
182             for i from 0
183             for values = (remove-duplicates (getf xref-data key)
184                                             :test #'equal)
185             for flattened = (reduce #'append values :from-end t)
186             collect (setf (aref array i)
187                           (when flattened
188                             (make-array (length flattened)
189                                         :initial-contents flattened))))
190       array)))