diff --git a/docs/architecture.en.md b/docs/architecture.en.md index 3628897..3e64fc3 100644 --- a/docs/architecture.en.md +++ b/docs/architecture.en.md @@ -464,7 +464,9 @@ inside the Ebox framework callback and restores it through the same inverse journal on failure. A semantic-only change runs that CAS under ETAF ownership without creating an Ebox commit or TP revision. Mirror projection and obsolete route cleanup after CAS are postcommit work and cannot reverse the committed -token if they fail. +token if they fail. Such failures are retained in the retirement diagnostic +journal and re-signaled with the same committed trailer used by lifecycle +failures; they never re-enter semantic rollback. Each mounted Runtime also owns a distinct Host authority containing `state / opaque token / version`. The initial v2 framework stage enters only a @@ -507,17 +509,21 @@ settles across all touched contexts before any Runtime callback publishes. Within a context, each source and Effect is delivered once per scheduler turn, and multiple changed sources enqueue a Runtime once. A reentrant write to an already delivered source is deferred to the next turn; a per-context turn -budget contains cross-context cycles with reusable fault diagnostics. Dedupe -in one context never suppresses another, and registry/token/Host validation -filters stale Runtime routes before fan-out. +budget contains cross-context cycles with reusable fault diagnostics. A source +wave snapshots the current FIFO, so newly discovered distinct sources consume +another budgeted turn and cannot monopolize one drain. Dedupe in one context +never suppresses another, and registry/token/Host validation filters stale +Runtime routes before fan-out. Runtime callbacks are detached as a turn, so a lifecycle write enters the -following turn. Data success/error multi-ref publication and event/action -callbacks use this same projection boundary, while the legacy facade continues -through the default context. Data source failures update the Controller error -state; a later projection/render failure propagates unchanged and cannot be -reclassified as a source failure. Runtime operation reports include both the -local context deltas and full cross-context projection summaries for source +following turn. One failing callback is retained as the context fault only +after every later callback in that detached turn has run. Data success/error +multi-ref publication and event/action callbacks use this same projection +boundary, while the legacy facade continues through the default context. Data +source failures update the Controller error state; a later projection/render +failure propagates unchanged and cannot be reclassified as a source failure. +Runtime operation reports include both the local context deltas and full +cross-context projection summaries for source delivery, subscriber visits, effect work, Runtime work, stale drops, turns, and faults. diff --git a/docs/architecture.zh.md b/docs/architecture.zh.md index b65955b..aef2fbb 100644 --- a/docs/architecture.zh.md +++ b/docs/architecture.zh.md @@ -452,7 +452,8 @@ instance/resource/artifact/route store versions。render 路径在 Ebox framewor stage 中暂存一次 CAS,失败时由同一个 inverse journal 恢复;没有可见 Ebox 变化的 semantic-only 路径由 ETAF 自己执行同一 CAS,不创建 Ebox commit 或 TP revision。CAS 后的 mirror 与旧 route 清理属于 postcommit,失败不能反向恢复已提交 -token。 +token;这类失败会写入 retirement diagnostic journal,并用与 lifecycle failure +相同的 committed trailer 重新 signal,绝不会重新进入 semantic rollback。 每个 mounted Runtime 还拥有独立的 Host authority:`state / opaque token / version`。initial v2 framework stage 只进入 provisional state,并向 TP 注册固定 @@ -491,15 +492,18 @@ context。 Effect 每个 scheduler turn 只 delivery 一次,多个 changed source 也只 enqueue 同一 Runtime 一次。已经 delivery 的 source 若重入写入,会延后到下一个 turn; per-context turn budget 会包含跨 context cycle,并留下可复用的 fault diagnostics。 -context A 的 dedupe 不会压制 context B;registry/token/Host 校验会在 fan-out 前 -过滤 stale Runtime route。 +每个 source wave 都会 snapshot 当前 FIFO,因此 wave 中发现的不同 source 必须在 +下一个受预算约束的 turn 执行,不能垄断一次 drain。context A 的 dedupe 不会压制 +context B;registry/token/Host 校验会在 fan-out 前过滤 stale Runtime route。 Runtime callback 先作为一个完整 turn detach,因此 lifecycle write 会进入下一个 -turn。Data success/error 的 multi-ref publication 与 event/action callback 都复用 -同一个 projection boundary,legacy façade 则继续走 default context。Data source -failure 会更新 Controller error state;之后发生的 projection/render failure 保持 -原 condition,不能被重新归类为 source failure。Runtime operation report 同时携带 -本 context delta 与完整 cross-context projection summary,覆盖 source delivery、 +turn;某个 callback 失败时,scheduler 会先执行该 detached turn 中剩余 callback, +再把首个 condition 记录为 context fault。Data success/error 的 multi-ref +publication 与 event/action callback 都复用同一个 projection boundary,legacy +façade 则继续走 default context。Data source failure 会更新 Controller error state; +之后发生的 projection/render failure 保持原 condition,不能被重新归类为 source +failure。Runtime operation report 同时携带本 context delta 与完整 cross-context +projection summary,覆盖 source delivery、 subscriber visit、effect work、Runtime work、stale drop、turn 与 fault。 每次 Runtime flush 都记录 candidate-aware effect tuple:其中包含 generation id、 diff --git a/etaf-render-port.el b/etaf-render-port.el index 50e81a4..e665676 100644 --- a/etaf-render-port.el +++ b/etaf-render-port.el @@ -361,8 +361,8 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings." (buffer input framework-stage framework-rollback &optional observer) "Run selected initial operation for BUFFER and canonical INPUT. FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair. -OBSERVER, when non-nil, is installed while initial v2 publication remains -provisional so TP and Ebox acceptance reports are preserved." +OBSERVER, when non-nil, receives TP and Ebox snapshots measured during the +initial v2 publication and replayed only after successful final accept." (if (eq (etaf-render-port-route etaf-render-port--selected-port) 'v1) (funcall (etaf-render-port-initial-function etaf-render-port--selected-port) diff --git a/etaf-retirement.el b/etaf-retirement.el index a5ce16d..5429fea 100644 --- a/etaf-retirement.el +++ b/etaf-retirement.el @@ -19,6 +19,11 @@ (defvar etaf-retirement--journal-id-counter 0) (defvar etaf-retirement--entry-id-counter 0) +(defconst etaf-retirement--condition-payload-keys + '(:kind :committed-p :operation-id :outcome-id :generation-id :revision + :diagnostic-journal-id) + "Canonical ordered keys in a v1 postcommit condition payload.") + (cl-defstruct (etaf-retirement-entry (:constructor etaf-retirement-entry--create)) @@ -211,6 +216,27 @@ forms are equal, and a positive integer otherwise." (etaf-retirement-journal-state journal) 'completed) public-condition)) +(defun etaf-retirement-record-contained-failure + (journal owner kind condition) + "Append contained postcommit CONDITION metadata to JOURNAL. +OWNER and KIND identify the failed postcommit step. This records evidence +without rerunning the failed operation or changing committed authority." + (unless (and (etaf-retirement-journal-p journal) + (eq (etaf-retirement-journal-state journal) 'open) + owner kind + (consp condition) (symbolp (car condition))) + (signal 'etaf-retirement-error + (list :invalid-contained-failure owner kind condition))) + (push (list :entry-id (cl-incf etaf-retirement--entry-id-counter) + :owner (copy-tree owner) + :kind kind + :policy 'contained-once + :attempt-count 1 + :state 'failed-contained + :condition (copy-tree condition)) + (etaf-retirement-journal-diagnostics journal)) + condition) + (defun etaf-retirement-condition-trailer (journal &optional kind) "Return the canonical committed trailer for JOURNAL and optional KIND." (list @@ -234,13 +260,23 @@ forms are equal, and a positive integer otherwise." (eq (car trailer) :etaf-condition-trailer/v1) (cadr trailer)))) (when (and (proper-list-p payload) + (= (length payload) + (* 2 (length etaf-retirement--condition-payload-keys))) + (equal + (cl-loop for (key _value) on payload by #'cddr + collect key) + etaf-retirement--condition-payload-keys) (eq (plist-get payload :committed-p) t) (eq (plist-get payload :kind) 'postcommit) (integerp (plist-get payload :operation-id)) + (>= (plist-get payload :operation-id) 0) (plist-get payload :outcome-id) (integerp (plist-get payload :generation-id)) + (>= (plist-get payload :generation-id) 0) (integerp (plist-get payload :revision)) - (integerp (plist-get payload :diagnostic-journal-id))) + (>= (plist-get payload :revision) 0) + (integerp (plist-get payload :diagnostic-journal-id)) + (> (plist-get payload :diagnostic-journal-id) 0)) (copy-tree payload))))) (defun etaf-retirement-resignal (condition journal) diff --git a/etaf-runtime.el b/etaf-runtime.el index fc0d203..4915f8e 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -1317,6 +1317,15 @@ effect-to-source edges. It is intentionally immutable and suitable as an :generation-id (etaf-runtime-generation runtime) :revision (etaf-render-port-revision (etaf-runtime-buffer runtime)))) +(defun etaf--runtime-run-postcommit-step (journal owner kind function) + "Run FUNCTION after commit, recording its condition in JOURNAL. +OWNER and KIND identify the step. Return the original condition, or nil." + (condition-case condition + (progn (funcall function) nil) + ((error quit) + (etaf-retirement-record-contained-failure + journal owner kind condition)))) + (defun etaf--runtime-retain-retirement-journal (runtime journal) "Retain completed JOURNAL and its diagnostics on RUNTIME." (push journal (etaf-runtime-retirement-journals runtime)) @@ -6065,33 +6074,54 @@ RENDERED-IDENTITIES names the Component render participants." runtime retry-effect-ids) (signal (car err) (cdr err)))) (etaf--runtime-participant-commit participant) - (etaf--runtime-complete-generation runtime candidate-generation) - (etaf--runtime-install-generation-mirrors - runtime candidate-generation nil) - (etaf--runtime-clear-dirty-effects runtime) (let ((retirement (etaf--runtime-new-retirement-journal runtime (etaf-semantic-candidate-candidate-id semantic-candidate))) - updated) - (unwind-protect - (progn - (dolist (instance (etaf-runtime-candidate-created runtime)) - (setf (etaf--component-instance-mounted-p instance) t)) - (dolist (entry (etaf--generation-index-entries - candidate-generation 'lifecycle)) - (let ((identity (car entry))) - (when-let* ((semantic (etaf--generation-semantic old identity)) - (instance - (gethash - (etaf--semantic-component-resource-key semantic) - (etaf-runtime-resource-registry runtime)))) - (push instance updated)))) - (etaf--runtime-run-lifecycle - (list (etaf-runtime-candidate-created runtime) - (nreverse updated)) - retirement) - (etaf--runtime-drain-retirement runtime retirement)) - (etaf--runtime-clear-candidate runtime)))))) + updated first-condition public-condition) + (cl-labels + ((run-step + (kind function) + (when-let* ((condition + (etaf--runtime-run-postcommit-step + retirement 'component-overlay kind function))) + (unless first-condition + (setq first-condition condition))))) + (run-step + 'generation-completion + (lambda () + (etaf--runtime-complete-generation runtime candidate-generation))) + (run-step + 'generation-mirror-projection + (lambda () + (etaf--runtime-install-generation-mirrors + runtime candidate-generation nil))) + (etaf--runtime-clear-dirty-effects runtime) + (unwind-protect + (progn + (run-step + 'lifecycle-preparation + (lambda () + (dolist (instance (etaf-runtime-candidate-created runtime)) + (setf (etaf--component-instance-mounted-p instance) t)) + (dolist (entry (etaf--generation-index-entries + candidate-generation 'lifecycle)) + (let ((identity (car entry))) + (when-let* + ((semantic (etaf--generation-semantic old identity)) + (instance + (gethash + (etaf--semantic-component-resource-key semantic) + (etaf-runtime-resource-registry runtime)))) + (push instance updated)))) + (etaf--runtime-run-lifecycle + (list (etaf-runtime-candidate-created runtime) + (nreverse updated)) + retirement))) + (setq public-condition + (etaf--runtime-drain-retirement runtime retirement t)) + (when-let* ((condition (or first-condition public-condition))) + (etaf-retirement-resignal condition retirement))) + (etaf--runtime-clear-candidate runtime))))))) (defun etaf--runtime-render-effect (runtime) "Build and publish one Root-owned candidate for RUNTIME." @@ -6176,25 +6206,47 @@ RENDERED-IDENTITIES names the Component render participants." (etaf--runtime-clear-candidate runtime) (signal (car err) (cdr err)))) (etaf--runtime-participant-commit participant) - (etaf--runtime-complete-generation runtime candidate-generation) - (etaf--runtime-install-generation-mirrors - runtime candidate-generation t) - (setf (etaf-runtime-root-node runtime) root-node - (etaf-runtime-root-dirty-p runtime) nil) - (etaf--runtime-clear-dirty-effects runtime) ;; Publication has completed. Lifecycle and cleanup callbacks run after ;; the retained state is promoted; their errors remain visible without ;; incorrectly rolling back an already published Ebox tree. (let ((retirement (etaf--runtime-new-retirement-journal - runtime (etaf-semantic-candidate-candidate-id semantic-candidate)))) - (unwind-protect - (let ((groups (etaf--runtime-promote runtime retirement))) - (etaf--runtime-promote-behaviors runtime retirement) - (etaf--runtime-run-lifecycle groups retirement) - (etaf--runtime-drain-retirement runtime retirement)) - (etaf--runtime-rollback-behaviors runtime) - (etaf--runtime-clear-candidate runtime))) + runtime (etaf-semantic-candidate-candidate-id semantic-candidate))) + groups first-condition public-condition) + (cl-labels + ((run-step + (kind function) + (when-let* ((condition + (etaf--runtime-run-postcommit-step + retirement 'root-render kind function))) + (unless first-condition + (setq first-condition condition))))) + (run-step + 'generation-completion + (lambda () + (etaf--runtime-complete-generation runtime candidate-generation))) + (run-step + 'generation-mirror-projection + (lambda () + (etaf--runtime-install-generation-mirrors + runtime candidate-generation t))) + (setf (etaf-runtime-root-node runtime) root-node + (etaf-runtime-root-dirty-p runtime) nil) + (etaf--runtime-clear-dirty-effects runtime) + (unwind-protect + (progn + (run-step + 'authority-retirement-preparation + (lambda () + (setq groups (etaf--runtime-promote runtime retirement)) + (etaf--runtime-promote-behaviors runtime retirement) + (etaf--runtime-run-lifecycle groups retirement))) + (setq public-condition + (etaf--runtime-drain-retirement runtime retirement t)) + (when-let* ((condition (or first-condition public-condition))) + (etaf-retirement-resignal condition retirement))) + (etaf--runtime-rollback-behaviors runtime) + (etaf--runtime-clear-candidate runtime)))) next-root)) (defun etaf--runtime-render-root-turn (runtime &optional force-components-p) diff --git a/etaf-scheduler.el b/etaf-scheduler.el index 3e56e33..7ec5965 100644 --- a/etaf-scheduler.el +++ b/etaf-scheduler.el @@ -367,24 +367,27 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (max 0 (1- (etaf-scheduler-context-busy-depth context)))))) (defun etaf-scheduler--drain-context-sources (context projection-id) - "Drain CONTEXT source FIFO for PROJECTION-ID." - (setf (etaf-scheduler-context-phase context) 'source) - (etaf-scheduler--call-context-work - context - (lambda () - (while (etaf-scheduler-context-source-queue context) - (let* ((source (pop (etaf-scheduler-context-source-queue context))) - (delivery - (gethash source - (etaf-scheduler-context-source-set context)))) - (unless (etaf-scheduler-context-source-queue context) - (setf (etaf-scheduler-context-source-queue-tail context) nil)) - (remhash source (etaf-scheduler-context-source-set context)) - (puthash source t - (etaf-scheduler-context-delivered-source-set context)) - (cl-incf (etaf-scheduler-context-source-delivery-count context)) - (when delivery - (funcall delivery context source projection-id))))))) + "Drain one snapshotted CONTEXT source turn for PROJECTION-ID." + (let ((turn (etaf-scheduler-context-source-queue context))) + ;; New sources discovered by TURN belong to the next bounded scheduler + ;; turn. Detaching the current FIFO prevents a chain of distinct source + ;; identities from monopolizing one unbudgeted drain. + (setf (etaf-scheduler-context-source-queue context) nil + (etaf-scheduler-context-source-queue-tail context) nil + (etaf-scheduler-context-phase context) 'source) + (etaf-scheduler--call-context-work + context + (lambda () + (dolist (source turn) + (let ((delivery + (gethash source + (etaf-scheduler-context-source-set context)))) + (remhash source (etaf-scheduler-context-source-set context)) + (puthash source t + (etaf-scheduler-context-delivered-source-set context)) + (cl-incf (etaf-scheduler-context-source-delivery-count context)) + (when delivery + (funcall delivery context source projection-id)))))))) (defun etaf-scheduler--detach-runtime-turns (projection) "Detach and return PROJECTION's Runtime queues in context order." @@ -397,19 +400,25 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (nreverse turns))) (defun etaf-scheduler--run-runtime-turn (context turn) - "Run detached Runtime TURN owned by CONTEXT." - (setf (etaf-scheduler-context-phase context) 'runtime) - (etaf-scheduler--call-context-work - context - (lambda () - (dolist (runtime turn) - (let ((function - (gethash runtime - (etaf-scheduler-context-runtime-set context)))) - (remhash runtime (etaf-scheduler-context-runtime-set context)) - (when function - (cl-incf (etaf-scheduler-context-runtime-execution-count context)) - (funcall function))))))) + "Run detached Runtime TURN in CONTEXT and return its first condition." + (let (first-condition) + (setf (etaf-scheduler-context-phase context) 'runtime) + (etaf-scheduler--call-context-work + context + (lambda () + (dolist (runtime turn) + (let ((function + (gethash runtime + (etaf-scheduler-context-runtime-set context)))) + (remhash runtime (etaf-scheduler-context-runtime-set context)) + (when function + (cl-incf (etaf-scheduler-context-runtime-execution-count context)) + (condition-case condition + (funcall function) + ((error quit) + (unless first-condition + (setq first-condition condition))))))))) + first-condition)) (defun etaf-scheduler--record-fault (context projection-id condition) "Record CONTEXT failure CONDITION for PROJECTION-ID." @@ -434,6 +443,10 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." ;; All source propagation across every context settles before any ;; Runtime can observe and publish the resulting reactive state. (while (etaf-scheduler--projection-source-work-p projection) + ;; Each source wave is one bounded turn. A wave snapshots every + ;; context's current FIFO, so newly discovered distinct sources + ;; consume another step and peers get an opportunity to run. + (setq marked-contexts (make-hash-table :test #'eq)) (dolist (context (etaf-scheduler--projection-contexts projection)) (cond ((gethash context failed-contexts) @@ -460,7 +473,11 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (progn (etaf-scheduler--mark-turn context projection-id marked-contexts context-steps) - (etaf-scheduler--run-runtime-turn context turn)) + (when-let* ((runtime-condition + (etaf-scheduler--run-runtime-turn + context turn))) + (signal (car runtime-condition) + (cdr runtime-condition)))) ((error quit) (puthash context t failed-contexts) (unless first-condition (setq first-condition condition)) diff --git a/tests/etaf-generation-tests.el b/tests/etaf-generation-tests.el index 71044d2..3b9a67d 100644 --- a/tests/etaf-generation-tests.el +++ b/tests/etaf-generation-tests.el @@ -276,7 +276,9 @@ (ert-deftest etaf-semantic-postcommit-mirror-failure-keeps-token-committed () "A postcommit mirror error cannot reverse generation/token or TP facts." (let ((buffer-name " *etaf-semantic-postcommit-test*") - (source (etaf-ref 0))) + (source (etaf-ref 0)) + captured + (rollback-count 0)) (unwind-protect (progn (etaf-mount @@ -288,12 +290,27 @@ (car tp--buffer-surfaces))) (generation (etaf-runtime-generation runtime)) (token (etaf-runtime-generation-token runtime)) - (revision (tp-surface-revision surface))) + (revision (tp-surface-revision surface)) + (original-rollback + (symbol-function 'etaf-semantic-candidate-rollback))) (cl-letf (((symbol-function 'etaf--runtime-install-generation-mirrors) (lambda (&rest _arguments) - (error "injected postcommit mirror failure")))) - (should-error (setf (etaf-value source) 1) :type 'error)) + (error "injected postcommit mirror failure"))) + ((symbol-function 'etaf-semantic-candidate-rollback) + (lambda (candidate) + (cl-incf rollback-count) + (funcall original-rollback candidate)))) + (condition-case condition + (setf (etaf-value source) 1) + (error (setq captured condition)))) + (should captured) + (should (eq (car captured) 'error)) + (should + (equal (butlast (cdr captured)) + '("injected postcommit mirror failure"))) + (should (etaf-condition-postcommit-info captured)) + (should (zerop rollback-count)) (should (= (1+ generation) (etaf-runtime-generation runtime))) (should (= (1+ token) diff --git a/tests/etaf-retirement-tests.el b/tests/etaf-retirement-tests.el index 8ec3b14..64bf925 100644 --- a/tests/etaf-retirement-tests.el +++ b/tests/etaf-retirement-tests.el @@ -122,7 +122,39 @@ (etaf-condition-postcommit-info '(error business (:etaf-condition-trailer/v2 - (:kind postcommit :committed-p t))))))) + (:kind postcommit :committed-p t))))) + (dolist + (malformed + '((:kind postcommit :committed-p t :operation-id 1 + :outcome-id 2 :generation-id 3 :revision 4 + :diagnostic-journal-id 5 :unexpected accepted) + (:kind postcommit :committed-p t :operation-id 1 + :outcome-id 2 :generation-id 3 :revision 4 + :diagnostic-journal-id 5 :operation-id 6) + (:kind postcommit :committed-p t :operation-id 1 + :outcome-id 2 :generation-id 3 :revision 4 + :diagnostic-journal-id) + (:kind postcommit :committed-p t :operation-id -1 + :outcome-id 2 :generation-id 3 :revision 4 + :diagnostic-journal-id 5))) + (should-not + (etaf-condition-postcommit-info + (list 'error + (list :etaf-condition-trailer/v1 malformed))))) + (let (decorated) + (condition-case condition + (etaf-retirement-resignal + '(etaf-retirement-test-condition + "business" + (:etaf-condition-trailer/v1 + (:kind postcommit :committed-p t :operation-id 1 + :outcome-id 2 :generation-id 3 :revision 4 + :diagnostic-journal-id 5 :unexpected accepted))) + journal) + (etaf-retirement-test-condition (setq decorated condition))) + (should decorated) + (should (etaf-condition-postcommit-info decorated)) + (should (= 3 (length (cdr decorated))))))) (ert-deftest etaf-retirement-updated-error-is-committed-and-not-rerun () "Updated hook error carries a trailer while generation and buffer stay new." diff --git a/tests/etaf-scheduler-tests.el b/tests/etaf-scheduler-tests.el index f67d2d5..be6df30 100644 --- a/tests/etaf-scheduler-tests.el +++ b/tests/etaf-scheduler-tests.el @@ -246,6 +246,26 @@ (etaf--stop-effect left-effect) (etaf--stop-effect right-effect)))) +(ert-deftest etaf-scheduler-runtime-fault-does-not-suppress-context-tail () + "A failing Runtime job cannot discard later jobs in the same context." + (let ((context (etaf-scheduler-context-create :name 'runtime-fault-tail)) + second-ran captured) + (condition-case condition + (etaf-scheduler-call-with-projection + (lambda () + (etaf-scheduler-enqueue-runtime + context 'first + (lambda () + (signal 'etaf-scheduler-test-condition '("first")))) + (etaf-scheduler-enqueue-runtime + context 'second (lambda () (setq second-ran t))))) + (etaf-scheduler-test-condition (setq captured condition))) + (should (equal captured '(etaf-scheduler-test-condition "first"))) + (should second-ran) + (should (= 2 (plist-get (etaf-scheduler-context-metrics context) + :runtime-executions))) + (should (etaf-scheduler-context-idle-p context)))) + (ert-deftest etaf-scheduler-body-error-precedes-drain-error-and-quit-drains () "Body failure wins over drain failure; quit still drains queued effects." (let* ((context (etaf-scheduler-context-create :name 'precedence)) @@ -406,6 +426,37 @@ (etaf--stop-effect right-effect)) (when recovery-effect (etaf--stop-effect recovery-effect))))) +(ert-deftest etaf-scheduler-distinct-source-chain-consumes-turn-budget () + "A distinct-source chain yields to peers and cannot hide in one turn." + (let* ((chain-context + (etaf-scheduler-context-create + :name 'distinct-source-chain :fixed-point-step-budget 3)) + (peer-context (etaf-scheduler-context-create :name 'chain-peer)) + seen peer-ran captured) + (condition-case condition + (etaf-scheduler-call-with-projection + (lambda () + (cl-labels + ((deliver (_context source _projection-id) + (push source seen) + (etaf-scheduler-enqueue-source + chain-context (1+ source) #'deliver))) + (etaf-scheduler-enqueue-source chain-context 0 #'deliver)) + (etaf-scheduler-enqueue-source + peer-context 'peer + (lambda (_context _source _projection-id) + (setq peer-ran t))))) + (etaf-scheduler-error (setq captured condition))) + (should captured) + (should (eq 'fixed-point-step-budget + (plist-get (cdr captured) :kind))) + (should (= 4 (plist-get (cdr captured) :steps))) + (should (= 3 (plist-get (cdr captured) :budget))) + (should (equal '(0 1 2) (nreverse seen))) + (should peer-ran) + (should (etaf-scheduler-context-idle-p chain-context)) + (should (etaf-scheduler-context-idle-p peer-context)))) + (ert-deftest etaf-scheduler-data-success-is-one-turn-per-context () "One Data success projection coalesces all changed refs in each context." (let* ((left-buffer " *etaf-scheduler-data-left*") diff --git a/tests/fixtures/etaf-m0a-condition-consumers.sexp b/tests/fixtures/etaf-m0a-condition-consumers.sexp index 4d94a12..ac8c479 100644 --- a/tests/fixtures/etaf-m0a-condition-consumers.sexp +++ b/tests/fixtures/etaf-m0a-condition-consumers.sexp @@ -20,6 +20,7 @@ (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)