;;;; xref facility

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-C")

(defconstant-eqx +xref-kinds+ #(:binds :calls :sets :references :macroexpands)
  #'equalp)

(defun record-component-xrefs (component)
  (declare (type component component))
  (unless (policy *lexenv* (zerop store-xref-data))
    (do-blocks (block component)
      (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.
               (do-nodes (node nil block)
                 (record-node-xrefs node functional))
               ;; Properly record the deferred macroexpansion and source
               ;; transform information that's been stored in the block.
               (loop for (kind what path) in (block-xrefs block)
                     do (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)
  (let* ((functional (block-home-lambda block))
         (seen nil))
    (when (policy functional (plusp store-xref-data))
      (labels ((local-function-name-p (name)
                 (and (consp name)
                      (member (car name)
                              '(flet labels lambda))))
               (handle-refs (functional)
                 ;; Recurse only if we haven't already seen the
                 ;; functional.
                 (unless (memq functional seen)
                   (push functional seen)
                   (loop for ref in (functional-refs functional)
                         thereis (handle-functional (node-home-lambda ref)))))
               (handle-functional (functional)
                 ;; If a functional looks like a global function (has a
                 ;; XEP, isn't a local function or a lambda) record xref
                 ;; information for it. Otherwise recurse on the
                 ;; home-lambdas of all references to the functional.
                 (when (functional-kind-eq functional external)
                   (let ((entry (functional-entry-fun functional)))
                     (when entry
                       (let ((name (functional-debug-name entry)))
                         ;; Is it a lambda inside another function?
                         (when (or (not (local-function-name-p name))
                                   (not (handle-refs functional)))
                           (funcall fun entry)
                           (return-from handle-functional t))))))
                 (handle-refs functional)))
        (unless (or (functional-kind-eq functional deleted)
                    ;; If the block came from an inlined global
                    ;; function, ignore it.
                    (and (functional-inline-expanded functional)
                         (symbolp (functional-debug-name functional))))
          (handle-functional functional))))))

(defun record-node-xrefs (node context)
  (declare (type node node))
  (etypecase node
    ((or creturn cif entry mv-combination cast exit
         enclose cdynamic-extent jump-table))
    (combination
     (let ((name (combination-fun-debug-name node)))
       (when (equal name '(cas symbol-value))
         (let ((symbol (third (combination-args node))))
           (when (constant-lvar-p symbol)
             ;; It also references the symbol, but it's probably not
             ;; the primary reason for doing CAS.
             (record-xref :sets (lvar-value symbol) context node nil))))))
    (ref
     (let ((leaf (ref-leaf node)))
       (typecase leaf
         (global-var
          (let* ((name (leaf-debug-name leaf)))
            (case (global-var-kind leaf)
              ;; Reading a special
              ((:special :global)
               (record-xref :references name context node nil))
              ;; Calling a function
              (:global-function
               (record-xref :calls name context node nil)))))
         ;; Inlined global function
         (clambda
          (let ((fun (or (lambda-optional-dispatch leaf) leaf)))
            (when (and (leaf-has-source-name-p fun)
                       (functional-inline-expanded fun))
              ;; TODO: a WHO-INLINES xref-kind could be useful
              (record-xref :calls (leaf-source-name fun) context node nil))))
         ;; Reading a constant
         (constant
          (record-xref :references (leaf-%source-name leaf) context node nil)))))
    ;; Setting a special variable
    (cset
     (let ((var (set-var node)))
       (when (and (global-var-p var)
                  (memq (global-var-kind var) '(:special :global)))
         (record-xref :sets
                      (leaf-debug-name var)
                      context
                      node
                      nil))))
    ;; Binding a special variable
    (bind
     (let ((vars (lambda-vars (bind-lambda node))))
       (dolist (var vars)
         (when (lambda-var-specvar var)
           (record-xref :binds
                        (lambda-var-%source-name var)
                        context
                        node
                        nil)))))))

(defun xref-internal-name-p (what)
  ;; 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 #'xref-internal-name-p what))
    (symbol
     (or (eq '.anonymous. what)
         #-sb-xref-for-internals
         (let ((pkg (sb-xc:symbol-package what)))
           (or (and pkg (system-package-p pkg))
               (eq pkg *cl-package*)))))
    (t t)))

(defun record-xref (kind what context node path)
  (unless (xref-internal-name-p what)
    (push (cons what
                (source-path-form-number (or path
                                             (node-source-path node))))
          (getf (functional-xref context) kind))))

(defun record-macroexpansion (what block path)
  (unless (xref-internal-name-p what)
    (push (list :macroexpands what path) (block-xrefs block))))

(defun record-call (what block path)
  (unless (xref-internal-name-p what)
    (push (list :calls what path) (block-xrefs block))))

(defun record-late-xref (kind what node)
  (unless (policy node (zerop store-xref-data))
    (call-with-block-external-functionals (node-block node)
                                          (lambda (functional)
                                            (record-xref kind what functional node nil)))))


;;;; Packing of xref tables
;;;;
;;;; xref information can be transformed into the following "packed"
;;;; form to save space:
;;;;
;;;;   #(PACKED-ENTRIES NAME1 NAME2 ...)
;;;;
;;;; where NAME1 NAME2 ... are names referred to by the entries
;;;; encoded in PACKED-ENTRIES. PACKED-ENTRIES is a (simple-array
;;;; (unsigned-byte 8) 1) containing variable-width integers (see
;;;; {READ,WRITE}-VAR-INTEGER). The contained sequence of integers is
;;;; of the following form:
;;;;
;;;;   packed-entries        ::= NAME-BITS NUMBER-COUNT-BITS entries-for-xref-kind+
;;;;   entries-for-xref-kind ::= XREF-KIND-AND-ENTRY-COUNT entry+
;;;;   entry                 ::= NAME-INDEX-AND-FORM-NUMBER-COUNT
;;;;   n-form-numbers+:  each number is an offset from the previous, starting from 0
;;;;
;;;; where NAME-BITS and NUMBER-COUNT-BITS are variable-width integers that
;;;; encode the number of bits used for name indices in
;;;; NAME-INDEX-AND-FORM-NUMBER-COUNT and the number of bits used for form
;;;; numbers in NAME-INDEX-AND-FORM-NUMBER respectively,
;;;;
;;;; XREF-KIND-AND-ENTRY-COUNT is a variable-width integer cc...kkk
;;;; where c bits encode the number of integers (encoded entries)
;;;; following this integer and k bits encode the xref kind (index
;;;; into +XREF-KINDS+) of the entries following the integer,
;;;;
;;;; NAME-INDEX-AND-FORM-NUMBER is a (name-bits+number-bits)-bit integer
;;;; ii...nn... where i bits encode a name index (see below) and n
;;;; bits encode the form number of the xref entry.
;;;;
;;;; The name index is either an integer i such that
;;;;
;;;;    (< 0 i (length **most-common-xref-names-by-index**))
;;;;
;;;; in which case it refers to the i-th name in that vector or
;;;;
;;;;    (< 0 (+ i (length **m-c-x-n-b-i**)) (1- (length XREF-DATA)))
;;;;
;;;; in which case it is an index (offset by (length **m-c-x-n-b-i**))
;;;; into the name list NAME1 NAME2 ... starting at index 1 of the
;;;; outer vector.
;;;;
;;;; When packing xref information, an initial pass over the entries
;;;; that should be packed has to be made to collect unique names and
;;;; determine the largest form number that will be encoded. Then:
;;;;
;;;;   name-bits   <- (integer-length LARGEST-NAME-INDEX)
;;;;   number-bits <- (integer-length LARGEST-FORM-NUMBER-COUNT)

;;; Will be overwritten with 64 most frequently cross referenced
;;; names.
(declaim (type vector **most-common-xref-names-by-index**)
         (type hash-table **most-common-xref-names-by-name**))
(defglobal **most-common-xref-names-by-index** #())
(defglobal **most-common-xref-names-by-name** (make-hash-table :test #'equal))

(flet ((encode-kind-and-count (kind count)
         (logior kind (ash (1- count) 3)))
       (decode-kind-and-count (integer)
         (values (ldb (byte 3 0) integer) (1+ (ash integer -3))))
       (index-and-number-encoder (name-bits number-bits)
         (lambda (index number)
           (dpb number (byte number-bits name-bits) index)))
       (index-and-number-decoder (name-bits number-bits)
         (lambda (integer)
           (values (ldb (byte name-bits 0) integer)
                   (ldb (byte number-bits name-bits) integer))))
       (name->index (vector)
         (let ((common-count (length **most-common-xref-names-by-index**)))
           (lambda (name)
             (let ((found t))
               (values (or (gethash name **most-common-xref-names-by-name**)
                           (+ (or (position name vector :start 1 :test #'equal)
                                  (progn
                                    (setf found nil)
                                    (vector-push-extend name vector)
                                    (1- (length vector))))
                              -1 common-count))
                       found)))))
       (index->name (vector)
         (let ((common-count (length **most-common-xref-names-by-index**)))
           (lambda (index)
             (if (< index common-count)
                 (aref **most-common-xref-names-by-index** index)
                 (aref vector (+ index 1 (- common-count))))))))
  (declare (inline decode-kind-and-count index-and-number-decoder index->name))

  ;;; Pack the xref table that was stored for a functional into a more
  ;;; space-efficient form, and return that packed form.
  (defun pack-xref-data (xref-data)
    (unless xref-data (return-from pack-xref-data))
    (let* ((result (make-array 1 :adjustable t :fill-pointer 1
                                 :initial-element 0))
           (ensure-index (name->index result))
           (entries '())
           (max-index 0)
           (max-number 0))
      ;; Collect unique names, assigning indices (implicitly via
      ;; position in RESULT). Determine MAX-INDEX and MAX-NUMBER, the
      ;; largest name index and form number respectively, occurring in
      ;; XREF-DATA.
      (labels ((collect-entries-for-kind (kind records)
                 (let* ((kind-number (position kind +xref-kinds+ :test #'eq))
                        (kind-entries (cons kind-number '())))
                   (push kind-entries entries)
                   (mapc
                    (lambda (record)
                      (destructuring-bind (name . number) record
                        (binding* (((index foundp) (funcall ensure-index name))
                                   (cell
                                    (or (when foundp
                                          (find index (cdr kind-entries) :key #'first))
                                        (let ((cell (list index)))
                                          (push cell (cdr kind-entries))
                                          cell))))
                          (pushnew number (cdr cell) :test #'=)
                          (setf max-index (max max-index index)
                                max-number (max max-number (length (cdr cell)))))))
                    records))))
        (loop for (kind records) on xref-data by #'cddr
           when records do (collect-entries-for-kind kind records)))
      ;; Encode the number of index and form number bits followed by
      ;; chunks of collected entries for all kinds.
      (let* ((name-bits (integer-length max-index))
             (number-bits (integer-length max-number))
             (encoder (index-and-number-encoder name-bits number-bits))
             (vector (make-array 0 :element-type '(unsigned-byte 8)
                                 :adjustable t :fill-pointer 0 :initial-element 0)))
        (write-var-integer name-bits vector)
        (write-var-integer number-bits vector)
        (loop for (kind-number . kind-entries) in entries
              for kind-count = (length kind-entries)
              do (write-var-integer
                  (encode-kind-and-count kind-number kind-count) vector)
                 (loop for (index . numbers) in kind-entries
                       do
                       (write-var-integer (funcall encoder index (length numbers)) vector)
                       (let ((prev 0))
                         (dolist (number (sort numbers #'<))
                           (write-var-integer (- number prev) vector)
                           (setf prev number)))))
        (setf (aref result 0)
              (coerce vector '(simple-array (unsigned-byte 8) 1))))
      ;; RESULT is adjustable. Make it simple.
      (coerce result 'simple-vector)))

  ;;; Call FUNCTION for each entry in XREF-DATA. FUNCTION's
  ;;; lambda-list has to be compatible to
  ;;;
  ;;;   (kind name form-number)
  ;;;
  ;;; where KIND is the xref kind (see +XREF-KINDS+), NAME is the name
  ;;; of the referenced thing and FORM-NUMBER is the number of the
  ;;; form in which the reference occurred.
  (defun map-packed-xref-data (function xref-data)
    (declare (dynamic-extent function))
    (let* ((function (coerce function 'function))
           (lookup (index->name xref-data))
           (packed (aref xref-data 0))
           (offset 0)
           (decoder (index-and-number-decoder
                     (read-var-integerf packed offset)
                     (read-var-integerf packed offset))))
      (loop while (< offset (length packed))
            do (binding* (((kind-number record-count)
                           (decode-kind-and-count (read-var-integerf packed offset)))
                          (kind (elt +xref-kinds+ kind-number)))
                 (loop repeat record-count
                       do (binding* (((index number-count)
                                      (funcall decoder (read-var-integerf packed offset)))
                                     (name (funcall lookup index)))
                            (let ((prev 0))
                              (loop repeat number-count
                                    for form-number = (+ (read-var-integerf packed offset) prev)
                                    do
                                    (funcall function kind name form-number)
                                    (setf prev form-number))))))))))
