perf: make surface observation opt-in
This commit is contained in:
Kinneyzhang
parent
edc51194b6
commit
31304c1906
@ -2376,13 +2376,16 @@
|
||||
:key 'root :kind 'range :props '(help-echo "tp")
|
||||
:capability 'properties)))
|
||||
(surface (tp-surface-mount
|
||||
buffer producer '(:capability properties)))
|
||||
buffer producer
|
||||
(list :capability 'properties
|
||||
:observers (list #'ignore))))
|
||||
(id (tp--surface-id surface))
|
||||
(ledger (tp--surface-ledger surface))
|
||||
(mounts (tp--surface-mounts surface)))
|
||||
(should (eq (gethash id tp--surfaces) surface))
|
||||
(tp-surface-unmount surface)
|
||||
(should-not (gethash id tp--surfaces))
|
||||
(should-not (tp--surface-observers surface))
|
||||
(should-not (tp-range-anchor-live-p anchor))
|
||||
(dolist (entry ledger)
|
||||
(should-not (marker-position (tp--property-ledger-start entry)))
|
||||
@ -2424,10 +2427,12 @@
|
||||
(let* ((buffer (generate-new-buffer " *tp-surface-kill*"))
|
||||
(surface (tp-surface-mount
|
||||
buffer (tp-surface-test--leaf 'root "x")
|
||||
'(:capability content)))
|
||||
(list :capability 'content
|
||||
:observers (list #'ignore))))
|
||||
(object (tp-object-resolve surface '(root))))
|
||||
(kill-buffer buffer)
|
||||
(should-not (tp-surface-live-p surface))
|
||||
(should-not (tp--surface-observers surface))
|
||||
(should-not (tp-object-live-p object))))
|
||||
|
||||
(ert-deftest tp-surface-test-omitted-binding-defaults-to-deletion ()
|
||||
@ -2497,18 +2502,113 @@
|
||||
(tp-surface-unmount surface))))
|
||||
|
||||
(ert-deftest tp-surface-test-no-observer-skips-report-snapshot ()
|
||||
"A surface without observers does not copy an unused asynchronous report."
|
||||
"A surface without observers constructs no observation event or timing."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((copies 0)
|
||||
(clock-calls 0)
|
||||
surface
|
||||
(original (symbol-function 'tp-surface-report)))
|
||||
(cl-letf (((symbol-function 'tp-surface-report)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf copies)
|
||||
(apply original arguments))))
|
||||
(apply original arguments)))
|
||||
((symbol-function 'tp--surface-observation-clock)
|
||||
(lambda ()
|
||||
(cl-incf clock-calls)
|
||||
1.0)))
|
||||
(setq surface
|
||||
(tp-surface-mount
|
||||
buffer (tp-surface-test--leaf 'root "committed")
|
||||
'(:capability content))))
|
||||
(should (= copies 0))
|
||||
(should (= clock-calls 0))
|
||||
(let ((report (tp-surface-report surface)))
|
||||
(should-not (plist-get report :provider))
|
||||
(should-not (plist-get report :stage))
|
||||
(should-not (plist-get report :duration-ms))
|
||||
(should-not (plist-get report :timing))))))
|
||||
|
||||
(ert-deftest tp-surface-test-observer-registration-is-public-and-idempotent ()
|
||||
"Observers can be added and removed without duplicates."
|
||||
(tp-surface-test--with-buffer
|
||||
(let* ((calls 0)
|
||||
(observer (lambda (_surface _report) (cl-incf calls)))
|
||||
(surface
|
||||
(tp-surface-mount
|
||||
buffer (tp-surface-test--leaf 'root "one")
|
||||
'(:capability content))))
|
||||
(should-error (tp-surface-add-observer surface 'not-a-function)
|
||||
:type 'wrong-type-argument)
|
||||
(should-error (tp-surface-remove-observer surface 'not-a-function)
|
||||
:type 'wrong-type-argument)
|
||||
(should (eq (tp-surface-add-observer surface observer) surface))
|
||||
(should (eq (tp-surface-add-observer surface observer) surface))
|
||||
(should (= (length (tp--surface-observers surface)) 1))
|
||||
(tp-surface-update surface (tp-surface-test--leaf 'root "two"))
|
||||
(should (= calls 1))
|
||||
(should (eq (tp-surface-remove-observer surface observer) surface))
|
||||
(tp-surface-update surface (tp-surface-test--leaf 'root "three"))
|
||||
(should (= calls 1)))))
|
||||
|
||||
(ert-deftest tp-surface-test-observer-report-has-publication-metadata ()
|
||||
"An enabled observer receives provider, stage, and duration metadata."
|
||||
(tp-surface-test--with-buffer
|
||||
(let ((clock-values '(10.0 10.025))
|
||||
observed-report)
|
||||
(cl-letf (((symbol-function 'tp--surface-observation-clock)
|
||||
(lambda () (pop clock-values))))
|
||||
(tp-surface-mount
|
||||
buffer (tp-surface-test--leaf 'root "committed")
|
||||
'(:capability content)))
|
||||
(should (= copies 0)))))
|
||||
(list :capability 'content
|
||||
:observers
|
||||
(list (lambda (_surface report)
|
||||
(setq observed-report report))))))
|
||||
(should (eq (plist-get observed-report :provider) 'tp))
|
||||
(should (eq (plist-get observed-report :stage) 'publication))
|
||||
(should (< (abs (- (plist-get observed-report :duration-ms) 25.0))
|
||||
0.001))
|
||||
(should (plist-member observed-report :transaction-id))
|
||||
(should (plist-member observed-report :scope-count))
|
||||
(should (plist-member observed-report :text-operations)))))
|
||||
|
||||
(ert-deftest tp-surface-test-observation-does-not-change-committed-state ()
|
||||
"Observed and unobserved surfaces commit equivalent text and state."
|
||||
(let ((plain-buffer (generate-new-buffer " *tp-plain*"))
|
||||
(observed-buffer (generate-new-buffer " *tp-observed*")))
|
||||
(unwind-protect
|
||||
(let* ((plan (tp-surface-test--leaf
|
||||
'root "same" '(face bold help-echo "same")))
|
||||
(plain (tp-surface-mount
|
||||
plain-buffer plan '(:capability content)))
|
||||
(observed (tp-surface-mount
|
||||
observed-buffer plan
|
||||
(list :capability 'content
|
||||
:observers (list #'ignore)))))
|
||||
(should (equal-including-properties
|
||||
(with-current-buffer plain-buffer
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
(with-current-buffer observed-buffer
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (= (tp-surface-revision plain)
|
||||
(tp-surface-revision observed)))
|
||||
(should (equal (tp-surface-client-state plain)
|
||||
(tp-surface-client-state observed)))
|
||||
(let ((next (tp-surface-test--leaf
|
||||
'root "updated"
|
||||
'(face italic help-echo "updated"))))
|
||||
(tp-surface-update plain next)
|
||||
(tp-surface-update observed next))
|
||||
(should (equal-including-properties
|
||||
(with-current-buffer plain-buffer
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
(with-current-buffer observed-buffer
|
||||
(buffer-substring (point-min) (point-max)))))
|
||||
(should (= (tp-surface-revision plain)
|
||||
(tp-surface-revision observed)))
|
||||
(should (equal (tp-surface-client-state plain)
|
||||
(tp-surface-client-state observed))))
|
||||
(when (buffer-live-p plain-buffer) (kill-buffer plain-buffer))
|
||||
(when (buffer-live-p observed-buffer) (kill-buffer observed-buffer)))))
|
||||
|
||||
(ert-deftest tp-surface-test-observer-failure-does-not-roll-back ()
|
||||
"Observer errors are recorded after a successful publication."
|
||||
@ -2525,6 +2625,36 @@
|
||||
:observer-errors))
|
||||
1)))))
|
||||
|
||||
(ert-deftest tp-surface-test-observer-runs-only-after-accepted-publication ()
|
||||
"A rolled-back publication emits no observation; a retry emits one."
|
||||
(tp-surface-test--with-buffer
|
||||
(let* ((calls 0)
|
||||
(observer (lambda (_surface _report) (cl-incf calls)))
|
||||
(surface
|
||||
(tp-surface-mount
|
||||
buffer
|
||||
(tp-surface-test--leaf
|
||||
'root "old" '(face bold help-echo "old"))
|
||||
(list :capability 'content :observers (list observer))))
|
||||
(revision (tp-surface-revision surface))
|
||||
(old (buffer-substring (point-min) (point-max)))
|
||||
(next (tp-surface-test--leaf
|
||||
'root "new" '(face italic help-echo "new"))))
|
||||
(setq calls 0)
|
||||
(cl-letf (((symbol-function 'accept-change-group)
|
||||
(lambda (_group) (error "Injected final-accept failure"))))
|
||||
(should-error (tp-surface-update surface next)))
|
||||
(should (= calls 0))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(should (equal-including-properties
|
||||
old (buffer-substring (point-min) (point-max))))
|
||||
(tp-surface-update surface next)
|
||||
(should (= calls 1))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should (equal-including-properties
|
||||
(buffer-substring (point-min) (point-max))
|
||||
(propertize "new" 'face 'italic 'help-echo "new"))))))
|
||||
|
||||
(ert-deftest tp-surface-test-observer-write-starts-a-new-transaction ()
|
||||
"An observer signal write runs after the publishing transaction exits."
|
||||
(tp-surface-test--with-buffer
|
||||
|
||||
@ -162,6 +162,22 @@ producer result to the active prepare transaction."
|
||||
(defconst tp--surface-producer-key '(tp/surface . producer))
|
||||
(defconst tp--surface-extension-key 'tp-surface)
|
||||
|
||||
(defun tp--normalize-surface-observers (observers)
|
||||
"Validate OBSERVERS and return them once each, in declaration order."
|
||||
(unless (listp observers)
|
||||
(signal 'wrong-type-argument (list 'listp observers)))
|
||||
(let (normalized)
|
||||
(dolist (observer observers)
|
||||
(unless (functionp observer)
|
||||
(signal 'wrong-type-argument (list 'functionp observer)))
|
||||
(unless (memq observer normalized)
|
||||
(push observer normalized)))
|
||||
(nreverse normalized)))
|
||||
|
||||
(defun tp--surface-observation-clock ()
|
||||
"Return the current time for optional surface publication observation."
|
||||
(float-time))
|
||||
|
||||
(defun tp--plist-shape-p (value)
|
||||
"Return non-nil when VALUE is an even property list with symbol keys."
|
||||
(and (listp value)
|
||||
@ -2190,7 +2206,8 @@ to the committed projection, as with `tp-object-reuse-subtree'."
|
||||
:objects (make-hash-table :test #'equal) :mounts nil :index nil
|
||||
:mount-index (make-hash-table :test #'eq)
|
||||
:ledger nil :revision 0 :live nil :stale nil
|
||||
:observers (copy-sequence (plist-get options :observers)))))
|
||||
:observers
|
||||
(tp--normalize-surface-observers (plist-get options :observers)))))
|
||||
|
||||
(defun tp--surface-compute-function (surface input options initial)
|
||||
"Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state."
|
||||
@ -2277,6 +2294,30 @@ handle."
|
||||
surface plan-or-producer (tp--surface-options surface) nil)
|
||||
(tp-surface-report surface))
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-surface-add-observer (surface observer)
|
||||
"Add function OBSERVER to live SURFACE and return SURFACE.
|
||||
OBSERVER receives SURFACE and a defensive REPORT copy after each successful
|
||||
publication. Adding the same function more than once has no effect."
|
||||
(tp--validate-live-surface surface)
|
||||
(unless (functionp observer)
|
||||
(signal 'wrong-type-argument (list 'functionp observer)))
|
||||
(unless (memq observer (tp--surface-observers surface))
|
||||
(setf (tp--surface-observers surface)
|
||||
(append (tp--surface-observers surface) (list observer))))
|
||||
surface)
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-surface-remove-observer (surface observer)
|
||||
"Remove function OBSERVER from live SURFACE and return SURFACE.
|
||||
Removing a function that is not registered has no effect."
|
||||
(tp--validate-live-surface surface)
|
||||
(unless (functionp observer)
|
||||
(signal 'wrong-type-argument (list 'functionp observer)))
|
||||
(setf (tp--surface-observers surface)
|
||||
(delq observer (tp--surface-observers surface)))
|
||||
surface)
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-surface-update-scoped
|
||||
(surface objects plan-or-producer &optional options)
|
||||
@ -2992,8 +3033,9 @@ the generic property-operation ledger."
|
||||
|
||||
(defun tp--publish-one-surface (prepared)
|
||||
"Publish PREPARED buffer and side state."
|
||||
(let* ((started (float-time))
|
||||
(surface (tp--prepared-surface-surface prepared))
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
(observed (tp--surface-observers surface))
|
||||
(started (and observed (tp--surface-observation-clock)))
|
||||
(counts (if (eq (tp--surface-capability surface) 'content)
|
||||
(tp--publish-buffer-content prepared)
|
||||
(tp--publish-buffer-properties prepared))))
|
||||
@ -3008,10 +3050,17 @@ the generic property-operation ledger."
|
||||
(tp--publication-step 'marker surface)
|
||||
(tp--publication-step 'index surface)
|
||||
(tp--swap-surface-state prepared counts)
|
||||
(let ((report (plist-put (tp--surface-report surface) :timing
|
||||
(list :publication (- (float-time) started)))))
|
||||
(setf (tp--surface-report surface) report
|
||||
(tp--prepared-surface-report prepared) report))))
|
||||
(when started
|
||||
(let* ((duration-ms
|
||||
(* 1000.0 (- (tp--surface-observation-clock) started)))
|
||||
(report (tp--surface-report surface)))
|
||||
(setq report (plist-put report :provider 'tp)
|
||||
report (plist-put report :stage 'publication)
|
||||
report (plist-put report :duration-ms duration-ms)
|
||||
report (plist-put report :timing
|
||||
(list :publication (/ duration-ms 1000.0))))
|
||||
(setf (tp--surface-report surface) report
|
||||
(tp--prepared-surface-report prepared) report)))))
|
||||
|
||||
(defun tp--journal-intervals (prepared-list)
|
||||
"Return buffer intervals whose properties PREPARED-LIST may mutate."
|
||||
@ -3871,7 +3920,8 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
|
||||
(tp--surface-mounts surface) nil (tp--surface-index surface) nil
|
||||
(tp--surface-mount-index surface) (make-hash-table :test #'eq)
|
||||
(tp--surface-ledger surface) nil
|
||||
(tp--surface-client-state surface) nil)))
|
||||
(tp--surface-client-state surface) nil
|
||||
(tp--surface-observers surface) nil)))
|
||||
|
||||
;;;###autoload
|
||||
(defun tp-surface-unmount (surface)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user