geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

perf: match retained mount identities with ordered queues

Browse Source
This commit is contained in:
Kinneyzhang 2026-09-07 04:09:57 +08:00
parent 5bcc91d867
commit 6ed8df3915
2 changed files with 206 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

154
tests/tp-surface-tests.el
View File

@ -2003,6 +2003,141 @@ prepare context."
(should (tp-object-live-p hidden)) (should (tp-object-live-p hidden))
(should-not (tp-object-mounts hidden))))) (should-not (tp-object-mounts hidden)))))
(ert-deftest tp-surface-test-prepared-mount-ids-preserve-signature-order ()
"Mount IDs follow first-unused EQ identities and equal tags in spec order."
(let* ((tp--mount-id-counter 1000)
(object (tp--make-surface-object :id 1))
(equal-object (copy-sequence object))
(other-object (tp--make-surface-object :id 2))
(anchor (tp--make-range-anchor :id 1))
(equal-anchor (copy-sequence anchor))
(index (make-hash-table :test #'eq))
(records
(list (list nil object 'content anchor '(:slot unused))
(list 11 object 'content anchor '(:slot duplicate))
(list 12 object 'properties anchor '(:slot duplicate))
(list nil object 'content anchor '(:slot duplicate))
(list 13 object 'content equal-anchor '(:slot duplicate))
(list 14 object 'content anchor '(:slot other))
(list 21 equal-object 'content anchor '(:slot duplicate))
(list 31 other-object 'content nil '(:slot other))))
(live
(cl-loop for (id owner capability attachment tags) in records
for position from 1
collect (tp--make-surface-mount
:id id :object owner :capability capability
:anchor attachment :tags (copy-tree tags)
:start position :end (1+ position))))
(spec-signatures
(list (list object anchor '(:slot other))
(list equal-object anchor '(:slot duplicate))
(list object anchor '(:slot duplicate))
(list object equal-anchor '(:slot duplicate))
(list object anchor '(:slot duplicate))
(list object anchor '(:slot duplicate))
(list equal-object equal-anchor '(:slot duplicate))
(list equal-object anchor '(:slot duplicate))
(list other-object nil '(:slot other))
(list object anchor '(:slot absent))))
(specs
(cl-loop for (owner attachment tags) in spec-signatures
for position from 101
collect (list :object owner :anchor attachment
:tags (copy-tree tags) :mount-id -1
:start position :end (+ position 2))))
(surface (tp--make-surface :capability 'content
:mounts live :mount-index index))
(prepared (tp--make-prepared-surface :surface surface :mount-specs specs))
saved-buckets)
(should (equal object equal-object))
(should-not (eq object equal-object))
(should (equal anchor equal-anchor))
(should-not (eq anchor equal-anchor))
(dolist (mount live)
(let ((owner (tp--surface-mount-object mount)))
(puthash owner (append (gethash owner index) (list mount)) index)))
;; Preserve the matcher's single-use and identity checks even when a
;; bucket repeats a record or contains an entry owned by another object.
(puthash object (append (gethash object index)
(list (nth 1 live) (nth 6 live)))
index)
(maphash
(lambda (owner bucket)
(push (list owner bucket (copy-sequence bucket)
(cl-loop for tail on bucket collect tail))
saved-buckets))
index)
(should (eq prepared (tp--assign-prepared-mount-ids prepared)))
(should (equal (mapcar (lambda (spec) (plist-get spec :mount-id))
(tp--prepared-surface-mount-specs prepared))
'(14 21 11 13 1001 1002 1003 1004 31 1005)))
(should (= tp--mount-id-counter 1005))
;; An unmatched live mount must not receive an ID while an index is built.
(should-not (tp--surface-mount-id (car live)))
(should (= (tp--surface-mount-id (nth 3 live)) 1001))
(should (eq live (tp--surface-mounts surface)))
(should (eq index (tp--surface-mount-index surface)))
(should (= (hash-table-count index) 3))
(dolist (saved saved-buckets)
(let ((bucket (gethash (nth 0 saved) index)))
(should (eq (nth 1 saved) bucket))
(should (equal (nth 2 saved) bucket))
(should (cl-every #'identity
(cl-mapcar #'eq (nth 3 saved)
(cl-loop for tail on bucket collect tail))))))
(cl-loop for spec in (tp--prepared-surface-mount-specs prepared)
for (owner attachment tags) in spec-signatures
for position from 101
do (should (eq owner (plist-get spec :object)))
(should (eq attachment (plist-get spec :anchor)))
(should (equal tags (plist-get spec :tags)))
(should (= position (plist-get spec :start)))
(should (= (+ position 2) (plist-get spec :end))))))
(ert-deftest tp-surface-test-prepared-mount-ids-bound-candidate-scans ()
"Growing duplicate mounts must not repeatedly scan their used prefix."
(let ((assign (tp-surface-test--source-function 'tp--assign-prepared-mount-ids))
(find-if (symbol-function 'cl-find-if))
samples)
(dolist (count '(16 32 64))
(let* ((tp--mount-id-counter 1000)
(object (tp--make-surface-object :id 1))
(live (cl-loop for id from 1 to count
collect (tp--make-surface-mount
:id id :object object :capability 'content
:tags (list :slot 'same) :start id :end (1+ id))))
(index (make-hash-table :test #'eq))
(surface (tp--make-surface :capability 'content
:mounts live :mount-index index))
(prepared
(tp--make-prepared-surface
:surface surface
:mount-specs
(cl-loop for position from 101 below (+ 101 count)
collect (list :object object :tags (list :slot 'same)
:start position :end (1+ position)))))
(visits 0))
(puthash object live index)
;; Count actual predicate visits, including candidates rejected by the
;; used-prefix check before comparing their matching signature.
;; This bounds candidate scans, not the complete assignment algorithm.
(cl-letf (((symbol-function 'cl-find-if)
(lambda (predicate sequence &rest options)
(apply find-if
(lambda (mount)
(cl-incf visits)
(funcall predicate mount))
sequence options))))
(funcall assign prepared))
(should (equal (mapcar (lambda (spec) (plist-get spec :mount-id))
(tp--prepared-surface-mount-specs prepared))
(number-sequence 1 count)))
(should (= tp--mount-id-counter 1000))
(push (cons count visits) samples)))
(ert-info ((format "mount count / candidate visits: %S" (reverse samples)))
(dolist (sample samples)
(should (<= (cdr sample) (* 2 (car sample))))))))
(ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically () (ert-deftest tp-surface-test-disjoint-mount-index-rolls-back-atomically ()
"Failed publication restores every mount of a retained logical object." "Failed publication restores every mount of a retained logical object."
(tp-surface-test--with-buffer (tp-surface-test--with-buffer
@ -2028,6 +2163,10 @@ prepare context."
buffer producer '(:capability content))) buffer producer '(:capability content)))
(logical (tp-object-resolve surface '(root logical))) (logical (tp-object-resolve surface '(root logical)))
(mounts (tp-object-mounts logical)) (mounts (tp-object-mounts logical))
(live (tp--surface-mounts surface))
(index (tp--surface-mount-index surface))
(bucket (gethash logical index))
(mount-ids (mapcar #'tp--surface-mount-id live))
(revision (tp-surface-revision surface))) (revision (tp-surface-revision surface)))
(setq value "LONG") (setq value "LONG")
(let ((tp--surface-publication-step-function (let ((tp--surface-publication-step-function
@ -2038,7 +2177,20 @@ prepare context."
(should (= (tp-surface-revision surface) revision)) (should (= (tp-surface-revision surface) revision))
(should (equal (buffer-string) "AA")) (should (equal (buffer-string) "AA"))
(should (eq logical (tp-object-resolve surface '(root logical)))) (should (eq logical (tp-object-resolve surface '(root logical))))
(should (equal (tp-object-mounts logical) mounts)))))) (should (equal (tp-object-mounts logical) mounts))
(should (eq live (tp--surface-mounts surface)))
(should (eq index (tp--surface-mount-index surface)))
(should (eq bucket (gethash logical index)))
(should (equal mount-ids (mapcar #'tp--surface-mount-id live)))
(tp-surface-update surface producer)
(should (= (tp-surface-revision surface) (1+ revision)))
(should (equal (buffer-string) "LONGLONG"))
(should (eq logical (tp-object-resolve surface '(root logical))))
(should (equal mount-ids
(mapcar #'tp--surface-mount-id (tp--surface-mounts surface))))
(should (equal (tp-object-mounts logical)
'((:start 1 :end 5 :tags left)
(:start 5 :end 9 :tags right))))))))
(ert-deftest tp-surface-test-properties-capability-rejects-text () (ert-deftest tp-surface-test-properties-capability-rejects-text ()
"A properties-only mount cannot replace host text." "A properties-only mount cannot replace host text."

81
tp-surface.el
View File

@ -2510,40 +2510,65 @@ caller reads the scalar summary from the surface instead."
(or (tp--surface-mount-id mount) (or (tp--surface-mount-id mount)
(setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter)))) (setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter))))
(defun tp--mount-spec-matches-live-p (spec mount capability) (defun tp--mount-match-queues (mounts object capability seen)
"Return non-nil when SPEC denotes live MOUNT for CAPABILITY." "Group matching MOUNTS by anchor identity and equal tags in live order.
(and (eq (plist-get spec :object) (tp--surface-mount-object mount)) Only include OBJECT and CAPABILITY by identity. SEEN prevents enqueuing the
(eq capability (tp--surface-mount-capability mount)) same mount record twice. Queue spines are private; no mount IDs are allocated."
(eq (plist-get spec :anchor) (tp--surface-mount-anchor mount)) (let ((anchors (make-hash-table :test #'eq)))
(equal (plist-get spec :tags) (tp--surface-mount-tags mount)))) (dolist (mount mounts)
(when (and (eq object (tp--surface-mount-object mount))
(eq capability (tp--surface-mount-capability mount))
(not (gethash mount seen)))
(puthash mount t seen)
(let* ((anchor (tp--surface-mount-anchor mount))
(tags (tp--surface-mount-tags mount))
(by-tags (or (gethash anchor anchors)
(puthash anchor (make-hash-table :test #'equal)
anchors))))
(push mount (gethash tags by-tags)))))
(maphash
(lambda (_anchor by-tags)
(maphash (lambda (tags queue)
(puthash tags (nreverse queue) by-tags))
by-tags))
anchors)
anchors))
(defun tp--assign-prepared-mount-ids (prepared) (defun tp--assign-prepared-mount-ids (prepared)
"Bind PREPARED mount specs to stable live or fresh private mount ids." "Bind PREPARED mount specs to stable live or fresh private mount ids."
(let* ((surface (tp--prepared-surface-surface prepared)) (let* ((surface (tp--prepared-surface-surface prepared))
(capability (tp--surface-capability surface)) (live (tp--surface-mounts surface)))
(live (tp--surface-mounts surface))
(live-by-object (tp--surface-mount-index surface))
(used (make-hash-table :test #'eq)))
(if (tp--prepared-surface-retained-mount-state-p prepared) (if (tp--prepared-surface-retained-mount-state-p prepared)
(dolist (mount live) (tp--ensure-surface-mount-id mount)) (dolist (mount live) (tp--ensure-surface-mount-id mount))
(setf (let ((capability (tp--surface-capability surface))
(tp--prepared-surface-mount-specs prepared) (live-by-object (tp--surface-mount-index surface))
(mapcar (queues-by-object (make-hash-table :test #'eq))
(lambda (spec) (seen (make-hash-table :test #'eq)))
(let ((match (setf
(cl-find-if (tp--prepared-surface-mount-specs prepared)
(lambda (mount) (mapcar
(and (not (gethash mount used)) (lambda (spec)
(tp--mount-spec-matches-live-p (let* ((object (plist-get spec :object))
spec mount capability))) (anchors
(gethash (plist-get spec :object) live-by-object)))) (or (gethash object queues-by-object)
(when match (puthash match t used)) ;; Cache empty queues too: later unmatched specs must
(plist-put ;; not rebuild the same object's live bucket.
spec :mount-id (puthash object
(if match (tp--mount-match-queues
(tp--ensure-surface-mount-id match) (gethash object live-by-object)
(cl-incf tp--mount-id-counter))))) object capability seen)
(tp--prepared-surface-mount-specs prepared)))) queues-by-object)))
(by-tags (gethash (plist-get spec :anchor) anchors))
(tags (plist-get spec :tags))
(queue (and by-tags (gethash tags by-tags)))
(match (car queue)))
(when match (puthash tags (cdr queue) by-tags))
(plist-put
spec :mount-id
(if match
(tp--ensure-surface-mount-id match)
(cl-incf tp--mount-id-counter)))))
(tp--prepared-surface-mount-specs prepared)))))
prepared)) prepared))
(defun tp--prepared-target-mount-ids (prepared) (defun tp--prepared-target-mount-ids (prepared)