1.0.21.19: Eagerly find a stream's external-format when a coding-error occurs.
[sbcl.git] / src / code / dyncount.lisp
1 ;;;; runtime support for dynamic VOP statistics collection
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!DYNCOUNT")
13
14 #|
15 comments from CMU CL:
16   Make sure multi-cycle instruction costs are plausible.
17   VOP classification.
18     Make tables of %cost for benchmark X class.
19     Could be represented as a sort of bar chart.
20 |#
21
22 (eval-when (:compile-toplevel)
23   (when *collect-dynamic-statistics*
24     (error "Compiling this file with dynamic stat collection turned on would ~
25     be a very bad idea.")))
26 \f
27 ;;;; hash utilities
28
29 (defun make-hash-table-like (table)
30   #!+sb-doc
31   "Make a hash-table with the same test as table."
32   (declare (type hash-table table))
33   (make-hash-table :test (sb!impl::hash-table-kind table)))
34
35 (defun hash-difference (table1 table2)
36   #!+sb-doc
37   "Return a hash-table containing only the entries in Table1 whose key is not
38    also a key in Table2." (declare (type hash-table table1 table2))
39   (let ((res (make-hash-table-like table1)))
40     (with-locked-hash-table (table2)
41       (dohash ((k v) table1 :locked t)
42         (unless (nth-value 1 (gethash k table2))
43           (setf (gethash k res) v))))
44     res))
45
46 (defun hash-list (table)
47   #!+sb-doc
48   "Return a list of the values in Table."
49   (declare (type hash-table table))
50   (collect ((res))
51     (dohash ((k v) table)
52       (declare (ignore k))
53       (res v))
54     (res)))
55
56 ;;; Read (or write) a hashtable from (or to) a file.
57 (defun read-hash-table (file)
58   (with-open-file (s file :direction :input)
59     (dotimes (i 3)
60       (format t "~%; ~A" (read-line s)))
61     (let* ((eof '(nil))
62            (test (read s))
63            (reader (read s))
64            (res (make-hash-table :test test)))
65       (read s); Discard writer...
66       (loop
67         (let ((key (read s nil eof)))
68           (when (eq key eof) (return))
69           (setf (gethash key res)
70                 (funcall reader s key))))
71       res)))
72 (defun write-hash-table (table file &key
73                                (comment (format nil "Contents of ~S" table))
74                                (reader 'read) (writer 'prin1) (test 'equal))
75   (with-open-file (s file :direction :output :if-exists :new-version)
76     (with-standard-io-syntax
77       (let ((*print-readably* nil))
78         (format s
79                 "~A~%~A version ~A on ~A~%"
80                 comment
81                 (lisp-implementation-type)
82                 (lisp-implementation-version)
83                 (machine-instance))
84         (format-universal-time s (get-universal-time))
85         (terpri s)
86         (format s "~S ~S ~S~%" test reader writer)
87         (dohash ((k v) table :locked t)
88           (prin1 k s)
89           (write-char #\space s)
90           (funcall writer v s)
91           (terpri s)))))
92   table)
93 \f
94 ;;;; info accumulation
95
96 ;;; Used to accumulate info about the usage of a single VOP. Cost and count
97 ;;; are kept as double-floats, which lets us get more bits and avoid annoying
98 ;;; overflows.
99 (deftype count-vector () '(simple-array double-float (2)))
100 (defstruct (vop-stats
101             (:constructor %make-vop-stats (name))
102             (:constructor make-vop-stats-key)
103             (:copier nil))
104   (name (missing-arg) :type simple-string)
105   (data (make-array 2 :element-type 'double-float) :type count-vector))
106
107 (defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0))
108 (defmacro vop-stats-cost (x) `(aref (vop-stats-data ,x) 1))
109
110 (defun make-vop-stats (&key name count cost)
111   (let ((res (%make-vop-stats name)))
112     (setf (vop-stats-count res) count)
113     (setf (vop-stats-cost res) cost)
114     res))
115
116 #!-sb-fluid (declaim (freeze-type dyncount-info vop-stats))
117
118 ;;;    Add the Info into the cumulative result on the VOP name plist. We use
119 ;;; plists so that we will touch minimal system code outside of this file
120 ;;; (which may be compiled with profiling on.)
121 (defun note-dyncount-info (info)
122   (declare (type dyncount-info info) (inline get %put)
123            (optimize (speed 2)))
124   (let ((counts (dyncount-info-counts info))
125         (vops (dyncount-info-vops info)))
126     (dotimes (index (length counts))
127       (declare (type index index))
128       (let ((count (coerce (the (unsigned-byte 31)
129                                 (aref counts index))
130                            'double-float)))
131         (when (minusp count)
132           (warn "Oops: overflow.")
133           (return-from note-dyncount-info nil))
134         (unless (zerop count)
135           (let* ((vop-info (svref vops index))
136                  (length (length vop-info)))
137             (declare (simple-vector vop-info))
138             (do ((i 0 (+ i 4)))
139                 ((>= i length))
140               (declare (type index i))
141               (let* ((name (svref vop-info i))
142                      (entry (or (get name 'vop-stats)
143                                 (setf (get name 'vop-stats)
144                                       (%make-vop-stats (symbol-name name))))))
145                 (incf (vop-stats-count entry)
146                       (* (coerce (the index (svref vop-info (1+ i)))
147                                  'double-float)
148                          count))
149                 (incf (vop-stats-cost entry)
150                       (* (coerce (the index (svref vop-info (+ i 2)))
151                                  'double-float)
152                          count))))))))))
153
154 (defun clear-dyncount-info (info)
155   (declare (type dyncount-info info))
156   (declare (optimize (speed 3) (safety 0)))
157   (let ((counts (dyncount-info-counts info)))
158     (dotimes (i (length counts))
159       (setf (aref counts i) 0))))
160
161 ;;; Clear any VOP-COUNTS properties and the counts vectors for all code
162 ;;; objects. The latter loop must not call any random functions.
163 (defun clear-vop-counts (&optional (spaces '(:dynamic)))
164   #!+sb-doc
165   "Clear all dynamic VOP counts for code objects in the specified spaces."
166   (dohash ((k v) *backend-template-names* :locked t)
167     (declare (ignore v))
168     (remprop k 'vop-stats))
169
170   (locally
171       (declare (optimize (speed 3) (safety 0))
172                (inline sb!vm::map-allocated-objects))
173     (without-gcing
174       (dolist (space spaces)
175         (sb!vm::map-allocated-objects
176          (lambda (object type-code size)
177            (declare (ignore type-code size))
178            (when (dyncount-info-p object)
179              (clear-dyncount-info object)))
180          space)))))
181
182 ;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the
183 ;;; specified spaces. Return a hashtable describing the counts. The initial
184 ;;; loop must avoid calling any functions outside this file to prevent adding
185 ;;; noise to the data, since other files may be compiled with profiling.
186 (defun get-vop-counts (&optional (spaces '(:dynamic)) &key (clear nil))
187   #!+sb-doc
188   "Return a hash-table mapping string VOP names to VOP-STATS structures
189    describing the VOPs executed. If clear is true, then reset all counts to
190    zero as a side effect."
191   (locally
192       (declare (optimize (speed 3) (safety 0))
193                (inline sb!vm::map-allocated-objects))
194     (without-gcing
195       (dolist (space spaces)
196         (sb!vm::map-allocated-objects
197          (lambda (object type-code size)
198            (declare (ignore type-code size))
199            (when (dyncount-info-p object)
200              (note-dyncount-info object)
201              (when clear
202                (clear-dyncount-info object))))
203          space))))
204
205   (let ((counts (make-hash-table :test 'equal)))
206     (dohash ((k v) *backend-template-names* :locked t)
207       (declare (ignore v))
208       (let ((stats (get k 'vop-stats)))
209         (when stats
210           (setf (gethash (symbol-name k) counts) stats)
211           (when clear
212             (remprop k 'vop-stats)))))
213     counts))
214
215 ;;; Return the DYNCOUNT-INFO for FUNCTION.
216 (defun find-info-for (function)
217   (declare (type function function))
218   (let* ((function (%primitive closure-fun function))
219          (component (sb!di::fun-code-header function)))
220     (do ((end (get-header-data component))
221          (i sb!vm:code-constants-offset (1+ i)))
222         ((= end i))
223       (let ((constant (code-header-ref component i)))
224         (when (dyncount-info-p constant)
225           (return constant))))))
226
227 (defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space)
228   #!+sb-doc
229   "Apply Function to Args, collecting dynamic statistics on the running.
230    Spaces are the spaces to scan for counts. If By-Space is true, we return a
231    list of result tables, instead of a single table. In this case, specify
232    :READ-ONLY first."
233   (clear-vop-counts spaces)
234   (apply function args)
235   (if by-space
236       (mapcar (lambda (space)
237                 (get-vop-counts (list space) :clear t))
238               spaces)
239       (get-vop-counts spaces)))
240 \f
241 ;;;; adjustments
242
243 (defun get-vop-costs ()
244   #!+sb-doc
245   "Return a hash-table mapping string VOP names to the cost recorded in the
246    generator for all VOPs which are also the names of assembly routines."
247   (let ((res (make-hash-table :test 'equal)))
248      (dohash ((name v) *assembler-routines* :locked t)
249        (declare (ignore v))
250        (let ((vop (gethash name *backend-template-names*)))
251          (when vop
252            (setf (gethash (symbol-name name) res)
253                  (template-cost (template-or-lose name))))))
254     res))
255
256 (defvar *native-costs* (get-vop-costs)
257   #!+sb-doc
258   "Costs of assember routines on this machine.")
259 \f
260 ;;;; classification
261
262 (defparameter *basic-classes*
263   '(("Integer multiplication"
264      "*/FIXNUM" "*/SIGNED" "*/UNSIGNED" "SIGNED-*" "FIXNUM-*" "GENERIC-*")
265     ("Integer division" "TRUNCATE")
266     ("Generic arithmetic" "GENERIC" "TWO-ARG")
267     ("Inline EQL" "EQL")
268     ("Inline compare less/greater" "</" ">/" "<-C/" ">-C/")
269     ("Inline arith" "*/" "//" "+/" "-/" "NEGATE" "ABS" "+-C" "--C")
270     ("Inline logic" "-ASH" "$ASH" "LOG")
271     ("CAR/CDR" "CAR" "CDR")
272     ("Array type test" "ARRAYP" "VECTORP" "ARRAY-HEADER-P")
273     ;; FIXME: STRUCTUREP? This looks somewhat stale..
274     ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP")
275     ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE")
276     ("Array bounds check" "CHECK-BOUND")
277     ("Complex type check" "$CHECK-" "COERCE-TO-FUN")
278     ("Special read" "SYMBOL-VALUE")
279     ("Special bind" "BIND$")
280     ("Tagging" "MOVE-FROM")
281     ("Untagging" "MOVE-TO" "MAKE-FIXNUM")
282     ("Move" "MOVE")
283     ("Non-local exit" "CATCH" "THROW" "DYNAMIC-STATE" "NLX" "UNWIND")
284     ("Array write" "DATA-VECTOR-SET" "$SET-RAW-BITS$")
285     ("Array read" "DATA-VECTOR-REF" "$RAW-BITS$" "VECTOR-LENGTH"
286      "LENGTH/SIMPLE" "ARRAY-HEADER")
287     ("List/string utility" "LENGTH/LIST" "SXHASH" "BIT-BASH" "$LENGTH$")
288     ("Alien operations" "SAP" "ALLOC-NUMBER-STACK" "$CALL-OUT$")
289     ("Function call/return" "CALL" "RETURN" "ALLOCATE-FRAME"
290      "COPY-MORE-ARG" "LISTIFY-REST-ARG" "VERIFY-ARG-COUNT")
291     ("Allocation" "MAKE-" "ALLOC" "$CONS$" "$LIST$" "$LIST*$")
292     ("Float conversion" "%SINGLE-FLOAT" "%DOUBLE-FLOAT" "-BITS$")
293     ("Complex type predicate" "P$")))
294
295 ;;;    Return true if Name patches a specified pattern. Pattern is a string
296 ;;; (or symbol) or a list of strings (or symbols). If any specified string
297 ;;; appears as a substring of name, the pattern is matched. #\$'s are wapped
298 ;;; around name, allowing the use of $ to force a match at the beginning or
299 ;;; end.
300 (defun matches-pattern (name pattern)
301   (declare (simple-string name))
302   (let ((name (concatenate 'string "$" name "$")))
303     (dolist (pat (if (listp pattern) pattern (list pattern)) nil)
304       (when (search (the simple-string (string pat))
305                     name :test #'char=)
306         (return t)))))
307
308 ;;; Utilities for debugging classification rules. FIND-MATCHES returns a
309 ;;; list of all the VOP names in Table that match Pattern. WHAT-CLASS returns
310 ;;; the class that NAME would be placed in.
311 (defun find-matches (table pattern)
312   (collect ((res))
313     (dohash ((key value) table :locked t)
314       (declare (ignore value))
315       (when (matches-pattern key pattern) (res key)))
316     (res)))
317 (defun what-class (name classes)
318   (dolist (class classes nil)
319     (when (matches-pattern name (rest class)) (return (first class)))))
320
321 ;;; Given a VOP-STATS hash-table, return a new one with VOPs in the same
322 ;;; class merged into a single entry for that class. The classes are
323 ;;; represented as a list of lists: (class-name pattern*). Each pattern is a
324 ;;; string (or symbol) that can appear as a subsequence of the VOP name. A VOP
325 ;;; is placed in the first class that it matches, or is left alone if it
326 ;;; matches no class.
327 (defun classify-costs (table classes)
328   (let ((res (make-hash-table-like table)))
329     (dohash ((key value) table :locked t)
330       (let ((class (dolist (class classes nil)
331                      (when (matches-pattern key (rest class))
332                        (return (first class))))))
333         (if class
334             (let ((found (or (gethash class res)
335                              (setf (gethash class res)
336                                    (%make-vop-stats class)))))
337               (incf (vop-stats-count found) (vop-stats-count value))
338               (incf (vop-stats-cost found) (vop-stats-cost value)))
339             (setf (gethash key res) value))))
340     res))
341 \f
342 ;;;; analysis
343
344 ;;; Sum the count and costs.
345 (defun cost-summary (table)
346   (let ((total-count 0d0)
347         (total-cost 0d0))
348     (dohash ((k v) table :locked t)
349       (declare (ignore k))
350       (incf total-count (vop-stats-count v))
351       (incf total-cost (vop-stats-cost v)))
352     (values total-count total-cost)))
353
354 ;;; Return a hashtable of DYNCOUNT-INFO structures, with cost adjustments
355 ;;; according to the Costs table. Any VOPs in the list IGNORE are ignored.
356 (defun compensate-costs (table costs &optional ignore)
357   (let ((res (make-hash-table-like table)))
358     (dohash ((key value) table :locked t)
359       (unless (or (string= key "COUNT-ME")
360                   (member key ignore :test #'string=))
361         (let ((cost (gethash key costs)))
362           (if cost
363               (let* ((count (vop-stats-count value))
364                      (sum (+ (* cost count)
365                              (vop-stats-cost value))))
366                 (setf (gethash key res)
367                       (make-vop-stats :name key :count count :cost sum)))
368               (setf (gethash key res) value)))))
369     res))
370
371 ;;; Take two tables of vop-stats and return a table of entries where the
372 ;;; entries have been compared. The counts are normalized to Compared. The
373 ;;; costs are the difference of the costs adjusted by the difference in counts:
374 ;;; the cost for Original is modified to correspond to the count in Compared.
375 (defun compare-stats (original compared)
376   (declare (type hash-table original compared))
377   (let ((res (make-hash-table-like original)))
378     (dohash ((k cv) compared :locked t)
379       (let ((ov (gethash k original)))
380         (when ov
381           (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv))))
382             (setf (gethash k res)
383                   (make-vop-stats
384                    :name k
385                    :count norm-cnt
386                    :cost (- (/ (vop-stats-cost ov) norm-cnt)
387                             (vop-stats-cost cv))))))))
388     res))
389
390 (defun combine-stats (&rest tables)
391   #!+sb-doc
392   "Sum the VOP stats for the specified tables, returning a new table with the
393    combined results."
394   (let ((res (make-hash-table-like (first tables))))
395     (dolist (table tables)
396       (dohash ((k v) table :locked t)
397         (let ((found (or (gethash k res)
398                          (setf (gethash k res) (%make-vop-stats k)))))
399           (incf (vop-stats-count found) (vop-stats-count v))
400           (incf (vop-stats-cost found) (vop-stats-cost v)))))
401     res))
402 \f
403 ;;;; report generation
404
405 (defun sort-result (table by)
406   (sort (hash-list table) #'>
407         :key (lambda (x)
408                (abs (ecase by
409                       (:count (vop-stats-count x))
410                       (:cost (vop-stats-cost x)))))))
411
412 ;;; Report about VOPs in the list of stats structures.
413 (defun entry-report (entries cut-off compensated compare total-cost)
414   (let ((counter (if (and cut-off (> (length entries) cut-off))
415                      cut-off
416                      most-positive-fixnum)))
417   (dolist (entry entries)
418     (let* ((cost (vop-stats-cost entry))
419            (name (vop-stats-name entry))
420            (entry-count (vop-stats-count entry))
421            (comp-entry (if compare (gethash name compare) entry))
422            (count (vop-stats-count comp-entry)))
423       (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F  ~5,2,2F%~%"
424               (vop-stats-name entry)
425               compare
426               (if compare entry-count (round entry-count))
427               (/ cost count)
428               (/ (if compare
429                      (- (vop-stats-cost (gethash name compensated))
430                         (vop-stats-cost comp-entry))
431                      cost)
432                  total-cost))
433       (when (zerop (decf counter))
434         (format t "[End of top ~W]~%" cut-off))))))
435
436 ;;; Divide SORTED into two lists, the first CUT-OFF elements long. Any VOP
437 ;;; names that match one of the report strings are moved into the REPORT list
438 ;;; even if they would otherwise fall below the CUT-OFF.
439 (defun find-cut-off (sorted cut-off report)
440   (if (or (not cut-off) (<= (length sorted) cut-off))
441       (values sorted ())
442       (let ((not-cut (subseq sorted 0 cut-off)))
443         (collect ((select)
444                   (reject))
445           (dolist (el (nthcdr cut-off sorted))
446             (let ((name (vop-stats-name el)))
447               (if (matches-pattern name report)
448                   (select el)
449                   (reject el))))
450           (values (append not-cut (select)) (reject))))))
451
452 ;;; Display information about entries that were not displayed due to the
453 ;;; cut-off. Note: if compare, we find the total cost delta and the geometric
454 ;;; mean of the normalized counts.
455 (defun cut-off-report (other compare total-cost)
456   (let ((rest-cost 0d0)
457         (rest-count 0d0)
458         (rest-entry-count (if compare 1d0 0d0)))
459     (dolist (entry other)
460       (incf rest-cost (vop-stats-cost entry))
461       (incf rest-count
462             (vop-stats-count
463              (if compare
464                  (gethash (vop-stats-name entry) compare)
465                  entry)))
466       (if compare
467           (setq rest-entry-count
468                 (* rest-entry-count (vop-stats-count entry)))
469           (incf rest-entry-count (vop-stats-count entry))))
470
471     (let ((count (if compare
472                      (expt rest-entry-count
473                            (/ (coerce (length other) 'double-float)))
474                      (round rest-entry-count))))
475       (format t "~30<Other~>: ~:[~13:D~;~13,2F~] ~9,2F  ~@[~5,2,2F%~]~%"
476               compare count
477               (/ rest-cost rest-count)
478               (unless compare
479                 (/ rest-cost total-cost))))))
480
481 ;;; Report summary information about the difference between the comparison
482 ;;; and base data sets.
483 (defun compare-report (total-count total-cost compare-total-count
484                                    compare-total-cost compensated compare)
485   (format t "~30<Relative total~>: ~13,2F ~9,2F~%"
486           (/ total-count compare-total-count)
487           (/ total-cost compare-total-cost))
488   (flet ((frob (a b sign wot)
489            (multiple-value-bind (cost count)
490                (cost-summary (hash-difference a b))
491              (unless (zerop count)
492                (format t "~30<~A~>: ~13:D ~9,2F  ~5,2,2F%~%"
493                        wot (* sign (round count))
494                        (* sign (/ cost count))
495                        (* sign (/ cost compare-total-cost)))))))
496     (frob compensated compare 1 "Not in comparison")
497     (frob compare compensated -1 "Only in comparison"))
498   (format t "~30<Comparison total~>: ~13,2E ~9,2E~%"
499           compare-total-count compare-total-cost))
500
501 ;;; The fraction of system time that we guess happened during GC.
502 (defparameter *gc-system-fraction* 2/3)
503
504 ;;; Estimate CPI from CPU time and cycles accounted in profiling information.
505 (defun find-cpi (total-cost user system gc clock)
506   (let ((adj-time (if (zerop gc)
507                       user
508                       (- user (- gc (* system *gc-system-fraction*))))))
509     (/ (* adj-time clock) total-cost)))
510
511 ;;; Generate a report from the specified table.
512 (defun generate-report (table &key (cut-off 15) (sort-by :cost)
513                               (costs *native-costs*)
514                               ((:compare uncomp-compare))
515                               (compare-costs costs)
516                               ignore report
517                               (classes *basic-classes*)
518                               user (system 0d0) (gc 0d0)
519                               (clock 25d6))
520   (let* ((compensated
521           (classify-costs
522            (if costs
523                (compensate-costs table costs ignore)
524                table)
525            classes))
526          (compare
527           (when uncomp-compare
528             (classify-costs
529              (if compare-costs
530                  (compensate-costs uncomp-compare compare-costs ignore)
531                  uncomp-compare)
532              classes)))
533          (compared (if compare
534                        (compare-stats compensated compare)
535                        compensated)))
536     (multiple-value-bind (total-count total-cost) (cost-summary compensated)
537       (multiple-value-bind (compare-total-count compare-total-cost)
538           (when compare (cost-summary compare))
539         (format t "~2&~30<Vop~>  ~13<Count~> ~9<Cost~>  ~6:@<Percent~>~%")
540         (let ((sorted (sort-result compared sort-by))
541               (base-total (if compare compare-total-cost total-cost)))
542           (multiple-value-bind (report other)
543               (find-cut-off sorted cut-off report)
544             (entry-report report cut-off compensated compare base-total)
545             (when other
546               (cut-off-report other compare base-total))))
547
548         (when compare
549           (compare-report total-count total-cost compare-total-count
550                           compare-total-cost compensated compare))
551
552         (format t "~30<Total~>: ~13,2E ~9,2E~%" total-count total-cost)
553         (when user
554           (format t "~%Cycles per instruction = ~,2F~%"
555                   (find-cpi total-cost user system gc clock))))))
556   (values))
557
558 ;;; Read & write VOP stats using hash IO utility.
559 (defun stats-reader (stream key)
560   (make-vop-stats :name key :count (read stream) :cost (read stream)))
561 (defun stats-writer (object stream)
562   (format stream "~S ~S" (vop-stats-count object) (vop-stats-cost object)))