tcl: replace eager coroutine pre-execution with true suspension via fibers
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s

Rewrote the coroutine implementation to use lib/fiber.sx (make-fiber,
fiber-resume, fiber-done?) instead of eagerly running the proc body and
collecting all yields into a list. Each coroutine is now a live fiber —
calls to the coro command invoke fiber-resume, yield suspends via call/cc.

- make-tcl-interp: remove :coroutines/:in-coro/:coro-yields, add :coro-yield-fn nil
- tcl-cmd-yield: calls :coro-yield-fn (fiber's yield fn) to truly suspend
- tcl-cmd-yieldto: same pattern, yields "" to resumer
- make-coro-cmd: takes fiber (not coro-name), calls fiber-resume on each invoke
- tcl-cmd-coroutine: creates a fiber whose body runs the proc with :coro-yield-fn set
- tcl-call-proc result merge: drop :coro-yields/:coroutines propagation
- test.sh: load lib/fiber.sx before lib/tcl/runtime.sx in epoch 4

All 337/337 tests pass including all 20 coro tests.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-06 17:30:47 +00:00
parent 0596376199
commit f0f339709e
2 changed files with 51 additions and 57 deletions

View File

@@ -1,5 +1,6 @@
; Tcl-on-SX runtime evaluator
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
; Requires lib/fiber.sx to be loaded first (provides make-fiber, fiber-resume, fiber-done?)
(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
@@ -20,7 +21,7 @@
(frame name val)
(assoc frame :locals (assoc (get frame :locals) name val))))
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coroutines {} :in-coro false :coro-yields (list)}))
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coro-yield-fn nil}))
(define
tcl-register
@@ -297,8 +298,6 @@
:result result-val
:output (str caller-output proc-output)
:code (if (= code 2) 0 code)
:coro-yields (get result-interp :coro-yields)
:coroutines (get result-interp :coroutines)
:commands (get result-interp :commands))))))))))))))
(define
@@ -2769,65 +2768,49 @@
((equal? sub "tclversion") (assoc interp :result "8.6"))
(else (error (str "info: unknown subcommand \"" sub "\""))))))))
; make-coro-cmd: returns a command function that pops values from the coroutine's yields list
; tcl-cmd-yield: suspend the current coroutine fiber, returning val to the resumer
(define
tcl-cmd-yield
(fn
(interp args)
(let
((val (if (> (len args) 0) (first args) "")))
(if
(get interp :in-coro)
(assoc
(assoc
interp
:coro-yields (append (get interp :coro-yields) (list val)))
:result "")
(error "yield called outside coroutine")))))
(let
((yield-fn (get interp :coro-yield-fn)))
(if
(nil? yield-fn)
(error "yield called outside coroutine")
(let
((resume-val (yield-fn val)))
(assoc interp :result (if (nil? resume-val) "" resume-val))))))))
; coroutine: execute proc eagerly in a coroutine context, collecting all yields
; tcl-cmd-yieldto: suspend the current coroutine fiber (simplified: yields "" to resumer)
(define
tcl-cmd-yieldto
(fn
(interp args)
(if
(get interp :in-coro)
(assoc
(assoc
interp
:coro-yields (append (get interp :coro-yields) (list "")))
:result "")
(error "yieldto called outside coroutine"))))
(let
((yield-fn (get interp :coro-yield-fn)))
(if
(nil? yield-fn)
(error "yieldto called outside coroutine")
(let
((resume-val (yield-fn "")))
(assoc interp :result (if (nil? resume-val) "" resume-val)))))))
; --- clock command (stubs) ---
(define
make-coro-cmd
(fn
(coro-name)
(fiber)
(fn
(interp args)
(let
((coros (get interp :coroutines)))
((resume-val (if (> (len args) 0) (first args) "")))
(let
((coro (get coros coro-name)))
(if
(nil? coro)
(error (str "coroutine \"" coro-name "\" not found"))
(let
((yields (get coro :yields)) (pos (get coro :pos)))
(if
(>= pos (len yields))
(assoc interp :result "")
(let
((val (nth yields pos)))
(let
((new-coro (assoc coro :pos (+ pos 1))))
(assoc
(assoc
interp
:coroutines (assoc coros coro-name new-coro))
:result val)))))))))))
((yielded (fiber-resume fiber resume-val)))
(assoc interp :result (if (nil? yielded) "" yielded)))))))
; --- file I/O stubs ---
@@ -2843,24 +2826,34 @@
(cmd-name (nth args 1))
(call-args (rest (rest args))))
(let
((coro-interp (assoc interp :in-coro true :coro-yields (list) :result "" :code 0)))
((base-interp (assoc interp :result "" :code 0 :coro-yield-fn nil)))
(let
((cmd-fn (get (get coro-interp :commands) cmd-name)))
((fiber
(make-fiber
(fn
(fiber-yield _)
(let
((coro-interp (assoc base-interp :coro-yield-fn fiber-yield)))
(let
((cmd-fn (get (get coro-interp :commands) cmd-name)))
(if
(nil? cmd-fn)
(let
((proc-entry (tcl-proc-lookup coro-interp cmd-name)))
(if
(nil? proc-entry)
(error
(str "coroutine: unknown command \"" cmd-name "\""))
(tcl-call-proc
coro-interp
(get proc-entry :name)
(get proc-entry :def)
call-args)))
(cmd-fn coro-interp call-args))))))))
(let
((exec-result (if (nil? cmd-fn) (let ((proc-entry (tcl-proc-lookup coro-interp cmd-name))) (if (nil? proc-entry) (error (str "coroutine: unknown command \"" cmd-name "\"")) (tcl-call-proc coro-interp (get proc-entry :name) (get proc-entry :def) call-args))) (cmd-fn coro-interp call-args))))
(let
((yields (get exec-result :coro-yields)))
(let
((new-coros (assoc (get exec-result :coroutines) coro-name {:yields yields :pos 0})))
(let
((new-commands (assoc (get exec-result :commands) coro-name (make-coro-cmd coro-name))))
(assoc
exec-result
:coroutines new-coros
:commands new-commands
:in-coro false
:coro-yields (list)
:result "")))))))))))
((new-commands
(assoc (get interp :commands) coro-name (make-coro-cmd fiber))))
(assoc interp :commands new-commands :result ""))))))))
(define
tcl-cmd-clock

View File

@@ -39,6 +39,7 @@ cat > "$TMPFILE" << EPOCHS
(epoch 3)
(load "lib/tcl/tests/parse.sx")
(epoch 4)
(load "lib/fiber.sx")
(load "lib/tcl/runtime.sx")
(epoch 5)
(load "lib/tcl/tests/eval.sx")