X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fxref.lisp;h=7801e4e5d926de1ecd63e75bf81faa8c5b881f85;hb=aa7b669779e8e88349938ca962229f31ead08af2;hp=4bf2fd08582705a748eff9f5c6bea4bf915c6e77;hpb=30e65b004ace56e530469a364c35a6f5f5d686eb;p=sbcl.git

diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp
index 4bf2fd0..7801e4e 100644
--- a/src/compiler/xref.lisp
+++ b/src/compiler/xref.lisp
@@ -28,20 +28,20 @@
                (loop for ctran = start then (node-next (ctran-next ctran))
                      while ctran
                      do (record-node-xrefs (ctran-next ctran) functional))
-               ;; Properly record the deferred macroexpansion information
-               ;; that's been stored in the block.
-               (dolist (xref-data (block-macroexpands block))
-                 (record-xref :macroexpands
-                              (car xref-data)
-                              ;; We use the debug-name of the functional
-                              ;; as an identifier. This works quite nicely,
-                              ;; except for (fast/slow)-methods with non-symbol,
-                              ;; non-number eql specializers, for which
-                              ;; the debug-name doesn't map exactly
-                              ;; to the fdefinition of the method.
-                              functional
-                              nil
-                              (cdr xref-data)))))
+               ;; Properly record the deferred macroexpansion and source
+               ;; transform information that's been stored in the block.
+               (dolist (xref-data (block-xrefs block))
+                 (destructuring-bind (kind what path) xref-data
+                   (record-xref kind what
+                                ;; We use the debug-name of the functional
+                                ;; as an identifier. This works quite nicely,
+                                ;; except for (fast/slow)-methods with non-symbol,
+                                ;; non-number eql specializers, for which
+                                ;; the debug-name doesn't map exactly
+                                ;; to the fdefinition of the method.
+                                functional
+                                nil
+                                path)))))
         (call-with-block-external-functionals block #'handle-node)))))
 
 (defun call-with-block-external-functionals (block fun)
@@ -130,26 +130,29 @@
                         nil)))))))
 
 (defun internal-name-p (what)
-  ;; Don't store XREF information for internals. We define as internal
-  ;; anything named only by symbols from either implementation
-  ;; packages, COMMON-LISP or KEYWORD. The last one is useful for
-  ;; example when dealing with ctors.
+  ;; Unless we're building with SB-XREF-FOR-INTERNALS, don't store
+  ;; XREF information for internals. We define anything with a symbol
+  ;; from either an implementation package or from COMMON-LISP as
+  ;; internal
   (typecase what
     (list
      (every #'internal-name-p what))
     (symbol
+     #!+sb-xref-for-internals
+     (eq '.anonymous. what)
+     #!-sb-xref-for-internals
      (or (eq '.anonymous. what)
          (member (symbol-package what)
-                 (load-time-value (list* (find-package "COMMON-LISP")
-                                         (find-package "KEYWORD")
-                                         #+sb-xc-host (find-package "SB-XC")
-                                         (remove-if-not
-                                          (lambda (package)
-                                            (= (mismatch "SB!"
-                                                         (package-name package))
-                                               3))
-                                          (list-all-packages)))))
-         #+sb-xc-host ; again, special case like in genesis and dump
+                 (load-time-value
+                  (list* (find-package "COMMON-LISP")
+                         #+sb-xc-host (find-package "SB-XC")
+                         (remove-if-not
+                          (lambda (package)
+                            (= (mismatch "SB!"
+                                         (package-name package))
+                               3))
+                          (list-all-packages)))))
+         #+sb-xc-host   ; again, special case like in genesis and dump
          (multiple-value-bind (cl-symbol cl-status)
              (find-symbol (symbol-name what) sb!int:*cl-package*)
            (and (eq what cl-symbol) (eq cl-status :external)))))
@@ -166,7 +169,11 @@
 
 (defun record-macroexpansion (what block path)
   (unless (internal-name-p what)
-    (push (cons what path) (block-macroexpands block))))
+    (push (list :macroexpands what path) (block-xrefs block))))
+
+(defun record-call (what block path)
+  (unless (internal-name-p what)
+    (push (list :calls what path) (block-xrefs block))))
 
 ;;; Pack the xref table that was stored for a functional into a more
 ;;; space-efficient form, and return that packed form.