profile.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  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.
  17 ;;;
  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.
  29
  30 (in-package :xuriella)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35
  36 ;;;; profiling support
  37
  38
  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.)
  43
  44
  45 (defvar *profiling-callers* nil)
  46 (defvar *samples* nil)
  47
  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))
  52
  53 (defun counter- (a b &rest rest)
  54   (if rest
  55       (apply #'counter- (counter- a b) rest)
  56       (make-profile-counter
  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)))))
  60
  61 (defun report-counter (counter label &optional (callsp t))
  62   (format t "  ~A:~40T~5D run ~5D real~@[ (~D calls)~]~%"
  63           label
  64           (profile-counter-run counter)
  65           (profile-counter-real counter)
  66           (and callsp (profile-counter-calls counter))))
  67
  68 (defun enable-profiling ()
  69   "@return{nil}
  70    @short{Enables profiling.}
  71
  72    Resets any existing profile samples and enables profiling for future
  73    XSLT processing.
  74
  75    Also enables XPath profiling, see @fun{xpath-sys:enable-profiling}.
  76
  77    Profiling is not thread safe.
  78
  79    @see{disable-profiling}
  80    @see{report}"
  81   (setf *profiling-enabled-p* t)
  82   (setf *samples* nil)
  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))
  89
  90 (defun disable-profiling ()
  91   "@return{nil}
  92    @short{Disables profiling.}
  93
  94    Disables profiling for future XSLT processing, but keeps recorded
  95    profiling samples for @fun{report}.
  96
  97    Also disables XPath profiling, see @fun{xpath-sys:disable-profiling}.
  98
  99    @see{enable-profiling}"
 100   (setf *profiling-enabled-p* nil)
 101   (format t "~&XSLT profiling disabled.  (~D sample~:P currently recorded)~%"
 102           (length *samples*))
 103   (xpath-sys:disable-profiling))
 104
 105 (defun invoke-template/profile (ctx template param-bindings)
 106   (let ((run0 (get-internal-run-time))
 107         (real0 (get-internal-real-time)))
 108     (unwind-protect
 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))
 113              (run (- run1 run0))
 114              (real (- real1 real0)))
 115         (push (list template *profiling-callers* run real) *samples*)))))
 116
 117 (defun invoke-with-profile-counter (fn counter)
 118   (let ((run0 (get-internal-run-time))
 119         (real0 (get-internal-real-time)))
 120     (unwind-protect
 121          (funcall fn)
 122       (let* ((run1 (get-internal-run-time))
 123              (real1 (get-internal-real-time))
 124              (run (- run1 run0))
 125              (real (- real1 real0)))
 126         (incf (profile-counter-calls counter))
 127         (incf (profile-counter-run counter) run)
 128         (incf (profile-counter-real counter) real)))))
 129
 130 (defstruct (profile-data
 131              (:constructor make-profile-data (template))
 132              (:conc-name "DATA-"))
 133   template
 134   (total-real 0)
 135   (total-run 0)
 136   (self-real 0)
 137   (self-run 0)
 138   (calls 0))
 139
 140 (defun group-and-sort-samples ()
 141   (let ((table (make-hash-table)))
 142     (loop
 143        for (callee callers run real) in *samples*
 144        do
 145          (let ((data
 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)))
 155          (when callers
 156            (let* ((caller (car callers))
 157                   (data
 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))))
 163     (sort (loop
 164              for data being each hash-value in table
 165              collect data)
 166           #'>
 167           :key #'data-total-run)))
 168
 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)
 180                 (data-calls data)
 181                 (floor (data-total-run data) (data-calls data))
 182                 (data-self-run data)
 183                 (data-self-real data))
 184         (let ((base-uri (template-base-uri template)))
 185           (format t "<~D> "
 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)))
 195         (format t "~%~%")))
 196     (format t "~%Index of stylesheets:~%~%")
 197     (let ((sorted-base-uris
 198            (sort (loop
 199                     for base-uri being each hash-key
 200                     using (hash-value id)
 201                     in base-uris
 202                     collect (cons id base-uri))
 203                  #'<
 204                  :key #'car)))
 205       (loop
 206          for (id . base-uri) in sorted-base-uris
 207          do (format t " <~D> = ~A~%" id base-uri)))))
 208
 209 (defun report ()
 210   "@short{Shows profiling output.}
 211
 212    Shows cumulative run time and real time, number of calls, and average
 213    run time for each template that was invoked.
 214
 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*
 227                             *parse-xml-counter*
 228                             *unparse-xml-counter*)
 229                   "      Remaining XSLT processing time"
 230                   nil)
 231   (terpri)
 232   (terpri)
 233   (loop
 234      for (nil run real) in xpath::*samples*
 235      count t into calls
 236      sum run into total-run
 237      sum real into total-real
 238      finally
 239        (report-counter
 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.)")
 243   (terpri)
 244   (terpri)
 245   (report-samples (group-and-sort-samples)))