X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fxref.lisp;h=7801e4e5d926de1ecd63e75bf81faa8c5b881f85;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=4ea73e42151432901a2920c4c1c94acbd6a398e8;hpb=3b6e07c0fcb050fa86c7c42db33f49107e3097e6;p=sbcl.git diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp index 4ea73e4..7801e4e 100644 --- a/src/compiler/xref.lisp +++ b/src/compiler/xref.lisp @@ -19,31 +19,29 @@ (return-from record-component-xrefs)) (do ((block (block-next (component-head component)) (block-next block))) ((null (block-next block))) - (let* ((this-cont (block-start block)) - (last (block-last block))) + (let ((start (block-start block))) (flet ((handle-node (functional) ;; Record xref information for all nodes in the block. ;; Note that this code can get executed several times ;; for the same block, if the functional is referenced ;; from multiple XEPs. - (loop for node = (ctran-next this-cont) - then (ctran-next (node-next node)) - until (eq node last) - do (record-node-xrefs node 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))))) + (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 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) @@ -81,7 +79,7 @@ (defun record-node-xrefs (node context) (declare (type node node)) (etypecase node - ((or creturn cif entry mv-combination cast)) + ((or creturn cif entry mv-combination cast exit)) (combination ;; Record references to globals made using SYMBOL-VALUE. (let ((fun (principal-lvar-use (combination-fun node))) @@ -103,24 +101,13 @@ (record-xref :calls name context node nil))))) ;; Inlined global function (clambda - (when (functional-inlinep leaf) - (let ((name (leaf-debug-name leaf))) - ;; FIXME: we should store the original var into the - ;; functional when creating inlined-functionals, so that - ;; we could just check whether it was a global-var, - ;; rather then needing to guess based on the debug-name. - (when (or (symbolp name) - ;; Any non-SETF non-symbol names will - ;; currently be either non-functions or - ;; internals. - (and (consp name) - (equal (car name) 'setf))) - ;; TODO: a WHO-INLINES xref-kind could be useful - (record-xref :calls name context node nil))))) + (let ((inline-var (functional-inline-expanded leaf))) + (when (global-var-p inline-var) + ;; TODO: a WHO-INLINES xref-kind could be useful + (record-xref :calls (leaf-debug-name inline-var) context node nil)))) ;; Reading a constant (constant - (let* ((name (constant-%source-name leaf))) - (record-xref :references name context node nil)))))) + (record-xref :references (ref-%source-name node) context node nil))))) ;; Setting a special variable (cset (let* ((var (set-var node))) @@ -143,23 +130,32 @@ 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 - (member (symbol-package what) - (load-time-value (list* (find-package "COMMON-LISP") - (find-package "KEYWORD") - (remove-if-not - (lambda (package) - (= (mismatch "SB!" - (package-name package)) - 3)) - (list-all-packages)))))) + #!+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") + #+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))))) (t t))) (defun record-xref (kind what context node path) @@ -173,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.