;;;; Repacking xref information exploiting occurrence frequencies
;;;; 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.
;;;; Since the most frequently referenced names (even just within SBCL
;;;; itself) are not known until the system is built, the computing
;;;; the frequencies has to be done in warm load. However, all xref
;;;; information has already been collected and stored by that
;;;; time. Therefore, after the frequencies have been computed, all
;;;; xref information is unpacked and repacked, this time exploiting
;;;; the compact encoding for the most frequent names.
(in-package "SB-C")
(labels ((functoid-simple-fun (functoid)
(typecase functoid
(fdefn
(functoid-simple-fun (fdefn-fun functoid)))
(closure
(let ((fun (%closure-fun functoid)))
(if (and (eq (%fun-name fun) 'sb-impl::encapsulation))
(functoid-simple-fun
(sb-impl::encapsulation-info-definition
(sb-impl::encapsulation-info functoid)))
fun)))
((and function (not funcallable-instance))
(%fun-fun functoid)))))
;;; Note that this function is used by sb-introspect.
(defun map-simple-funs (function)
(let ((function (%coerce-callable-to-fun function)))
(labels ((process (name value)
(awhen (functoid-simple-fun value)
(funcall function name it))))
(call-with-each-globaldb-name
(lambda (name)
;; In general it might be unsafe to call INFO with a NAME
;; that is not valid for the kind of info being retrieved,
;; as when the defaulting function tries to perform a
;; sanity-check. But here it's safe.
(awhen (or (info :function :macro-function name)
(info :function :definition name))
(cond
((and (fdefn-p it)
(typep (fdefn-fun it) 'generic-function))
(loop for method in (sb-mop:generic-function-methods (fdefn-fun it))
for fun = (sb-pcl::safe-method-fast-function method)
when fun do (process (sb-kernel:%fun-name fun) fun)))
;; Methods are already processed above
((and (fdefn-p it)
(typep (fdefn-name it)
'(cons (member sb-pcl::slow-method
sb-pcl::fast-method)))))
(t
(process name it))))))))))
;;; Repack all xref data vectors in the system, potentially making
;;; them compact, but without changing their meaning:
;;;
;;; 1. Go through all xref data vectors, unpacking their contents
;;; (using the current values of
;;; **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**) and determining the
;;; COMPACT-NAME-COUNT most frequently referenced names.
;;;
;;; 2. Update **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** with this
;;; information.
;;;
;;; 3. Repack all xref data vectors using the updated
;;; **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
(defun repack-xref (&key (compact-name-count 256) verbose)
(let ((verbose (ecase verbose
((nil) 0)
((1 2) verbose)
((t) 2)))
(counts '())
(counts-by-name (make-hash-table :test #'equal))
(all-unpacked '())
(old-size 0)
(new-size 0))
(flet ((xref-size (xref)
;; Disregarding overhead for array headers, required
;; space is number of octets in nested octet-vector plus
;; one word for each element in outer vector.
(+ (* sb-vm:n-word-bytes (length xref))
(length (aref xref 0)))))
;; Unpack (using old values of
;; **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**) xref data and count
;; occurrence frequencies of names.
(map-simple-funs
(lambda (name fun)
(declare (ignore name))
(binding* ((xrefs (%simple-fun-xrefs fun) :exit-if-null)
(seen (make-hash-table :test #'equal))
(unpacked '()))
;; Record size of the xref data for this simple fun.
(incf old-size (xref-size xrefs))
(map-packed-xref-data
(lambda (kind name number)
;; Count NAME, but only once for each FUN.
(unless (gethash name seen)
(setf (gethash name seen) t)
(incf (cdr (ensure-gethash name counts-by-name
(let ((cell (cons name 0)))
(push cell counts)
cell)))))
;; Store (KIND NAME NUMBER) tuple for repacking.
(setf (getf unpacked kind) (nconc (getf unpacked kind)
(list (cons name number)))))
xrefs)
(unless unpacked (break))
;; Store FUN and UNPACKED for repacking.
(push (cons fun unpacked) all-unpacked))))
;; Update **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
(let* ((sorted-names (mapcar #'car (stable-sort counts #'> :key #'cdr)))
(new-names (subseq sorted-names 0 (min (length sorted-names)
compact-name-count))))
(when (>= verbose 2)
(format t "; Updating most frequently cross-referenced names~%")
(pprint-logical-block (*standard-output* new-names :per-line-prefix "; ")
(format t "~:[no cross references~;~:*~
~{~/sb-ext:print-symbol-with-prefix/~^ ~:_~}~]"
(coerce new-names 'list)))
(terpri))
(setf **most-common-xref-names-by-index** (coerce new-names 'vector))
(let ((table **most-common-xref-names-by-name**))
(clrhash table)
(loop for name in new-names
for i from 0
do (setf (gethash name table) i))))
;; Repack with updated **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
(when (>= verbose 1)
(format t "; Repacking xref information~%"))
(loop for (fun . unpacked) in all-unpacked do
(let ((new-xrefs (pack-xref-data unpacked)))
(incf new-size (xref-size new-xrefs))
(aver (vectorp new-xrefs))
(let ((info (%simple-fun-info fun)))
(if (typep info '(cons t simple-vector))
(rplacd info new-xrefs)
(setf (%simple-fun-info fun) new-xrefs))))))
(when (>= verbose 1)
(format t "; Old xref size ~11:D byte~:P~@
; New xref size ~11:D byte~:P~%"
old-size new-size))))