cgit.sxemacs.org Git - sxemacs/blob - tests/benchmark/benchmark.el

   1 ;;; benchmark.el ---
   2 ;; Copyright (C) 2007 Sebastian Freundt
   3 ;;
   4 ;; Author: Sebastian Freundt <hroptatyr@sxemacs.org>
   5 ;; Keywords: profiling, benchmark
   6 ;;
   7 ;; This file is part of SXEmacs.
   8 ;;
   9 ;; Redistribution and use in source and binary forms, with or without
  10 ;; modification, are permitted provided that the following conditions
  11 ;; are met:
  12 ;;
  13 ;; 1. Redistributions of source code must retain the above copyright
  14 ;;    notice, this list of conditions and the following disclaimer.
  15 ;;
  16 ;; 2. Redistributions in binary form must reproduce the above copyright
  17 ;;    notice, this list of conditions and the following disclaimer in the
  18 ;;    documentation and/or other materials provided with the distribution.
  19 ;;
  20 ;; 3. Neither the name of the author nor the names of any contributors
  21 ;;    may be used to endorse or promote products derived from this
  22 ;;    software without specific prior written permission.
  23 ;;
  24 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35 ;;
  36 ;;; Synched up with: Not in FSF.
  37 ;;
  38 ;;; Code:
  39
  40 (defmacro bm-profile-time-ord (&rest body)
  41   `(let ((sttb (current-time)))
  42      ,@body
  43      (time-subtract (current-time) sttb)))
  44
  45 (defmacro bm-profile-time-multi-ord (count &rest body)
  46   `(let* ((cnt ,count)
  47           (sttb (current-time)))
  48      (while (< 0 cnt)
  49        ,@body
  50        (setq cnt (1- cnt)))
  51      (time-subtract (current-time) sttb)))
  52
  53
  54 (defmacro bm-profile-time-btime (&rest body)
  55   `(let* ((none (garbage-collect))
  56           (sttb (current-btime)))
  57      ,@body
  58      (- (current-btime) sttb)))
  59
  60 (defmacro bm-profile-time-multi-btime (count &rest body)
  61   `(let* ((cnt ,count)
  62           (sttb (current-btime)))
  63      (while (nonnegativep cnt)
  64        ,@body
  65        (setq cnt (1- cnt)))
  66      (- (current-btime) sttb)))
  67
  68
  69 (cond ((fboundp #'current-btime)
  70        (defalias 'bm-profile-time 'bm-profile-time-btime)
  71        (defalias 'bm-profile-time-multi 'bm-profile-time-multi-btime))
  72       ((fboundp #'time-subtract)
  73        (defalias 'bm-profile-time 'bm-profile-time-ord)
  74        (defalias 'bm-profile-time-multi 'bm-profile-time-multi-ord))
  75       (t nil))
  76
  77 (put 'bm-profile-time 'lisp-indent-function 'defun)
  78 (put 'bm-profile-time-multi 'lisp-indent-function 'defun)
  79
  80
  81 (defun bm-compute-sample-points (test-range &optional grain)
  82   (let* ((lo (car test-range))
  83          (hi (cdr test-range))
  84          (grain-ratio (// hi lo grain))
  85          (lol (log lo))
  86          (hil (log hi))
  87          (step (// (- hi lo) grain))
  88          (stepl (// (- hil lol) grain))
  89          (i (coerce-number lol 'int))
  90          (logp (> grain-ratio 1))
  91          (result (make-vector (1+ grain) nil))
  92          logf linf)
  93     (fset #'logf
  94           #'(lambda (unused)
  95               (let* ((exp (exp lol))
  96                      (this (coerce-number exp 'int)))
  97                 (setq lol (+ lol stepl))
  98                 this)))
  99     (fset #'linf
 100           #'(lambda (unused)
 101               (let* ((this (coerce-number lo 'int)))
 102                 (setq lo (+ lo step))
 103                 this)))
 104     (mapc-inplace (if logp #'logf #'linf) result)
 105     result))
 106
 107 (defun bm-util-average (dllv c)
 108   (let* ((size (dllist-size dllv))
 109          (res 0))
 110     (mapc-internal
 111      #'(lambda (v)
 112          (setq res (+ res (aref v c))))
 113      dllv)
 114     (// res size)))
 115
 116 (defun bm-util-deviation (dllv avg c)
 117   (let* ((size (dllist-size dllv))
 118          (res 0))
 119     (mapc-internal
 120      #'(lambda (v)
 121          (setq res
 122                (+ res (^ (- (aref v c) avg) 2))))
 123      dllv)
 124     (sqrt (// res size))))
 125
 126 (defun bm-determine-time-stability (test-funv result)
 127   "Examine RESULT and try to guess if time data behaves like O(1)."
 128   (let* ((vlen (length test-funv))
 129          (resv (make-vector (1+ vlen) 0))
 130          (j 0)
 131          (avgsum 0)
 132          (devsum 0))
 133     (while (< j vlen)
 134       (let* ((fun (aref test-funv j))
 135              (name (function-documentation fun))
 136              (avg (bm-util-average result j))
 137              (adev (bm-util-deviation result avg j))
 138              (rdev (* (// adev avg) 100)))
 139         (setq avgsum (+ avgsum avg)
 140               devsum (+ devsum adev))
 141         (aset resv j (vector name avg adev rdev)))
 142       (setq j (1+ j)))
 143     (aset resv vlen (vector "SUM" avgsum devsum (* (// devsum avgsum) 100)))
 144     resv))
 145
 146 (defun bm-examine-time-stability (test-funv point)
 147   (princ (format "Testing time stability on %d ...\n" point)
 148          'external-debugging-output)
 149   (let* ((grain 100)
 150          (pile (dllist)))
 151     (loop for i below grain
 152       do (dllist-append
 153           pile
 154           (prog2
 155             ;; for the log
 156             (insert (format "%d" point))
 157             (mapvector
 158              #'(lambda (f)
 159                  (let* ((time
 160                          (bm-profile-time
 161                           (funcall f point))))
 162                    ;; for the log
 163                    (insert (format " %d" time))
 164                    time))
 165              test-funv)
 166             ;; for the log
 167             (insert (format "\n" point)))))
 168     (let* ((ts (bm-determine-time-stability test-funv pile)))
 169       ;;(bm-dump-pile test-funv pile ts)
 170       (mapc-internal
 171        #'(lambda (v)
 172            (let* ((name (aref v 0))
 173                   (avg (aref v 1))
 174                   (adev (aref v 2))
 175                   (rdev (aref v 3)))
 176              (princ (format "%32s, avg: %10d us (±%d us = %3.2f %%%s)\n"
 177                             name avg adev rdev
 178                             (if (< rdev 25) "" " = UNSTABLE!"))
 179                     'external-debugging-output)))
 180        ts)
 181       (vector pile ts))))
 182
 183 (defun bm-run-tests (test-funv point)
 184   (bm-examine-time-stability test-funv point))
 185
 186 (defun bm-estimate-time (test &optional grain)
 187   (let* ((test-funv (plist-get test :test-funv))
 188          (test-range (plist-get test :test-range))
 189          (grain (or grain (plist-get test :grain) 20))
 190          (pf (plist-get test :plot-file))
 191          (buf (get-buffer-create (or pf "dontcare")))
 192          (tflen (length test-funv))
 193          (sample-points (bm-compute-sample-points test-range grain))
 194          (samples (make-skiplist)))
 195     (with-temp-buffer
 196       ;; for the log
 197       (insert "N")
 198       (loop for j from 1 to tflen
 199         do (insert (format " t%d" j)))
 200       (insert "\n")
 201       ;; now run the tests
 202       (mapcar
 203        #'(lambda (point)
 204            (put-skiplist samples point (bm-run-tests test-funv point)))
 205        sample-points)
 206       (write-region-internal (point-min) (point-max) pf)
 207       (princ "\n" 'external-debugging-output))
 208     samples))
 209
 210
 211 (defun bm-plot-samples-comp (samples c buf)
 212   ;; samples is a vector consisting of a pile and an estimation?
 213   (with-current-buffer (get-buffer-create buf)
 214     (insert (format "\n### component %d\n" c))
 215     (map-skiplist
 216      #'(lambda (key val)
 217          (let* ((pile (aref val 0))
 218                 (ts (aref val 1))
 219                 (tslen (length ts))
 220                 (vec (aref ts c)))
 221            (insert (format "%d %f %f %f\n"
 222                            key (aref vec 1) (aref vec 2) (aref vec 3)))))
 223      samples)
 224     (insert "\n")))
 225
 226 (defun bm-dump-samples (samples buf)
 227   ;; samples is a vector consisting of a pile and an estimation?
 228   (with-current-buffer (get-buffer-create buf)
 229     (map-skiplist
 230      #'(lambda (key val)
 231          (insert (format "%s %S\n" key val)))
 232      samples)
 233     (insert "\n")))
 234
 235 (defun bm-dump-pile (test-funv pile ts)
 236   (with-temp-buffer
 237     (let* ((vlen (length test-funv))
 238            (resv (make-vector (1+ vlen) 0))
 239            (j 0))
 240       (while (< j vlen)
 241         (let* ((fun (aref test-funv j))
 242                (name (function-documentation fun))
 243                (i 0))
 244           (insert "\n\n## " name "\n")
 245           (mapc-internal
 246            #'(lambda (v)
 247                (insert (format "%d %f\n" i (aref v j)))
 248                (setq i (1+ i)))
 249            pile))
 250         (setq j (1+ j)))
 251       (write-region (point-min) (point-max) "benchmark.plot")
 252       (princ "\n" 'external-debugging-output))))
 253
 254
 255 (provide 'benchmark)
 256