code.delx.au - gnu-emacs-elpa/blob - packages/context-coloring/benchmark/context-coloring-benchmark.el

   1 ;;; context-coloring-benchmark.el --- Benchmarks for context coloring  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2015  Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; Benchmarks for context coloring.
  23
  24 ;; Use with `make bench'.
  25
  26 ;;; Code:
  27
  28 (require 'context-coloring)
  29 (require 'js2-mode)
  30
  31
  32 (defconst context-coloring-benchmark-path
  33   (file-name-directory (or load-file-name buffer-file-name))
  34   "This file's directory.")
  35
  36 (defun context-coloring-benchmark-resolve-path (path)
  37   "Resolve PATH from this file's directory."
  38   (expand-file-name path context-coloring-benchmark-path))
  39
  40 (defun context-coloring-benchmark-next-tick (callback)
  41   "Run CALLBACK in the next turn of the event loop."
  42   (run-with-timer nil nil callback))
  43
  44 (defun context-coloring-benchmark-series (sequence callback)
  45   "Call each function in SEQUENCE, then call CALLBACK.  Each
  46 function is passed a single callback parameter for it to call
  47 when it is done."
  48   (cond
  49    ((null sequence)
  50     (funcall callback))
  51    (t
  52     (funcall
  53      (car sequence)
  54      (lambda ()
  55        (context-coloring-benchmark-next-tick
  56         (lambda ()
  57           (context-coloring-benchmark-series
  58            (cdr sequence)
  59            callback))))))))
  60
  61 (defun context-coloring-benchmark-mapc (sequence iteratee callback)
  62   "For each element in SEQUENCE, call ITERATEE, finally call
  63 CALLBACK.  ITERATEE is passed the current element and a callback
  64 for it to call when it is done."
  65   (cond
  66    ((null sequence)
  67     (funcall callback))
  68    (t
  69     (funcall
  70      iteratee
  71      (car sequence)
  72      (lambda ()
  73        (context-coloring-benchmark-next-tick
  74         (lambda ()
  75           (context-coloring-benchmark-mapc
  76            (cdr sequence)
  77            iteratee
  78            callback))))))))
  79
  80 (defun context-coloring-benchmark-log-results (result-file fixture statistics)
  81   "Log benchmarking results to RESULT-FILE for fixture FIXTURE
  82 with STATISTICS."
  83   (let ((results (prog1
  84                      (progn
  85                        (elp-results)
  86                        (buffer-substring-no-properties (point-min) (point-max)))
  87                    (kill-buffer))))
  88     (make-directory (context-coloring-benchmark-resolve-path "./logs") t)
  89     (append-to-file
  90      (with-temp-buffer
  91        (goto-char (point-min))
  92        (insert (format "For fixture \"%s\":\n" fixture))
  93        (insert "\n")
  94        (insert "General statistics:\n")
  95        (insert (format "File size: %s bytes\n" (plist-get statistics :file-size)))
  96        (insert (format "Lines: %s\n" (plist-get statistics :lines)))
  97        (insert (format "Words: %s\n" (plist-get statistics :words)))
  98        (insert (format "Colorization times: %s\n"
  99                        (context-coloring-join
 100                         (mapcar (lambda (number)
 101                                   (format "%.4f" number))
 102                                 (plist-get statistics :colorization-times)) ", ")))
 103        (insert (format "Average colorization time: %.4f\n"
 104                        (plist-get statistics :average-colorization-time)))
 105        (insert "\n")
 106        (insert "Function statistics:\n")
 107        (insert "(Function Name / Call Count / Elapsed Time / Average Time):\n")
 108        (insert results)
 109        (insert "\n")
 110        (buffer-substring-no-properties (point-min) (point-max)))
 111      nil result-file)))
 112
 113 (defun context-coloring-benchmark (title setup teardown fixtures callback)
 114   "Execute a benchmark titled TITLE with SETUP and TEARDOWN
 115 callbacks.  Measure the performance of all FIXTURES, calling
 116 CALLBACK when all are done."
 117   (funcall setup)
 118   (elp-instrument-package "context-coloring-")
 119   (let ((result-file (context-coloring-benchmark-resolve-path
 120                       (format "./logs/results-%s-%s.log"
 121                               title (format-time-string "%s")))))
 122     (context-coloring-benchmark-mapc
 123      fixtures
 124      (lambda (path callback)
 125        (let ((fixture (context-coloring-benchmark-resolve-path path))
 126              colorization-start-time
 127              (colorization-times '())
 128              advice)
 129          (setq
 130           advice
 131           (let ((count 0))
 132             (lambda (original-function)
 133               (funcall
 134                original-function
 135                (lambda ()
 136                  (setq count (+ count 1))
 137                  (push (- (float-time) colorization-start-time) colorization-times)
 138                  ;; Test 5 times.
 139                  (cond
 140                   ((= count 5)
 141                    (advice-remove #'context-coloring-colorize advice)
 142                    (context-coloring-benchmark-log-results
 143                     result-file
 144                     fixture
 145                     (list
 146                      :file-size (nth 7 (file-attributes fixture))
 147                      :lines (count-lines (point-min) (point-max))
 148                      :words (count-words (point-min) (point-max))
 149                      :colorization-times colorization-times
 150                      :average-colorization-time (/ (apply #'+ colorization-times) 5)))
 151                    (kill-buffer)
 152                    (funcall callback))
 153                   (t
 154                    (setq colorization-start-time (float-time))
 155                    (context-coloring-colorize))))))))
 156          (advice-add #'context-coloring-colorize :around advice)
 157          (setq colorization-start-time (float-time))
 158          (find-file fixture)))
 159      (lambda ()
 160        (funcall teardown)
 161        (funcall callback)))))
 162
 163 (defconst context-coloring-benchmark-js-fixtures
 164   '("./fixtures/jquery-2.1.1.js"
 165     "./fixtures/lodash-2.4.1.js"
 166     "./fixtures/async-0.9.0.js"
 167     "./fixtures/mkdirp-0.5.0.js")
 168   "Arbitrary JavaScript files for performance scrutiny.")
 169
 170 (defun context-coloring-benchmark-js-mode-run (callback)
 171   "Benchmark `js-mode', then call CALLBACK."
 172   (context-coloring-benchmark
 173    "js-mode"
 174    (lambda ()
 175      "Preparation logic for `js-mode'."
 176      (add-hook 'js-mode-hook #'context-coloring-mode))
 177    (lambda ()
 178      "Cleanup logic for `js-mode'."
 179      (remove-hook 'js-mode-hook #'context-coloring-mode))
 180    context-coloring-benchmark-js-fixtures
 181    callback))
 182
 183 (defun context-coloring-benchmark-js2-mode-run (callback)
 184   "Benchmark `js2-mode', then call CALLBACK."
 185   (context-coloring-benchmark
 186    "js2-mode"
 187    (lambda ()
 188      "Preparation logic for `js2-mode'."
 189      (setq js2-mode-show-parse-errors nil)
 190      (setq js2-mode-show-strict-warnings nil)
 191      (add-to-list 'auto-mode-alist '("\\.js\\'" . js2-mode))
 192      (add-hook 'js2-mode-hook #'context-coloring-mode))
 193    (lambda ()
 194      "Cleanup logic for `js2-mode'."
 195      (remove-hook 'js2-mode-hook #'context-coloring-mode)
 196      (setq auto-mode-alist (delete '("\\.js\\'" . js2-mode)
 197                                    auto-mode-alist))
 198      (setq js2-mode-show-strict-warnings t)
 199      (setq js2-mode-show-parse-errors t))
 200    context-coloring-benchmark-js-fixtures
 201    callback))
 202
 203 (defconst context-coloring-benchmark-emacs-lisp-fixtures
 204   '("./fixtures/lisp.el"
 205     "./fixtures/faces.el"
 206     "./fixtures/subr.el"
 207     "./fixtures/simple.el")
 208   "Arbitrary Emacs Lisp files for performance scrutiny.")
 209
 210 (defun context-coloring-benchmark-emacs-lisp-mode-run (callback)
 211   "Benchmark `emacs-lisp-mode', then call CALLBACK."
 212   (context-coloring-benchmark
 213    "emacs-lisp-mode"
 214    (lambda ()
 215      "Preparation logic for `emacs-lisp-mode'."
 216      (add-hook 'emacs-lisp-mode-hook #'context-coloring-mode))
 217    (lambda ()
 218      "Cleanup logic for `emacs-lisp-mode'."
 219      (remove-hook 'emacs-lisp-mode-hook #'context-coloring-mode))
 220    context-coloring-benchmark-emacs-lisp-fixtures
 221    callback))
 222
 223 (defun context-coloring-benchmark-run ()
 224   "Benchmark all modes, then exit."
 225   (context-coloring-benchmark-series
 226    (list
 227     #'context-coloring-benchmark-js-mode-run
 228     #'context-coloring-benchmark-js2-mode-run
 229     #'context-coloring-benchmark-emacs-lisp-mode-run)
 230    (lambda ()
 231      (kill-emacs))))
 232
 233 (provide 'context-coloring-benchmark)
 234
 235 ;;; context-coloring-benchmark.el ends here