0d35358e05
Replace the legacy managed layer renderer with one independent retained/reactive text runtime. TP now owns exact dependencies, stable objects, marker-backed mounts, property contribution composition, atomic publication, rollback, and direct text-property facades without ECSS or Ebox dependencies.\n\nBREAKING CHANGE: remove tp-render, tp-stack, scan-driven managed layers, inline runtime metadata, TP-owned CSS cascade APIs, and dollar-variable declarations.\n\nVerified: 290/290 ERT, shuffled 290/290 (seed 20260806), 8/8 doctests, WERROR compile-all, checkdoc, package-lint, diff-check, and isolated TP-only load.
326 lines
14 KiB
EmacsLisp
326 lines
14 KiB
EmacsLisp
;;; 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
|