Added an XPath profiler.
Sat May 24 12:50:35 PDT 2008 David Lichteblau <david@lichteblau.com>
* Added an XPath profiler.
diff -rN -u old-plexippus-xpath/api.lisp new-plexippus-xpath/api.lisp
--- old-plexippus-xpath/api.lisp 2014-07-25 10:40:31.000000000 -0700
+++ new-plexippus-xpath/api.lisp 2014-07-25 10:40:31.000000000 -0700
@@ -155,10 +155,12 @@
(xpath-error "invalid xpath designator: ~A" xpath))
(if (functionp xpath)
xpath
- (compile-xpath/sexpr (if (stringp xpath)
- (parse-xpath xpath)
- (second xpath))
- environment)))
+ (maybe-wrap-profiling
+ xpath
+ (compile-xpath/sexpr (if (stringp xpath)
+ (parse-xpath xpath)
+ (second xpath))
+ environment))))
(defun evaluate-compiled (compiled-xpath context &optional unordered-p)
"@arg[compiled-xpath]{a compiled XPath expression}
@@ -226,7 +228,8 @@
(if (functionp ,xpath)
,xpath
(with-cache ((,xpath :test equal)
- (*dynamic-namespaces* :test namespaces-match-p))
+ (*dynamic-namespaces* :test namespaces-match-p)
+ (*profiling-enabled-p* :test eql))
(compile-xpath ,xpath
(make-dynamic-environment
*dynamic-namespaces*))))
diff -rN -u old-plexippus-xpath/package.lisp new-plexippus-xpath/package.lisp
--- old-plexippus-xpath/package.lisp 2014-07-25 10:40:31.000000000 -0700
+++ new-plexippus-xpath/package.lisp 2014-07-25 10:40:31.000000000 -0700
@@ -139,7 +139,10 @@
#:define-extension
#:define-xpath-function/lazy
#:define-xpath-function/eager
- #:define-xpath-function/single-type)
+ #:define-xpath-function/single-type
+ #:enable-profiling
+ #:disable-profiling
+ #:report)
(:export #:compile-xpath
#:parse-xpath
@@ -303,7 +306,10 @@
#:define-extension
#:define-xpath-function/lazy
#:define-xpath-function/eager
- #:define-xpath-function/single-type)
+ #:define-xpath-function/single-type
+ #:enable-profiling
+ #:disable-profiling
+ #:report)
(:export #:make-node-set
#:make-pipe
#:pipe-head
@@ -317,7 +323,10 @@
#:define-extension
#:define-xpath-function/lazy
#:define-xpath-function/eager
- #:define-xpath-function/single-type)
+ #:define-xpath-function/single-type
+ #:enable-profiling
+ #:disable-profiling
+ #:report)
(:documentation
"The XPATH-SYS package provides an API for extensions to Plexippus XPath.
@@ -371,6 +380,14 @@
@aboutmacro{define-xpath-function/single-type}
@aboutfun{find-xpath-function}
@end{section}
+ @begin[Profiling support]{section}
+ The profiling facility records the run time of XPath evaluations
+ and pattern matching.
+
+ @aboutfun{enable-profiling}
+ @aboutfun{disable-profiling}
+ @aboutfun{report}
+ @end{section}
@begin[Miscellaneous functions]{section}
Other useful functions:
diff -rN -u old-plexippus-xpath/patterns.lisp new-plexippus-xpath/patterns.lisp
--- old-plexippus-xpath/patterns.lisp 2014-07-25 10:40:31.000000000 -0700
+++ new-plexippus-xpath/patterns.lisp 2014-07-25 10:40:31.000000000 -0700
@@ -40,11 +40,14 @@
@see{compute-patterns}")
(defstruct (pattern
- (:constructor %make-pattern (key thunk priority value)))
+ (:constructor %make-pattern
+ (key thunk priority value expression)))
priority
value
key
- thunk)
+ thunk
+ ;; for profiler output only:
+ expression)
(setf (documentation 'pattern 'type)
"Represents a parsed XSLT pattern.
@@ -201,31 +204,33 @@
(push spec (gethash type type-patterns)))
(t
(push spec other-patterns))))
- (lambda (node)
- (let ((results nil)
- (result-priority nil))
- (flet ((process-spec (spec)
- (destructuring-bind (priority thunk value)
- spec
- (when (and (or (null result-priority)
- (<= result-priority priority))
- (funcall thunk node))
- (cond
- ((null result-priority)
- (setf result-priority priority))
- ((< result-priority priority)
- (setf result-priority priority)
- (setf results nil)))
- (pushnew value results)))))
- (let ((name (xpath-protocol:local-name node))
- (uri (xpath-protocol:namespace-uri node))
- (type (node-type node)))
- (when name
- (mapc #'process-spec (gethash (cons name uri) name-patterns))
- (mapc #'process-spec (gethash uri namespace-patterns)))
- (mapc #'process-spec (gethash type type-patterns))
- (mapc #'process-spec other-patterns)))
- results))))
+ (maybe-wrap-profiling
+ patterns
+ (lambda (node)
+ (let ((results nil)
+ (result-priority nil))
+ (flet ((process-spec (spec)
+ (destructuring-bind (priority thunk value)
+ spec
+ (when (and (or (null result-priority)
+ (<= result-priority priority))
+ (funcall thunk node))
+ (cond
+ ((null result-priority)
+ (setf result-priority priority))
+ ((< result-priority priority)
+ (setf result-priority priority)
+ (setf results nil)))
+ (pushnew value results)))))
+ (let ((name (xpath-protocol:local-name node))
+ (uri (xpath-protocol:namespace-uri node))
+ (type (node-type node)))
+ (when name
+ (mapc #'process-spec (gethash (cons name uri) name-patterns))
+ (mapc #'process-spec (gethash uri namespace-patterns)))
+ (mapc #'process-spec (gethash type type-patterns))
+ (mapc #'process-spec other-patterns)))
+ results)))))
(defun compute-patterns (expression priority value environment)
"@arg[expression]{a string or s-expression}
@@ -246,12 +251,13 @@
@see{make-pattern-matcher*}
@see{make-pattern-matcher}"
- (multiple-value-bind (keys thunks)
+ (multiple-value-bind (keys thunks subexpressions)
(compile-pattern-expression expression environment)
- (mapcar (lambda (key thunk)
- (%make-pattern key thunk priority value))
+ (mapcar (lambda (key thunk subexpression)
+ (%make-pattern key thunk priority value subexpression))
keys
- thunks)))
+ thunks
+ subexpressions)))
(defun node-matches-p (node pattern-expression)
"@arg[node]{any node implementing the XPath protocol}
@@ -276,7 +282,8 @@
(once-only (pattern)
`(matching-value
(with-cache ((,pattern)
- (*dynamic-namespaces* :test namespaces-match-p))
+ (*dynamic-namespaces* :test namespaces-match-p)
+ (*profiling-enabled-p* :test eql))
(make-pattern-matcher*
,pattern
(make-dynamic-environment *dynamic-namespaces*)))
@@ -341,7 +348,8 @@
*dynamic-namespaces*)))))
`(funcall
(matching-value
- (with-cache ((*dynamic-namespaces* :test namespaces-match-p))
+ (with-cache ((*dynamic-namespaces* :test namespaces-match-p)
+ (*profiling-enabled-p* :test eql))
(make-pattern-matcher (append ,@patterns)))
,node
(lambda () ,@otherwise-body)))))
@@ -420,7 +428,8 @@
(assert (eq (car pattern) :patterns))
(values
(mapcar (lambda (x) (subpattern-key x environment)) (cdr pattern))
- (mapcar (lambda (x) (compile-subpattern x environment)) (cdr pattern))))
+ (mapcar (lambda (x) (compile-subpattern x environment)) (cdr pattern))
+ (cdr pattern)))
(defun subpattern-key (subpattern environment)
(ecase (car subpattern)
diff -rN -u old-plexippus-xpath/xpath.asd new-plexippus-xpath/xpath.asd
--- old-plexippus-xpath/xpath.asd 2014-07-25 10:40:31.000000000 -0700
+++ new-plexippus-xpath/xpath.asd 2014-07-25 10:40:31.000000000 -0700
@@ -31,4 +31,5 @@
(:file "plx")
(:file "xmls-compat")
(:file "patterns")
+ (:file "profile")
(:file "xpath-test")))
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.