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