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.")

(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
       :objects :subscribers :invalidated :recomputed :skipped
       :text-operations :property-operations :touched :revision :published
       :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 for SCENARIO and print a benchmark row.

SCENARIO, FIXTURE, SEED, REQUESTED and ACTUAL identify the row metadata.
BODY performs the timed operation."
  (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--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 :touched size :note (length matches)))))))

(defun tp-benchmark--fragmented (runs seed)
  "Measure fragmented property intervals using SEED.
RUNS is the number of intervals."
  (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 :touched runs :note (length matches)))))))

(defun tp-benchmark--retained-producer (entries)
  "Return a retained content producer for ENTRIES.
Each entry is a cons whose car is a stable key and whose cdr is text."
  (lambda (context)
    (let ((root (tp-object-ensure context nil 'root 'group)))
      (tp-surface-plan-create
       :key 'root
       :kind 'group
       :children
       (mapcar
        (lambda (entry)
          (tp-object-ensure context root (car entry) 'text)
          (tp-surface-plan-create
           :key (car entry) :kind 'text :text (cdr entry)
           :capability 'content))
        entries)
       :capability 'content))))

(defun tp-benchmark--retained-reconcile (count seed)
  "Benchmark retained keyed reconciliation of COUNT items using SEED."
  (let* ((entries
          (cl-loop for index below count
                   collect (cons index (format "%d " index))))
         (changed-key (mod seed count))
         (updated
          (reverse
           (mapcar
            (lambda (entry)
              (if (= (car entry) changed-key)
                  (cons (car entry) (format "changed-%d " seed))
                entry))
            entries)))
         (buffer (generate-new-buffer " *tp-benchmark-retained*"))
         surface object)
    (unwind-protect
        (progn
          (setq surface
                (tp-surface-mount
                 buffer (tp-benchmark--retained-producer entries)
                 '(:capability content))
                object (tp-object-resolve surface (list 'root changed-key)))
          (tp-benchmark--measure
           'retained-keyed-reconcile 'buffer seed count count
           (lambda ()
             (let ((report
                    (tp-surface-update
                     surface (tp-benchmark--retained-producer updated))))
               (unless (eq object
                           (tp-object-resolve surface
                                              (list 'root changed-key)))
                 (error "Retained object identity changed"))
               (with-current-buffer buffer
                 (unless (equal (buffer-string)
                                (mapconcat #'cdr updated ""))
                   (error "Retained reconciliation published wrong text")))
               (unless (and (zerop (plist-get report :created-objects))
                            (zerop (plist-get report :removed-objects)))
                 (error "Retained reconciliation replaced stable objects"))
               (list :operations 1
                     :objects (plist-get report :reconciled-objects)
                     :text-operations (plist-get report :text-operations)
                     :property-operations
                     (plist-get report :property-operations)
                     :touched (plist-get report :touched-characters)
                     :revision (plist-get report :new-revision)
                     :published 1
                     :note (format "moved=%d"
                                   (plist-get report :moved-objects)))))))
      (when (and surface (tp-surface-live-p surface))
        (tp-surface-unmount surface))
      (when (buffer-live-p buffer)
        (kill-buffer buffer)))))

(defun tp-benchmark--sparse-signal-update (unrelated-count seed)
  "Benchmark one exact signal update beside UNRELATED-COUNT bindings.
SEED supplies the target signal value."
  (let* ((target (tp-signal-create 0))
         (unrelated (tp-signal-create 0))
         (target-owner (list 'target seed))
         (unrelated-owner (list 'unrelated seed))
         (target-calls 0)
         (unrelated-calls 0))
    (unwind-protect
        (progn
          (tp-with-transaction
            (tp-bind target-owner '(benchmark . target)
                     (lambda ()
                       (cl-incf target-calls)
                       (tp-signal-read target)))
            (dotimes (index unrelated-count)
              (tp-bind unrelated-owner (list 'benchmark index)
                       (lambda ()
                         (cl-incf unrelated-calls)
                         (tp-signal-read unrelated)))))
          (unless (and (= (tp-signal-subscriber-count target) 1)
                       (= (tp-signal-subscriber-count unrelated)
                          unrelated-count))
            (error "Sparse dependency graph has wrong subscriber counts"))
          (tp-reactive-reset-counters)
          (tp-benchmark--measure
           'signal-sparse-update 'binding-graph seed
           unrelated-count unrelated-count
           (lambda ()
             (tp-signal-set target (1+ seed))
             (unless (and (= target-calls 2)
                          (= unrelated-calls unrelated-count))
               (error "Sparse update recomputed unrelated bindings"))
             (let ((counters (tp-reactive-counters)))
               (unless (and (= (plist-get counters :invalidated) 1)
                            (= (plist-get counters :recomputed) 1))
                 (error "Sparse update did not stay dependency-local"))
               (list :operations 1
                     :objects (1+ unrelated-count)
                     :subscribers (tp-signal-subscriber-count target)
                     :invalidated (plist-get counters :invalidated)
                     :recomputed (plist-get counters :recomputed)
                     :skipped (plist-get counters :skipped)
                     :published 0
                     :note "unrelated-bindings-untouched")))))
      (tp-binding-dispose-owner target-owner)
      (tp-binding-dispose-owner unrelated-owner)
      (when (tp-signal-live-p target)
        (tp-signal-dispose target))
      (when (tp-signal-live-p unrelated)
        (tp-signal-dispose unrelated)))))

(defun tp-benchmark--reactive-surface-producer (signal)
  "Return a retained producer backed by a binding to SIGNAL."
  (let ((compute (lambda () (tp-signal-read signal))))
    (lambda (context)
      (let* ((object (tp-object-ensure context nil 'value 'text))
             (binding (tp-bind object '(benchmark . value) compute)))
        (tp-surface-plan-create
         :key 'value :kind 'text
         :text (number-to-string (tp-binding-read binding))
         :capability 'content)))))

(defun tp-benchmark--batched-and-noop-publication (writes seed)
  "Benchmark WRITES batched writes and equal no-ops using SEED."
  (let* ((signal (tp-signal-create seed))
         (buffer (generate-new-buffer " *tp-benchmark-batch*"))
         (producer (tp-benchmark--reactive-surface-producer signal))
         surface)
    (unwind-protect
        (progn
          (setq surface
                (tp-surface-mount buffer producer '(:capability content)))
          (let ((revision (tp-surface-revision surface)))
            (tp-reactive-reset-counters)
            (tp-benchmark--measure
             'transaction-batch 'retained-surface seed writes writes
             (lambda ()
               (tp-with-transaction
                 (dotimes (index writes)
                   (tp-signal-set signal (+ seed index 1))))
               (let* ((report (tp-surface-report surface))
                      (counters (tp-reactive-counters))
                      (expected (+ seed writes)))
                 (with-current-buffer buffer
                   (unless (equal (buffer-string)
                                  (number-to-string expected))
                     (error "Batched publication produced wrong text")))
                 (unless (and (= (tp-surface-revision surface)
                                 (1+ revision))
                              (= (plist-get report :candidate-source-writes) 1)
                              (= (plist-get counters :recomputed) 2))
                   (error "Batched writes were not committed once"))
                 (list :operations writes
                       :objects (plist-get report :reconciled-objects)
                       :invalidated (plist-get counters :invalidated)
                       :recomputed (plist-get counters :recomputed)
                       :skipped (plist-get counters :skipped)
                       :text-operations (plist-get report :text-operations)
                       :property-operations
                       (plist-get report :property-operations)
                       :touched (plist-get report :touched-characters)
                       :revision (tp-surface-revision surface)
                       :published 1
                       :note "one-surface-commit")))))
          (let ((revision (tp-surface-revision surface))
                (value (tp-signal-peek signal)))
            (tp-reactive-reset-counters)
            (tp-benchmark--measure
             'equal-write-noop 'retained-surface seed writes writes
             (lambda ()
               (tp-with-transaction
                 (dotimes (_index writes)
                   (tp-signal-set signal value)))
               (let ((counters (tp-reactive-counters)))
                 (unless (and (= (tp-surface-revision surface) revision)
                              (equal counters
                                     '(:invalidated 0 :recomputed 0 :skipped 0
                                       :subscription-added 0
                                       :subscription-removed 0)))
                   (error "Equal writes changed retained runtime state"))
                 (list :operations writes
                       :subscribers (tp-signal-subscriber-count signal)
                       :invalidated 0 :recomputed 0 :skipped 0
                       :revision revision :published 0
                       :note "revision-unchanged"))))))
      (when (and surface (tp-surface-live-p surface))
        (tp-surface-unmount surface))
      (when (tp-signal-live-p signal)
        (tp-signal-dispose signal))
      (when (buffer-live-p buffer)
        (kill-buffer buffer)))))

(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 (count '(10 100 1000))
      (tp-benchmark--retained-reconcile count seed))
    (dolist (unrelated-count '(1 100 10000))
      (tp-benchmark--sparse-signal-update unrelated-count seed))
    (dolist (writes '(1 100 10000))
      (tp-benchmark--batched-and-noop-publication writes seed))))

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