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