perf: retain surface state and layered paint slots

docs/API-REFERENCE.md

@@ -271,6 +271,12 @@ properties。
   result；
 - tp-surface-result-create-owned 只可对当前 active prepare context 使用，
   结果只消费一次。
+- tp-surface-retained-content-result-create 用于对象拓扑不变的 content
+  candidate；最后一个可选 `property-contributions` 参数接受按顺序排列的
+  `(:start N :end N :props PLIST)` 相对范围。TP 使用已注册 property merge
+  policy 在 prepare 内组合这些贡献，再通过同一个 content surface 原子 diff、
+  发布和回滚；调用者不需要创建重叠的 properties surface，也不应预先压平
+  Theme/状态/inline face。
 
 producer 接收一个 prepare context，并应返回 plan 或 result：
 

tests/tp-binding-tests.el

@@ -777,5 +777,22 @@
         (when (buffer-live-p buffer) (kill-buffer buffer))
         (makunbound symbol)))))
 
+(ert-deftest tp-binding-test-precomputed-keeps-explicit-edge-reactive ()
+  "A precomputed binding skips first compute and reacts through its edge."
+  (let* ((signal (tp-signal-create 1))
+         (parent (tp-bind 'parent 'value (lambda () (tp-signal-read signal))))
+         (runs 0)
+         (child
+          (tp-bind-precomputed
+           'child 'value
+           (lambda () (cl-incf runs) (1+ (tp-binding-read parent)))
+           2 (list parent))))
+    (should (= (tp-binding-read child) 2))
+    (should (= runs 0))
+    (should (= (tp-binding-dependency-count child) 1))
+    (tp-signal-set signal 4)
+    (should (= (tp-binding-read child) 5))
+    (should (= runs 1))))
+
 (provide 'tp-binding-tests)
 ;;; tp-binding-tests.el ends here

tests/tp-builtins-tests.el

@@ -252,6 +252,14 @@ tp-builtins restores the shipped layer definitions."
   (tp-builtins-test--with-background-mode 'dark
     (should (equal (tp-palette-color 'info :fg) "#58a6ff"))))
 
+(ert-deftest tp-builtins-test-palette-color-resolves-explicit-mode ()
+  "Resolve a palette for an application mode without reading the frame."
+  (should (equal "#0969da"
+                 (tp-palette-color-for-mode 'info :fg 'light)))
+  (should (equal "#58a6ff"
+                 (tp-palette-color-for-mode 'info :fg 'dark)))
+  (should-error (tp-palette-color-for-mode 'info :fg 'sepia)))
+
 (ert-deftest tp-builtins-test-palette-has-p ()
   "tp-palette-has-p tests palette registration and per-key presence."
   (should (tp-palette-has-p 'info))

tests/tp-core-tests.el

@@ -287,6 +287,17 @@
       (should-not (eq copy value))
       (should (eq (cdr copy) copy)))))
 
+(ert-deftest tp-core-test-public-property-value-copy-is-defensive ()
+  "The public copy boundary preserves opaque values and isolates containers."
+  (let* ((function (lambda () t))
+         (source (list :nested (vector "value") :function function))
+         (copy (tp-property-value-copy source)))
+    (should (equal copy source))
+    (should-not (eq copy source))
+    (should-not (eq (plist-get copy :nested)
+                    (plist-get source :nested)))
+    (should (eq (plist-get copy :function) function))))
+
 ;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map
 
 (ert-deftest tp-core-test-intervals-buffer-relative-default ()

tests/tp-style-tests.el

@@ -33,6 +33,33 @@
    :projector (lambda (value)
                 (list 'face (list :foreground value)))))
 
+(ert-deftest tp-style-test-paint-slot-keeps-one-face-address ()
+  "Updating a paint slot changes its face without rewriting text properties."
+  (let* ((slot (tp-paint-slot-create '(:foreground "red")))
+         (face (tp-paint-slot-face slot))
+         (text (propertize "x" 'face face))
+         (buffer (generate-new-buffer " *tp-paint-slot-test*")))
+    (should (facep face))
+    (should (eq face (get-text-property 0 'face text)))
+    (tp-paint-slot-update slot '(:foreground "red"))
+    (should (equal "red" (face-attribute face :foreground nil nil)))
+    (tp-paint-slot-update slot '(:foreground "blue"))
+    (should (eq face (get-text-property 0 'face text)))
+    (should (equal "blue" (face-attribute face :foreground nil nil)))
+    (unwind-protect
+        (let ((journal
+               (tp-paint-slot-apply-updates
+                buffer (list (cons slot '(:foreground "green"))))))
+          (with-current-buffer buffer
+            (should
+             (equal '(:foreground "green")
+                    (cadr (assq face face-remapping-alist)))))
+          (tp-paint-slot-rollback-updates journal)
+          (with-current-buffer buffer
+            (should-not (assq face face-remapping-alist)))
+          (should (equal "blue" (face-attribute face :foreground nil nil))))
+      (kill-buffer buffer))))
+
 (ert-deftest tp-style-test-policy-registration-is-atomic ()
   "Invalid replacement leaves the previous valid policy installed."
   (tp-style-test--isolated
@@ -155,6 +182,12 @@
         (should (= compute-calls 1))
         (should (= result-calls 0))))))
 
+(ert-deftest tp-style-test-computed-p-distinguishes-literal-functions ()
+  "Only explicit computed wrappers satisfy the public predicate."
+  (let ((function (lambda () "value")))
+    (should-not (tp-computed-p function))
+    (should (tp-computed-p (tp-computed function)))))
+
 (ert-deftest tp-style-test-public-resolver-only-executes-computed-sources ()
   "The public resolver preserves literal functions and evaluates tags."
   (let ((literal (lambda () 'literal))

tests/tp-surface-tests.el

@@ -57,6 +57,211 @@
     (with-silent-modifications
       (put-text-property beg end 'face 'corrupt))))
 
+(ert-deftest tp-surface-test-commit-batch-is-atomic-and-revision-bound ()
+  "A precomputed batch commits text/properties/state once and rolls back."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             (current-buffer)
+             (tp-surface-test--leaf 'root "abc" '(face bold))
+             '(:capability content)))
+           (replacement (propertize "XY" 'face 'italic))
+           (batch
+            (tp-commit-batch-create
+             :base-revision (tp-surface-revision surface)
+             :target-revision (1+ (tp-surface-revision surface))
+             :base-extent 3 :target-extent 4
+             :patches
+             (list (list :old-start 1 :old-end 2
+                         :new-start 1 :new-end 3
+                         :replacement replacement))
+             :coordinate-patches
+             (list (list :old-start 1 :old-end 2
+                         :new-start 1 :new-end 3))
+             :client-state '(:value next))))
+      (tp-surface-commit-batch surface batch)
+      (should (equal "aXYc" (buffer-string)))
+      (should (eq 'italic (get-text-property 2 'face)))
+      (should (= 2 (tp-surface-revision surface)))
+      (should (equal '(:value next) (tp-surface-client-state surface)))
+      (should (plist-get (tp-surface-report surface) :commit-batch))
+      (let ((failing
+             (tp-commit-batch-create
+              :base-revision 2 :target-revision 3
+              :base-extent 4 :target-extent 4
+              :patches
+              (list (list :old-start 1 :old-end 3
+                          :new-start 1 :new-end 3
+                          :replacement "ZZ"))
+              :client-state '(:value rejected))))
+        (add-hook 'after-change-functions
+                  #'tp-surface-test--corrupt-after-change nil t)
+        (setq-local tp-surface-test--corrupt-next t)
+        (unwind-protect
+            (should-error (tp-surface-commit-batch surface failing))
+          (remove-hook 'after-change-functions
+                       #'tp-surface-test--corrupt-after-change t))
+        (should (equal "aXYc" (buffer-string)))
+        (should (= 2 (tp-surface-revision surface)))
+        (should (equal '(:value next)
+                       (tp-surface-client-state surface))))
+      (should-error (tp-surface-commit-batch surface batch)))))
+
+(ert-deftest tp-surface-test-producer-can-return-equal-coordinate-batch ()
+  "A retained producer can publish a strict batch through normal TP phases."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             (current-buffer) (tp-surface-test--leaf 'root "abc")
+             '(:capability content :coordinate-mounts t)))
+           root)
+      (maphash (lambda (_path object)
+                 (unless (tp--surface-object-parent object)
+                   (setq root object)))
+               (tp--surface-objects surface))
+      (let ((old-mounts (copy-sequence (tp--surface-mounts surface)))
+            (old-index (tp--surface-mount-index surface))
+            (batch
+             (tp-commit-batch-create
+              :base-revision 1 :target-revision 2
+              :base-extent 3 :target-extent 4
+              :patches
+              (list (list :old-start 1 :old-end 2
+                          :new-start 1 :new-end 3
+                          :replacement (propertize "XY" 'face 'bold)))
+              :coordinate-patches
+              (list (list :old-start 1 :old-end 2
+                          :new-start 1 :new-end 3))
+              :client-state '(:batch committed))))
+        (tp-surface-update
+         surface
+         (lambda (context)
+           (tp-object-reuse-subtree context root)
+           (tp-commit-batch-result-create context batch)))
+      (should (equal "aXYc" (buffer-string)))
+      (should (eq 'bold (get-text-property 2 'face)))
+      (should (= 2 (tp-surface-revision surface)))
+      (should (equal '(:batch committed)
+                     (tp-surface-client-state surface)))
+      (should (eq old-index (tp--surface-mount-index surface)))
+      (should (cl-every #'identity
+                        (cl-mapcar #'eq old-mounts
+                                   (tp--surface-mounts surface))))
+      (should
+       (cl-every (lambda (mount)
+                   (<= (tp--mount-position (tp--surface-mount-end mount))
+                       (point-max)))
+                 (tp--surface-mounts surface)))
+      (should (plist-get (tp-surface-report surface) :commit-batch))
+      (let ((before-mounts (tp-object-mounts root))
+            (before-live (copy-sequence (tp--surface-mounts surface)))
+            (failing
+             (tp-commit-batch-create
+              :base-revision 2 :target-revision 3
+              :base-extent 4 :target-extent 5
+              :patches
+              (list (list :old-start 1 :old-end 3
+                          :new-start 1 :new-end 4
+                          :replacement "XYZ"))
+              :coordinate-patches
+              (list (list :old-start 1 :old-end 3
+                          :new-start 1 :new-end 4)))))
+        (let ((tp--surface-publication-step-function
+               (lambda (step _surface)
+                 (when (eq step 'client-state)
+                   (error "Injected retained mount rollback")))))
+          (should-error
+           (tp-surface-update
+            surface
+            (lambda (context)
+              (tp-object-reuse-subtree context root)
+              (tp-commit-batch-result-create context failing)))))
+        (should (equal "aXYc" (buffer-string)))
+        (should (= 2 (tp-surface-revision surface)))
+        (should (equal before-mounts (tp-object-mounts root)))
+        (should (cl-every #'identity
+                          (cl-mapcar #'eq before-live
+                                     (tp--surface-mounts surface)))))))))
+
+(ert-deftest tp-surface-test-commit-batch-promotes-exact-target-mounts ()
+  "A shrinking batch publishes producer-supplied target mounts atomically."
+  (tp-surface-test--with-buffer
+    (let ((owned-state (list :batch 'exact-mounts)) root logical)
+      (let* ((producer
+              (lambda (context)
+                (setq root (tp-object-ensure context nil 'root 'text)
+                      logical
+                      (tp-object-ensure context root 'logical 'item))
+                (tp-object-attach-content-range
+                 context logical root 4 6 '(:slot old))
+                (tp-surface-test--leaf 'root "abcdef")))
+             (surface
+              (tp-surface-mount
+               buffer producer
+               '(:capability content :coordinate-mounts t))))
+        (tp-surface-update
+         surface
+         (lambda (context)
+           (tp-object-reuse-subtree context root)
+           (tp-commit-batch-result-create
+            context
+            (tp-commit-batch-create
+             :base-revision 1 :target-revision 2
+             :base-extent 6 :target-extent 2
+             :patches
+             (list (list :old-start 0 :old-end 6
+                         :new-start 0 :new-end 2
+                         :replacement "XY"))
+             :coordinate-patches
+             (list (list :old-start 0 :old-end 6
+                         :new-start 0 :new-end 2)))
+            :mount-specs
+            (list (list :object root :start 0 :end 2 :tags nil)
+                  (list :object logical :start 0 :end 2
+                        :tags '(:slot new)))
+            :client-state owned-state)))
+        (should (equal (buffer-string) "XY"))
+        (should (= (tp-surface-revision surface) 2))
+        (should (eq (tp-surface-client-state surface) owned-state))
+        (should (plist-get (tp-surface-report surface) :commit-batch))
+        (should (equal (tp-object-mounts logical)
+                       '((:start 1 :end 3 :tags (:slot new)))))))))
+
+(ert-deftest tp-surface-test-commit-batch-reuses-proven-mount-projection ()
+  "A producer proof can retain mounts despite nonidentity text coordinates."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             buffer (tp-surface-test--leaf 'root "abcd")
+             '(:capability content :coordinate-mounts t)))
+           (root (tp-object-resolve surface '(root)))
+           (mounts (tp--surface-mounts surface))
+           (mount-index (tp--surface-mount-index surface))
+           (batch
+            (tp-commit-batch-create
+             :base-revision 1 :target-revision 2
+             :base-extent 4 :target-extent 4
+             :patches
+             (list (list :old-start 1 :old-end 3
+                         :new-start 1 :new-end 3
+                         :replacement "XY"))
+             :coordinate-patches
+             (list (list :old-start 1 :old-end 2
+                         :new-start 1 :new-end 1)
+                   (list :old-start 3 :old-end 3
+                         :new-start 2 :new-end 3)))))
+      (tp-surface-update
+       surface
+       (lambda (context)
+         (tp-object-reuse-subtree context root)
+         (tp-commit-batch-result-create
+          context batch :reuse-mount-projection t)))
+      (should (equal (buffer-string) "aXYd"))
+      (should (eq mounts (tp--surface-mounts surface)))
+      (should (eq mount-index (tp--surface-mount-index surface)))
+      (should (plist-get (tp-surface-report surface)
+                         :retained-mount-state)))))
+
 (ert-deftest tp-surface-test-plan-validates-and-defensively-copies ()
   "Plans reject duplicate keys and own their caller-provided values."
   (let* ((callback (byte-compile
@@ -121,6 +326,110 @@
           (should (eq (get-text-property 0 'face rendered) 'bold)))
         (should (equal (tp-surface-plan-tags child) '(:role leaf)))))))
 
+(ert-deftest tp-surface-test-retained-content-composes-property-contributions ()
+  "A content surface should layer property contributions without text work."
+  (tp-surface-test--with-buffer
+    (let* ((plan
+            (tp-surface-plan-create
+             :key 'root :kind 'group :capability 'content
+             :children
+             (list
+              (tp-surface-plan-create
+               :key 'fragments :kind 'group :capability 'content
+               :children (list (tp-surface-test--leaf 'text "abcd"))))))
+           (surface (tp-surface-mount buffer plan '(:capability content)))
+           (producer
+            (lambda (contributions)
+              (lambda (context)
+                (let* ((root (tp-object-ensure context nil 'root 'group))
+                       (fragments
+                        (tp-object-ensure context root 'fragments 'group))
+                       (_text
+                        (tp-object-ensure context fragments 'text 'text))
+                       (owned-plan
+                        (tp-surface-plan-create-owned
+                         :key 'root :kind 'group :capability 'content
+                         :children
+                         (list
+                          (tp-surface-plan-create-owned
+                           :key 'fragments :kind 'group :capability 'content
+                           :children
+                           (list
+                            (tp-surface-plan-create-owned
+                             :key 'text :kind 'text :text "abcd"
+                             :capability 'content)))))))
+                  (tp-surface-retained-content-result-create
+                   context owned-plan "abcd" nil nil t contributions)))))
+           (base
+            (list :start 0 :end 4
+                  :props '(face (:foreground "white"
+                                 :background "black"))))
+           (specific
+            (list :start 1 :end 3
+                  :props '(face (:foreground "red")))))
+      (tp-surface-update surface (funcall producer (list base specific)))
+      (should (equal (buffer-string) "abcd"))
+      (let ((outer (get-text-property 1 'face))
+            (inner (get-text-property 2 'face)))
+        (should (equal (plist-get outer :foreground) "white"))
+        (should (equal (plist-get outer :background) "black"))
+        (should (equal (plist-get inner :foreground) "red"))
+        (should (equal (plist-get inner :background) "black")))
+      (let* ((next-base
+              (list :start 0 :end 4
+                    :props '(face (:foreground "#EEEEEE"
+                                   :background "#111111"))))
+             (report
+              (tp-surface-update
+               surface (funcall producer (list next-base specific)))))
+        (should (equal (buffer-string) "abcd"))
+        (should (= 0 (plist-get report :text-operations)))
+        (should (> (plist-get report :property-operations) 0))
+        (let ((outer (get-text-property 1 'face))
+              (inner (get-text-property 2 'face)))
+          (should (equal (plist-get outer :foreground) "#EEEEEE"))
+          (should (equal (plist-get outer :background) "#111111"))
+          (should (equal (plist-get inner :foreground) "red"))
+          (should (equal (plist-get inner :background) "#111111")))))))
+
+(ert-deftest tp-surface-test-retained-content-rejects-invalid-contribution ()
+  "Invalid contribution ranges must fail before mutating published content."
+  (tp-surface-test--with-buffer
+    (let* ((plan
+            (tp-surface-plan-create
+             :key 'root :kind 'group :capability 'content
+             :children
+             (list
+              (tp-surface-plan-create
+               :key 'fragments :kind 'group :capability 'content
+               :children (list (tp-surface-test--leaf 'text "safe"))))))
+           (surface (tp-surface-mount buffer plan '(:capability content))))
+      (should-error
+       (tp-surface-update
+        surface
+        (lambda (context)
+          (let* ((root (tp-object-ensure context nil 'root 'group))
+                 (fragments
+                  (tp-object-ensure context root 'fragments 'group))
+                 (_text (tp-object-ensure context fragments 'text 'text))
+                 (owned-plan
+                  (tp-surface-plan-create-owned
+                   :key 'root :kind 'group :capability 'content
+                   :children
+                   (list
+                    (tp-surface-plan-create-owned
+                     :key 'fragments :kind 'group :capability 'content
+                     :children
+                     (list
+                      (tp-surface-plan-create-owned
+                       :key 'text :kind 'text :text "safe"
+                       :capability 'content)))))))
+            (tp-surface-retained-content-result-create
+             context owned-plan "safe" nil nil t
+             '((:start 0 :end 9 :props (face bold)))))))
+       :type 'tp-invalid-content-range)
+      (should (equal (buffer-string) "safe")))))
+
 (ert-deftest tp-surface-test-owned-plan-result-transfers-candidate-tree ()
   "Owned plan and result constructors skip a duplicate candidate snapshot."
   (tp-surface-test--with-buffer
@@ -1227,6 +1536,60 @@
           (should (tp-binding-live-p binding))
           (should (equal (buffer-string) "after")))))))
 
+(ert-deftest tp-surface-test-reuse-one-preserves-only-proven-object ()
+  "Single-object reuse retains that identity without retaining a removed peer."
+  (tp-surface-test--with-buffer
+    (let ((value "before") kept removed)
+      (cl-labels
+          ((producer (context)
+             (let ((root (tp-object-ensure context nil 'root 'group)))
+               (if kept
+                   (tp-object-reuse context kept)
+                 (setq kept (tp-object-ensure context root 'kept 'item)
+                       removed (tp-object-ensure context root 'removed 'item))
+                 (tp-object-retain context kept)
+                 (tp-object-retain context removed))
+               (tp-object-ensure context root 'text 'text))
+             (tp-surface-plan-create
+              :key 'root :kind 'group :capability 'content
+              :children (list (tp-surface-test--leaf 'text value)))))
+        (let ((surface (tp-surface-mount
+                        buffer #'producer '(:capability content))))
+          (setq value "after")
+          (tp-surface-update surface #'producer)
+          (should (eq kept (tp-object-resolve surface '(root kept))))
+          (should-not (tp-object-live-p removed))
+          (should (equal (buffer-string) "after")))))))
+
+(ert-deftest tp-surface-test-ensure-at-reuses-anonymous-slot-without-prefix-replay ()
+  "Compiled topology can address one anonymous slot directly."
+  (tp-surface-test--with-buffer
+    (let (second)
+      (cl-labels
+          ((producer (context)
+             (let ((root (tp-object-ensure context nil 'root 'group)))
+               (if second
+                   (progn
+                     (tp-object-reuse
+                      context
+                      (tp-object-resolve
+                       (tp--context-surface context)
+                       '(root (:position 0 :kind item))))
+                     (setq second
+                           (tp-object-ensure-at context root nil 'item 1)))
+                 (tp-object-retain
+                  context (tp-object-ensure context root nil 'item))
+                 (setq second (tp-object-ensure context root nil 'item))
+                 (tp-object-retain context second))
+               (tp-object-retain context second))
+             (tp-surface-plan-create
+              :key 'root :kind 'group :capability 'content)))
+        (let ((surface (tp-surface-mount
+                        buffer #'producer '(:capability content)))
+              (identity second))
+          (tp-surface-update surface #'producer)
+          (should (eq identity second)))))))
+
 (ert-deftest tp-surface-test-logical-object-owns-leaf-local-ranges ()
   "One logical object can own multiple ranges in one content leaf."
   (tp-surface-test--with-buffer

tp-core.el

@@ -425,6 +425,12 @@ and other opaque objects keep their identity; functions are never executed."
                     (tp--copy-property-value (aref copy index) cache)))
             copy)))))))
 
+(defun tp-property-value-copy (value)
+  "Return a defensive copy of mutable text-property VALUE.
+Functions, records, and other opaque identities are retained; mutable cons,
+string, and non-record vector graphs are copied with sharing and cycles intact."
+  (tp--copy-property-value value (make-hash-table :test #'eq)))
+
 (defun tp--deep-merge-plist (base new)
   "Deep merge NEW plist into BASE plist.
 For nested plists (starting with keyword), recursively merge.

tp-palette.el

@@ -261,45 +261,43 @@ documentation of NAME and PLIST.")
   "Return non-nil when the current frame's background mode is light."
   (eq (frame-parameter nil 'background-mode) 'light))
 
-(defun tp-parse-color (color)
+(defun tp-parse-color (color &optional mode)
-  "Resolve COLOR to a color string for the current theme.
+  "Resolve COLOR to a color string for MODE or the current frame theme.
 COLOR may be:
 - a color string, returned as is: \"red\"
 - a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be
   nil, meaning no color for that mode
 - a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\")
-Return nil when COLOR is nil, or when the side selected by the
+MODE may be `light' or `dark'.  When MODE is nil, use the current
-current theme is nil.  When the theme cannot be determined, fall
+frame's background mode.  Return nil when COLOR is nil, or when the
-back to the light color."
+selected side is nil.  An unknown frame mode falls back to `light'."
-  (cond ((stringp color) color)
+  (let ((mode (or mode (if (tp-theme-dark-p) 'dark 'light))))
+    (unless (memq mode '(light dark))
+      (signal 'wrong-type-argument (list '(member light dark) mode)))
+    (cond ((stringp color) color)
         ((and (consp color)
               (or (stringp (car color)) (null (car color)))
               (or (stringp (cdr color)) (null (cdr color))))
-         (cond
+         (if (eq mode 'dark) (cdr color) (car color)))
-          ((tp-theme-light-p) (car color))
-          ((tp-theme-dark-p) (cdr color))
-          ;; Default to light color when background-mode is unknown
-          (t (car color))))
         ((and (tp-palette--plistp color)
               (or (plist-member color :light)
                   (plist-member color :dark)))
-         (cond
+         (if (eq mode 'dark)
-          ((tp-theme-light-p) (plist-get color :light))
+             (plist-get color :dark)
-          ((tp-theme-dark-p) (plist-get color :dark))
+           (plist-get color :light)))
-          ;; Default to light color when background-mode is unknown
-          (t (plist-get color :light))))
         ((null color) nil)
-        (t (error "Invalid format of color %S" color))))
+        (t (error "Invalid format of color %S" color)))))
 
-(defun tp-palette--get-color (symbol key)
+(defun tp-palette--get-color (symbol key &optional mode)
-  "Get color value for KEY from the palette named SYMBOL.
+  "Get color value for KEY from palette SYMBOL, resolving MODE.
 SYMBOL is looked up in `tp-palette-alist'.  KEY should be one of
 :fg, :bg, or :border.  Return nil if SYMBOL names no registered
 palette or its definition doesn't contain KEY.
-The public entry point delegating here is `tp-palette-color'."
+The public entry points are `tp-palette-color' and
+`tp-palette-color-for-mode'."
   (let ((plist (alist-get symbol tp-palette-alist)))
     (when (tp-palette--plistp plist)
-      (tp-parse-color (plist-get plist key)))))
+      (tp-parse-color (plist-get plist key) mode))))
 
 (defun tp-palette-color (symbol key)
   "Return the KEY color of the palette named SYMBOL, theme-resolved.
@@ -317,6 +315,14 @@ conveniences equivalent to calling it with a fixed KEY.  See also
 color."
   (tp-palette--get-color symbol key))
 
+(defun tp-palette-color-for-mode (symbol key mode)
+  "Return palette SYMBOL KEY resolved explicitly for MODE.
+MODE must be `light' or `dark'.  Unlike `tp-palette-color', this
+function does not inspect the selected frame, so a higher-level
+application Theme can switch palettes without changing the Emacs
+frame's own background mode."
+  (tp-palette--get-color symbol key mode))
+
 (defun tp-palette-has-p (symbol &optional kind)
   "Return non-nil when KIND is available in SYMBOL's palette.
 With nil KIND, test only that SYMBOL names a palette registered in

tp-reactive.el

@@ -490,6 +490,55 @@ or `retain'."
      (lambda () (tp--bind-in-transaction
                  owner key compute equality lifecycle)))))
 
+(defun tp--bind-precomputed-in-transaction
+    (owner key compute value dependencies equality lifecycle)
+  "Install one new initialized binding with explicit DEPENDENCIES."
+  (let ((table (tp--owner-binding-table owner t)))
+    (when (gethash key table)
+      (signal 'tp-reactive-error (list :precomputed-binding-exists key)))
+    (dolist (dependency dependencies)
+      (cond ((tp-signal-p dependency) (tp--validate-live-signal dependency))
+            ((tp-binding-p dependency) (tp--validate-live-binding dependency))
+            (t (signal 'wrong-type-argument
+                       (list '(or tp-signal-p tp-binding-p) dependency)))))
+    (let ((binding
+           (tp--make-binding
+            :id (cl-incf tp--binding-id-counter)
+            :owner owner :key (tp--copy-property-value key) :compute compute
+            :equality equality :last-value value :initialized-p t
+            :dependencies (copy-sequence dependencies)
+            :subscribers (make-hash-table :test #'eq)
+            :dirty nil :state 'clean :revision 1 :lifecycle lifecycle)))
+      (tp--register-binding binding)
+      (push binding tp--transaction-created-bindings)
+      (dolist (dependency dependencies)
+        (tp--subscription-add dependency binding))
+      (when tp--binding-touch-function
+        (funcall tp--binding-touch-function binding))
+      binding)))
+
+(cl-defun tp-bind-precomputed
+    (owner key compute value dependencies
+           &key (equality #'equal) (lifecycle 'delete))
+  "Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
+COMPUTE remains the authoritative recomputation function after any dependency
+changes.  This entry avoids evaluating COMPUTE merely to rediscover a value
+and graph edges already produced by a compiler or pure projection pass."
+  (when (null owner)
+    (signal 'tp-reactive-error (list :owner owner)))
+  (when (null key)
+    (signal 'tp-reactive-error (list :binding-key key)))
+  (tp--validate-binding-options compute equality lifecycle)
+  (unless (proper-list-p dependencies)
+    (signal 'wrong-type-argument (list 'proper-list-p dependencies)))
+  (if tp--transaction-active
+      (tp--bind-precomputed-in-transaction
+       owner key compute value dependencies equality lifecycle)
+    (tp--call-with-transaction
+     (lambda ()
+       (tp--bind-precomputed-in-transaction
+        owner key compute value dependencies equality lifecycle)))))
+
 (defun tp--detach-binding-dependencies (binding)
   "Remove BINDING from all dependency subscriber tables."
   (dolist (dependency (tp-binding-dependencies binding))

tp-style.el

@@ -28,6 +28,13 @@
 (cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
   function)
 
+(cl-defstruct (tp-paint-slot (:constructor tp--make-paint-slot))
+  "Stable named-face address for one mutable paint contribution."
+  face spec installed-p)
+
+(defvar tp--paint-slot-counter 0
+  "Monotonic id source for private paint-slot faces.")
+
 (defconst tp--property-policy-option-keys
   '(:normalizer :validator :equality :merge :projector)
   "Accepted property policy option keys.")
@@ -41,6 +48,92 @@
 (defvar tp--named-styles (make-hash-table :test #'eq)
   "Named direct declaration sets.")
 
+(defun tp--paint-slot-face-spec (spec)
+  "Return validated face SPEC for a paint slot."
+  (unless (and (listp spec) (zerop (% (length spec) 2))
+               (cl-loop for key in spec by #'cddr always (keywordp key)))
+    (signal 'tp-invalid-declaration (list :paint-slot spec)))
+  (copy-tree spec))
+
+;;;###autoload
+(defun tp-paint-slot-create (spec)
+  "Create a stable paint slot initialized from anonymous face SPEC."
+  (let* ((face (intern (format "tp-paint-slot-%d"
+                               (cl-incf tp--paint-slot-counter))))
+         (slot (tp--make-paint-slot
+                :face face :spec (tp--paint-slot-face-spec spec)
+                :installed-p nil)))
+    (make-face face)
+    slot))
+
+;;;###autoload
+(defun tp-paint-slot-update (slot spec)
+  "Update SLOT to anonymous face SPEC without changing its address."
+  (unless (tp-paint-slot-p slot)
+    (signal 'wrong-type-argument (list 'tp-paint-slot-p slot)))
+  (let* ((face (tp-paint-slot-face slot))
+         (next (tp--paint-slot-face-spec spec))
+         (previous (tp-paint-slot-spec slot)))
+    (condition-case err
+        (progn
+          (face-spec-reset-face face)
+          (when next
+            (face-spec-set face `((t ,next))))
+          (setf (tp-paint-slot-spec slot) next))
+      (error
+       (face-spec-reset-face face)
+       (when previous
+         (face-spec-set face `((t ,previous))))
+       (signal (car err) (cdr err))))
+    slot))
+
+(defun tp-paint-slot-apply-updates (buffer updates)
+  "Apply `(SLOT . SPEC)' UPDATES to BUFFER in one face-remap swap.
+Return a rollback journal containing the previous buffer map and slot specs."
+  (unless (buffer-live-p buffer)
+    (signal 'wrong-type-argument (list 'buffer-live-p buffer)))
+  (let ((normalized
+         (mapcar
+          (lambda (entry)
+            (unless (tp-paint-slot-p (car entry))
+              (signal 'wrong-type-argument
+                      (list 'tp-paint-slot-p (car entry))))
+            (cons (car entry) (tp--paint-slot-face-spec (cdr entry))))
+          updates))
+        slot-journal next)
+    (with-current-buffer buffer
+      (setq next (copy-tree face-remapping-alist))
+      (dolist (entry normalized)
+        (let* ((slot (car entry))
+               (spec (cdr entry))
+               (face (tp-paint-slot-face slot)))
+          (push (list slot (copy-tree (tp-paint-slot-spec slot))
+                      (tp-paint-slot-installed-p slot))
+                slot-journal)
+          (setq next (assq-delete-all face next))
+          (when spec
+            (push (list face spec) next))
+          (setf (tp-paint-slot-spec slot) spec
+                (tp-paint-slot-installed-p slot) t)))
+      (prog1
+          (list :buffer buffer
+                :face-remapping-alist (copy-tree face-remapping-alist)
+                :slot-specs (nreverse slot-journal))
+        (setq-local face-remapping-alist next)))))
+
+(defun tp-paint-slot-rollback-updates (journal)
+  "Restore paint slots from reverse-safe JOURNAL."
+  (when-let ((buffer (plist-get journal :buffer)))
+    (when (buffer-live-p buffer)
+      (with-current-buffer buffer
+        (setq-local face-remapping-alist
+                    (copy-tree
+                     (plist-get journal :face-remapping-alist))))))
+  (dolist (entry (reverse (plist-get journal :slot-specs)))
+    (setf (tp-paint-slot-spec (nth 0 entry)) (copy-tree (nth 1 entry))
+          (tp-paint-slot-installed-p (nth 0 entry)) (nth 2 entry)))
+  nil)
+
 (defun tp--canonical-property-id-p (id)
   "Return non-nil when ID is a namespaced property symbol."
   (and (symbolp id)
@@ -142,6 +235,10 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
     (signal 'wrong-type-argument (list 'functionp function)))
   (tp--make-computed-source :function function))
 
+(defun tp-computed-p (value)
+  "Return non-nil when VALUE is an explicit computed source."
+  (tp--computed-source-p value))
+
 ;;;###autoload
 (defun tp-resolve-value (value &optional _property _subject)
   "Resolve VALUE only when it is an explicit `tp-computed' source.

tp-surface.el

@@ -74,10 +74,23 @@ owned result is bound to OWNER-CONTEXT and consumed once during prepare."
                (:constructor tp--make-retained-content-candidate))
   "Candidate for a content-only update on an unchanged TP object tree.
 PLAN is the candidate's unchanged object topology with a new text leaf,
-RENDERED is the already-propertized candidate text, and RANGES are the
+RENDERED is the candidate text, RANGES are the candidate-owned content-range
-candidate-owned content-range attachments.  CONTEXT authenticates the
+attachments, and PROPERTY-CONTRIBUTIONS are ordered relative range property
-one-shot producer result to the active prepare transaction."
+layers composed by TP during prepare.  CONTEXT authenticates the one-shot
-  plan rendered ranges client-state context full-surface-p consumed-p)
+producer result to the active prepare transaction."
+  plan rendered ranges property-contributions client-state context
+  full-surface-p consumed-p)
+
+(cl-defstruct (tp-commit-batch (:constructor tp--make-commit-batch))
+  "One precomputed content commit for a stable retained surface topology."
+  base-revision target-revision base-extent target-extent patches
+  coordinate-patches client-state)
+
+(cl-defstruct (tp-commit-batch-candidate
+               (:constructor tp--make-commit-batch-candidate))
+  "One prepare-context-authenticated precomputed commit result."
+  batch context mount-specs exact-mount-specs-p client-state
+  exact-client-state-p reuse-mount-projection-p consumed-p)
 
 (cl-defstruct (tp-surface
                (:constructor tp--make-surface)
@@ -122,7 +135,8 @@ one-shot producer result to the active prepare transaction."
   surface context plan rendered mount-specs ledger-specs property-operations
   objects client-state producer initial created removed moved reconciled
   scope-objects scope-patches scope-fallback live-mounts live-mount-index
-  live-ledger report retained-content-p)
+  live-ledger report retained-content-p commit-batch
+  retained-mount-state-p mount-coordinate-updates mount-coordinate-undo)
 
 (cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot))
   plan objects mounts index mount-index ledger client-state producer revision
@@ -261,14 +275,17 @@ Use `tp-surface-result-create' for ordinary caller-owned plans."
    (tp--validate-surface-plan-tree plan) client-state t context))
 
 (defun tp-surface-retained-content-result-create
-    (context plan rendered ranges &optional client-state full-surface-p)
+    (context plan rendered ranges &optional client-state full-surface-p
+             property-contributions)
   "Create a one-shot retained content candidate for CONTEXT.
 PLAN must preserve the committed TP object topology and contain the new text
 leaf.  RENDERED is the final propertized text and RANGES are candidate-local
-content attachments already associated with PLAN's text leaf.  This entry
+content attachments already associated with PLAN's text leaf.
-point is intentionally narrow: callers must prove that object topology is
+PROPERTY-CONTRIBUTIONS is an ordered list of relative `:start', `:end', and
-unchanged; TP still validates every object, range, scope, and publication
+`:props' plists.  TP composes them over RENDERED using registered property
-phase before accepting the candidate."
+merge policy before diff and publication.  This entry point is intentionally
+narrow: callers must prove that object topology is unchanged; TP still
+validates every object, range, scope, and publication phase."
   (tp--validate-prepare-context context)
   (unless (eq context tp--current-prepare-context)
     (signal 'tp-owned-result-error
@@ -279,8 +296,53 @@ phase before accepting the candidate."
     (signal 'tp-invalid-surface-plan
             (list :retained-content plan rendered ranges)))
   (tp--make-retained-content-candidate
-   :plan plan :rendered rendered :ranges ranges :client-state client-state
+   :plan plan :rendered rendered :ranges ranges
-   :context context :full-surface-p full-surface-p))
+   :property-contributions property-contributions
+   :client-state client-state :context context
+   :full-surface-p full-surface-p))
+
+(defun tp--compose-relative-property-contributions (rendered contributions)
+  "Compose ordered relative CONTRIBUTIONS over RENDERED.
+Each contribution contains `:start', `:end', and direct `:props'."
+  (unless (proper-list-p contributions)
+    (signal 'tp-invalid-content-range
+            (list :property-contributions contributions)))
+  (let ((result (copy-sequence rendered))
+        (limit (length rendered)))
+    (dolist (contribution contributions)
+      (let ((start (plist-get contribution :start))
+            (end (plist-get contribution :end))
+            (props (plist-get contribution :props)))
+        (unless (and (integerp start) (integerp end)
+                     (<= 0 start) (<= start end) (<= end limit))
+          (signal 'tp-invalid-content-range
+                  (list :property-contribution contribution
+                        :leaf-length limit)))
+        (unless (tp--plist-shape-p props)
+          (signal 'tp-invalid-surface-plan
+                  (list :property-contribution-props props)))
+        (cl-loop for (property value) on props by #'cddr
+                 do
+                 (let ((position start)
+                       (merge
+                        (tp-property-policy-merge
+                         (tp-register-text-property property))))
+                   (while (< position end)
+                     (let* ((next
+                             (or (next-single-property-change
+                                  position property result end)
+                                 end))
+                            (cell
+                             (plist-member
+                              (text-properties-at position result) property))
+                            (target
+                             (cond
+                              ((null value) nil)
+                              (cell (funcall merge (cadr cell) value))
+                              (t (tp--copy-property-value value)))))
+                       (put-text-property position next property target result)
+                       (setq position next)))))))
+    result))
 
 (defun tp--property-value-equal-p (property left right)
   "Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal."
@@ -399,6 +461,36 @@ phase before accepting the candidate."
     (puthash object t (tp--context-touched context))
     object))
 
+(defun tp-object-ensure-at (context parent key kind position)
+  "Return candidate identity at explicit sibling POSITION below PARENT.
+KEYED objects retain their normal explicit-key identity; POSITION is used only
+for anonymous objects.  This is the compiled-topology entry point and does not
+depend on replaying preceding siblings to discover the same slot."
+  (tp--validate-prepare-context context)
+  (tp--validate-context-parent context parent)
+  (unless kind
+    (signal 'tp-invalid-surface-plan (list :kind kind)))
+  (unless (and (integerp position) (>= position 0))
+    (signal 'tp-invalid-surface-plan (list :position position)))
+  (let* ((segment
+          (if key
+              (let ((seen (tp--context-child-table context parent)))
+                (when (gethash key seen)
+                  (signal 'tp-duplicate-object-key (list key)))
+                (puthash key t seen)
+                key)
+            (list :position position :kind kind)))
+         (path (append (and parent (tp--surface-object-path parent))
+                       (list segment)))
+         (objects (tp--context-objects context))
+         (old (gethash path objects))
+         (object (if (and old (equal kind (tp--surface-object-kind old)))
+                     old
+                   (tp--new-candidate-object context parent key kind path))))
+    (puthash path object objects)
+    (puthash object t (tp--context-touched context))
+    object))
+
 (defun tp-object-live-p (object)
   "Return non-nil when OBJECT is committed on a live surface."
   (and (tp-object-p object) (tp--surface-object-live object)
@@ -472,6 +564,27 @@ When EPHEMERAL is non-nil, no identity may be promoted."
   (puthash object t (tp--context-retained context))
   object)
 
+(defun tp-object-reuse (context object)
+  "Reuse one proven unchanged live OBJECT in CONTEXT.
+The object and its live bindings remain in the candidate without being marked
+as touched.  The caller owns the proof that identity, parent path, output, and
+lifecycle are unchanged."
+  (tp--validate-prepare-context context)
+  (unless (tp-object-p object)
+    (signal 'wrong-type-argument (list 'tp-object-p object)))
+  (let* ((surface (tp--context-surface context))
+         (path (tp--surface-object-path object))
+         (objects (tp--context-objects context)))
+    (unless (and (tp-object-live-p object)
+                 (eq (tp--surface-object-surface object) surface)
+                 (eq object (gethash path objects)))
+      (signal 'tp-stale-object (list object)))
+    (puthash object t (tp--context-retained context))
+    (dolist (binding (tp-binding-owner-bindings object))
+      (when (tp-binding-live-p binding)
+        (puthash binding t (tp--context-bindings context)))))
+  object)
+
 (defun tp--object-path-prefix-p (prefix path)
   "Return non-nil when PREFIX is a path prefix of PATH."
   (and (<= (length prefix) (length path))
@@ -730,9 +843,12 @@ OWNED-P transfers candidate-local property values through the render pass."
   (let ((expected (make-hash-table :test #'equal))
         (actual (make-hash-table :test #'equal)))
     (dolist (path (tp--plan-paths plan)) (puthash path t expected))
-    (maphash (lambda (object _present)
+    (maphash
-               (puthash (tp--surface-object-path object) object actual))
+     (lambda (_path object)
-             (tp--context-touched context))
+       (when (or (gethash object (tp--context-touched context))
+                 (gethash object (tp--context-retained context)))
+         (puthash (tp--surface-object-path object) object actual)))
+     (tp--context-objects context))
     (maphash
      (lambda (path _present)
        (unless (gethash path actual)
@@ -765,6 +881,16 @@ OWNED-P transfers candidate-local property values through the render pass."
 (defun tp--producer-result (value surface options context)
   "Normalize producer VALUE for SURFACE and active CONTEXT using OPTIONS."
   (cond
+   ((tp-commit-batch-candidate-p value)
+    (unless (and context
+                 (tp--context-active context)
+                 (eq context tp--current-prepare-context)
+                 (eq context (tp-commit-batch-candidate-context value))
+                 (not (tp-commit-batch-candidate-consumed-p value)))
+      (signal 'tp-owned-result-error (list value context)))
+    (setf (tp-commit-batch-candidate-consumed-p value) t
+          (tp-commit-batch-candidate-context value) nil)
+    (list :commit-batch value))
    ((tp-retained-content-candidate-p value)
     (unless (and context
                  (tp--context-active context)
@@ -1243,7 +1369,10 @@ still validated and published through the ordinary TP transaction phases."
   (unless (eq (tp--surface-capability surface) 'content)
     (signal 'tp-capability-error (list :retained-content 'properties)))
   (let* ((plan (tp-retained-content-candidate-plan candidate))
-         (rendered (tp-retained-content-candidate-rendered candidate))
+         (rendered
+          (tp--compose-relative-property-contributions
+           (tp-retained-content-candidate-rendered candidate)
+           (tp-retained-content-candidate-property-contributions candidate)))
          (ranges (tp-retained-content-candidate-ranges candidate))
          (objects (tp--context-objects context))
          (root-path (list (tp--plan-segment plan 0)))
@@ -1283,7 +1412,7 @@ still validated and published through the ordinary TP transaction phases."
           (unless (<= end (length rendered))
             (signal 'tp-invalid-content-range
                     (list :start start :end end
-                          :leaf-length (length rendered)))))
+                          :leaf-length (length rendered))))))
       (puthash text-leaf ranges
                (tp--context-content-range-attachments context)))
     (let* ((length (length rendered))
@@ -1339,7 +1468,163 @@ still validated and published through the ordinary TP transaction phases."
        :reconciled 0 :scope-objects scope-objects
        :scope-patches scope-patches
        :scope-fallback (plist-get scope-analysis :fallback)
-       :retained-content-p retained-content-p)))))
+       :retained-content-p retained-content-p))))
+
+(defun tp--commit-batch-rebase-position (patches position end-p)
+  "Map old POSITION through ordered coordinate PATCHES.
+END-P selects the right boundary when POSITION lies inside a replacement."
+  (let ((delta 0) result)
+    (while (and patches (null result))
+      (let* ((patch (car patches))
+             (old-start (plist-get patch :old-start))
+             (old-end (plist-get patch :old-end))
+             (new-start (plist-get patch :new-start))
+             (new-end (plist-get patch :new-end)))
+        (cond
+         ((< position old-start) (setq result (+ position delta)))
+         ((= position old-start) (setq result new-start))
+         ((< position old-end) (setq result (if end-p new-end new-start)))
+         ((= position old-end) (setq result new-end))
+         (t (setq delta (- new-end old-end)
+                  patches (cdr patches))))))
+    (or result (+ position delta))))
+
+(defun tp--commit-batch-mount-specs (surface batch)
+  "Return SURFACE coordinate mounts rebased through BATCH."
+  (let ((base (marker-position (tp--surface-start surface))))
+    (mapcar
+     (lambda (mount)
+       (let ((start (- (tp--mount-position
+                        (tp--surface-mount-start mount)) base))
+             (end (- (tp--mount-position
+                      (tp--surface-mount-end mount)) base))
+             (patches (tp-commit-batch-coordinate-patches batch)))
+         (list :object (tp--surface-mount-object mount)
+               :start (tp--commit-batch-rebase-position patches start nil)
+               :end (tp--commit-batch-rebase-position patches end t)
+               :tags (copy-tree (tp--surface-mount-tags mount)))))
+     (tp--surface-mounts surface))))
+
+(defun tp--commit-batch-retained-mount-state
+    (surface mount-specs context target-extent)
+  "Return exact coordinate updates when SURFACE can retain MOUNT-SPECS.
+The returned cons distinguishes an exact empty update set from a proof miss."
+  (let ((base (marker-position (tp--surface-start surface)))
+        (mounts (tp--surface-mounts surface))
+        (specs mount-specs)
+        (retainable
+         (and (plist-get (tp--surface-options surface) :coordinate-mounts) t))
+        (updates
+         (and (plist-get (tp--surface-options surface) :coordinate-mounts)
+              (make-vector (* 3 (length mount-specs)) nil)))
+        (update-index 0))
+    (while specs
+      (let* ((spec (pop specs))
+             (mount (and mounts (pop mounts)))
+             (object (plist-get spec :object))
+             (start (plist-get spec :start))
+             (end (plist-get spec :end)))
+        (unless (and (tp-object-p object)
+                     (or (gethash object (tp--context-touched context))
+                         (gethash object (tp--context-retained context)))
+                     (integerp start) (integerp end)
+                     (<= 0 start end target-extent))
+          (signal 'tp-surface-error
+                  (list :commit-mount-range start end target-extent)))
+        (if (and retainable mount
+                 (integerp (tp--surface-mount-start mount))
+                 (integerp (tp--surface-mount-end mount))
+                 (eq (tp--surface-mount-object mount) object)
+                 (eq (tp--surface-mount-tags mount)
+                     (plist-get spec :tags)))
+            (progn
+              (aset updates update-index mount)
+              (aset updates (1+ update-index) (+ base start))
+              (aset updates (+ update-index 2) (+ base end))
+              (setq update-index (+ update-index 3)))
+          (setq retainable nil
+                updates nil))))
+    (when mounts (setq retainable nil))
+    (and retainable (cons t updates))))
+
+(defun tp--commit-batch-stable-object-set-p (surface objects)
+  "Return non-nil when OBJECTS are exactly SURFACE's retained identities."
+  (let ((live (tp--surface-objects surface)))
+    (and (hash-table-p live)
+         (= (hash-table-count live) (length objects))
+         (cl-every
+          (lambda (object)
+            (eq (gethash (tp--surface-object-path object) live) object))
+          objects))))
+
+(defun tp--commit-batch-coordinate-identity-p (batch)
+  "Return non-nil when BATCH cannot move any retained coordinate."
+  (and (= (tp-commit-batch-base-extent batch)
+          (tp-commit-batch-target-extent batch))
+       (cl-every
+        (lambda (patch)
+          (and (= (plist-get patch :old-start)
+                  (plist-get patch :new-start))
+               (= (plist-get patch :old-end)
+                  (plist-get patch :new-end))))
+        (tp-commit-batch-coordinate-patches batch))))
+
+(defun tp--prepare-commit-batch
+    (surface candidate context scope-objects input initial)
+  "Prepare strict equal-coordinate CANDIDATE for stable SURFACE topology."
+  (when initial
+    (signal 'tp-invalid-surface-plan (list :commit-batch-initial t)))
+  (unless (and (eq (tp--surface-capability surface) 'content)
+               (plist-get (tp--surface-options surface) :coordinate-mounts))
+    (signal 'tp-capability-error (list :commit-batch-coordinate-surface)))
+  (let* ((batch (tp-commit-batch-candidate-batch candidate))
+         (extent (- (marker-position (tp--surface-end surface))
+                    (marker-position (tp--surface-start surface))))
+         (objects (tp--candidate-object-list context))
+         (reuse-mount-projection-p
+          (tp-commit-batch-candidate-reuse-mount-projection-p candidate))
+         (coordinate-identity-p
+          (and (not reuse-mount-projection-p)
+               (not (tp-commit-batch-candidate-exact-mount-specs-p candidate))
+               (tp--commit-batch-coordinate-identity-p batch)))
+         (mount-specs
+          (cond
+           ((tp-commit-batch-candidate-exact-mount-specs-p candidate)
+            (tp-commit-batch-candidate-mount-specs candidate))
+           (reuse-mount-projection-p nil)
+           (coordinate-identity-p nil)
+           (t (tp--commit-batch-mount-specs surface batch))))
+         (retained-mount-state
+          (if (or reuse-mount-projection-p coordinate-identity-p)
+              (cons t [])
+            (tp--commit-batch-retained-mount-state
+             surface mount-specs context
+             (tp-commit-batch-target-extent batch)))))
+    (unless (and (= (tp-commit-batch-base-revision batch)
+                    (tp--surface-revision surface))
+                 (= (tp-commit-batch-target-revision batch)
+                    (1+ (tp--surface-revision surface)))
+                 (= extent (tp-commit-batch-base-extent batch))
+                 (or (not reuse-mount-projection-p)
+                     (= (tp-commit-batch-base-extent batch)
+                        (tp-commit-batch-target-extent batch))))
+      (signal 'tp-surface-error (list :unsupported-commit-batch batch)))
+    (unless (tp--commit-batch-stable-object-set-p surface objects)
+      (signal 'tp-orphan-object (list :commit-batch-object-set)))
+    (tp--make-prepared-surface
+     :surface surface :context context :plan (tp--surface-plan surface)
+     :rendered nil :mount-specs mount-specs
+     :objects objects
+     :client-state
+     (if (tp-commit-batch-candidate-exact-client-state-p candidate)
+         (tp-commit-batch-candidate-client-state candidate)
+       (tp-commit-batch-client-state batch))
+     :producer input :initial nil :created nil :removed nil :moved 0
+     :reconciled 0 :scope-objects scope-objects
+     :scope-patches (tp-commit-batch-patches batch)
+     :scope-fallback nil :commit-batch batch
+     :retained-mount-state-p (and retained-mount-state t)
+     :mount-coordinate-updates (cdr retained-mount-state))))
 
 (defun tp--prepare-surface (surface input options initial)
   "Prepare INPUT for SURFACE without publishing it.
@@ -1362,11 +1647,15 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication."
                 surface
                 (lambda ()
                   (tp--prepare-input surface input options context)))))
-          (if (eq (car normalized) :retained-content)
+          (if (memq (car normalized) '(:retained-content :commit-batch))
               (setq result
-                    (tp--prepare-retained-content
+                    (if (eq (car normalized) :retained-content)
-                     surface (cadr normalized) context scope-objects
+                        (tp--prepare-retained-content
-                     scope-options initial))
+                         surface (cadr normalized) context scope-objects
+                         scope-options initial)
+                      (tp--prepare-commit-batch
+                       surface (cadr normalized) context scope-objects
+                       input initial)))
             (let* ((plan (nth 0 normalized))
                    (client-state (nth 1 normalized))
                    (owned-p (nth 2 normalized))
@@ -1665,6 +1954,199 @@ MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
   (tp--validate-live-surface surface)
   (tp--surface-client-state surface))
 
+(cl-defun tp-commit-batch-create
+    (&key base-revision target-revision base-extent target-extent
+          patches coordinate-patches client-state)
+  "Create a validated precomputed content commit batch.
+PATCHES are ordered plists containing :old-start, :old-end, :new-start,
+:new-end, and a propertized :replacement string."
+  (unless (and (integerp base-revision) (>= base-revision 0)
+               (integerp target-revision)
+               (= target-revision (1+ base-revision)))
+    (signal 'tp-surface-error
+            (list :commit-revision base-revision target-revision)))
+  (unless (and (integerp base-extent) (>= base-extent 0)
+               (integerp target-extent) (>= target-extent 0)
+               (proper-list-p patches) (proper-list-p coordinate-patches))
+    (signal 'tp-surface-error
+            (list :commit-extents base-extent target-extent)))
+  (let ((old-cursor 0) (new-cursor 0) copy coordinate-copy)
+    (dolist (patch patches)
+      (let ((old-start (plist-get patch :old-start))
+            (old-end (plist-get patch :old-end))
+            (new-start (plist-get patch :new-start))
+            (new-end (plist-get patch :new-end))
+            (replacement (plist-get patch :replacement)))
+        (unless (and (integerp old-start) (integerp old-end)
+                     (integerp new-start) (integerp new-end)
+                     (<= old-cursor old-start old-end base-extent)
+                     (<= new-cursor new-start new-end target-extent)
+                     (= (- old-start old-cursor)
+                        (- new-start new-cursor))
+                     (stringp replacement)
+                     (= (length replacement) (- new-end new-start)))
+          (signal 'tp-surface-error (list :commit-patch patch)))
+        (push (copy-tree patch) copy)
+        (setq old-cursor old-end new-cursor new-end)))
+    (unless (= (- base-extent old-cursor)
+               (- target-extent new-cursor))
+      (signal 'tp-surface-error
+              (list :commit-tail old-cursor new-cursor)))
+    (setq old-cursor 0 new-cursor 0)
+    (dolist (patch coordinate-patches)
+      (let ((old-start (plist-get patch :old-start))
+            (old-end (plist-get patch :old-end))
+            (new-start (plist-get patch :new-start))
+            (new-end (plist-get patch :new-end)))
+        (unless (and (integerp old-start) (integerp old-end)
+                     (integerp new-start) (integerp new-end)
+                     (<= old-cursor old-start old-end base-extent)
+                     (<= new-cursor new-start new-end target-extent)
+                     (= (- old-start old-cursor)
+                        (- new-start new-cursor)))
+          (signal 'tp-surface-error
+                  (list :commit-coordinate-patch patch)))
+        (push (copy-tree patch) coordinate-copy)
+        (setq old-cursor old-end new-cursor new-end)))
+    (unless (= (- base-extent old-cursor)
+               (- target-extent new-cursor))
+      (signal 'tp-surface-error
+              (list :commit-coordinate-tail old-cursor new-cursor)))
+    (tp--make-commit-batch
+     :base-revision base-revision :target-revision target-revision
+     :base-extent base-extent :target-extent target-extent
+     :patches (nreverse copy)
+     :coordinate-patches (nreverse coordinate-copy)
+     :client-state (tp--copy-property-value client-state))))
+
+(cl-defun tp-commit-batch-result-create
+    (context batch
+             &key (mount-specs nil mount-specs-p)
+             (client-state nil client-state-p)
+             reuse-mount-projection)
+  "Return one authenticated producer result carrying precomputed BATCH.
+When MOUNT-SPECS is supplied, it is the complete target coordinate projection
+for the batch.  Each spec contains `:object', `:start', `:end', and optional
+`:tags'.  When CLIENT-STATE is supplied, it replaces BATCH's defensive state
+snapshot.  The active prepare context owns and transfers these candidate
+values without another materialization.  REUSE-MOUNT-PROJECTION asserts that
+the producer proved the complete target mount topology and coordinates equal
+to the committed projection, as with `tp-object-reuse-subtree'."
+  (unless (and (tp-prepare-context-p context)
+               (tp--context-active context)
+               (eq context tp--current-prepare-context)
+               (tp-commit-batch-p batch))
+    (signal 'tp-owned-result-error (list :commit-batch context batch)))
+  (when (and mount-specs-p reuse-mount-projection)
+    (signal 'tp-surface-error (list :conflicting-commit-mount-projection)))
+  (when mount-specs-p
+    (unless (proper-list-p mount-specs)
+      (signal 'tp-surface-error (list :commit-mount-specs))))
+  (tp--make-commit-batch-candidate
+   :batch batch :context context :mount-specs mount-specs
+   :exact-mount-specs-p mount-specs-p :client-state client-state
+   :exact-client-state-p client-state-p
+   :reuse-mount-projection-p (and reuse-mount-projection t)))
+
+(defun tp--commit-batch-apply-patches (surface batch)
+  "Apply BATCH's already validated patches to SURFACE."
+  (let ((buffer (tp--surface-buffer surface))
+        (base (marker-position (tp--surface-start surface))))
+    (with-current-buffer buffer
+      (save-restriction
+        (widen)
+        (let ((inhibit-read-only
+               (plist-get (tp--surface-options surface)
+                          :inhibit-read-only)))
+          (dolist (patch (reverse (tp-commit-batch-patches batch)))
+            (let ((start (+ base (plist-get patch :old-start)))
+                  (end (+ base (plist-get patch :old-end)))
+                  (replacement (plist-get patch :replacement)))
+              (delete-region start end)
+              (goto-char start)
+              (insert replacement))))))
+    (set-marker (tp--surface-start surface) base buffer)
+    (set-marker (tp--surface-end surface)
+                (+ base (tp-commit-batch-target-extent batch)) buffer)))
+
+(defun tp--commit-batch-validate-buffer (surface batch)
+  "Validate BATCH's published extent and changed spans on SURFACE."
+  (let ((buffer (tp--surface-buffer surface))
+        (base (marker-position (tp--surface-start surface))))
+    (let ((actual (- (marker-position (tp--surface-end surface)) base))
+          (expected (tp-commit-batch-target-extent batch)))
+      (unless (= actual expected)
+        (signal 'tp-publication-mismatch
+                (list :commit-extent :actual actual :expected expected))))
+    (dolist (patch (tp-commit-batch-patches batch))
+      (let ((start (+ base (plist-get patch :new-start)))
+            (end (+ base (plist-get patch :new-end)))
+            (replacement (plist-get patch :replacement)))
+        (unless (equal-including-properties
+                 (with-current-buffer buffer (buffer-substring start end))
+                 replacement)
+          (signal 'tp-publication-mismatch
+                  (list :commit-patch patch)))))))
+
+(defun tp--commit-batch-validate-mounts (surface batch mounts)
+  "Validate target MOUNTS for BATCH inside SURFACE."
+  (let ((base (marker-position (tp--surface-start surface)))
+        (limit (+ (marker-position (tp--surface-start surface))
+                  (tp-commit-batch-target-extent batch))))
+    (dolist (mount mounts)
+      (let ((start (tp--mount-position (tp--surface-mount-start mount)))
+            (end (tp--mount-position (tp--surface-mount-end mount))))
+        (unless (and start end (<= base start end limit))
+          (signal 'tp-publication-mismatch
+                  (list :commit-mount mount)))))))
+
+;;;###autoload
+(defun tp-surface-commit-batch (surface batch)
+  "Atomically apply precomputed BATCH to stable content SURFACE."
+  (tp--validate-live-surface surface)
+  (unless (and (tp-commit-batch-p batch)
+               (eq (tp--surface-capability surface) 'content)
+               (= (tp--surface-revision surface)
+                  (tp-commit-batch-base-revision batch))
+               (= (- (marker-position (tp--surface-end surface))
+                     (marker-position (tp--surface-start surface)))
+                  (tp-commit-batch-base-extent batch)))
+    (signal 'tp-surface-error (list :stale-commit-batch surface batch)))
+  (let* ((buffer (tp--surface-buffer surface))
+         (old-revision (tp--surface-revision surface))
+         (old-client-state (tp--surface-client-state surface))
+         (old-report (tp--surface-report surface))
+         (views (tp--capture-view-state (list buffer)))
+         (group (tp--prepare-change-group-for-buffers (list buffer)))
+         success)
+    (unwind-protect
+        (progn
+          (tp--commit-batch-apply-patches surface batch)
+          (tp--commit-batch-validate-buffer surface batch)
+          (tp--commit-batch-validate-mounts
+           surface batch (tp--surface-mounts surface))
+          (setf (tp--surface-client-state surface)
+                (tp-commit-batch-client-state batch)
+                (tp--surface-revision surface)
+                (tp-commit-batch-target-revision batch)
+                (tp--surface-report surface)
+                (list :transaction-id (cl-incf tp--surface-transaction-id)
+                      :surface-id (tp--surface-id surface)
+                      :old-revision old-revision
+                      :new-revision (tp-commit-batch-target-revision batch)
+                      :text-operations (length (tp-commit-batch-patches batch))
+                      :property-operations 0 :commit-batch t
+                      :rolled-back nil :failure nil))
+          (accept-change-group group)
+          (setq success t)
+          (tp-surface-report surface))
+      (unless success
+        (tp--cancel-change-group-safely group)
+        (setf (tp--surface-client-state surface) old-client-state
+              (tp--surface-revision surface) old-revision
+              (tp--surface-report surface) old-report))
+      (tp--restore-view-state views))))
+
 (defun tp--validate-surface-buffer (surface initial)
   "Validate SURFACE's buffer before prepare; INITIAL permits a candidate."
   (let ((buffer (tp--surface-buffer surface)))
@@ -2233,6 +2715,48 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
           (tp--prepared-surface-live-ledger prepared) ledger)
     mounts))
 
+(defun tp--retain-candidate-mount-state (prepared)
+  "Apply PREPARED coordinate updates while retaining mount identity and index."
+  (let* ((surface (tp--prepared-surface-surface prepared))
+         (mounts (tp--surface-mounts surface))
+         (updates (tp--prepared-surface-mount-coordinate-updates prepared))
+         (undo (make-vector (* 2 (/ (length updates) 3)) nil))
+         (update-index 0)
+         (undo-index 0))
+    (while (< update-index (length updates))
+      (let ((mount (aref updates update-index)))
+        (aset undo undo-index (tp--surface-mount-start mount))
+        (aset undo (1+ undo-index) (tp--surface-mount-end mount))
+        (setf (tp--surface-mount-start mount)
+              (aref updates (1+ update-index))
+              (tp--surface-mount-end mount)
+              (aref updates (+ update-index 2)))
+        (setq update-index (+ update-index 3)
+              undo-index (+ undo-index 2))))
+    (setf (tp--prepared-surface-mount-coordinate-undo prepared)
+          undo
+          (tp--prepared-surface-live-mounts prepared) mounts
+          (tp--prepared-surface-live-mount-index prepared)
+          (tp--surface-mount-index surface)
+          (tp--prepared-surface-live-ledger prepared)
+          (tp--surface-ledger surface))
+    mounts))
+
+(defun tp--restore-retained-mount-state (prepared)
+  "Restore PREPARED retained mount coordinates after rollback."
+  (let ((updates (tp--prepared-surface-mount-coordinate-updates prepared))
+        (undo (tp--prepared-surface-mount-coordinate-undo prepared))
+        (update-index 0)
+        (undo-index 0))
+    (when (and (vectorp updates) (vectorp undo))
+      (while (< update-index (length updates))
+        (let ((mount (aref updates update-index)))
+          (setf (tp--surface-mount-start mount) (aref undo undo-index)
+                (tp--surface-mount-end mount) (aref undo (1+ undo-index)))
+          (setq update-index (+ update-index 3)
+                undo-index (+ undo-index 2))))))
+  (setf (tp--prepared-surface-mount-coordinate-undo prepared) nil))
+
 (defun tp--surface-snapshot (surface)
   "Return a rollback snapshot of SURFACE side state."
   (tp--make-surface-snapshot
@@ -2261,12 +2785,15 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
          (fallback (tp--prepared-surface-scope-fallback prepared))
          (patches (tp--prepared-surface-scope-patches prepared))
          (touched
-          (if (and scoped (not fallback))
+          (if-let ((batch (tp--prepared-surface-commit-batch prepared)))
+              (cl-loop for patch in (tp-commit-batch-patches batch)
+                       sum (length (plist-get patch :replacement)))
+            (if (and scoped (not fallback))
               (cl-loop for patch in patches
                        sum (if (eq (tp--surface-capability surface) 'content)
                                (length (plist-get patch :replacement))
                              (- (cdr patch) (car patch))))
-            (length (tp--prepared-surface-rendered prepared)))))
+              (length (tp--prepared-surface-rendered prepared))))))
     (list :transaction-id tp--surface-transaction-id
           :surface-id (tp--surface-id surface)
           :old-revision old-revision :new-revision new-revision
@@ -2287,6 +2814,9 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
           :scope-range-count (and scoped (length patches))
           :scope-fallback fallback
           :property-conflicts nil :rolled-back nil
+          :commit-batch (and (tp--prepared-surface-commit-batch prepared) t)
+          :retained-mount-state
+          (and (tp--prepared-surface-retained-mount-state-p prepared) t)
           :failure nil :observer-errors nil :timing nil)))
 
 (defun tp--scoped-content-ranges (patches)
@@ -2363,6 +2893,15 @@ the generic property-operation ledger."
 
 (defun tp--publish-buffer-content (prepared)
   "Publish PREPARED's text and properties, returning operation counts."
+  (cl-block publish
+    (when-let ((batch (tp--prepared-surface-commit-batch prepared)))
+      (let ((surface (tp--prepared-surface-surface prepared)))
+        (tp--commit-batch-apply-patches surface batch)
+        (tp--publication-step 'text surface)
+        (tp--commit-batch-validate-buffer surface batch)
+        (tp--publication-step 'property surface)
+        (cl-return-from publish
+          (cons (length (tp-commit-batch-patches batch)) 0))))
   (let* ((surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
          (rendered (tp--prepared-surface-rendered prepared))
@@ -2399,7 +2938,7 @@ the generic property-operation ledger."
               (when (tp--prepared-surface-retained-content-p prepared)
                 (tp--publication-step 'property surface))))
             (goto-char (min point-before (point-max)))))
-      (cons text-operations (length property-operations))))))
+      (cons text-operations (length property-operations)))))))
 
 (defun tp--publish-buffer-properties (prepared)
   "Publish PREPARED's host-range property operations."
@@ -2430,7 +2969,10 @@ the generic property-operation ledger."
     (tp--promote-prepared-objects prepared)
     (setf (tp--surface-plan surface) (tp--prepared-surface-plan prepared)
           (tp--surface-objects surface)
-          (tp--surface-object-table (tp--prepared-surface-objects prepared))
+          (if (tp--prepared-surface-retained-mount-state-p prepared)
+              (tp--surface-objects surface)
+            (tp--surface-object-table
+             (tp--prepared-surface-objects prepared)))
           (tp--surface-mounts surface) mounts
           (tp--surface-index surface) mounts
           (tp--surface-mount-index surface)
@@ -2455,7 +2997,14 @@ the generic property-operation ledger."
          (counts (if (eq (tp--surface-capability surface) 'content)
                      (tp--publish-buffer-content prepared)
                    (tp--publish-buffer-properties prepared))))
-    (tp--create-candidate-mount-state prepared)
+    (if (tp--prepared-surface-retained-mount-state-p prepared)
+        (tp--retain-candidate-mount-state prepared)
+      (tp--create-candidate-mount-state prepared))
+    (when-let ((batch (and (not (tp--prepared-surface-retained-mount-state-p
+                                 prepared))
+                           (tp--prepared-surface-commit-batch prepared))))
+      (tp--commit-batch-validate-mounts
+       surface batch (tp--prepared-surface-live-mounts prepared)))
     (tp--publication-step 'marker surface)
     (tp--publication-step 'index surface)
     (tp--swap-surface-state prepared counts)
@@ -2627,6 +3176,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
 (defun tp--restore-surface-snapshot (prepared snapshot)
   "Restore PREPARED's surface from SNAPSHOT after failed publication."
   (let ((surface (tp--prepared-surface-surface prepared)))
+    (tp--restore-retained-mount-state prepared)
     (tp--dispose-content-mounts
      (tp--prepared-surface-live-mounts prepared))
     (tp--dispose-ledger (tp--prepared-surface-live-ledger prepared))
@@ -2729,6 +3279,36 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
   (when tp--surface-precommit-step-function
     (funcall tp--surface-precommit-step-function step state)))
 
+(defun tp--validate-retained-batch-precommit (prepared snapshot)
+  "Validate PREPARED retained batch from constant-time committed identities."
+  (let* ((surface (tp--prepared-surface-surface prepared))
+         (batch (tp--prepared-surface-commit-batch prepared))
+         (mounts (tp--surface-mounts surface))
+         (mount-index (tp--surface-mount-index surface)))
+    (tp--validate-live-surface surface)
+    (unless (and batch
+                 (eq (tp--surface-plan surface)
+                     (tp--prepared-surface-plan prepared))
+                 (eq (tp--surface-objects surface)
+                     (tp--surface-snapshot-objects snapshot))
+                 (eq mounts (tp--surface-snapshot-mounts snapshot))
+                 (eq mount-index
+                     (tp--surface-snapshot-mount-index snapshot))
+                 (eq (tp--surface-index surface) mounts)
+                 (eq (tp--prepared-surface-live-mounts prepared) mounts)
+                 (eq (tp--prepared-surface-live-mount-index prepared)
+                     mount-index)
+                 (= (tp--surface-revision surface)
+                    (tp-commit-batch-target-revision batch))
+                 (not (tp--context-active
+                       (tp--prepared-surface-context prepared)))
+                 (plist-get (tp--surface-report surface) :commit-batch)
+                 (plist-get (tp--surface-report surface)
+                            :retained-mount-state))
+      (signal 'tp-surface-error
+              (list :invalid-retained-batch-precommit
+                    (tp--surface-id surface))))))
+
 (defun tp--validate-surface-precommit (state)
   "Validate final published semantics and rollback ownership in STATE."
   (unless (and (gethash 'change-group state)
@@ -2746,15 +3326,18 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
     (unless (and (tp--prepared-surface-p (car entry))
                  (tp--surface-snapshot-p (cdr entry)))
       (signal 'tp-surface-error (list :invalid-surface-cleanup entry)))
-    (let* ((prepared (car entry))
+    (let ((prepared (car entry))
-           (surface (tp--prepared-surface-surface prepared))
+          (snapshot (cdr entry)))
-           (plan (tp--surface-plan surface))
+      (if (tp--prepared-surface-retained-mount-state-p prepared)
-           (objects (tp--surface-objects surface))
+          (tp--validate-retained-batch-precommit prepared snapshot)
-           (mounts (tp--surface-mounts surface))
+        (let* ((surface (tp--prepared-surface-surface prepared))
-           (mount-index (tp--surface-mount-index surface))
+               (plan (tp--surface-plan surface))
-           (capability (tp--surface-capability surface))
+               (objects (tp--surface-objects surface))
-           (mount-set (make-hash-table :test #'eq))
+               (mounts (tp--surface-mounts surface))
-           (indexed-mount-set (make-hash-table :test #'eq)))
+               (mount-index (tp--surface-mount-index surface))
+               (capability (tp--surface-capability surface))
+               (mount-set (make-hash-table :test #'eq))
+               (indexed-mount-set (make-hash-table :test #'eq)))
       (tp--validate-live-surface surface)
       (unless (eq plan (tp--prepared-surface-plan prepared))
         (signal 'tp-surface-error (list :invalid-published-plan surface)))
@@ -2823,31 +3406,32 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
                           (list :invalid-published-anchor mount))))
             (when (tp--surface-mount-anchor mount)
               (signal 'tp-surface-error
-                      (list :invalid-content-anchor mount)))))))
+                      (list :invalid-content-anchor mount)))))))))
   state))
 
 (defun tp--surface-prevalidate-cleanup (state)
   "Validate marker-backed cleanup lists retained in surface STATE."
   (dolist (entry (gethash 'snapshots state))
-    (let* ((prepared (car entry))
+    (let ((prepared (car entry)))
-           (snapshot (cdr entry))
+      (unless (tp--prepared-surface-retained-mount-state-p prepared)
-           (surface (tp--prepared-surface-surface prepared))
+        (let* ((snapshot (cdr entry))
-           (coordinate-p
+               (surface (tp--prepared-surface-surface prepared))
-            (plist-get (tp--surface-options surface) :coordinate-mounts)))
+               (coordinate-p
-      (dolist (mount (tp--surface-snapshot-mounts snapshot))
+                (plist-get (tp--surface-options surface) :coordinate-mounts)))
-        (when (eq (tp--surface-mount-capability mount) 'content)
+          (dolist (mount (tp--surface-snapshot-mounts snapshot))
-          (unless (or (and (markerp (tp--surface-mount-start mount))
+            (when (eq (tp--surface-mount-capability mount) 'content)
-                           (markerp (tp--surface-mount-end mount)))
+              (unless (or (and (markerp (tp--surface-mount-start mount))
-                      (and coordinate-p
+                               (markerp (tp--surface-mount-end mount)))
-                           (integerp (tp--surface-mount-start mount))
+                          (and coordinate-p
-                           (integerp (tp--surface-mount-end mount))))
+                               (integerp (tp--surface-mount-start mount))
-            (signal 'tp-surface-error
+                               (integerp (tp--surface-mount-end mount))))
-                    (list :invalid-mount-cleanup mount)))))
+                (signal 'tp-surface-error
-      (dolist (ledger (tp--surface-snapshot-ledger snapshot))
+                        (list :invalid-mount-cleanup mount)))))
-        (unless (and (markerp (tp--property-ledger-start ledger))
+          (dolist (ledger (tp--surface-snapshot-ledger snapshot))
-                     (markerp (tp--property-ledger-end ledger)))
+            (unless (and (markerp (tp--property-ledger-start ledger))
-          (signal 'tp-surface-error
+                         (markerp (tp--property-ledger-end ledger)))
-                  (list :invalid-ledger-cleanup ledger))))))
+              (signal 'tp-surface-error
+                      (list :invalid-ledger-cleanup ledger))))))))
   state)
 
 (defun tp--surface-final-accept ()
@@ -2873,12 +3457,13 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
               (let* ((prepared (car entry))
                      (snapshot (cdr entry))
                      (surface (tp--prepared-surface-surface prepared)))
-                (dolist (mounts
+                (unless (tp--prepared-surface-retained-mount-state-p prepared)
-                         (list (tp--surface-snapshot-mounts snapshot)
+                  (dolist (mounts
-                               (tp--surface-mounts surface)))
+                           (list (tp--surface-snapshot-mounts snapshot)
-                  (dolist (mount mounts)
+                                 (tp--surface-mounts surface)))
-                    (when-let ((anchor (tp--surface-mount-anchor mount)))
+                    (dolist (mount mounts)
-                      (push anchor anchors))))))
+                      (when-let ((anchor (tp--surface-mount-anchor mount)))
+                        (push anchor anchors)))))))
             (puthash 'anchor-undo
                      (tp--capture-anchor-ownership-undo (nreverse anchors))
                      state))
@@ -2886,9 +3471,10 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
             (let* ((prepared (car entry))
                    (snapshot (cdr entry))
                    (surface (tp--prepared-surface-surface prepared)))
-              (tp--apply-anchor-ownership
+              (unless (tp--prepared-surface-retained-mount-state-p prepared)
-               surface (tp--surface-snapshot-mounts snapshot)
+                (tp--apply-anchor-ownership
-               (tp--surface-mounts surface)))))
+                 surface (tp--surface-snapshot-mounts snapshot)
+                 (tp--surface-mounts surface))))))
         (tp--surface-precommit-step 'lifecycle state)
         (dolist (prepared all-prepared)
           (tp--finalize-object-lifecycle prepared)
@@ -3097,23 +3683,24 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
           (let* ((prepared (car entry))
                  (snapshot (cdr entry))
                  (surface (tp--prepared-surface-surface prepared)))
-            (dolist (anchor
+            (unless (tp--prepared-surface-retained-mount-state-p prepared)
-                     (tp--anchors-in-mounts
+              (dolist (anchor
-                      (tp--surface-snapshot-mounts snapshot)))
+                       (tp--anchors-in-mounts
-              (when (null (tp--anchor-surfaces anchor))
+                        (tp--surface-snapshot-mounts snapshot)))
-                (cleanup
+                (when (null (tp--anchor-surfaces anchor))
-                 surface (list 'old-anchor (tp--anchor-id anchor))
+                  (cleanup
-                 (lambda () (tp--dispose-anchor anchor)))))
+                   surface (list 'old-anchor (tp--anchor-id anchor))
-            (cleanup
+                   (lambda () (tp--dispose-anchor anchor)))))
-             surface 'old-mounts
+              (cleanup
-             (lambda ()
+               surface 'old-mounts
-               (tp--dispose-content-mounts
+               (lambda ()
-                (tp--surface-snapshot-mounts snapshot))))
+                 (tp--dispose-content-mounts
-            (cleanup
+                  (tp--surface-snapshot-mounts snapshot))))
-             surface 'old-ledger
+              (cleanup
-             (lambda ()
+               surface 'old-ledger
-               (tp--dispose-ledger
+               (lambda ()
-                (tp--surface-snapshot-ledger snapshot))))))
+                 (tp--dispose-ledger
+                  (tp--surface-snapshot-ledger snapshot)))))))
         (when-let ((table (gethash 'prepared state)))
           (dolist (prepared (tp--all-prepared-surfaces table))
             (let* ((surface (tp--prepared-surface-surface prepared))