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 (declaim (type list *xref-kinds*))
  15 (defglobal *xref-kinds* '(:binds :calls :sets :references :macroexpands))
  16
  17 (defun record-component-xrefs (component)
  18   (declare (type component component))
  19   (when (policy *lexenv* (zerop store-xref-data))
  20     (return-from record-component-xrefs))
  21   (do ((block (block-next (component-head component)) (block-next block)))
  22       ((null (block-next block)))
  23     (let ((start (block-start block)))
  24       (flet ((handle-node (functional)
  25                ;; Record xref information for all nodes in the block.
  26                ;; Note that this code can get executed several times
  27                ;; for the same block, if the functional is referenced
  28                ;; from multiple XEPs.
  29                (loop for ctran = start then (node-next (ctran-next ctran))
  30                      while ctran
  31                      do (record-node-xrefs (ctran-next ctran) functional))
  32                ;; Properly record the deferred macroexpansion and source
  33                ;; transform information that's been stored in the block.
  34                (loop for (kind what path) in (block-xrefs block)
  35                      do (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 \f
 177 ;;;; Packing of xref tables
 178 ;;;;
 179 ;;;; xref information can be transformed into the following "packed"
 180 ;;;; form to save space:
 181 ;;;;
 182 ;;;;   #(PACKED-ENTRIES NAME1 NAME2 ...)
 183 ;;;;
 184 ;;;; where NAME1 NAME2 ... are names referred to by the entries
 185 ;;;; encoded in PACKED-ENTRIES. PACKED-ENTRIES is a (simple-array
 186 ;;;; (unsigned-byte 8) 1) containing variable-width integers (see
 187 ;;;; {READ,WRITE}-VAR-INTEGER). The contained sequence of integers is
 188 ;;;; of the following form:
 189 ;;;;
 190 ;;;;   packed-entries        ::= NAME-BITS NUMBER-BITS entries-for-xref-kind+
 191 ;;;;   entries-for-xref-kind ::= XREF-KIND-AND-ENTRY-COUNT entry+
 192 ;;;;   entry                 ::= NAME-INDEX-AND-FORM-NUMBER
 193 ;;;;
 194 ;;;; where NAME-BITS and NUMBER-BITS are variable-width integers that
 195 ;;;; encode the number of bits used for name indices in
 196 ;;;; NAME-INDEX-AND-FORM-NUMBER and the number of bits used for form
 197 ;;;; numbers in NAME-INDEX-AND-FORM-NUMBER respectively,
 198 ;;;;
 199 ;;;; XREF-KIND-AND-ENTRY-COUNT is a variable-width integer cc...kkk
 200 ;;;; where c bits encode the number of integers (encoded entries)
 201 ;;;; following this integer and k bits encode the xref kind (index
 202 ;;;; into *XREF-KINDS*) of the entries following the integer,
 203 ;;;;
 204 ;;;; NAME-INDEX-AND-FORM-NUMBER is a (name-bits+number-bits)-bit integer
 205 ;;;; ii...nn... where i bits encode a name index (see below) and n
 206 ;;;; bits encode the form number of the xref entry.
 207 ;;;;
 208 ;;;; The name index is either an integer i such that
 209 ;;;;
 210 ;;;;    (< 0 i (length **most-common-xref-names-by-index**))
 211 ;;;;
 212 ;;;; in which case it refers to the i-th name in that vector or
 213 ;;;;
 214 ;;;;    (< 0 (+ i (length **m-c-x-n-b-i**)) (1- (length XREF-DATA)))
 215 ;;;;
 216 ;;;; in which case it is an index (offset by (length **m-c-x-n-b-i**))
 217 ;;;; into the name list NAME1 NAME2 ... starting at index 1 of the
 218 ;;;; outer vector.
 219 ;;;;
 220 ;;;; When packing xref information, an initial pass over the entries
 221 ;;;; that should be packed has to be made to collect unique names and
 222 ;;;; determine the largest form number that will be encoded. Then:
 223 ;;;;
 224 ;;;;   name-bits   <- (integer-length LARGEST-NAME-INDEX)
 225 ;;;;   number-bits <- (integer-length LARGEST-FORM-NUMBER)
 226
 227 ;;; Will be overwritten with 64 most frequently cross referenced
 228 ;;; names.
 229 (declaim (type vector **most-common-xref-names-by-index**)
 230          (type hash-table **most-common-xref-names-by-name**))
 231 (defglobal **most-common-xref-names-by-index** #())
 232 (defglobal **most-common-xref-names-by-name** (make-hash-table :test #'equal))
 233
 234 (flet ((encode-kind-and-count (kind count)
 235          (logior kind (ash (1- count) 3)))
 236        (decode-kind-and-count (integer)
 237          (values (ldb (byte 3 0) integer) (1+ (ash integer -3))))
 238        (index-and-number-encoder (name-bits number-bits)
 239          (lambda (index number)
 240            (dpb number (byte number-bits name-bits) index)))
 241        (index-and-number-decoder (name-bits number-bits)
 242          (lambda (integer)
 243            (values (ldb (byte name-bits 0) integer)
 244                    (ldb (byte number-bits name-bits) integer))))
 245        (name->index (vector)
 246          (let ((common-count (length **most-common-xref-names-by-index**)))
 247            (lambda (name)
 248              (let ((found t))
 249                (values (or (gethash name **most-common-xref-names-by-name**)
 250                            (+ (or (position name vector :start 1 :test #'equal)
 251                                   (progn
 252                                     (setf found nil)
 253                                     (vector-push-extend name vector)
 254                                     (1- (length vector))))
 255                               -1 common-count))
 256                        found)))))
 257        (index->name (vector)
 258          (let ((common-count (length **most-common-xref-names-by-index**)))
 259            (lambda (index)
 260              (if (< index common-count)
 261                  (aref **most-common-xref-names-by-index** index)
 262                  (aref vector (+ index 1 (- common-count))))))))
 263
 264   ;;; Pack the xref table that was stored for a functional into a more
 265   ;;; space-efficient form, and return that packed form.
 266   (defun pack-xref-data (xref-data)
 267     (unless xref-data (return-from pack-xref-data))
 268     (let* ((result (make-array 1 :adjustable t :fill-pointer 1))
 269            (ensure-index (name->index result))
 270            (entries '())
 271            (max-index 0)
 272            (max-number 0))
 273       ;; Collect unique names, assigning indices (implicitly via
 274       ;; position in RESULT). Determine MAX-INDEX and MAX-NUMBER, the
 275       ;; largest name index and form number respectively, occurring in
 276       ;; XREF-DATA.
 277       (labels ((collect-entries-for-kind (kind records)
 278                  (let* ((kind-number (position kind *xref-kinds* :test #'eq))
 279                         (kind-entries (cons kind-number '())))
 280                    (push kind-entries entries)
 281                    (mapc
 282                     (lambda (record)
 283                       (destructuring-bind (name . number) record
 284                         (binding* (((index foundp) (funcall ensure-index name))
 285                                    (cell
 286                                     (or (when foundp
 287                                           (find index (cdr kind-entries) :key #'first))
 288                                         (let ((cell (list index)))
 289                                           (push cell (cdr kind-entries))
 290                                           cell))))
 291                           (pushnew number (cdr cell) :test #'=)
 292                           (setf max-index (max max-index index)
 293                                 max-number (max max-number number)))))
 294                     records))))
 295         (loop for (kind records) on xref-data by #'cddr
 296            when records do (collect-entries-for-kind kind records)))
 297       ;; Encode the number of index and form number bits followed by
 298       ;; chunks of collected entries for all kinds.
 299       (let* ((name-bits (integer-length max-index))
 300              (number-bits (integer-length max-number))
 301              (encoder (index-and-number-encoder name-bits number-bits))
 302              (vector (make-array 0 :element-type '(unsigned-byte 8)
 303                                  :adjustable t :fill-pointer 0)))
 304         (write-var-integer name-bits vector)
 305         (write-var-integer number-bits vector)
 306         (loop for (kind-number . kind-entries) in entries
 307            for kind-count = (reduce #'+ kind-entries
 308                                     :key (lambda (entry) (length (cdr entry))))
 309            do (write-var-integer
 310                (encode-kind-and-count kind-number kind-count) vector)
 311              (loop for (index . numbers) in kind-entries
 312                 do (dolist (number numbers)
 313                      (write-var-integer (funcall encoder index number) vector))))
 314         (setf (aref result 0) (!make-specialized-array
 315                                (length vector) '(unsigned-byte 8) vector)))
 316       ;; RESULT is adjustable. Make it simple.
 317       (coerce result 'simple-vector)))
 318
 319   ;;; Call FUNCTION for each entry in XREF-DATA. FUNCTION's
 320   ;;; lambda-list has to be compatible to
 321   ;;;
 322   ;;;   (kind name form-number)
 323   ;;;
 324   ;;; where KIND is the xref kind (see *XREF-KINDS*), NAME is the name
 325   ;;; of the referenced thing and FORM-NUMBER is the number of the
 326   ;;; form in which the reference occurred.
 327   (defun map-packed-xref-data (function xref-data)
 328     (let* ((function (coerce function 'function))
 329            (lookup (index->name xref-data))
 330            (packed (aref xref-data 0))
 331            (offset 0)
 332            (decoder (index-and-number-decoder
 333                      (read-var-integerf packed offset)
 334                      (read-var-integerf packed offset))))
 335       (loop while (< offset (length packed))
 336          do (binding* (((kind-number record-count)
 337                         (decode-kind-and-count (read-var-integerf packed offset)))
 338                        (kind (nth kind-number *xref-kinds*)))
 339               (loop repeat record-count
 340                  do (binding* (((index number)
 341                                 (funcall decoder (read-var-integerf packed offset)))
 342                                (name (funcall lookup index)))
 343                       (funcall function kind name number))))))))