source: trunk/contrib/huebner/advice-profiler/profiler.lisp @ 16687

Last change on this file since 16687 was 16687, checked in by rme, 5 years ago

Update copyright/licesne header as authorized by author.

File size: 28.9 KB
Line 
1;;; -*- Lisp -*-
2;;;
3;;; Copyright 2008 Hans Huebner
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17;;; Deterministic profiler for Clozure CL
18
19;;; Inspired by the public domain profiler written by Mark Kantrowitz
20
21;;; To get accurate profiling results, you need to make sure that your
22;;; processor runs at full speed.  Modern CPUs adjust their CPU clock
23;;; dynamically, which will have negative effects on accuracy of the
24;;; profiling result.
25
26;;; In virtual machines, the profiling results may also be inaccurate
27;;; due to virtualized timers.
28
29;;; Bottom line: Always try to profile on the bare metal, with all
30;;; power saving techniques switched off.  Repeat your profiling to get
31;;; a feel for the precision of the results.
32
33;;; The code has provisions for measuring CPU time in addition to real
34;;; time, but it seems that no operating system can deliver consistent
35;;; and accurate per-thread CPU time usage.
36
37;;; All clock values that are handled by this profiler are specified
38;;; in nanoseconds.  This means that it will use bignums on 32 bit
39;;; platforms.
40
41(in-package "PROFILER")
42
43(defvar *profiler-loaded* nil)
44 
45(eval-when (:load-toplevel :execute)
46  (when (and (not *profiler-loaded*)
47             (> (length (all-processes)) 2))
48    (error "Profiler can't be loaded with active application threads.  Please load from ccl-init.lisp"))
49  (setf *profiler-loaded* t))
50
51;;; Process specific variables
52(eval-when (:compile-toplevel :load-toplevel :execute)
53  (defmacro defvar-process-specific (var init doc)
54    `(progn
55       (defvar ,var ,init ,doc)
56       (ccl::def-standard-initial-binding ,var ,init))))
57
58(defvar-process-specific *process-profile-results* nil
59  "Variable to hold profiling information, in a hash table.  If NIL,
60   profiling is disabled for this process.")
61
62(defvar-process-specific *total-cpu-time* 0
63  "Amount of CPU time used by profiled functions so far")
64(defvar-process-specific *total-real-time* 0
65  "Amount of real time used by profiled functions so far")
66(defvar-process-specific *total-cons* 0
67  "Amount of consing in profiled functions so far")
68(defvar-process-specific *total-calls* 0
69  "Number of calls to profiled functions so far")
70
71;;; Global variables
72
73;;; Profiler overhead is determined by the function DETERMINE-OVERHEAD
74
75(eval-when (:compile-toplevel :load-toplevel :execute)
76  (defvar *real-overhead* 0 "Real time overhead")
77  (defvar *cpu-overhead* 0 "CPU time overhead")
78  (defvar *cons-overhead* 0 "Consing overhead (additional consing per call)"))
79
80(defvar *profiled-functions* nil
81  "List of function names that are currently being profiled.")
82
83(defvar *clock-errors* nil
84  "This flag indicates that the CPU and real time clock have shown to be inconsistent.  A warning
85   will be printed in the report if this is found to be true.")
86
87(defparameter *profile-new-processes* t
88  "This flag indicates that profiling should automatically be enabled for new processes that are
89   created.  If it nil, no call recording takes place for processes until after
90   PROCESS-ENABLE-PROFILING has been called for them.")
91
92(defvar *profiler-lock* (make-lock "Profiler lock")
93  "Lock to guard accesses to global profiler structures")
94
95(defmacro with-profiler-locked (() &body body)
96  `(with-lock-grabbed (*profiler-lock*)
97     ,@body))
98
99#+darwin
100(defun mach-timespec->nanoseconds (ts)
101  "Convert the given typespec structure into nanoseconds."
102  (+ (* 1000000000 (pref ts :mach_timespec.tv_sec))
103     (pref ts :mach_timespec.tv_nsec)))
104#+darwin
105(declaim (inline mach-timespec->nanoseconds))
106
107(defun timespec->nanoseconds (ts)
108  "Convert the given typespec structure into nanoseconds."
109  (+ (* 1000000000 (pref ts :timespec.tv_sec))
110     (pref ts :timespec.tv_nsec)))
111(declaim (inline timespec->nanoseconds))
112
113;;; Clock handling
114
115;;; For Darwin, we use the Mach clock service
116
117#+darwin
118(let ((clock-port (make-record :clock_serv_t)))
119  (#_host_get_clock_service (#_mach_host_self) #$REALTIME_CLOCK clock-port)
120  (defun get-real-time ()
121    (ccl:rlet ((ts :mach_timespec))
122      (unless (zerop (#_clock_get_time (%get-ptr clock-port) ts))
123        (error "error reading Mach clock: ~A~%" (ccl::%strerror (ccl::%get-errno))))
124      (mach-timespec->nanoseconds ts))))
125
126;;; For non-Darwin platforms, we use clock_gettime() with the
127;;; CLOCK_MONOTONIC clock.
128
129#-darwin
130(defun get-posix-clock (id)
131  (ccl:rlet ((ts :timespec))
132    (unless (zerop (#_clock_gettime id ts))
133      (error "error reading clock ~A: ~A~%" id (ccl::%strerror (ccl::%get-errno))))
134    (timespec->nanoseconds ts)))
135(declaim (inline get-posix-clock))
136
137#-darwin
138(defun get-real-time ()
139  (get-posix-clock #$CLOCK_MONOTONIC))
140
141;;; Per-thread CPU time measurement is only available on Linux
142
143(defun get-cpu-time ()
144  #+linux-target
145  (get-posix-clock #$CLOCK_THREAD_CPUTIME_ID)
146  #-linux-target
147  0)
148
149(defparameter *can-report-cpu* #+linux-target t #-linux-target nil)
150
151(defun get-cons ()
152  (ccl::total-bytes-allocated))
153
154(declaim (inline get-cpu-time get-real-time get-cons))
155
156;;; Helper macro to measure elapsed time
157
158(eval-when (:compile-toplevel :load-toplevel :execute)
159  (defmacro with-real/cpu/cons ((delta-real delta-cpu delta-cons &key adjusted) form &body post-process)
160    "Evaluate FORM, then run POST-PROCESS with DELTA-REAL, DELTA-CPU and
161   DELTA-CONS bound to the elapsed real time, elapsed CPU time and
162   amount of consing that happened in FORM.  If ADJUSTED is non-nil,
163   the values are adjusted by the overhead values."
164    (let ((start-real (gensym "START-REAL-"))
165          (start-cpu (gensym "START-CPU-"))
166          (start-cons (gensym "START-CONS-")))
167      `(let ((,start-real (get-real-time))
168             (,start-cpu (get-cpu-time))
169             (,start-cons (get-cons)))
170         (declare (type fixnum ,start-real ,start-cpu ,start-cons))
171         (multiple-value-prog1 ,form
172           (let ((,delta-real (- (get-real-time) ,start-real ,@(when adjusted (list '*real-overhead*))))
173                 (,delta-cpu (- (get-cpu-time) ,start-cpu ,@(when adjusted (list '*cpu-overhead*))))
174                 (,delta-cons (- (get-cons) ,start-cons ,@(when adjusted (list '*cons-overhead*)))))
175             (declare (type fixnum ,delta-real ,delta-cpu ,delta-cons))
176             ;; If there is clock imprecision, we can end up with
177             ;; negative delta values here.  For now, we just make
178             ;; sure that we never pass negative deltas back to the
179             ;; reporting code, but it may be preferable to take a
180             ;; note of such events and mark the report as being
181             ;; questionable.
182             (when (minusp ,delta-real) (setf ,delta-real 0))
183             (when (minusp ,delta-cpu) (setf ,delta-cpu 0))
184             (when (minusp ,delta-cons) (setf ,delta-cons 0))
185             (when (>= ,delta-real ,delta-cpu)
186               (setf *clock-errors* t))
187             ,@post-process))))))
188
189;;; Formatting
190
191(defun format-time (nanoseconds)
192  "Given a time in NANOSECONDS, return a human readable string with
193   the time scaled.  Times shorter than a second are reported with the
194   proper sub-second unit (ns, us, ms), times longer than a second are
195   reported in wall clock format (HH:MM:SSh)."
196  (cond
197    ((> 1000 nanoseconds)
198     (format nil "~Ans" (floor nanoseconds)))
199    ((> 1000000 nanoseconds)
200     (format nil "~,1Fus" (/ nanoseconds 1000)))
201    ((> 1000000000 nanoseconds)
202     (format nil "~,1Fms" (/ nanoseconds 1000000)))
203    ((> 100000000000 nanoseconds)
204     (format nil "~,1Fs " (/ nanoseconds 1000000000)))
205    (t
206     (let* ((seconds (floor nanoseconds 1000000000))
207            (minutes (floor seconds 60))
208            (hours (floor minutes 60)))
209       (format nil "~A:~2,'0D:~2,'0Dh"
210               hours
211               (- minutes (* 60 hours))
212               (- seconds (* 60 minutes)))))))
213               
214;; For each profiled function that is called within a process, a
215;; function-call-record structure is created that carries the counters
216;; and timing information.
217
218(defstruct (function-call-record
219             (:conc-name fcr-)
220             (:constructor make-function-call-record%))
221  (process *current-process* :type process)
222  (name nil :type symbol)
223  (inclusive-real-time 0 :type fixnum)
224  (exclusive-real-time 0 :type fixnum)
225  (inclusive-cpu-time 0 :type fixnum)
226  (exclusive-cpu-time 0 :type fixnum)
227  (inclusive-cons 0 :type fixnum)
228  (exclusive-cons 0 :type fixnum)
229  (calls 0 :type fixnum)
230  (nested-calls 0 :type fixnum))
231
232(defun make-function-call-record (name)
233  "Create a function-call-record structure for the function named NAME.  The
234   current process is written into the structure created for later
235   analysis."
236  (let ((fcr (make-function-call-record%)))
237    (setf (fcr-name fcr) name)
238    fcr))
239
240(defun sum-fcrs (fcrs)
241  (let ((sum (make-function-call-record (fcr-name (first fcrs)))))
242    (setf (fcr-inclusive-real-time sum) (reduce #'+ fcrs :key #'fcr-inclusive-real-time)
243          (fcr-exclusive-real-time sum) (reduce #'+ fcrs :key #'fcr-exclusive-real-time)
244          (fcr-inclusive-cpu-time sum) (reduce #'+ fcrs :key #'fcr-inclusive-cpu-time)
245          (fcr-exclusive-cpu-time sum) (reduce #'+ fcrs :key #'fcr-exclusive-cpu-time)
246          (fcr-inclusive-cons sum) (reduce #'+ fcrs :key #'fcr-inclusive-cons)
247          (fcr-exclusive-cons sum) (reduce #'+ fcrs :key #'fcr-exclusive-cons)
248          (fcr-calls sum) (reduce #'+ fcrs :key #'fcr-calls)
249          (fcr-nested-calls sum) (reduce #'+ fcrs :key #'fcr-nested-calls))
250    sum))
251
252(defmacro profile (&rest names)
253  "Profile the functions named by NAMES.  As in TRACE, the names are
254   not evaluated.  Strings and keywords are interpreted as package
255   designators and will cause all functions named by external symbols
256   in the package to be profiled.  If a function is already profiled,
257   then unprofile and reprofile (useful to notice function
258   redefinition).  If a name is undefined, give a warning and ignore
259   it."
260  `(progn
261     (let (new-names)
262       ,@(mapcar
263          (lambda (name)
264            (if (or (stringp name)
265                    (keywordp name))
266              `(setf new-names (append (profile-package ,name :external-only t) new-names))
267              `(with-profiler-locked ()
268                 (if (find ',name *profiled-functions*)
269                   (unprofile ,name)
270                   (push ',name new-names))
271                 (cond
272                   ((not (fboundp ',name))
273                    (warn "ignored argument ~A, which is not the name of a function" ',name))
274                   (t
275                    (ccl:advise ,name
276                                (progn
277                                  (when (and (null *process-profile-results*)
278                                             *profile-new-processes*)
279                                    (setf *process-profile-results* (make-hash-table)))
280                                  (if *process-profile-results*
281                                    (let ((prev-cpu-time *total-cpu-time*)
282                                          (prev-real-time *total-real-time*)
283                                          (prev-cons *total-cons*)
284                                          (prev-calls *total-calls*))
285                                      (declare (type fixnum prev-cpu-time prev-real-time prev-cons prev-calls))
286                                      (with-real/cpu/cons (delta-real delta-cpu delta-cons :adjusted t)
287                                          (:do-it)
288                                        (multiple-value-bind (fcr presentp)
289                                            (gethash ',name *process-profile-results*)
290                                          (unless presentp
291                                            (setf fcr (make-function-call-record ',name))
292                                            (setf (gethash ',name *process-profile-results*) fcr))
293                                          ;; Call counters
294                                          (incf *total-calls*)
295                                          (incf (fcr-calls fcr))
296                                          (incf (fcr-nested-calls fcr) (- *total-calls* prev-calls))
297                                          ;; Real time
298                                          (incf (fcr-inclusive-real-time fcr) delta-real)
299                                          (incf (fcr-exclusive-real-time fcr) (- delta-real
300                                                                                 (- *total-real-time* prev-real-time)))
301                                          (setf *total-real-time* (+ delta-real prev-real-time))
302                                          ;; CPU time
303                                          (incf (fcr-inclusive-cpu-time fcr) delta-cpu)
304                                          (incf (fcr-exclusive-cpu-time fcr) (- delta-cpu
305                                                                                (- *total-cpu-time* prev-cpu-time)))
306                                          (setf *total-cpu-time* (+ delta-cpu prev-cpu-time))
307                                          ;; consing
308                                          (incf (fcr-inclusive-cons fcr) delta-cons)
309                                          (incf (fcr-exclusive-cons fcr) (- delta-cons
310                                                                            (- *total-cons* prev-cons)))
311                                          (setf *total-cons* (+ delta-cons prev-cons)))))
312                                    (:do-it)))
313                                :when :around)
314                    (pushnew ',name *profiled-functions*))))))
315          names)
316       new-names)))
317
318(defun symbol-external-p (symbol)
319  "Return non-nil if the SYMBOL is external in its package (being
320exported)."
321  (eq :external (nth-value 1 (find-symbol (symbol-name symbol) (symbol-package symbol)))))
322
323(defun functions-in-package (package external-only)
324  "Return the list of symbols in PACKAGE that have a function bound to
325   them.  If EXTERNAL-ONLY is true, only returns those symbols that
326   are external."
327  (let ((package (if (packagep package)
328                   package
329                   (or (find-package package)
330                       (error "package ~S not found" package))))
331        symbols)
332    (do-symbols (symbol package)
333      (when (and (fboundp symbol)
334                 (not (macro-function symbol))
335                 (eq (symbol-package symbol) package)
336                 (or (not external-only)
337                     (symbol-external-p symbol)))
338        (pushnew symbol symbols)))
339    symbols))
340
341;;; Per-process profiling API
342
343(defmacro within-process ((process) &body body)
344  "Run BODY within PROCESS, using PROCESS-INTERRUPT."
345  (let ((sem (gensym "SEM-")))
346    `(let ((,sem (make-semaphore)))
347       (process-interrupt ,process
348                          (lambda ()
349                            (unwind-protect
350                                 (progn ,@body)
351                              (signal-semaphore, sem))))
352       (wait-on-semaphore ,sem))))
353
354(defun process-enable-profiling (&optional (process *current-process*))
355  "Enable profiling for the given process."
356  (within-process (process)
357    (unless *process-profile-results*
358      (setf *process-profile-results* (make-hash-table)))))
359
360(defun process-disable-profiling (&optional (process *current-process*))
361  "Disable profiling for the given process."
362  (within-process (process)
363    (setf *process-profile-results* nil)))
364
365(defun enable-profiling ()
366  "Enable profiling in all current and future processes."
367  (dolist (process (all-processes))
368    (process-enable-profiling process))
369  (setf *profile-new-processes* t))
370
371(defun disable-profiling ()
372  "Disable profiling in all current and future processes."
373  (dolist (process (all-processes))
374    (process-enable-profiling process))
375  (setf *profile-new-processes* nil))
376
377;;; Global profiling API
378
379(defmacro profile-package (&optional (package *package*) &key external-only)
380  "Profile all functions in the specified package."
381  `(profile ,@(functions-in-package package external-only)))
382
383(eval-when (:compile-toplevel :load-toplevel :execute)
384  (defmacro unprofile (&rest names)
385    "Unprofile the functions named by NAMES.  If an argument is a
386     keyword or a string, it is considered to be a package name and
387     all (!) symbols in the package will be unprofiled."
388    `(with-profiler-locked ()
389       ,@(mapcar (lambda (name)
390                   (if (or (stringp name)
391                           (keywordp name))
392                       `(unprofile-package ,name)
393                       `(ccl:unadvise ,name)))
394                 names)
395       (setf *profiled-functions* (set-difference *profiled-functions* ',names)))))
396
397(defmacro unprofile-all ()
398  "Unprofile all functions that are currently profiled."
399  `(with-profiler-locked ()
400     ,@(mapcar (lambda (name) `(ccl:unadvise ,name)) *profiled-functions*)
401     (setf *profiled-functions* nil)))
402
403(defmacro unprofile-package (&optional (package *package*) &key external-only)
404  "Profile all functions in the specified PACKAGE, which may be either
405   a string, a keyword symbol or a package instance.  If EXTERNAL-ONLY
406   is t, only functions named by symbols which are external in PACKAGE
407   are unprofiled."
408  `(unprofile ,@(functions-in-package package external-only)))
409
410(defun reset ()
411  "Reset profiling information in all processes."
412  (setf *total-cpu-time* 0
413        *total-real-time* 0
414        *total-cons* 0
415        *total-calls* 0)
416  (dolist (process (all-processes))
417    (within-process (process)
418      (when *process-profile-results*
419        (clrhash *process-profile-results*)))))
420
421(defun collect-profiling-results (&key reset)
422  "Collect profiling results from all processes.  If RESET is true,
423   the profiling results are cleared when they have been read."
424  (let (results)
425    (dolist (process (all-processes))
426      (within-process (process)
427        (when *process-profile-results*
428          (with-profiler-locked ()
429            (maphash (lambda (key value)
430                       (declare (ignore key))
431                       (push value results))
432                     *process-profile-results*))
433          (when reset
434            (clrhash *process-profile-results*)))))
435    results))
436
437;; Reporting
438
439(defun write-results-xml (&key (stream *standard-output*))
440  "Write the profiling results to the given STREAM in an XML format,
441   one 'entry' element for each function call record that has been
442   collected."
443  (format stream "<profile-results>~%")
444  (dolist (fcr (collect-profiling-results))
445    (format stream "  <entry function='~S' ~
446                             process='~A' ~
447                             inclusive-real-time='~A' exclusive-real-time='~A' ~
448                             inclusive-cpu-time='~A' exclusive-cpu-time='~A' ~
449                             inclusive-cons='~A' exclusive-cons='~A' ~
450                             calls='~A' nested-calls='~A'/>~%"
451            (fcr-name fcr)
452            (process-name (fcr-process fcr))
453            (fcr-inclusive-real-time fcr) (fcr-exclusive-real-time fcr)
454            (fcr-inclusive-cpu-time fcr) (fcr-exclusive-cpu-time fcr)
455            (fcr-inclusive-cons fcr) (fcr-exclusive-cons fcr)
456            (fcr-calls fcr) (fcr-nested-calls fcr)))
457  (format stream "</profile-results>~%"))
458
459(defun write-results-csv (&key (stream *standard-output*))
460  "Write the profiling results to the given STREAM in a CSV format
461   which can be imported into excel for further analysis."
462  (format stream "package;function;process;inclusive-real-time;exclusive-real-time;inclusive-cpu-time;exclusive-cpu-time;~
463                  inclusive-cons;exclusive-cons;calls;nested-calls~%")
464  (dolist (fcr (collect-profiling-results))
465    (format stream "\"~S\";\"~A\";~A;~A;~A;~A;~A;~A;~A;~A~%"
466            (fcr-name fcr)
467            (process-name (fcr-process fcr))
468            (fcr-inclusive-real-time fcr) (fcr-exclusive-real-time fcr)
469            (fcr-inclusive-cpu-time fcr) (fcr-exclusive-cpu-time fcr)
470            (fcr-inclusive-cons fcr) (fcr-exclusive-cons fcr)
471            (fcr-calls fcr) (fcr-nested-calls fcr))))
472
473(defstruct (profile-results
474            (:conc-name pr-)
475            (:constructor make-profile-results
476                          (name process
477                                calls
478                                real-time cpu-time cons
479                                percent-real-time percent-cpu-time percent-cons)))
480  name
481  process
482  calls
483  real-time
484  cpu-time
485  cons
486  percent-real-time
487  percent-cpu-time
488  percent-cons)
489
490(defun group-on (list &key (test #'eql) (key #'identity) (include-key t))
491  (let ((hash (make-hash-table :test test))
492        keys)
493    (dolist (el list)
494      (let ((key (funcall key el)))
495        (unless (nth-value 1 (gethash key hash))
496          (push key keys))
497        (push el (gethash key hash))))   
498    (mapcar (lambda (key) (let ((keys (nreverse (gethash key hash))))
499                            (if include-key
500                                (cons key keys)
501                                keys)))
502            (nreverse keys))))
503
504(defun get-postprocessed (&key (by-process t) reset sort-by)
505  "Collect profiling results from all processes and compress them for
506   display, return a list of lists of PROFILE-RESULTS.  BY-PROCESS
507   determines whether the report will be per process or one report for
508   all processes combined."
509  (labels
510      ((percentage (value total)
511         (if (and (plusp value) (plusp total))
512           (/ value (/ total 100))
513           0))
514       (postprocess (records)
515         (let ((total-real-time 0)
516               (total-cpu-time 0)
517               (total-cons 0))
518           (dolist (record records)
519             (incf total-real-time (fcr-exclusive-real-time record))
520             (incf total-cpu-time (fcr-exclusive-cpu-time record))
521             (incf total-cons (fcr-exclusive-cons record)))
522           (sort (mapcar (lambda (fcr)
523                           (make-profile-results (let ((*package* (find-package :keyword)))
524                                                   (prin1-to-string (fcr-name fcr)))
525                                                 (fcr-process fcr)
526                                                 (fcr-calls fcr)
527                                                 (fcr-exclusive-real-time fcr)
528                                                 (fcr-exclusive-cpu-time fcr)
529                                                 (fcr-exclusive-cons fcr)
530                                                 (percentage (fcr-exclusive-real-time fcr) total-real-time)
531                                                 (percentage (fcr-exclusive-cpu-time fcr) total-cpu-time)
532                                                 (percentage (fcr-exclusive-cons fcr) total-cons)))
533                         records)
534                 #'<
535                 :key sort-by))))
536    (if by-process
537      (mapcar #'postprocess
538              (group-on (collect-profiling-results :reset reset)
539                        :key #'fcr-process
540                        :test #'eq
541                        :include-key nil))
542      (list (postprocess (mapcar #'sum-fcrs (group-on (collect-profiling-results :reset reset)
543                                                      :key #'fcr-name
544                                                      :test #'eq
545                                                      :include-key nil)))))))
546
547(defun sort-key-function (keyword)
548  (let ((valid-sort-keys (append '(:calls
549                                   :cons :percent-cons
550                                   :real-time :percent-real-time)
551                                 (when *can-report-cpu*
552                                   '(:cpu-time :percent-cpu-time)))))
553    (unless (member keyword valid-sort-keys)
554      (error "invalid sort key ~S, specify one of ~S"
555             keyword valid-sort-keys))
556    (fdefinition (find-symbol (format nil "PR-~A" keyword) :profiler))))
557
558(defun report (&key
559               (threshold 0.01)
560               (by-process t)
561               (stream *trace-output*)
562               (report-cpu *can-report-cpu*)
563               (sort-by (if *can-report-cpu* :cpu-time :real-time))
564               report-overhead)
565  (labels
566      ((do-report (records)
567         (let ((max-length 8)           ; Function header size
568               (max-cons-length 8)
569               (max-colon-pos 0)        ; Maximum offset of a colon in any name
570               (total-real-time 0)
571               (total-cpu-time 0)
572               (total-consed 0)
573               (total-calls 0)
574               (total-percent-real-time 0)
575               (total-percent-cpu-time 0)
576               (total-percent-cons 0))
577           (dolist (result records)
578             (when (or (zerop threshold)
579                       (> (pr-percent-real-time result) threshold))
580               (setq max-colon-pos
581                     (max max-colon-pos
582                          (position #\: (pr-name result))))
583               (setq max-length
584                     (max max-length
585                          (length (pr-name result))))
586               (setq max-cons-length
587                     (max max-cons-length
588                          (/ (pr-cons result) (pr-calls result))))))
589           (incf max-length 2)
590           (setf max-cons-length (max 4 (ceiling (log max-cons-length 10))))
591           (format stream
592                   "~
593             ~&   %      ~@[~* %      ~]                          ~@[~*          ~]~V@A~
594             ~%  Real    ~@[~*CPU     ~] %             Real Time  ~@[~*CPU Time  ~]~V@A      Total  ~@[~*   Total  ~]     Total~
595             ~%  Time    ~@[~*Time    ~]Cons    Calls      /Call  ~@[~*   /Call  ~]~V@A  Real Time  ~@[~*CPU Time  ~]      Cons  Name~
596             ~%~V,,,'-A"
597                   report-cpu report-cpu max-cons-length "Cons"
598                   report-cpu report-cpu max-cons-length "Per"  report-cpu
599                   report-cpu report-cpu max-cons-length "Call" report-cpu
600                   (+ max-length (if report-cpu 92 64) (max 0 (- max-cons-length 5))) "-")
601           (dolist (result records)
602             (when (or (zerop threshold)
603                       (> (pr-percent-real-time result) threshold))
604               (format stream
605                       "~%~6,2F  ~@[~6,2F  ~]~6,2F  ~7D   ~8@A  ~@[~8@A  ~]~VD   ~8@A  ~@[~8@A  ~]~10D  ~V@A"
606                       (pr-percent-real-time result)
607                       (and report-cpu (pr-percent-cpu-time result))
608                       (pr-percent-cons result)
609                       (pr-calls result)
610                       (format-time (/ (pr-real-time result) (pr-calls result)))
611                       (and report-cpu (format-time (/ (pr-cpu-time result) (pr-calls result))))
612                       max-cons-length
613                       (floor (/ (pr-cons result) (pr-calls result)))
614                       (format-time (pr-real-time result))
615                       (and report-cpu (format-time (pr-cpu-time result)))
616                       (pr-cons result)
617                       (+ (length (pr-name result))
618                          (- max-colon-pos (position #\: (pr-name result))))
619                       (pr-name result))
620               (incf total-real-time (pr-real-time result))
621               (incf total-cpu-time (pr-cpu-time result))
622               (incf total-consed (pr-cons result))
623               (incf total-calls (pr-calls result))
624               (incf total-percent-real-time (pr-percent-real-time result))
625               (incf total-percent-cpu-time (pr-percent-cpu-time result))
626               (incf total-percent-cons (pr-percent-cons result))))
627           (format stream
628                   "~%~V,,,'-A~
629            ~%~6,2F  ~@[~6,2F  ~]~6,2F  ~7D  ~9@T ~VA~@[~*          ~]    ~8@A~@[  ~8@A~]  ~10D~%"
630                   (+ max-length (if report-cpu 92 64) (max 0 (- max-cons-length 5))) "-"
631                   total-percent-real-time
632                   (and report-cpu total-percent-cpu-time)
633                   total-percent-cons
634                   total-calls
635                   max-cons-length " "
636                   report-cpu
637                   (format-time total-real-time)
638                   (and report-cpu (format-time total-cpu-time))
639                   total-consed)
640           (when report-overhead
641             (format stream "Estimated monitoring overhead: real: ~A cons: ~A~%"
642                   (format-time (* *real-overhead* total-calls))
643                   (* *cons-overhead* total-calls)))
644           (terpri stream)
645           (values))))
646    (dolist (results (get-postprocessed :by-process by-process
647                                        :sort-by (sort-key-function sort-by)))
648      (if by-process
649          (format stream "Profile results for process ~A~%~%" (pr-process (car results)))
650          (format stream "Profile results combined for all profiledy processes~%~%"))
651      (do-report results))
652    (when (and *can-report-cpu* *clock-errors*)
653      (format stream "Warning: real time and CPU time clocks are inconsistent.~%"))))
Note: See TracBrowser for help on using the repository browser.