1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella
)
33 (declaim (optimize (debug 2)))
36 ;;;; profiling support
39 ;;; zzz Some profiling overhead is incurred even while profiling is disabled,
40 ;;; because we check *profiling-enable-p* at run time, not compilation time.
41 ;;; Reading one extra special variable for each template can't be a huge
42 ;;; problem though. (Well, and for each serialization function call.)
45 (defvar *profiling-callers
* nil
)
46 (defvar *samples
* nil
)
48 (defun clear-counter (counter)
49 (setf (profile-counter-calls counter
) 0)
50 (setf (profile-counter-run counter
) 0)
51 (setf (profile-counter-real counter
) 0))
53 (defun counter- (a b
&rest rest
)
55 (apply #'counter-
(counter- a b
) rest
)
57 :calls
(- (profile-counter-calls a
) (profile-counter-calls b
))
58 :real
(- (profile-counter-real a
) (profile-counter-real b
))
59 :run
(- (profile-counter-run a
) (profile-counter-run b
)))))
61 (defun report-counter (counter label
&optional
(callsp t
))
62 (format t
" ~A:~40T~5D run ~5D real~@[ (~D calls)~]~%"
64 (profile-counter-run counter
)
65 (profile-counter-real counter
)
66 (and callsp
(profile-counter-calls counter
))))
68 (defun enable-profiling ()
70 @short{Enables profiling.}
72 Resets any existing profile samples and enables profiling for future
75 Also enables XPath profiling, see @fun{xpath-sys:enable-profiling}.
77 Profiling is not thread safe.
79 @see{disable-profiling}
81 (setf *profiling-enabled-p
* t
)
83 (clear-counter *apply-stylesheet-counter
*)
84 (clear-counter *parse-stylesheet-counter
*)
85 (clear-counter *parse-xml-counter
*)
86 (clear-counter *unparse-xml-counter
*)
87 (format t
"~&XSLT profiling enabled. (0 samples now recorded)~%~%")
88 (xpath-sys:enable-profiling nil
))
90 (defun disable-profiling ()
92 @short{Disables profiling.}
94 Disables profiling for future XSLT processing, but keeps recorded
95 profiling samples for @fun{report}.
97 Also disables XPath profiling, see @fun{xpath-sys:disable-profiling}.
99 @see{enable-profiling}"
100 (setf *profiling-enabled-p
* nil
)
101 (format t
"~&XSLT profiling disabled. (~D sample~:P currently recorded)~%"
103 (xpath-sys:disable-profiling
))
105 (defun invoke-template/profile
(ctx template param-bindings
)
106 (let ((run0 (get-internal-run-time))
107 (real0 (get-internal-real-time)))
109 (let ((*profiling-callers
* (cons template
*profiling-callers
*)))
110 (invoke-template ctx template param-bindings
))
111 (let* ((run1 (get-internal-run-time))
112 (real1 (get-internal-real-time))
114 (real (- real1 real0
)))
115 (push (list template
*profiling-callers
* run real
) *samples
*)))))
117 (defun invoke-with-profile-counter (fn counter
)
118 (let ((run0 (get-internal-run-time))
119 (real0 (get-internal-real-time)))
122 (let* ((run1 (get-internal-run-time))
123 (real1 (get-internal-real-time))
125 (real (- real1 real0
)))
126 (incf (profile-counter-calls counter
))
127 (incf (profile-counter-run counter
) run
)
128 (incf (profile-counter-real counter
) real
)))))
130 (defstruct (profile-data
131 (:constructor make-profile-data
(template))
132 (:conc-name
"DATA-"))
140 (defun group-and-sort-samples ()
141 (let ((table (make-hash-table)))
143 for
(callee callers run real
) in
*samples
*
146 (or (gethash callee table
)
147 (setf (gethash callee table
)
148 (make-profile-data callee
)))))
149 (unless (find callee callers
)
150 (incf (data-total-run data
) run
)
151 (incf (data-total-real data
) real
))
152 (incf (data-self-run data
) run
)
153 (incf (data-self-real data
) real
)
154 (incf (data-calls data
)))
156 (let* ((caller (car callers
))
158 (or (gethash caller table
)
159 (setf (gethash caller table
)
160 (make-profile-data caller
)))))
161 (decf (data-self-run data
) run
)
162 (decf (data-self-real data
) real
))))
164 for data being each hash-value in table
167 :key
#'data-total-run
)))
169 (defun report-samples (template-times)
170 (format t
"~&~D Template~:P called:~%~%"
171 (length template-times
))
172 (format t
" run real # avg.run run real template~%")
173 (format t
" total total total self self~%~%")
174 (let ((base-uris (make-hash-table :test
#'equal
)))
175 (dolist (data template-times
)
176 (let ((template (data-template data
)))
177 (format t
"~6D ~6D ~6D ~6D ~6D ~6D "
178 (data-total-run data
)
179 (data-total-real data
)
181 (floor (data-total-run data
) (data-calls data
))
183 (data-self-real data
))
184 (let ((base-uri (template-base-uri template
)))
186 (or (gethash base-uri base-uris
)
187 (setf (gethash base-uri base-uris
)
188 (1+ (hash-table-count base-uris
))))))
189 (if (template-name template
)
190 (format t
"name=~S" (template-unparsed-qname template
))
191 (format t
"match=~S" (xpath::stringify-pattern-expression
192 (template-match-expression template
))))
193 (when (template-mode-qname template
)
194 (format t
", mode=~S" (template-mode-qname template
)))
196 (format t
"~%Index of stylesheets:~%~%")
197 (let ((sorted-base-uris
199 for base-uri being each hash-key
200 using
(hash-value id
)
202 collect
(cons id base-uri
))
206 for
(id . base-uri
) in sorted-base-uris
207 do
(format t
" <~D> = ~A~%" id base-uri
)))))
210 "@short{Shows profiling output.}
212 Shows cumulative run time and real time, number of calls, and average
213 run time for each template that was invoked.
215 @see{enable-profiling}
216 @see{disable-profiling}"
217 (format t
"~&~D template call~:P recorded~%~%" (length *samples
*))
218 (format t
"1 second = ~D time units~%~%"
219 internal-time-units-per-second
)
220 (report-counter *apply-stylesheet-counter
* "Stylesheet application (total)")
221 (report-counter *parse-stylesheet-counter
* " ... XSLT compilation")
222 (report-counter *parse-xml-counter
* " ... XML parsing")
223 (report-counter *unparse-xml-counter
* " ... Serialization" nil
)
224 (format t
" ----------------------------------------------------------------------~%")
225 (report-counter (counter- *apply-stylesheet-counter
*
226 *parse-stylesheet-counter
*
228 *unparse-xml-counter
*)
229 " Remaining XSLT processing time"
234 for
(nil run real
) in xpath
::*samples
*
236 sum run into total-run
237 sum real into total-real
240 (make-profile-counter :calls calls
:run total-run
:real total-real
)
241 "Includes XPath processing"))
242 (format t
"(Valid only if XPath profiling was enabled during XSLT compilation.)")
245 (report-samples (group-and-sort-samples)))