tcl: Phase 5b event loop — fileevent/after/vwait/update
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s

New SX primitive io-select-channels(read-list write-list timeout-ms) wrapping
Unix.select on the registered channel table. Returns {:readable :writable}.

Tcl event loop implemented purely in Tcl (no sx_server.ml changes):
- fileevent $chan readable|writable script (or "" to unregister)
- fileevent $chan event (1 arg) returns the registered script
- after ms script — schedule one-shot timer
- after ms (no script) — sleep, driving event loop in the meantime
- vwait varname — block until var is set/changed, handlers run between polls
- update — non-blocking event drain (poll-timeout=0)

State on interp: :fileevents (list of (chan event script)) and :timers
(sorted list of (expiry-ms script)).

tcl-event-step is the inner loop: expire timers, build fd lists from
:fileevents, call io-select-channels with computed timeout, run ready
handlers. vwait polls every 1000ms or until var changes.

Scoped to script mode by design — vwait from inside a server-handled
command does not interact with sx_server's stdin scheduler.

+5 idiom tests: after-vwait-timer, after-multiple-timers-update,
fileevent-readable-fires, fileevent-query-script,
after-cancel-via-vwait-timing. 354/354 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-07 12:47:31 +00:00
parent be820d0337
commit 64d36fa66e
3 changed files with 299 additions and 1 deletions

View File

@@ -3264,6 +3264,50 @@ let () =
Nil
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
(* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
register "io-select-channels" (fun args ->
let to_ms v = match v with
| Integer n -> n
| Number n -> int_of_float n
| _ -> raise (Eval_error "io-select-channels: timeout must be a number")
in
let to_list v = match v with
| List xs | ListRef { contents = xs } -> xs
| Nil -> []
| _ -> raise (Eval_error "io-select-channels: expected list")
in
let chan_name_of v = match v with
| String s -> s
| _ -> raise (Eval_error "io-select-channels: channel must be a string")
in
let (read_list, write_list, timeout_ms) = match args with
| [r; w; t] -> (to_list r, to_list w, to_ms t)
| _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
in
let read_pairs = List.map (fun v ->
let name = chan_name_of v in
let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
let write_pairs = List.map (fun v ->
let name = chan_name_of v in
let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
let read_fds = List.map snd read_pairs in
let write_fds = List.map snd write_pairs in
let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
let (ready_r, ready_w, _) =
try Unix.select read_fds write_fds [] timeout
with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
in
let names_of pairs ready =
List.filter_map (fun (n, fd) ->
if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
) pairs
in
let d = Hashtbl.create 2 in
Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
Dict d);
(* === Clock === *)
register "clock-seconds" (fun args ->
match args with