From 5932fdcf8c40e0d81b5f344dc9d98ee064f0ce06 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Sun, 25 May 2008 23:54:08 +0200 Subject: [PATCH] Added an XSLT profiler. --- package.lisp | 13 +++- parser.lisp | 4 +- profile.lisp | 245 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ unparse.lisp | 58 ++++++++------ xslt.lisp | 198 +++++++++++++++++++++++++++-------------------- xuriella.asd | 1 + 6 files changed, 409 insertions(+), 110 deletions(-) create mode 100644 profile.lisp diff --git a/package.lisp b/package.lisp index 97a6560..8566483 100644 --- a/package.lisp +++ b/package.lisp @@ -53,7 +53,11 @@ #:define-extension-parser #:define-extension-compiler #:parse-body - #:compile-instruction) + #:compile-instruction + + #:enable-profiling + #:disable-profiling + #:report) (:import-from :xpath-protocol #:define-default-method) (:documentation "Xuriella is an implementation of XSLT 1.0. @@ -78,6 +82,13 @@ @aboutfun{parse-stylesheet} @aboutclass{stylesheet} @end{section} + @begin[Profiling support]{section} + The profiling facility records the run time of XSLT templates. + + @aboutfun{enable-profiling} + @aboutfun{disable-profiling} + @aboutfun{report} + @end{section} @begin[Defining extension elements]{section} Xuriella can be extended in two ways: diff --git a/parser.lisp b/parser.lisp index 7014e24..472ff98 100644 --- a/parser.lisp +++ b/parser.lisp @@ -209,7 +209,9 @@ `(progn ,@fallbacks) `(xsl:terminate (xsl:text - "no fallback children in unknown element using forwards compatible processing"))))) + ,(format nil "no fallback children in unknown element ~A/~A using forwards compatible processing" + (stp:local-name node) + (stp:namespace-uri node))))))) (defmacro define-instruction-parser (name (node-var) &body body) `(progn diff --git a/profile.lisp b/profile.lisp new file mode 100644 index 0000000..22944de --- /dev/null +++ b/profile.lisp @@ -0,0 +1,245 @@ +;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*- + +;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov. +;;; All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :xuriella) + +#+sbcl +(declaim (optimize (debug 2))) + + +;;;; profiling support + + +;;; zzz Some profiling overhead is incurred even while profiling is disabled, +;;; because we check *profiling-enable-p* at run time, not compilation time. +;;; Reading one extra special variable for each template can't be a huge +;;; problem though. (Well, and for each serialization function call.) + + +(defvar *profiling-callers* nil) +(defvar *samples* nil) + +(defun clear-counter (counter) + (setf (profile-counter-calls counter) 0) + (setf (profile-counter-run counter) 0) + (setf (profile-counter-real counter) 0)) + +(defun counter- (a b &rest rest) + (if rest + (apply #'counter- (counter- a b) rest) + (make-profile-counter + :calls (- (profile-counter-calls a) (profile-counter-calls b)) + :real (- (profile-counter-real a) (profile-counter-real b)) + :run (- (profile-counter-run a) (profile-counter-run b))))) + +(defun report-counter (counter label &optional (callsp t)) + (format t " ~A:~40T~5D run ~5D real~@[ (~D calls)~]~%" + label + (profile-counter-run counter) + (profile-counter-real counter) + (and callsp (profile-counter-calls counter)))) + +(defun enable-profiling () + "@return{nil} + @short{Enables profiling.} + + Resets any existing profile samples and enables profiling for future + XSLT processing. + + Also enables XPath profiling, see @fun{xpath-sys:enable-profiling}. + + Profiling is not thread safe. + + @see{disable-profiling} + @see{report}" + (setf *profiling-enabled-p* t) + (setf *samples* nil) + (clear-counter *apply-stylesheet-counter*) + (clear-counter *parse-stylesheet-counter*) + (clear-counter *parse-xml-counter*) + (clear-counter *unparse-xml-counter*) + (format t "~&XSLT profiling enabled. (0 samples now recorded)~%~%") + (xpath-sys:enable-profiling nil)) + +(defun disable-profiling () + "@return{nil} + @short{Disables profiling.} + + Disables profiling for future XSLT processing, but keeps recorded + profiling samples for @fun{report}. + + Also disables XPath profiling, see @fun{xpath-sys:disable-profiling}. + + @see{enable-profiling}" + (setf *profiling-enabled-p* nil) + (format t "~&XSLT profiling disabled. (~D sample~:P currently recorded)~%" + (length *samples*)) + (xpath-sys:disable-profiling)) + +(defun invoke-template/profile (ctx template param-bindings) + (let ((run0 (get-internal-run-time)) + (real0 (get-internal-real-time))) + (unwind-protect + (let ((*profiling-callers* (cons template *profiling-callers*))) + (invoke-template ctx template param-bindings)) + (let* ((run1 (get-internal-run-time)) + (real1 (get-internal-real-time)) + (run (- run1 run0)) + (real (- real1 real0))) + (push (list template *profiling-callers* run real) *samples*))))) + +(defun invoke-with-profile-counter (fn counter) + (let ((run0 (get-internal-run-time)) + (real0 (get-internal-real-time))) + (unwind-protect + (funcall fn) + (let* ((run1 (get-internal-run-time)) + (real1 (get-internal-real-time)) + (run (- run1 run0)) + (real (- real1 real0))) + (incf (profile-counter-calls counter)) + (incf (profile-counter-run counter) run) + (incf (profile-counter-real counter) real))))) + +(defstruct (profile-data + (:constructor make-profile-data (template)) + (:conc-name "DATA-")) + template + (total-real 0) + (total-run 0) + (self-real 0) + (self-run 0) + (calls 0)) + +(defun group-and-sort-samples () + (let ((table (make-hash-table))) + (loop + for (callee callers run real) in *samples* + do + (let ((data + (or (gethash callee table) + (setf (gethash callee table) + (make-profile-data callee))))) + (unless (find callee callers) + (incf (data-total-run data) run) + (incf (data-total-real data) real)) + (incf (data-self-run data) run) + (incf (data-self-real data) real) + (incf (data-calls data))) + (when callers + (let* ((caller (car callers)) + (data + (or (gethash caller table) + (setf (gethash caller table) + (make-profile-data caller))))) + (decf (data-self-run data) run) + (decf (data-self-real data) real)))) + (sort (loop + for data being each hash-value in table + collect data) + #'> + :key #'data-total-run))) + +(defun report-samples (template-times) + (format t "~&~D Template~:P called:~%~%" + (length template-times)) + (format t " run real # avg.run run real template~%") + (format t " total total total self self~%~%") + (let ((base-uris (make-hash-table :test #'equal))) + (dolist (data template-times) + (let ((template (data-template data))) + (format t "~6D ~6D ~6D ~6D ~6D ~6D " + (data-total-run data) + (data-total-real data) + (data-calls data) + (floor (data-total-run data) (data-calls data)) + (data-self-run data) + (data-self-real data)) + (let ((base-uri (template-base-uri template))) + (format t "<~D> " + (or (gethash base-uri base-uris) + (setf (gethash base-uri base-uris) + (1+ (hash-table-count base-uris)))))) + (if (template-name template) + (format t "name=~S" (template-unparsed-qname template)) + (format t "match=~S" (xpath::stringify-pattern-expression + (template-match-expression template)))) + (when (template-mode-qname template) + (format t ", mode=~S" (template-mode-qname template))) + (format t "~%~%"))) + (format t "~%Index of stylesheets:~%~%") + (let ((sorted-base-uris + (sort (loop + for base-uri being each hash-key + using (hash-value id) + in base-uris + collect (cons id base-uri)) + #'< + :key #'car))) + (loop + for (id . base-uri) in sorted-base-uris + do (format t " <~D> = ~A~%" id base-uri))))) + +(defun report () + "@short{Shows profiling output.} + + Shows cumulative run time and real time, number of calls, and average + run time for each template that was invoked. + + @see{enable-profiling} + @see{disable-profiling}" + (format t "~&~D template call~:P recorded~%~%" (length *samples*)) + (format t "1 second = ~D time units~%~%" + internal-time-units-per-second) + (report-counter *apply-stylesheet-counter* "Stylesheet application (total)") + (report-counter *parse-stylesheet-counter* " ... XSLT compilation") + (report-counter *parse-xml-counter* " ... XML parsing") + (report-counter *unparse-xml-counter* " ... Serialization" nil) + (format t " ----------------------------------------------------------------------~%") + (report-counter (counter- *apply-stylesheet-counter* + *parse-stylesheet-counter* + *parse-xml-counter* + *unparse-xml-counter*) + " Remaining XSLT processing time" + nil) + (terpri) + (terpri) + (loop + for (nil run real) in xpath::*samples* + count t into calls + sum run into total-run + sum real into total-real + finally + (report-counter + (make-profile-counter :calls calls :run total-run :real total-real) + "Includes XPath processing")) + (format t "(Valid only if XPath profiling was enabled during XSLT compilation.)") + (terpri) + (terpri) + (report-samples (group-and-sort-samples))) diff --git a/unparse.lisp b/unparse.lisp index 9997659..f36acb1 100644 --- a/unparse.lisp +++ b/unparse.lisp @@ -56,6 +56,12 @@ (maybe-emit-start-tag) (funcall fn *sink*)) +(defmacro defun/unparse (name (&rest args) &body body) + `(defun ,name ,args + (with-profile-counter (*unparse-xml-counter*) + (let ((*unparse-xml-counter* nil)) + ,@body)))) + (defmacro with-element ((local-name uri &key suggested-prefix extra-namespaces process-aliases) &body body) @@ -66,7 +72,7 @@ :extra-namespaces ,extra-namespaces :process-aliases ,process-aliases)) -(defun doctype (name public-id system-id &optional internal-subset) +(defun/unparse doctype (name public-id system-id &optional internal-subset) (sax:start-dtd *sink* name public-id system-id) (when internal-subset (sax:unparsed-internal-subset *sink* internal-subset)) @@ -198,12 +204,14 @@ (defun invoke-with-element (fn local-name uri &key suggested-prefix extra-namespaces process-aliases) - (check-type local-name string) - (check-type uri string) - (check-type suggested-prefix (or null string)) - (maybe-emit-start-tag) - (when process-aliases - (setf uri (unalias-uri uri))) + ;; fixme: don't litter this function with calls to with-profile-counter + (with-profile-counter (*unparse-xml-counter*) + (check-type local-name string) + (check-type uri string) + (check-type suggested-prefix (or null string)) + (maybe-emit-start-tag) + (when process-aliases + (setf uri (unalias-uri uri)))) (let* ((parent *current-element*) (elt (make-sink-element :local-name local-name @@ -216,20 +224,22 @@ :attributes nil)) (*current-element* elt) (*start-tag-written-p* nil)) - ;; always establish explicitly copied namespaces first - ;; (not including declarations of the default namespace) - (process-extra-namespaces elt extra-namespaces process-aliases) - ;; establish the element's prefix (which might have to be the default - ;; namespace if it's the empty URI) - (ensure-prefix-for-uri elt uri suggested-prefix) + (with-profile-counter (*unparse-xml-counter*) + ;; always establish explicitly copied namespaces first + ;; (not including declarations of the default namespace) + (process-extra-namespaces elt extra-namespaces process-aliases) + ;; establish the element's prefix (which might have to be the default + ;; namespace if it's the empty URI) + (ensure-prefix-for-uri elt uri suggested-prefix)) ;; we'll do attributes incrementally (multiple-value-prog1 (funcall fn) - (maybe-emit-start-tag) - (sax:end-element *sink* uri local-name (sink-element-actual-qname elt)) - (loop - for (prefix . uri) in (sink-element-new-namespaces elt) do - (sax:end-prefix-mapping *sink* prefix))))) + (with-profile-counter (*unparse-xml-counter*) + (maybe-emit-start-tag) + (sax:end-element *sink* uri local-name (sink-element-actual-qname elt)) + (loop + for (prefix . uri) in (sink-element-new-namespaces elt) do + (sax:end-prefix-mapping *sink* prefix)))))) (defun process-extra-namespace (elt prefix uri process-aliases) (when process-aliases @@ -269,7 +279,7 @@ (push cons (sink-element-all-namespaces elt)) (push cons (sink-element-new-namespaces elt)))))) -(defun write-attribute +(defun/unparse write-attribute (local-name uri value &key suggested-prefix process-aliases) (check-type local-name string) (check-type uri string) @@ -296,7 +306,7 @@ (equal (sink-attribute-uri x) uri))) (sink-element-attributes *current-element*))))))) -(defun write-extra-namespace (prefix uri process-aliases) +(defun/unparse write-extra-namespace (prefix uri process-aliases) (check-type prefix string) (check-type uri string) (cond @@ -309,12 +319,12 @@ (t (process-extra-namespace *current-element* prefix uri process-aliases)))) -(defun write-text (data) +(defun/unparse write-text (data) (maybe-emit-start-tag) (sax:characters *sink* data) data) -(defun write-comment (data) +(defun/unparse write-comment (data) (maybe-emit-start-tag) ;; kludge: rewrite this in a nicer way (setf data (cl-ppcre:regex-replace-all "--" data "- -")) @@ -329,7 +339,7 @@ (every #'cxml::name-rune-p str)) (cxml::nc-name-p str))) -(defun write-processing-instruction (target data) +(defun/unparse write-processing-instruction (target data) (maybe-emit-start-tag) (setf data (cl-ppcre:regex-replace-all "[?]>" data "? >")) (cond @@ -339,6 +349,6 @@ (xslt-cerror "PI target not an NCName: ~A" target))) data) -(defun write-unescaped (str) +(defun/unparse write-unescaped (str) (maybe-emit-start-tag) (sax:unescaped *sink* str)) diff --git a/xslt.lisp b/xslt.lisp index 6ed6cb1..4be88bf 100644 --- a/xslt.lisp +++ b/xslt.lisp @@ -150,6 +150,20 @@ ;;; (setf (gethash "" xpath::*extensions*) non-extensions) ;;; (funcall fn))) +(defstruct profile-counter calls run real) + +(defvar *apply-stylesheet-counter* (make-profile-counter)) +(defvar *parse-stylesheet-counter* (make-profile-counter)) +(defvar *parse-xml-counter* (make-profile-counter)) +(defvar *unparse-xml-counter* (make-profile-counter)) + +(defmacro with-profile-counter ((var) &body body) + `((lambda (fn) + (if (and *profiling-enabled-p* ,var) + (invoke-with-profile-counter fn ,var) + (funcall fn))) + (lambda () ,@body))) + ;;;; Helper functions and macros @@ -524,6 +538,7 @@ (setf (stp:document-element document) new-document-element) (stp:append-child new-document-element new-template) (stp:append-child new-template literal-result-element) + (setf (stp:base-uri new-template) (stp:base-uri literal-result-element)) new-document-element)) (defun parse-stylesheet-to-stp (input uri-resolver) @@ -1216,6 +1231,8 @@ (*instruction-base-uri* (stp:base-uri