1 ;;;; Repacking xref information exploiting occurrence frequencies
3 ;;;; This software is part of the SBCL system. See the README file for
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.
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.
22 (labels ((functoid-simple-fun (functoid)
25 (functoid-simple-fun (fdefn-fun functoid
)))
27 (let ((fun (%closure-fun functoid
)))
28 (if (and (eq (%fun-name fun
) 'sb-impl
::encapsulation
))
30 (sb-impl::encapsulation-info-definition
31 (sb-impl::encapsulation-info functoid
)))
33 ((and function
(not funcallable-instance
))
34 (%fun-fun functoid
)))))
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
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
))
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
58 (typep (fdefn-name it
)
59 '(cons (member sb-pcl
::slow-method
60 sb-pcl
::fast-method
)))))
62 (process name it
))))))))))
64 ;;; Repack all xref data vectors in the system, potentially making
65 ;;; them compact, but without changing their meaning:
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.
72 ;;; 2. Update **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** with this
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
83 (counts-by-name (make-hash-table :test
#'equal
))
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)))))
94 ;; Unpack (using old values of
95 ;; **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**) xref data and count
96 ;; occurrence frequencies of names.
99 (declare (ignore name
))
100 (binding* ((xrefs (%simple-fun-xrefs fun
) :exit-if-null
)
101 (seen (make-hash-table :test
#'equal
))
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)))
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
)))))
118 (unless unpacked
(break))
119 ;; Store FUN and UNPACKED for repacking.
120 (push (cons fun unpacked
) all-unpacked
))))
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
))))
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
)))
133 (setf **most-common-xref-names-by-index
** (coerce new-names
'vector
))
134 (let ((table **most-common-xref-names-by-name
**))
136 (loop for name in new-names
138 do
(setf (gethash name table
) i
))))
140 ;; Repack with updated **MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}**.
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
)
152 (format t
"; Old xref size ~11:D byte~:P~@
153 ; New xref size ~11:D byte~:P~%"
154 old-size new-size
))))