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