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