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 (defglobal *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 and source
  32                ;; transform information that's been stored in the block.
  33                (dolist (xref-data (block-xrefs block))
  34                  (destructuring-bind (kind what path) xref-data
  35                    (record-xref kind what
  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                                 path)))))
  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 :global)
  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           (let ((inline-var (functional-inline-expanded leaf)))
 105             (when (global-var-p inline-var)
 106               ;; TODO: a WHO-INLINES xref-kind could be useful
 107               (record-xref :calls (leaf-debug-name inline-var) context node nil))))
 108          ;; Reading a constant
 109          (constant
 110           (record-xref :references (ref-%source-name node) context node nil)))))
 111     ;; Setting a special variable
 112     (cset
 113      (let ((var (set-var node)))
 114        (when (and (global-var-p var)
 115                   (memq (global-var-kind var) '(:special :global)))
 116          (record-xref :sets
 117                       (leaf-debug-name var)
 118                       context
 119                       node
 120                       nil))))
 121     ;; Binding a special variable
 122     (bind
 123      (let ((vars (lambda-vars (bind-lambda node))))
 124        (dolist (var vars)
 125          (when (lambda-var-specvar var)
 126            (record-xref :binds
 127                         (lambda-var-%source-name var)
 128                         context
 129                         node
 130                         nil)))))))
 131
 132 (defun internal-name-p (what)
 133   ;; Unless we're building with SB-XREF-FOR-INTERNALS, don't store
 134   ;; XREF information for internals. We define anything with a symbol
 135   ;; from either an implementation package or from COMMON-LISP as
 136   ;; internal
 137   (typecase what
 138     (list
 139      (every #'internal-name-p what))
 140     (symbol
 141      #!+sb-xref-for-internals
 142      (eq '.anonymous. what)
 143      #!-sb-xref-for-internals
 144      (or (eq '.anonymous. what)
 145          (member (symbol-package what)
 146                  (load-time-value
 147                   (list* (find-package "COMMON-LISP")
 148                          #+sb-xc-host (find-package "SB-XC")
 149                          (remove-if-not
 150                           (lambda (package)
 151                             (= (mismatch #+sb-xc "SB-" #-sb-xc "SB!"
 152                                          (package-name package))
 153                                3))
 154                           (list-all-packages))) t))
 155          #+sb-xc-host   ; again, special case like in genesis and dump
 156          (multiple-value-bind (cl-symbol cl-status)
 157              (find-symbol (symbol-name what) sb!int:*cl-package*)
 158            (and (eq what cl-symbol) (eq cl-status :external)))))
 159     (t t)))
 160
 161 (defun record-xref (kind what context node path)
 162   (unless (internal-name-p what)
 163     (push (cons what
 164                 (source-path-form-number (or path
 165                                              (node-source-path node))))
 166           (getf (functional-xref context) kind))))
 167
 168 (defun record-macroexpansion (what block path)
 169   (unless (internal-name-p what)
 170     (push (list :macroexpands what path) (block-xrefs block))))
 171
 172 (defun record-call (what block path)
 173   (unless (internal-name-p what)
 174     (push (list :calls what path) (block-xrefs 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             do
 186             (setf (aref array i)
 187                   (when values
 188                     (let* ((length (* (length values) 2))
 189                            (data (make-array length)))
 190                       (loop for i below length by 2
 191                             for (name . number) in values
 192                             do (setf (aref data i) name
 193                                      (aref data (1+ i)) number))
 194                       data))))
 195       array)))