Added an XSLT profiler.
authorDavid Lichteblau <david@lichteblau.com>
Sun, 25 May 2008 21:54:08 +0000 (25 23:54 +0200)
committerDavid Lichteblau <david@radon.(none)>
Sun, 25 May 2008 21:55:17 +0000 (25 23:55 +0200)
package.lisp
parser.lisp
profile.lisp [new file with mode: 0644]
unparse.lisp
xslt.lisp
xuriella.asd

index 97a6560..8566483 100644 (file)
           #: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.
       @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:
 
index 7014e24..472ff98 100644 (file)
         `(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 (file)
index 0000000..22944de
--- /dev/null
@@ -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)))
index 9997659..f36acb1 100644 (file)
   (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))
 
 (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
                :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
        (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)
                                    (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
     (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 "- -"))
        (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
      (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))
index 6ed6cb1..4be88bf 100644 (file)
--- a/xslt.lisp
+++ b/xslt.lisp
 ;;;     (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
 
     (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)
             (*instruction-base-uri* (stp:base-uri <template>)))
         (with-import-magic (<template> env)
           (dolist (template (compile-template <template> env i))
+            (setf (template-stylesheet template) stylesheet)
+            (setf (template-base-uri template) (stp:base-uri <template>))
             (let ((name (template-name template)))
               (if name
                   (let* ((table (stylesheet-named-templates stylesheet))
     (object &optional node-set)
   (let ((instruction-base-uri *instruction-base-uri*))
     (lambda (ctx)
-      (let* ((object (funcall object ctx))
-             (node-set (and node-set (funcall node-set ctx)))
-             (base-uri
-              (if node-set
-                  (document-base-uri (xpath::textually-first-node node-set))
-                  instruction-base-uri)))
-        (xpath-sys:make-node-set
-         (if (xpath:node-set-p object)
-             (xpath:map-node-set->list
-              (lambda (node)
-                (%document (xpath:string-value node)
-                           (if node-set
-                               base-uri
-                               (document-base-uri node))))
-              object)
-             (list (%document (xpath:string-value object) base-uri))))))))
+      (with-profile-counter (*parse-xml-counter*)
+        (let* ((object (funcall object ctx))
+               (node-set (and node-set (funcall node-set ctx)))
+               (base-uri
+                (if node-set
+                    (document-base-uri (xpath::textually-first-node node-set))
+                    instruction-base-uri)))
+          (xpath-sys:make-node-set
+           (if (xpath:node-set-p object)
+               (xpath:map-node-set->list
+                (lambda (node)
+                  (%document (xpath:string-value node)
+                             (if node-set
+                                 base-uri
+                                 (document-base-uri node))))
+                object)
+               (list (%document (xpath:string-value object) base-uri)))))))))
 
 
 (defun build-key-index (document key-conses)
    The specified @code{navigator} will be passed to XPath protocol functions.
 
    @see{parse-stylesheet}"
-  (when (typep stylesheet 'xml-designator)
-    (setf stylesheet
-          (handler-bind
-              ((cxml:xml-parse-error
-                (lambda (c)
-                  (xslt-error "cannot parse stylesheet: ~A" c))))
-            (parse-stylesheet stylesheet :uri-resolver uri-resolver))))
-  (with-resignalled-errors ()
-    (invoke-with-output-sink
-     (lambda ()
-       (let* ((*uri-to-document* (make-hash-table :test 'equal))
-              (*root-to-document*
-               ;; fixme? should be xpath-protocol:node-equal
-               (make-hash-table :test 'equal))
-              (xpath:*navigator* (or navigator :default-navigator))
-              (puri:*strict-parse* nil)
-              (*stylesheet* stylesheet)
-              (*empty-mode* (make-mode))
-              (*default-mode* (find-mode stylesheet nil))
-              (global-variable-chains
-               (stylesheet-global-variables stylesheet))
-              (*global-variable-values*
-               (make-variable-value-array (length global-variable-chains)))
-              (*uri-resolver* uri-resolver)
-              (source-document
-               (if (typep source-designator 'xml-designator)
-                   (cxml:parse source-designator (stp:make-builder))
-                   source-designator))
-              (xpath-root-node
-               (make-whitespace-stripper
-                source-document
-                (stylesheet-strip-thunk stylesheet)))
-              (ctx (xpath:make-context xpath-root-node))
-              (document (make-source-document
-                         :id 0
-                         :root-node xpath-root-node)))
-         (when (pathnamep source-designator) ;fixme: else use base uri?
-           (setf (gethash source-designator *uri-to-document*) document))
-         (setf (gethash xpath-root-node *root-to-document*) document)
-         (map nil
-              (lambda (chain)
-                (let ((head (car (variable-chain-definitions chain))))
-                  (when (variable-param-p head)
-                    (let ((value
-                           (find-parameter-value
-                            (variable-chain-local-name chain)
-                            (variable-chain-uri chain)
-                            parameters)))
-                      (when value
-                        (setf (global-variable-value
-                               (variable-chain-index chain))
-                              value))))))
-              global-variable-chains)
-         (map nil
-              (lambda (chain)
-                (funcall (variable-chain-thunk chain) ctx))
-              global-variable-chains)
-         ;; zzz we wouldn't have to mask float traps here if we used the
-         ;; XPath API properly.  Unfortunately I've been using FUNCALL
-         ;; everywhere instead of EVALUATE, so let's paper over that
-         ;; at a central place to be sure:
-         (xpath::with-float-traps-masked ()
-           (apply-templates ctx :mode *default-mode*))))
-     (stylesheet-output-specification stylesheet)
-     output)))
+  (with-profile-counter (*apply-stylesheet-counter*)
+    (when (typep stylesheet 'xml-designator)
+      (with-profile-counter (*parse-stylesheet-counter*)
+        (setf stylesheet
+              (handler-bind
+                  ((cxml:xml-parse-error
+                    (lambda (c)
+                      (xslt-error "cannot parse stylesheet: ~A" c))))
+                (parse-stylesheet stylesheet :uri-resolver uri-resolver)))))
+    (with-resignalled-errors ()
+      (invoke-with-output-sink
+       (lambda ()
+         (let* ((*uri-to-document* (make-hash-table :test 'equal))
+                (*root-to-document*
+                 ;; fixme? should be xpath-protocol:node-equal
+                 (make-hash-table :test 'equal))
+                (xpath:*navigator* (or navigator :default-navigator))
+                (puri:*strict-parse* nil)
+                (*stylesheet* stylesheet)
+                (*empty-mode* (make-mode))
+                (*default-mode* (find-mode stylesheet nil))
+                (global-variable-chains
+                 (stylesheet-global-variables stylesheet))
+                (*global-variable-values*
+                 (make-variable-value-array (length global-variable-chains)))
+                (*uri-resolver* uri-resolver)
+                (source-document
+                 (if (typep source-designator 'xml-designator)
+                     (with-profile-counter (*parse-xml-counter*)
+                       (cxml:parse source-designator (stp:make-builder)))
+                     source-designator))
+                (xpath-root-node
+                 (make-whitespace-stripper
+                  source-document
+                  (stylesheet-strip-thunk stylesheet)))
+                (ctx (xpath:make-context xpath-root-node))
+                (document (make-source-document
+                           :id 0
+                           :root-node xpath-root-node)))
+           (when (pathnamep source-designator) ;fixme: else use base uri?
+             (setf (gethash source-designator *uri-to-document*) document))
+           (setf (gethash xpath-root-node *root-to-document*) document)
+           (map nil
+                (lambda (chain)
+                  (let ((head (car (variable-chain-definitions chain))))
+                    (when (variable-param-p head)
+                      (let ((value
+                             (find-parameter-value
+                              (variable-chain-local-name chain)
+                              (variable-chain-uri chain)
+                              parameters)))
+                        (when value
+                          (setf (global-variable-value
+                                 (variable-chain-index chain))
+                                value))))))
+                global-variable-chains)
+           (map nil
+                (lambda (chain)
+                  (funcall (variable-chain-thunk chain) ctx))
+                global-variable-chains)
+           ;; zzz we wouldn't have to mask float traps here if we used the
+           ;; XPath API properly.  Unfortunately I've been using FUNCALL
+           ;; everywhere instead of EVALUATE, so let's paper over that
+           ;; at a central place to be sure:
+           (xpath::with-float-traps-masked ()
+             (apply-templates ctx :mode *default-mode*))))
+       (stylesheet-output-specification stylesheet)
+       output))))
 
 (defun find-attribute-set (local-name uri &optional (stylesheet *stylesheet*))
   (or (gethash (cons local-name uri) (stylesheet-attribute-sets stylesheet))
         :mode mode)))))
 
 (defvar *apply-imports*)
+(defvar *profiling-enabled-p* nil)
 
 (defun apply-applicable-templates (ctx templates param-bindings finally)
   (labels ((apply-imports (&optional actual-param-bindings)
                           (lambda (x)
                             (<= low (template-import-priority x) high))
                           templates))
-                   (invoke-template ctx this actual-param-bindings))
+                   (if *profiling-enabled-p*
+                       (invoke-template/profile ctx this actual-param-bindings)
+                       (invoke-template ctx this actual-param-bindings)))
                  (funcall finally))))
     (let ((*apply-imports* #'apply-imports))
       (apply-imports param-bindings))))
   mode-qname
   params
   body
-  n-variables)
+  n-variables
+  ;; for profiling output only:
+  unparsed-qname
+  stylesheet
+  base-uri)
 
 (defun expression-priority (form)
   (let ((step (second form)))
                              :apply-imports-limit *apply-imports-limit*
                              :params param-bindings
                              :body outer-body-thunk
-                             :n-variables n-variables))))
+                             :n-variables n-variables
+                             ;; record unparsed `name' for profiler output:
+                             :unparsed-qname name))))
          (when match
            (mapcar (lambda (expression)
                      (let* ((compiled-pattern
index e0c89c7..ba29696 100644 (file)
@@ -28,5 +28,6 @@
      (:file "number")
      (:file "stpx")
      (:file "extensions")
+     (:file "profile")
      (:file "test"))
     :depends-on (:cxml :cxml-stp :closure-html :xpath :split-sequence))