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

   1 ;;; benchmark/context-coloring-benchmark.el --- Benchmarks for context coloring. -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014 Jackson Ray Hamilton
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;; Code:
  19
  20 (defconst context-coloring-benchmark-path
  21   (file-name-directory (or load-file-name buffer-file-name))
  22   "This file's directory.")
  23
  24 (defun context-coloring-benchmark-resolve-path (path)
  25   "Resolve PATH from this file's directory."
  26   (expand-file-name path context-coloring-benchmark-path))
  27
  28 (defun context-coloring-benchmark-log-results (result-file fixture)
  29   "Log benchmarking results for FIXTURE to RESULT-FILE."
  30   (elp-results)
  31   (let ((results-buffer (current-buffer)))
  32     (with-temp-buffer
  33       (insert (concat fixture "\n"))
  34       (prepend-to-buffer results-buffer (point-min) (point-max)))
  35     (with-temp-buffer
  36       (insert "\n")
  37       (append-to-buffer results-buffer (point-min) (point-max))))
  38   (make-directory (context-coloring-benchmark-resolve-path "./logs") t)
  39   (append-to-file nil nil result-file))
  40
  41 (defun context-coloring-benchmark-next-tick (function)
  42   "Defer execution of FUNCTION to clear the stack and to ensure
  43 asynchrony."
  44   (run-at-time 0.001 nil function))
  45
  46 (defun context-coloring-benchmark-next (list continue stop)
  47   "Run the next test in LIST by calling CONTINUE.  When LIST is
  48 exhausted, call STOP instead."
  49   (if (null list)
  50       (context-coloring-benchmark-next-tick stop)
  51     (context-coloring-benchmark-next-tick
  52      (lambda ()
  53        (funcall
  54         continue
  55         (car list)
  56         (lambda ()
  57           (context-coloring-benchmark-next (cdr list) continue stop)))))))
  58
  59 (defun context-coloring-benchmark-async (title setup teardown fixtures callback)
  60   "Measure the performance of all FIXTURES, calling CALLBACK when
  61 all are done."
  62   (funcall setup)
  63   (let ((result-file (context-coloring-benchmark-resolve-path
  64                       (format "./logs/results-%s-%s.log"
  65                               title (format-time-string "%s")))))
  66     (context-coloring-benchmark-next
  67      fixtures
  68      (lambda (path next)
  69        (let ((fixture (context-coloring-benchmark-resolve-path path))
  70              advice)
  71          (setq
  72           advice
  73           (let ((count 0))
  74             (lambda (original-function)
  75               (funcall
  76                original-function
  77                (lambda ()
  78                  (setq count (+ count 1))
  79                  ;; Test 5 times.
  80                  (if (= count 5)
  81                      (progn
  82                        (advice-remove 'context-coloring-colorize advice)
  83                        (kill-buffer)
  84                        (context-coloring-benchmark-log-results
  85                         result-file
  86                         fixture)
  87                        (funcall next))
  88                    (funcall 'context-coloring-colorize)))))))
  89          (advice-add 'context-coloring-colorize :around advice)
  90          (find-file fixture)))
  91      (lambda ()
  92        (funcall teardown)
  93        (if callback (funcall callback))))))
  94
  95 (defconst context-coloring-benchmark-js-fixtures
  96   '("./fixtures/jquery-2.1.1.js"
  97     "./fixtures/lodash-2.4.1.js"
  98     "./fixtures/async-0.9.0.js"
  99     "./fixtures/mkdirp-0.5.0.js")
 100   "Arbitrary JavaScript files for performance scrutiny.")
 101
 102 (defun context-coloring-benchmark-js-mode-setup ()
 103   "Preparation logic for `js-mode'."
 104   (add-hook 'js-mode-hook 'context-coloring-mode)
 105   (elp-instrument-package "context-coloring-"))
 106
 107 (defun context-coloring-benchmark-js-mode-teardown ()
 108   "Cleanup logic for `js-mode'."
 109   (remove-hook 'js-mode-hook 'context-coloring-mode))
 110
 111 (defun context-coloring-benchmark-js-mode-run (callback)
 112   "Benchmark `js-mode', then call CALLBACK."
 113   (context-coloring-benchmark-async
 114    "js-mode"
 115    'context-coloring-benchmark-js-mode-setup
 116    'context-coloring-benchmark-js-mode-teardown
 117    context-coloring-benchmark-js-fixtures
 118    callback))
 119
 120 (defun context-coloring-benchmark-js2-mode-setup ()
 121   "Preparation logic for `js2-mode'."
 122   (require 'js2-mode)
 123   (setq js2-mode-show-parse-errors nil)
 124   (setq js2-mode-show-strict-warnings nil)
 125   (add-to-list 'auto-mode-alist '("\\.js\\'" . js2-mode))
 126   (add-hook 'js2-mode-hook 'context-coloring-mode)
 127   (elp-instrument-package "context-coloring-"))
 128
 129 (defun context-coloring-benchmark-js2-mode-teardown ()
 130   "Cleanup logic for `js2-mode'."
 131   (remove-hook 'js2-mode-hook 'context-coloring-mode)
 132   (setq auto-mode-alist (delete '("\\.js\\'" . js2-mode)
 133                                 auto-mode-alist))
 134   (setq js2-mode-show-strict-warnings t)
 135   (setq js2-mode-show-parse-errors t))
 136
 137 (defun context-coloring-benchmark-js2-mode-run (callback)
 138   "Benchmark `js2-mode', then call CALLBACK."
 139   (context-coloring-benchmark-async
 140    "js2-mode"
 141    'context-coloring-benchmark-js2-mode-setup
 142    'context-coloring-benchmark-js2-mode-teardown
 143    context-coloring-benchmark-js-fixtures
 144    callback))
 145
 146 (defun context-coloring-benchmark-run ()
 147   "Benchmark all modes, then exit."
 148   (context-coloring-benchmark-next
 149    '(context-coloring-benchmark-js-mode-run
 150      context-coloring-benchmark-js2-mode-run)
 151    (lambda (function next)
 152      (funcall function next))
 153    (lambda ()
 154      (kill-emacs))))
 155
 156 (provide 'context-coloring-benchmark)
 157
 158 ;;; context-coloring-benchmark.el ends here