tp/tp-benchmark.el

;;; tp-benchmark.el --- Batch benchmarks for tp -*- lexical-binding: t -*-

;; Copyright (C) 2024-2026 Geekinney

;; Author: Geekinney (kinneyzhang666@gmail.com)

;;; Commentary:

;; Run with:
;;   emacs -Q --batch -L . -l tp-benchmark.el -f tp-benchmark-run

;;; Code:

(require 'cl-lib)
(require 'tp)

(defconst tp-benchmark--fixed-seeds '(1 7 42 747555)
  "Fixed deterministic benchmark seeds.")

(defconst tp-benchmark--generated-seed 8675309
  "Printed generated seed.  Fixed so the benchmark output is reproducible.")

(defvar tp-bench-fanout-color nil
  "Reactive color variable used by `tp-benchmark-run'.")

(defun tp-benchmark--print (plist)
  "Print one benchmark row from PLIST."
  (princ
   (concat
    (mapconcat
     (lambda (key)
       (format "%s=%S" (substring (symbol-name key) 1)
               (plist-get plist key)))
     '(:scenario :status :fixture :seed :requested :actual :operations
       :scanned :changed :refreshed :elapsed :gcs :note)
     " ")
    "\n")))

(defun tp-benchmark--random-string (size seed)
  "Return deterministic random string of SIZE using SEED."
  (let ((state seed)
        (chars "abcdefghijklmnopqrstuvwxyz")
        (result (make-string size ?a))
        (pos 0))
    (while (< pos size)
      (setq state (mod (+ (* state 1103515245) 12345) 2147483648))
      (aset result pos (aref chars (mod state (length chars))))
      (setq pos (1+ pos)))
    result))

(defun tp-benchmark--measure (scenario fixture seed requested actual body)
  "Measure BODY after GC and print a benchmark row."
  (garbage-collect)
  (let* ((gc-start gcs-done)
         (start (float-time))
         (result (funcall body))
         (elapsed (- (float-time) start)))
    (tp-benchmark--print
     (append
      (list :scenario scenario :status 'ok :fixture fixture :seed seed
            :requested requested :actual actual)
      result
      (list :elapsed elapsed :gcs (- gcs-done gc-start) :note nil)))))

(defun tp-benchmark--blocked (scenario fixture seed requested note)
  "Print a blocked benchmark row."
  (tp-benchmark--print
   (list :scenario scenario :status 'blocked :fixture fixture :seed seed
         :requested requested :actual 0 :operations 0 :scanned 0
         :changed 0 :refreshed 0 :elapsed nil :gcs 0 :note note)))

(defun tp-benchmark--large-text (size seed)
  "Benchmark large text property set/search for SIZE and SEED."
  (let ((text (tp-benchmark--random-string size seed)))
    (tp-set 0 size '(tp-bench t) text)
    (unless (equal (tp-search text 'tp-bench t) (list (list 0 size t)))
      (error "large-text correctness failed"))
    (set-text-properties 0 size nil text)
    (tp-benchmark--measure
     'large-text 'string seed size size
     (lambda ()
       (tp-set 0 size '(tp-bench t) text)
       (let ((matches (tp-search text 'tp-bench t)))
         (unless (equal matches (list (list 0 size t)))
           (error "timed large-text correctness failed"))
         (list :operations 2 :scanned size :changed size
               :refreshed 0 :note (length matches)))))))

(defun tp-benchmark--fragmented (runs seed)
  "Benchmark RUNS fragmented property intervals using SEED."
  (let ((text (make-string runs ?x)))
    (cl-loop for i below runs
             when (zerop (mod i 2))
             do (put-text-property i (1+ i) 'tp-bench i text))
    (unless (= (length (tp-search text 'tp-bench)) (/ (1+ runs) 2))
      (error "fragmented correctness failed"))
    (tp-benchmark--measure
     'fragmented 'string seed runs runs
     (lambda ()
       (let ((matches (tp-search text 'tp-bench)))
         (list :operations 1 :scanned runs :changed (length matches)
               :refreshed 0 :note nil))))))

(defun tp-benchmark--define-stack-layers (depth)
  "Define DEPTH benchmark stack layers."
  (cl-loop for i below depth
           do (eval `(define-tp ,(intern (format "tp-bench-stack-%d" i))
                       () '(face bold)))))

(defun tp-benchmark--stack-depth (depth seed)
  "Benchmark stack operations at DEPTH using SEED."
  (tp-layer-reset)
  (tp-benchmark--define-stack-layers depth)
  (with-temp-buffer
    (insert (make-string 2000 ?s))
    (cl-loop for i below depth
             do (tp-push-layer 1 2001
                               (intern (format "tp-bench-stack-%d" i))))
    (unless (= (tp-layer-count 1 2001) depth)
      (error "stack-depth correctness failed"))
    (set-text-properties 1 2001 nil)
    (tp-benchmark--measure
     'stack-depth 'buffer seed depth depth
     (lambda ()
       (cl-loop for i below depth
                do (tp-push-layer 1 2001
                                  (intern (format "tp-bench-stack-%d" i))))
       (unless (= (tp-layer-count 1 2001) depth)
         (error "timed stack-depth correctness failed"))
       (let ((top (tp-layer-top 1 2001)))
         (list :operations (1+ depth) :scanned 2000 :changed 2000
               :refreshed 0 :note top))))))

(defun tp-benchmark--define-fanout-layer (seed)
  "Define one reactive layer for SEED."
  (set 'tp-bench-fanout-color "red")
  (eval '(define-tp tp-bench-fanout ()
           :props '(face (:foreground $tp-bench-fanout-color))
           :data '((tp-bench-fanout-color . "red"))))
  seed)

(defun tp-benchmark--reactive-fanout (requested seed)
  "Benchmark reactive fanout REQUESTED using SEED."
  (let ((actual (min requested 200)))
    (tp-layer-reset)
    (tp-reactive-reset)
    (tp-benchmark--define-fanout-layer seed)
    (let ((buffers nil))
      (unwind-protect
          (progn
            (dotimes (i actual)
              (let ((buf (generate-new-buffer
                          (format " *tp-bench-fanout-%d*" i))))
                (push buf buffers)
                (with-current-buffer buf
                  (insert "x")
                  (tp-set 1 2 'tp-bench-fanout))))
            (setq tp-bench-fanout-color "blue")
            (with-current-buffer (car buffers)
              (unless (equal (plist-get (get-text-property 1 'face)
                                        :foreground)
                             "blue")
                (error "reactive-fanout correctness failed")))
            (tp-benchmark--measure
             'reactive-fanout 'buffers seed requested actual
             (lambda ()
               (setq tp-bench-fanout-color "green")
               (list :operations 1 :scanned actual :changed actual
                     :refreshed actual
                     :note (format "requested=%d actual=%d"
                                   requested actual)))))
        (mapc (lambda (buf)
                (when (buffer-live-p buf) (kill-buffer buf)))
              buffers)))))

(defun tp-benchmark--theme-refresh (seed)
  "Benchmark current theme managed refresh hook using SEED."
  (if (not (fboundp 'tp--refresh-managed-after-theme-change))
      (tp-benchmark--blocked
       'theme-managed-refresh 'buffer seed 1
       "tp--refresh-managed-after-theme-change unavailable")
    (tp-layer-reset)
    (with-temp-buffer
      (insert (make-string 1000 ?t))
      (define-tp tp-bench-theme () '(face (:foreground "red")))
      (tp-push-layer 1 1001 'tp-bench-theme)
      (tp--refresh-managed-after-theme-change 'benchmark)
      (unless tp-theme-last-refreshed-ranges
        (error "theme-refresh correctness failed"))
      (tp-benchmark--measure
       'theme-managed-refresh 'buffer seed 1 1
       (lambda ()
         (tp--refresh-managed-after-theme-change 'benchmark)
         (list :operations 1 :scanned 1000 :changed 0
               :refreshed (length tp-theme-last-refreshed-ranges)
               :note tp-theme-last-refresh-mode))))))

(defun tp-benchmark-run ()
  "Run tp benchmarks in batch mode."
  (interactive)
  (princ (format "tp-benchmark emacs=%S generated-seed=%d fixed-seeds=%S\n"
                 emacs-version tp-benchmark--generated-seed
                 tp-benchmark--fixed-seeds))
  (dolist (seed (append tp-benchmark--fixed-seeds
                        (list tp-benchmark--generated-seed)))
    (dolist (size '(100000 1000000))
      (tp-benchmark--large-text size seed))
    (dolist (runs '(1000 10000 50000))
      (tp-benchmark--fragmented runs seed))
    (dolist (depth '(1 5 20 50))
      (tp-benchmark--stack-depth depth seed))
    (dolist (fanout '(1 10 100 500))
      (tp-benchmark--reactive-fanout fanout seed))
    (tp-benchmark--theme-refresh seed)))

(provide 'tp-benchmark)
;;; tp-benchmark.el ends here