perf: match retained mount identities with ordered queues
This commit is contained in:
Kinneyzhang
parent
5bcc91d867
commit
6ed8df3915
@ -2003,6 +2003,141 @@ prepare context."
|
||||
(should (tp-object-live-p 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 ()
|
||||
"Failed publication restores every mount of a retained logical object."
|
||||
(tp-surface-test--with-buffer
|
||||
@ -2028,6 +2163,10 @@ prepare context."
|
||||
buffer producer '(:capability content)))
|
||||
(logical (tp-object-resolve surface '(root 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)))
|
||||
(setq value "LONG")
|
||||
(let ((tp--surface-publication-step-function
|
||||
@ -2038,7 +2177,20 @@ prepare context."
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(should (equal (buffer-string) "AA"))
|
||||
(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 ()
|
||||
"A properties-only mount cannot replace host text."
|
||||
|
||||
@ -2510,40 +2510,65 @@ caller reads the scalar summary from the surface instead."
|
||||
(or (tp--surface-mount-id mount)
|
||||
(setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter))))
|
||||
|
||||
(defun tp--mount-spec-matches-live-p (spec mount capability)
|
||||
"Return non-nil when SPEC denotes live MOUNT for CAPABILITY."
|
||||
(and (eq (plist-get spec :object) (tp--surface-mount-object mount))
|
||||
(eq capability (tp--surface-mount-capability mount))
|
||||
(eq (plist-get spec :anchor) (tp--surface-mount-anchor mount))
|
||||
(equal (plist-get spec :tags) (tp--surface-mount-tags mount))))
|
||||
(defun tp--mount-match-queues (mounts object capability seen)
|
||||
"Group matching MOUNTS by anchor identity and equal tags in live order.
|
||||
Only include OBJECT and CAPABILITY by identity. SEEN prevents enqueuing the
|
||||
same mount record twice. Queue spines are private; no mount IDs are allocated."
|
||||
(let ((anchors (make-hash-table :test #'eq)))
|
||||
(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)
|
||||
"Bind PREPARED mount specs to stable live or fresh private mount ids."
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
(capability (tp--surface-capability surface))
|
||||
(live (tp--surface-mounts surface))
|
||||
(live-by-object (tp--surface-mount-index surface))
|
||||
(used (make-hash-table :test #'eq)))
|
||||
(live (tp--surface-mounts surface)))
|
||||
(if (tp--prepared-surface-retained-mount-state-p prepared)
|
||||
(dolist (mount live) (tp--ensure-surface-mount-id mount))
|
||||
(setf
|
||||
(tp--prepared-surface-mount-specs prepared)
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(let ((match
|
||||
(cl-find-if
|
||||
(lambda (mount)
|
||||
(and (not (gethash mount used))
|
||||
(tp--mount-spec-matches-live-p
|
||||
spec mount capability)))
|
||||
(gethash (plist-get spec :object) live-by-object))))
|
||||
(when match (puthash match t used))
|
||||
(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))))
|
||||
(let ((capability (tp--surface-capability surface))
|
||||
(live-by-object (tp--surface-mount-index surface))
|
||||
(queues-by-object (make-hash-table :test #'eq))
|
||||
(seen (make-hash-table :test #'eq)))
|
||||
(setf
|
||||
(tp--prepared-surface-mount-specs prepared)
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(let* ((object (plist-get spec :object))
|
||||
(anchors
|
||||
(or (gethash object queues-by-object)
|
||||
;; Cache empty queues too: later unmatched specs must
|
||||
;; not rebuild the same object's live bucket.
|
||||
(puthash object
|
||||
(tp--mount-match-queues
|
||||
(gethash object live-by-object)
|
||||
object capability seen)
|
||||
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))
|
||||
|
||||
(defun tp--prepared-target-mount-ids (prepared)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user