src/code/repack-xref.lisp

   1 ;;;; Repacking xref information exploiting occurrence frequencies
   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 ;;;; Since the most frequently referenced names (even just within SBCL
  13 ;;;; itself) are not known until the system is built, the computing
  14 ;;;; the frequencies has to be done in warm load. However, all xref
  15 ;;;; information has already been collected and stored by that
  16 ;;;; time. Therefore, after the frequencies have been computed, all
  17 ;;;; xref information is unpacked and repacked, this time exploiting
  18 ;;;; the compact encoding for the most frequent names.
  19
  20 (in-package "SB-C")
  21
  22 (labels ((functoid-simple-fun (functoid)
  23            (typecase functoid
  24              (fdefn
  25               (functoid-simple-fun (fdefn-fun functoid)))
  26              (closure
  27               (let ((fun (%closure-fun functoid)))
  28                 (if (and (eq (%fun-name fun) 'sb-impl::encapsulation))
  29                     (functoid-simple-fun
  30                      (sb-impl::encapsulation-info-definition
  31                       (sb-impl::encapsulation-info functoid)))
  32                     fun)))
  33              ((and function (not funcallable-instance))
  34               (%fun-fun functoid)))))
  35
  36   ;;; Note that this function is used by sb-introspect.
  37   (defun map-simple-funs (function)
  38     (let ((function (%coerce-callable-to-fun function)))
  39       (labels ((process (name value)
  40                  (awhen (functoid-simple-fun value)
  41                    (funcall function name it))))
  42         (call-with-each-globaldb-name
  43          (lambda (name)
  44            ;; In general it might be unsafe to call INFO with a NAME
  45            ;; that is not valid for the kind of info being retrieved,
  46            ;; as when the defaulting function tries to perform a
  47            ;; sanity-check. But here it's safe.
  48            (awhen (or (info :function :macro-function name)
  49                       (info :function :definition name))
  50              (cond
  51                ((and (fdefn-p it)
  52                      (typep (fdefn-fun it) 'generic-function))
  53                 (loop for method in (sb-mop:generic-function-methods (fdefn-fun it))
  54                    for fun = (sb-pcl::safe-method-fast-function method)
  55                    when fun do (process (sb-kernel:%fun-name fun) fun)))
  56                ;; Methods are already processed above
  57                ((and (fdefn-p it)
  58                      (typep (fdefn-name it)
  59                             '(cons (member sb-pcl::slow-method
  60                                            sb-pcl::fast-method)))))
  61                (t
  62                 (process name it))))))))))
  63
  64 ;;; Repack all xref data vectors in the system, potentially making
  65 ;;; them compact, but without changing their meaning:
  66 ;;;
  67 ;;; 1. Go through all xref data vectors, unpacking their contents
  68 ;;;    (using the current values of
  69 ;;;    **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**) and determining the
  70 ;;;    COMPACT-NAME-COUNT most frequently referenced names.
  71 ;;;
  72 ;;; 2. Update **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** with this
  73 ;;;    information.
  74 ;;;
  75 ;;; 3. Repack all xref data vectors using the updated
  76 ;;;    **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
  77 (defun repack-xref (&key (compact-name-count 256) verbose)
  78   (let ((verbose (ecase verbose
  79                    ((nil) 0)
  80                    ((1 2) verbose)
  81                    ((t)   2)))
  82         (counts '())
  83         (counts-by-name (make-hash-table :test #'equal))
  84         (all-unpacked '())
  85         (old-size 0)
  86         (new-size 0))
  87     (flet ((xref-size (xref)
  88              ;; Disregarding overhead for array headers, required
  89              ;; space is number of octets in nested octet-vector plus
  90              ;; one word for each element in outer vector.
  91              (+ (* sb-vm:n-word-bytes (length xref))
  92                 (length (aref xref 0)))))
  93
  94       ;; Unpack (using old values of
  95       ;; **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**) xref data and count
  96       ;; occurrence frequencies of names.
  97       (map-simple-funs
  98        (lambda (name fun)
  99          (declare (ignore name))
 100          (binding* ((xrefs (%simple-fun-xrefs fun) :exit-if-null)
 101                     (seen (make-hash-table :test #'equal))
 102                     (unpacked '()))
 103            ;; Record size of the xref data for this simple fun.
 104            (incf old-size (xref-size xrefs))
 105            (map-packed-xref-data
 106             (lambda (kind name number)
 107               ;; Count NAME, but only once for each FUN.
 108               (unless (gethash name seen)
 109                 (setf (gethash name seen) t)
 110                 (incf (cdr (or (gethash name counts-by-name)
 111                                (let ((cell (cons name 0)))
 112                                  (push cell counts)
 113                                  (setf (gethash name counts-by-name) cell))))))
 114               ;; Store (KIND NAME NUMBER) tuple for repacking.
 115               (setf (getf unpacked kind) (nconc (getf unpacked kind)
 116                                                 (list (cons name number)))))
 117             xrefs)
 118            (unless unpacked (break))
 119            ;; Store FUN and UNPACKED for repacking.
 120            (push (cons fun unpacked) all-unpacked))))
 121
 122       ;; Update **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
 123       (let* ((sorted-names (mapcar #'car (stable-sort counts #'> :key #'cdr)))
 124              (new-names (subseq sorted-names 0 (min (length sorted-names)
 125                                                     compact-name-count))))
 126         (when (>= verbose 2)
 127           (format t "; Updating most frequently cross-referenced names~%")
 128           (pprint-logical-block (*standard-output* new-names :per-line-prefix ";   ")
 129             (format t "~:[no cross references~;~:*~
 130                        ~{~/sb-impl:print-symbol-with-prefix/~^ ~:_~}~]"
 131                     (coerce new-names 'list)))
 132           (terpri))
 133         (setf **most-common-xref-names-by-index** (coerce new-names 'vector))
 134         (let ((table **most-common-xref-names-by-name**))
 135           (clrhash table)
 136           (loop for name in new-names
 137              for i from 0
 138              do (setf (gethash name table) i))))
 139
 140       ;; Repack with updated **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
 141       (when (>= verbose 1)
 142         (format t "; Repacking xref information~%"))
 143       (loop for (fun . unpacked) in all-unpacked do
 144            (let ((info (%simple-fun-info fun))
 145                  (new-xrefs (pack-xref-data unpacked)))
 146              (incf new-size (xref-size new-xrefs))
 147              (setf (%simple-fun-info fun) (if (consp info)
 148                                               (cons (car info) new-xrefs)
 149                                               new-xrefs)))))
 150
 151     (when (>= verbose 1)
 152       (format t ";   Old xref size ~11:D byte~:P~@
 153                  ;   New xref size ~11:D byte~:P~%"
 154               old-size new-size))))