;; -*- lexical-binding:t -*- (require 'cl-lib) (require 'subr-x) (require 'seq) (require 'hi-lock) ;; +===================================================================================+ ;; | Framework ;; +===================================================================================+ (defmacro perf-define-constant-test (name &optional doc &rest body) (declare (indent 1) (debug (symbol &optional string &rest form))) `(progn (put ',name 'perf-constant-test t) (defun ,name nil ,doc ,@body))) (defmacro perf-define-variable-test (name args &optional doc &rest body) (declare (indent 2) (debug defun)) (unless (and (consp args) (= (length args) 1)) (error "Function %s should accept exactly one argument." name)) `(progn (put ',name 'perf-variable-test t) (defun ,name ,args ,doc ,@body))) (defmacro perf-define-test-suite (name &rest tests) (declare (indent 1)) `(put ',name 'perf-test-suite ,(cons 'list tests))) (defun perf-constant-test-p (test) (get test 'perf-constant-test)) (defun perf-variable-test-p (test) (get test 'perf-variable-test)) (defun perf-test-suite-p (suite) (not (null (perf-test-suite-elements suite)))) (defun perf-test-suite-elements (suite) (get suite 'perf-test-suite)) (defun perf-expand-suites (test-and-suites) (apply #' append (mapcar (lambda (elt) (if (perf-test-suite-p elt) (perf-test-suite-elements elt) (list elt))) test-and-suites))) (defun perf-test-p (symbol) (or (perf-variable-test-p symbol) (perf-constant-test-p symbol))) (defun perf-all-tests () (let (result) (mapatoms (lambda (symbol) (when (and (fboundp symbol) (perf-test-p symbol)) (push symbol result)))) (sort result #'string-lessp))) (defvar perf-default-test-argument 4096) (defun perf-run-1 (&optional k n &rest tests) "Run TESTS K times using N as argument for non-constant ones. Return test-total elapsed time." (random "") (when (and n (not (numberp n))) (push k tests) (push n tests) (setq n nil k nil)) (when (and k (not (numberp k))) (push k tests) (setq k nil)) (let* ((k (or k 1)) (n (or n perf-default-test-argument)) (tests (perf-expand-suites (or tests (perf-all-tests)))) (variable-tests (seq-filter #'perf-variable-test-p tests)) (constant-tests (seq-filter #'perf-constant-test-p tests)) (max-test-string-width (perf-max-symbol-length tests))) (unless (seq-every-p #'perf-test-p tests) (error "Some of these are not tests: %s" tests)) (cl-labels ((format-result (result) (cond ((numberp result) (format "%.2f" result)) ((stringp result) result) ((null result) "N/A"))) (format-test (fn) (concat (symbol-name fn) (make-string (+ (- max-test-string-width (length (symbol-name fn))) 1) ?\s))) (format-summary (results _total) (let ((min (apply #'min results)) (max (apply #'max results)) (avg (/ (apply #'+ results) (float (length results))))) (format "n=%d min=%.2f avg=%.2f max=%.2f" (length results) min avg max))) (run-test (fn) (let ((total 0) results) (dotimes (_ (max 0 k)) (garbage-collect) (princ (concat " " (format-test fn))) (let ((result (condition-case-unless-debug err (cond ((perf-variable-test-p fn) (random "") (car (funcall fn n))) ((perf-constant-test-p fn) (random "") (car (funcall fn))) (t "skip")) (error (error-message-string err))))) (when (numberp result) (cl-incf total result) (push result results)) (princ (format-result result)) (terpri))) (when (> (length results) 1) (princ (concat "#" (format-test fn) (format-summary results total))) (terpri))))) (when variable-tests (terpri) (dolist (fn variable-tests) (run-test fn) (terpri))) (when constant-tests (dolist (fn constant-tests) (run-test fn) (terpri)))))) (defun perf-run (&optional k n &rest tests) (interactive (let* ((n (if current-prefix-arg (prefix-numeric-value current-prefix-arg) perf-default-test-argument)) (tests (mapcar #'intern (completing-read-multiple (format "Run tests (n=%d): " n) (perf-all-tests) nil t nil 'perf-test-history)))) (cons 1 (cons n tests)))) (with-current-buffer (get-buffer-create "*perf-results*") (let ((inhibit-read-only t) (standard-output (current-buffer))) (erase-buffer) (apply #'perf-run-1 k n tests) (display-buffer (current-buffer))))) (defun perf-batch-parse-command-line (args) (let ((k 1) (n perf-default-test-argument) tests) (while args (cond ((string-match-p "\\`-[cn]\\'" (car args)) (unless (and (cdr args) (string-match-p "\\`[0-9]+\\'" (cadr args))) (error "%s expectes a natnum argument" (car args))) (if (equal (car args) "-c") (setq k (string-to-number (cadr args))) (setq n (string-to-number (cadr args)))) (setq args (cddr args))) (t (push (intern (pop args)) tests)))) (list k n tests))) (defun perf-run-batch () "Runs tests from `command-line-args-left' and kill emacs." (let ((standard-output #'external-debugging-output)) (condition-case err (cl-destructuring-bind (k n tests) (perf-batch-parse-command-line command-line-args-left) (apply #'perf-run-1 k n tests) (save-buffers-kill-emacs)) (error (princ (error-message-string err)) (save-buffers-kill-emacs))))) (defconst perf-number-of-columns 70) (defun perf-insert-lines (n) "Insert N lines into the current buffer." (dotimes (i n) (insert (make-string 70 (if (= (% i 2) 0) ?. ?O)) ?\n))) (defun perf-switch-to-buffer-scroll-random (n &optional buffer) (interactive) (set-window-buffer nil (or buffer (current-buffer))) (goto-char (point-min)) (redisplay t) (dotimes (_ n) (goto-char (random (point-max))) (recenter) (redisplay t))) (defun perf-insert-overlays (n &optional create-callback random-p) (if random-p (perf-insert-overlays-random n create-callback) (perf-insert-overlays-sequential n create-callback))) (defun perf-insert-overlays-sequential (n &optional create-callback) "Insert an overlay every Nth line." (declare (indent 1)) (let ((i 0) (create-callback (or create-callback #'ignore))) (save-excursion (goto-char (point-min)) (while (not (eobp)) (when (= 0 (% i n)) (let ((ov (make-overlay (point-at-bol) (point-at-eol)))) (funcall create-callback ov) (overlay-put ov 'priority (random (buffer-size))))) (cl-incf i) (forward-line))))) (defun perf-insert-overlays-random (n &optional create-callback) "Insert an overlay every Nth line." (declare (indent 1)) (let ((create-callback (or create-callback #'ignore))) (save-excursion (while (>= (cl-decf n) 0) (let* ((beg (1+ (random (point-max)))) (ov (make-overlay beg (+ beg (random 70))))) (funcall create-callback ov) (overlay-put ov 'priority (random (buffer-size)))))))) (defun perf-insert-overlays-hierarchical (n &optional create-callback) (let ((create-callback (or create-callback #'ignore))) (save-excursion (goto-char (point-min)) (let ((spacing (floor (/ (/ (count-lines (point-min) (point-max)) (float 3)) n)))) (when (< spacing 1) (error "Hierarchical overlay overflow !!")) (dotimes (i n) (funcall create-callback (make-overlay (point) (save-excursion (goto-char (point-max)) (forward-line (- (* spacing i))) (point)))) (when (eobp) (error "End of buffer in hierarchical overlays")) (forward-line spacing)))))) (defun perf-overlay-ascii-chart (&optional buffer width) (interactive) (save-current-buffer (when buffer (set-buffer buffer)) (unless width (setq width 100)) (let* ((ovl (sort (overlays-in (point-min) (point-max)) (lambda (ov1 ov2) (or (<= (overlay-start ov1) (overlay-start ov2)) (and (= (overlay-start ov1) (overlay-start ov2)) (< (overlay-end ov1) (overlay-end ov2))))))) (ov-width (apply #'max (mapcar (lambda (ov) (- (overlay-end ov) (overlay-start ov))) ovl))) (ov-min (apply #'min (mapcar #'overlay-start ovl))) (ov-max (apply #'max (mapcar #'overlay-end ovl))) (scale (/ (float width) (+ ov-min ov-width)))) (with-current-buffer (get-buffer-create "*overlay-ascii-chart*") (let ((inhibit-read-only t)) (erase-buffer) (buffer-disable-undo) (insert (format "%06d%s%06d\n" ov-min (make-string (- width 12) ?\s) ov-max)) (dolist (ov ovl) (let ((length (round (* scale (- (overlay-end ov) (overlay-start ov)))))) (insert (make-string (round (* scale (overlay-start ov))) ?\s)) (cl-case length (0 (insert "O")) (1 (insert "|")) (t (insert (format "|%s|" (make-string (- length 2) ?-))))) (insert "\n"))) (goto-char (point-min))) (read-only-mode 1) (pop-to-buffer (current-buffer)))))) (defconst perf-overlay-faces (mapcar #'intern (seq-take hi-lock-face-defaults 3))) (defun perf-overlay-face-callback (ov) (overlay-put ov 'face (nth (random (length perf-overlay-faces)) perf-overlay-faces))) (defun perf-overlay-invisible-callback (ov) (overlay-put ov 'invisble (= 1 (random 2)))) (defun perf-overlay-display-callback (ov) (overlay-put ov 'display (make-string 70 ?*))) (defmacro perf-define-display-test (overlay-type property-type scroll-type) (let ((name (intern (format "perf-display-%s/%s/%s" overlay-type property-type scroll-type))) (arg (make-symbol "n"))) `(perf-define-variable-test ,name (,arg) (with-temp-buffer (perf-insert-lines ,arg) (overlay-recenter (point-max)) ,@(perf-define-display-test-1 arg overlay-type property-type scroll-type))))) (defun perf-define-display-test-1 (arg overlay-type property-type scroll-type) (list (append (cl-case overlay-type (sequential (list 'perf-insert-overlays-sequential 2)) (hierarchical `(perf-insert-overlays-hierarchical (/ ,arg 10))) (random `(perf-insert-overlays-random (/ ,arg 2))) (t (error "Invalid insert type: %s" overlay-type))) (list (cl-case property-type (display '#'perf-overlay-display-callback) (face '#'perf-overlay-face-callback) (invisible '#'perf-overlay-invisible-callback) (t (error "Invalid overlay type: %s" overlay-type))))) (list 'benchmark-run 1 (cl-case scroll-type (scroll '(perf-switch-to-buffer-scroll-up-and-down)) (random `(perf-switch-to-buffer-scroll-random (/ ,arg 50))) (t (error "Invalid scroll type: %s" overlay-type)))))) (defun perf-max-symbol-length (symbols) "Return the longest symbol in SYMBOLS, or -1 if symbols is nil." (if (null symbols) -1 (apply #'max (mapcar (lambda (elt) (length (symbol-name elt))) symbols)))) (defun perf-insert-text (n) "Insert N character into the current buffer." (let ((ncols 68) (char ?.)) (dotimes (_ (/ n ncols)) (insert (make-string (1- ncols) char) ?\n)) (when (> (% n ncols) 0) (insert (make-string (1- (% n ncols)) char) ?\n)))) (defconst perf-insert-overlays-default-length 24) (defun perf-insert-overlays-scattered (n &optional length) "Insert N overlays of max length 24 randomly." (dotimes (_ n) (let ((begin (random (1+ (point-max))))) (make-overlay begin (+ begin (random (1+ (or length perf-insert-overlays-default-length 0)))))))) (defvar perf-marker-gc-protection nil) (defun perf-insert-marker-scattered (n) "Insert N marker randomly." (setq perf-marker-gc-protection nil) (dotimes (_ n) (push (copy-marker (random (1+ (point-max)))) perf-marker-gc-protection))) (defun perf-switch-to-buffer-scroll-up-and-down (&optional buffer) (interactive) (set-window-buffer nil (or buffer (current-buffer))) (goto-char (point-min)) (redisplay t) (while (condition-case nil (progn (scroll-up) t) (end-of-buffer nil)) (redisplay t)) (while (condition-case nil (progn (scroll-down) t) (beginning-of-buffer nil)) (redisplay t))) (defun perf-emacs-lisp-setup () (add-to-list 'imenu-generic-expression '(nil "^\\s-*(perf-define\\(?:\\w\\|\\s_\\)*\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)" 1))) (add-hook 'emacs-lisp-mode 'perf-emacs-lisp-setup) ;; +===================================================================================+ ;; | Basic performance tests ;; +===================================================================================+ (perf-define-variable-test perf-make-overlay (n) (with-temp-buffer (overlay-recenter (point-min)) (benchmark-run 1 (dotimes (_ n) (make-overlay 1 1))))) (perf-define-variable-test perf-make-overlay-continuous (n) (with-temp-buffer (perf-insert-text n) (overlay-recenter (point-max)) (benchmark-run 1 (dotimes (i n) (make-overlay i (1+ i)))))) (perf-define-variable-test perf-make-overlay-scatter (n) (with-temp-buffer (perf-insert-text n) (benchmark-run 1 (perf-insert-overlays-scattered n)))) (perf-define-variable-test perf-delete-overlay (n) (with-temp-buffer (let ((ovls (cl-loop for i from 1 to n collect (make-overlay 1 1)))) (overlay-recenter (point-min)) (benchmark-run 1 (mapc #'delete-overlay ovls))))) (perf-define-variable-test perf-delete-overlay-continuous (n) (with-temp-buffer (perf-insert-text n) (let ((ovls (cl-loop for i from 1 to n collect (make-overlay i (1+ i))))) (overlay-recenter (point-min)) (benchmark-run 1 (mapc #'delete-overlay ovls))))) (perf-define-variable-test perf-delete-overlay-scatter (n) (with-temp-buffer (perf-insert-text n) (let ((ovls (progn (perf-insert-overlays-scattered n) (overlays-in (point-min) (point-max))))) (benchmark-run 1 (mapc #'delete-overlay ovls))))) (perf-define-variable-test perf-overlays-at (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (benchmark-run 1 (dotimes (i (point-max)) (overlays-at i))))) (perf-define-variable-test perf-overlays-in (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (let ((len perf-insert-overlays-default-length)) (benchmark-run 1 (dotimes (i (- (point-max) len)) (overlays-in i (+ i len))))))) (perf-define-variable-test perf-insert-before (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char 1) (overlay-recenter (point-min)) (benchmark-run 1 (dotimes (_ (/ n 2)) (insert ?X))))) (perf-define-variable-test perf-insert-before-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-insert-before n))) (perf-define-variable-test perf-insert-after-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-insert-after n))) (perf-define-variable-test perf-insert-scatter-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-insert-scatter n))) (perf-define-variable-test perf-delete-before-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-delete-before n))) (perf-define-variable-test perf-delete-after-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-delete-after n))) (perf-define-variable-test perf-delete-scatter-empty (n) (let ((perf-insert-overlays-default-length 0)) (perf-delete-scatter n))) (defmacro perf-define-marker-test (type where) (let ((name (intern (format "perf-%s-%s-marker" type where)))) `(perf-define-variable-test ,name (n) (with-temp-buffer (perf-insert-text n) (perf-insert-marker-scattered n) (goto-char ,(cl-case where (after (list 'point-max)) (t (list 'point-min)))) (benchmark-run 1 (dotimes (_ (/ n 2)) ,@(when (eq where 'scatter) (list '(goto-char (max 1 (random (point-max)))))) ,(cl-case type (insert (list 'insert ?X)) (delete (list 'delete-char (if (eq where 'after) -1 1)))))))))) (perf-define-test-suite perf-marker-suite (perf-define-marker-test insert before) (perf-define-marker-test insert after) (perf-define-marker-test insert scatter) (perf-define-marker-test delete before) (perf-define-marker-test delete after) (perf-define-marker-test delete scatter)) (perf-define-variable-test perf-insert-after (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char (point-max)) (overlay-recenter (point-max)) (benchmark-run 1 (dotimes (_ (/ n 2)) (insert ?X))))) (perf-define-variable-test perf-insert-scatter (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char (point-max)) (benchmark-run 1 (dotimes (_ (/ n 2)) (goto-char (1+ (random (point-max)))) (insert ?X))))) (perf-define-variable-test perf-delete-before (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char 1) (overlay-recenter (point-min)) (benchmark-run 1 (dotimes (_ (/ n 2)) (delete-char 1))))) (perf-define-variable-test perf-delete-after (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char (point-max)) (overlay-recenter (point-max)) (benchmark-run 1 (dotimes (_ (/ n 2)) (delete-char -1))))) (perf-define-variable-test perf-delete-scatter (n) (with-temp-buffer (perf-insert-text n) (perf-insert-overlays-scattered n) (goto-char (point-max)) (benchmark-run 1 (dotimes (_ (/ n 2)) (goto-char (max 1 (random (point-max)))) (delete-char 1))))) (perf-define-test-suite perf-insert-delete-suite 'perf-insert-before 'perf-insert-after 'perf-insert-scatter 'perf-delete-before 'perf-delete-after 'perf-delete-scatter ) ;; +===================================================================================+ ;; | Redisplay (new) ;; +===================================================================================+ ;; 5000 ;; 25000 ;; 75000 ;; Number of Overlays = N / 2 ;; ;; (except for the hierarchical case, where it is divided by 10.) ;; . scrolling through a buffer with lots of overlays that affect faces ;; of characters in the buffer text ;; . scrolling through a buffer with lots of overlays that define ;; 'display' properties which are strings ;; . scrolling through a buffer with lots of overlays that define ;; 'invisible' properties (perf-define-test-suite perf-display-suite (perf-define-display-test sequential display scroll) (perf-define-display-test sequential display random) (perf-define-display-test sequential face scroll) (perf-define-display-test sequential face random) (perf-define-display-test sequential invisible scroll) (perf-define-display-test sequential invisible random) (perf-define-display-test random display scroll) (perf-define-display-test random display random) (perf-define-display-test random face scroll) (perf-define-display-test random face random) (perf-define-display-test random invisible scroll) (perf-define-display-test random invisible random)) ;; |------------| ;; |--------| ;; |----| (perf-define-display-test hierarchical face scroll) ;; +===================================================================================+ ;; | Real World ;; +===================================================================================+ (require 'python) (defconst perf-many-errors-file (expand-file-name "many-errors.py" (and load-file-name (file-name-directory load-file-name)))) (perf-define-constant-test perf-realworld-flycheck (interactive) (package-initialize) (when (and (require 'flycheck nil t) (file-exists-p perf-many-errors-file) (or (executable-find "pylint") (executable-find "flake8"))) (setq flycheck-python-pylint-executable (executable-find "pylint")) (setq flycheck-python-flake8-executable (executable-find "flake8")) (setq python-indent-guess-indent-offset-verbose nil) (setq flycheck-check-syntax-automatically nil) (setq flycheck-checker-error-threshold nil) (setq flycheck-display-errors-function nil) (with-current-buffer (find-file-noselect perf-many-errors-file) (let* ((done) (flycheck-after-syntax-check-hook (list (lambda () (setq done t))))) (flycheck-mode 1) (flycheck-buffer) (benchmark-run 1 (while (not done) (accept-process-output)) (perf-switch-to-buffer-scroll-up-and-down) (flycheck-mode -1)))))) ;; https://lists.gnu.org/archive/html/emacs-devel/2009-04/msg00242.html (defun make-lines-invisible (regexp &optional arg) "Make all lines matching a regexp invisible and intangible. With a prefix arg, make it visible again. It is not necessary that REGEXP matches the whole line; if a hit is found, the affected line gets automatically selected. This command affects the whole buffer." (interactive "MRegexp: \nP") (let (ov ovs count) (cond ((equal arg '(4)) (setq ovs (overlays-in (point-min) (point-max))) (mapc (lambda (o) (if (overlay-get o 'make-lines-invisible) (delete-overlay o))) ovs)) (t (save-excursion (goto-char (point-min)) (setq count 0) (while (re-search-forward regexp nil t) (setq count (1+ count)) (if (= (% count 100) 0) (message "%d" count)) (setq ov (make-overlay (line-beginning-position) (1+ (line-end-position)))) (overlay-put ov 'make-lines-invisible t) (overlay-put ov 'invisible t) (overlay-put ov 'intangible t) (goto-char (line-end-position)))))))) (perf-define-constant-test perf-realworld-make-lines-invisible (with-temp-buffer (insert-file-contents "/usr/share/dict/words") (set-window-buffer nil (current-buffer)) (redisplay t) (overlay-recenter (point-max)) (benchmark-run 1 (make-lines-invisible "a")))) (perf-define-constant-test perf-realworld-line-numbering (interactive) (with-temp-buffer (insert-file-contents "/usr/share/dict/words") (overlay-recenter (point-max)) (goto-char (point-min)) (let* ((nlines (count-lines (point-min) (point-max))) (line 1) (width 0)) (dotimes (i nlines) ;;-with-progress-reporter "Creating overlays" (let ((ov (make-overlay (point) (point))) (str (propertize (format "%04d" line) 'face 'shadow))) (overlay-put ov 'before-string (propertize " " 'display `((margin left-margin) ,str))) (setq width (max width (length str))) (cl-incf line) (forward-line))) (benchmark-run 1 (let ((left-margin-width width)) (perf-switch-to-buffer-scroll-up-and-down)))))) (perf-define-test-suite perf-realworld-suite 'perf-realworld-flycheck 'perf-realworld-make-lines-invisible 'perf-realworld-line-numbering) ;; +===================================================================================+ ;; | next-overlay-change ;; +===================================================================================+ (perf-define-variable-test perf-noc-hierarchical/forward/linear (n) "Search linear for the next change on every line." (with-temp-buffer (perf-insert-lines (* 3 n)) (perf-insert-overlays-hierarchical n) (goto-char (point-min)) (benchmark-run 1 (while (not (eobp)) (next-overlay-change (point)) (forward-line))))) (perf-define-variable-test perf-noc-sequential/forward/linear (n) "Search linear for the next change on every line." (with-temp-buffer (perf-insert-lines (* 3 n)) (perf-insert-overlays-sequential n) (goto-char (point-min)) (benchmark-run 1 (while (not (eobp)) (next-overlay-change (point)) (forward-line))))) (perf-define-variable-test perf-noc-hierarchical/forward/backnforth (n) "Search back and forth for the next change from `point-min' to `point-max'." (with-temp-buffer (perf-insert-lines (* 3 n)) (overlay-recenter (point-max)) (perf-insert-overlays-hierarchical n) (goto-char (point-min)) (benchmark-run 1 (while (not (eobp)) (next-overlay-change (point)) (next-overlay-change (+ (point) 2)) (forward-char))))) (perf-define-test-suite perf-noc-suite 'perf-noc-hierarchical/forward/linear 'perf-noc-hierarchical/forward/backnforth 'perf-noc-hierarchical/forward/backnforth)