From f0f339709e29978acdf2364a6d874462a5fcdf27 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 17:30:47 +0000 Subject: [PATCH] tcl: replace eager coroutine pre-execution with true suspension via fibers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/tcl/runtime.sx | 107 +++++++++++++++++++++------------------------ lib/tcl/test.sh | 1 + 2 files changed, 51 insertions(+), 57 deletions(-) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 5fc413b2..e9d1e4f1 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -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 diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index b9c74216..445db51d 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -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")