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

   1 ;;; benchmark/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 ;; `ert' instruments and benchmarks the package's functions, and the results are
  25 ;; logged to `benchmark/logs'.
  26
  27 ;; To run, execute `make bench' from the project root.
  28
  29 ;;; Code:
  30
  31 (require 'js2-mode)
  32
  33 (defconst context-coloring-benchmark-path
  34   (file-name-directory (or load-file-name buffer-file-name))
  35   "This file's directory.")
  36
  37 (defun context-coloring-benchmark-resolve-path (path)
  38   "Resolve PATH from this file's directory."
  39   (expand-file-name path context-coloring-benchmark-path))
  40
  41 (defun context-coloring-benchmark-log-results (result-file fixture)
  42   "Log benchmarking results to RESULT-FILE for fixture FIXTURE."
  43   (elp-results)
  44   (let ((results-buffer (current-buffer)))
  45     (with-temp-buffer
  46       (insert (concat fixture "\n"))
  47       (prepend-to-buffer results-buffer (point-min) (point-max)))
  48     (with-temp-buffer
  49       (insert "\n")
  50       (append-to-buffer results-buffer (point-min) (point-max))))
  51   (make-directory (context-coloring-benchmark-resolve-path "./logs") t)
  52   (append-to-file nil nil result-file))
  53
  54 (defun context-coloring-benchmark-next-tick (function)
  55   "Defer execution of FUNCTION to clear the stack and to ensure
  56 asynchrony."
  57   (run-at-time 0.001 nil function))
  58
  59 (defun context-coloring-benchmark-next (list continue stop)
  60   "Run the next test in LIST by calling CONTINUE.  When LIST is
  61 exhausted, call STOP instead."
  62   (if (null list)
  63       (progn
  64         (context-coloring-benchmark-next-tick stop))
  65     (context-coloring-benchmark-next-tick
  66      (lambda ()
  67        (funcall
  68         continue
  69         (car list)
  70         (lambda ()
  71           (context-coloring-benchmark-next (cdr list) continue stop)))))))
  72
  73 (defun context-coloring-benchmark-async (title setup teardown fixtures callback)
  74   "Execute a benchmark titled TITLE with SETUP and TEARDOWN
  75 callbacks.  Measure the performance of all FIXTURES, calling
  76 CALLBACK when all are done."
  77   (funcall setup)
  78   (let ((result-file (context-coloring-benchmark-resolve-path
  79                       (format "./logs/results-%s-%s.log"
  80                               title (format-time-string "%s")))))
  81     (context-coloring-benchmark-next
  82      fixtures
  83      (lambda (path next)
  84        (let ((fixture (context-coloring-benchmark-resolve-path path))
  85              advice)
  86          (setq
  87           advice
  88           (let ((count 0))
  89             (lambda (original-function)
  90               (funcall
  91                original-function
  92                (lambda ()
  93                  (setq count (+ count 1))
  94                  ;; Test 5 times.
  95                  (if (= count 5)
  96                      (progn
  97                        (advice-remove 'context-coloring-colorize advice)
  98                        (kill-buffer)
  99                        (context-coloring-benchmark-log-results
 100                         result-file
 101                         fixture)
 102                        (funcall next))
 103                    (funcall 'context-coloring-colorize)))))))
 104          (advice-add 'context-coloring-colorize :around advice)
 105          (find-file fixture)))
 106      (lambda ()
 107        (funcall teardown)
 108        (when callback (funcall callback))))))
 109
 110 (defconst context-coloring-benchmark-js-fixtures
 111   '("./fixtures/jquery-2.1.1.js"
 112     "./fixtures/lodash-2.4.1.js"
 113     "./fixtures/async-0.9.0.js"
 114     "./fixtures/mkdirp-0.5.0.js")
 115   "Arbitrary JavaScript files for performance scrutiny.")
 116
 117 (defun context-coloring-benchmark-js-mode-setup ()
 118   "Preparation logic for `js-mode'."
 119   (add-hook 'js-mode-hook 'context-coloring-mode)
 120   (elp-instrument-package "context-coloring-"))
 121
 122 (defun context-coloring-benchmark-js-mode-teardown ()
 123   "Cleanup logic for `js-mode'."
 124   (remove-hook 'js-mode-hook 'context-coloring-mode))
 125
 126 (defun context-coloring-benchmark-js-mode-run (callback)
 127   "Benchmark `js-mode', then call CALLBACK."
 128   (context-coloring-benchmark-async
 129    "js-mode"
 130    'context-coloring-benchmark-js-mode-setup
 131    'context-coloring-benchmark-js-mode-teardown
 132    context-coloring-benchmark-js-fixtures
 133    callback))
 134
 135 (defun context-coloring-benchmark-js2-mode-setup ()
 136   "Preparation logic for `js2-mode'."
 137   (setq js2-mode-show-parse-errors nil)
 138   (setq js2-mode-show-strict-warnings nil)
 139   (add-to-list 'auto-mode-alist '("\\.js\\'" . js2-mode))
 140   (add-hook 'js2-mode-hook 'context-coloring-mode)
 141   (elp-instrument-package "context-coloring-"))
 142
 143 (defun context-coloring-benchmark-js2-mode-teardown ()
 144   "Cleanup logic for `js2-mode'."
 145   (remove-hook 'js2-mode-hook 'context-coloring-mode)
 146   (setq auto-mode-alist (delete '("\\.js\\'" . js2-mode)
 147                                 auto-mode-alist))
 148   (setq js2-mode-show-strict-warnings t)
 149   (setq js2-mode-show-parse-errors t))
 150
 151 (defun context-coloring-benchmark-js2-mode-run (callback)
 152   "Benchmark `js2-mode', then call CALLBACK."
 153   (context-coloring-benchmark-async
 154    "js2-mode"
 155    'context-coloring-benchmark-js2-mode-setup
 156    'context-coloring-benchmark-js2-mode-teardown
 157    context-coloring-benchmark-js-fixtures
 158    callback))
 159
 160 (defun context-coloring-benchmark-run ()
 161   "Benchmark all modes, then exit."
 162   (context-coloring-benchmark-next
 163    '(context-coloring-benchmark-js-mode-run
 164      context-coloring-benchmark-js2-mode-run)
 165    (lambda (function next)
 166      (funcall function next))
 167    (lambda ()
 168      (kill-emacs))))
 169
 170 (provide 'context-coloring-benchmark)
 171
 172 ;;; context-coloring-benchmark.el ends here