From f67498c789cba29400b667185ed24a34c7953c0d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:35:23 +0700 Subject: [PATCH] A re-run under --two-process builds the program again from the session and starts it in a new process, and the daemon outlives a finished child --- TODO.org | 6 -- lib/dev.ml | 152 ++++++++++++++++++++++++++++++++++++----------- lib/program.ml | 5 +- lib/session.ml | 9 ++- test/test_dev.ml | 73 +++++++++++++++++++---- 5 files changed, 189 insertions(+), 56 deletions(-) diff --git a/TODO.org b/TODO.org index bc1164ef..81a86da6 100644 --- a/TODO.org +++ b/TODO.org @@ -1543,12 +1543,6 @@ A finished program parks instead of dying, and a daemon op wakes it and re-enter Globals are not reset between runs — the process never died. Rules out a fresh process per run. -** NEXT Re-run does not work under --two-process -Decided 2026-09-25: re-run under =--two-process= starts a fresh child, installed redefinitions included, and says that globals start over because the process is new. -A finished child process is genuinely gone, so there is nothing to wake. Re-run is -merged-build only, and since the default backend runs merged it is no longer the -blocked case. - ** DONE An accepted re-run reads as running CLOSED: [2026-09-21] A caller that asked for a re-run and then waited for the program to park was diff --git a/lib/dev.ml b/lib/dev.ml index 5d9f3a17..5c1077db 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -28,11 +28,15 @@ type t = { (* The running program. [Some pid] is the two-process daemon, which launched it; [None] is the merged build, where the program is *this* process and the compiler is a thread inside it. That is the whole of the difference at - this layer — see [merged_setup] for why there is no third case. *) - child : int option; + this layer — see [merged_setup] for why there is no third case. A re-run + under --two-process replaces the child with a new one. *) + mutable child : int option; agent : string; (* where it listens for modules *) dir : string; (* modules are built here, one per eval *) - stdout : Unix.file_descr; (* the program's output, on its way to here *) + mutable stdout : Unix.file_descr; (* the program's output, on its way here *) + (* --two-process only: build the program again from the session as it is + now and start it, answering the new child and its stdout. *) + relaunch : (unit -> int * Unix.file_descr) option; out : Buffer.t; (* ...buffered until an editor asks for it *) mutable n : int; (* dlopen caches by path: never reuse one *) (* Bookkeeping for disassembly, and the reason it can exist at all: the @@ -822,7 +826,8 @@ let build_module (c : Session.change) ~debug ~out = spelled once so that every op tells the same story. [gone] is what all of them used to say and is now said only where it is - true: there is no process left and nothing short of a new one will help. + true: there is no process left and nothing short of a new one will help — + which, under --two-process, a re-run is. [parked] is the new half, and the sentence it appends is the whole point of the distinction. Somebody reading it has a program that is *there* — its @@ -833,7 +838,7 @@ let build_module (c : Session.change) ~debug ~out = refused for want of a frame boundary and an op refused for want of a stopped stack are refused by the same state for different causes, and a reader who cannot tell them apart cannot tell what to do instead. *) -let gone = "the program exited; restart flan dev" +let gone = "the program exited; M-x flan-rerun starts it again" let parked_msg why = why @@ -3658,7 +3663,58 @@ let abort t = park, the next request went out while the first run had not started, and the pair of them produced one run — or, a moment later, a refusal saying the program was already running. Both faces are gone with the lag. *) +(* Under --two-process a finished child is gone and there is no thread to + wake, so a re-run is a new process: the program is built again from the + session as it stands, which puts every accepted redefinition in it from + the start, and its globals start over. *) +let relaunch_child t relaunch = + match liveness t with + | Live | Parked -> + error + (if parked_break t then + "the program is stopped at a break, so it cannot be started again \ + until that ends: resume it or abort it" + else + "the program is still running; a re-run starts it again in a new \ + process once this one has finished. Close its window, or let it \ + finish, and ask again") + | Gone -> + let s = t.session in + (match Session.stale_sites s.Session.built s.Session.program with + | (x : Session.stale) :: _ as ss -> + error ~loc:(Loc.to_string x.Session.at) + (Printf.sprintf + "a re-run builds the program again, and %d call%s compiled for a \ + signature %s function no longer has, starting with %s calling %s \ + here. Recompile the caller with C-c C-c, or change %s back, and \ + ask again" + (List.length ss) + (if List.length ss = 1 then " was" else "s were") + (if List.length ss = 1 then "its" else "their") + x.Session.caller x.Session.target x.Session.target) + | [] -> + (match relaunch () with + | child, rd -> + drain t; + (try Unix.close t.stdout with Unix.Unix_error _ -> ()); + t.stdout <- rd; + t.child <- Some child; + t.finished <- false; + t.died <- None; + (* Every body is in the new host now, so no module owns one. *) + Hashtbl.reset t.owners; + ok + [ ":note " + ^ Wire.quote + "started the program again in a new process, built with \ + every change loaded so far; its globals start over, \ + because the process is new" ] + | exception Failure m -> error m)) + let rerun t = + match t.relaunch with + | Some relaunch -> relaunch_child t relaunch + | None -> match liveness t with | Gone -> error gone (* A file started with no [main] runs a stub that returns at once; running @@ -5057,8 +5113,11 @@ let accept_loop ?grace t ls = where a session with no editor attached spends its time. *) agent_check t; match liveness t with - | Gone -> () - | (Live | Parked) as live -> + | Gone when t.relaunch = None -> () + | live -> + (* A --two-process child that has ended can be started again, so the + session waits as a parked one does, on the parked grace. *) + let live = if live = Gone then Parked else live in let idle = Unix.gettimeofday () -. !since in if orphaned ~grace ~served:!served ~idle live then (* The measured gap and not the threshold it crossed: the threshold is @@ -5071,7 +5130,10 @@ let accept_loop ?grace t ls = else (* The program's pipe is in the same select as the listening socket: it has to be drained whether or not an editor is asking for anything. *) - match Unix.select [ ls; t.stdout ] [] [] 0.2 with + (* Not once it has read EOF: an ended child's pipe is readable for + ever, and the loop would spin on it. *) + let fds = if t.finished then [ ls ] else [ ls; t.stdout ] in + match Unix.select fds [] [] 0.2 with | [], _, _ -> go () | ready, _, _ when not (List.mem ls ready) -> drain t; go () | _ -> @@ -5246,19 +5308,22 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = against each module as it loads either way, but a breakpoint set on a line in the .flan buffer needs a line table on both sides — the host's to fire before the first C-c C-c, the module's to follow the reload. *) - let _, kept = - Build.executable - ~opts:{ Build.default with Build.dev = true; Build.keep = true; - Build.debug; Build.x86 } - ~csrcs ~lflags session.Session.host ~out:exe - in (* Host and modules are chosen together, which is the whole licence: an [--x86] host gets [--x86] modules because one flag set both, and the source [Build.executable] kept is assembly rather than IR. *) let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in - (match kept with - | Some src -> (try Sys.rename src host_ll with Sys_error _ -> ()) - | None -> ()); + let build_host () = + let _, kept = + Build.executable + ~opts:{ Build.default with Build.dev = true; Build.keep = true; + Build.debug; Build.x86 } + ~csrcs ~lflags session.Session.host ~out:exe + in + match kept with + | Some src -> (try Sys.rename src host_ll with Sys_error _ -> ()) + | None -> () + in + build_host (); let agent = Filename.concat dir "agent.sock" in (* The program's source names some socket path; the daemon is the one that @@ -5294,23 +5359,39 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = the pipe it was writing to; that also meant the pipe could never reach EOF while the child lived, so "wait for EOF on the daemon's end" was never the mechanism it looked like it could be. *) - let rd, wr = Unix.pipe ~cloexec:true () in - let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in - Unix.close wr; - Unix.set_nonblock rd; - - (* Wait for it to bind before accepting an evaluation. One that arrives first - would fail for a reason that reads like a compiler bug. *) - if not (await (fun () -> Sys.file_exists agent)) then begin - (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); - failwith - ("the program did not open its agent socket at " ^ agent - ^ ". Under --two-process every edit reaches the program through that \ - socket.") - end; + let spawn () = + (* A socket file a previous child left behind would answer the wait below + before this child has bound anything. *) + (try Unix.unlink agent with Unix.Unix_error _ -> ()); + let rd, wr = Unix.pipe ~cloexec:true () in + let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in + Unix.close wr; + Unix.set_nonblock rd; + (* Wait for it to bind before accepting an evaluation. One that arrives + first would fail for a reason that reads like a compiler bug. *) + if not (await (fun () -> Sys.file_exists agent)) then begin + (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); + (try Unix.close rd with Unix.Unix_error _ -> ()); + failwith + ("the program did not open its agent socket at " ^ agent + ^ ". Under --two-process every edit reaches the program through that \ + socket.") + end; + (child, rd) + in + let child, rd = spawn () in + (* A re-run: the host is built again from the session as it stands, so + every redefinition accepted so far is in the new process from its first + instruction rather than delivered to it later. *) + let relaunch () = + Session.rehost session; + build_host (); + spawn () + in let t = { session; child = Some child; agent; dir; stdout = rd; + relaunch = Some relaunch; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; park_noted = false; died = None; dropped = 0 } @@ -5324,9 +5405,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = ((Unix.gettimeofday () -. t0) *. 1000.); Fun.protect ~finally:(fun () -> - (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); + (match t.child with + | Some child -> + (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()) + | None -> ()); (try Unix.close ls with Unix.Unix_error _ -> ()); - (try Unix.close rd with Unix.Unix_error _ -> ()); + (try Unix.close t.stdout with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ())) (fun () -> accept_loop t ls); (* Here only when the loop returned: an exception out of it has already @@ -6169,7 +6253,7 @@ let merged_setup () = with Unix.Unix_error _ -> Sys.executable_name in let t = - { session; child = None; agent; dir; stdout = rd; + { session; child = None; agent; dir; stdout = rd; relaunch = None; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; park_noted = false; died = None; dropped = 0 } diff --git a/lib/program.ml b/lib/program.ml index 45091410..e7177ae2 100644 --- a/lib/program.ml +++ b/lib/program.ml @@ -98,6 +98,5 @@ let rerun ?(stopped = false) () = its window, or let it finish, and ask again" | _ -> Error - "this session's program is a process of its own, so there is no parked \ - thread here to send round again; it is the merged build that can re-run \ - a program, not --two-process" + "this process has no program thread of its own, so there is nothing \ + here to run again" diff --git a/lib/session.ml b/lib/session.ml index 41d45d6f..dd6c2292 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -65,7 +65,7 @@ type t = { mutable decls : Ast.decl list; (* post-Load: flat, one namespace *) mutable program : Tast.program; (* the last thing that checked *) mutable env : Check.env; (* the same, as the checker sees it *) - host : Tast.program; (* what the process was built from *) + mutable host : Tast.program; (* what the process was built from *) pkgs : Load.pkg list; (* alias, directory, names owned *) (* Every [defmacro] this session can expand a call to: the imports', under their aliases, and the buffer's own, under the names the buffer writes. @@ -782,6 +782,13 @@ let restore t h = newest one and no older activation is left running. *) let rerun t = t.live <- SM.empty +(* The process is about to be built again from what the session holds now + (a --two-process re-run), so that becomes what it was built from. *) +let rehost t = + t.host <- t.program; + t.built <- record_built t.env t.program t.program.Tast.fns SM.empty; + t.live <- SM.empty + (* [forms], when given, are [src] already read — [pruned] runs this over a file a form fewer each round and has no text for the subset. [base] is the file an [(import ...)] in them is resolved against, the session's own when diff --git a/test/test_dev.ml b/test/test_dev.ml index dcbff377..c1f02dc8 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5121,20 +5121,69 @@ let () = ignore (ask "(:op \"describe\")"); contains_sub (Buffer.contents seen) "42")) then fail "--two-process: the reload was never installed"; - (* And the one verb this shape cannot have. Running [main] again means - waking a thread that parked inside this process, and here the program - is a child: when it finishes it is gone, and there is nothing to wake. - Refused by naming what this daemon is rather than with the message a - merged one gives, because "the program is already running" would send - somebody back to try again after it had exited — and [--x86] arrives - here too, since it refuses the merged daemon for the -rdynamic reason - given below. *) + (* A re-run here is a new process. Refused while the child runs; once + it has finished, the program is built again from the session, so the + redefined [step] is what the new run's first line prints — the host + the daemon started with would print 1. *) let r = ask "(:op \"rerun\")" in let why = Option.value ~default:(status r) (Wire.string_field r "message") in - if status r <> "error" then - fail "--two-process answered a rerun it cannot perform" - else if not (contains_sub why "two-process") then - fail "--two-process refuses a rerun as: %s" why; + if status r <> "error" || not (contains_sub why "still running") then + fail "--two-process: a rerun while the child runs answered %s: %s" + (status r) why; + (* Two more deliveries take the program past its last two waits. *) + List.iter + (fun n -> + let r = + ask + (Printf.sprintf + "(:op \"eval\" :code \"(defn step [] i64 %d)\" \ + :file \"/tmp/buf.flan\")" n) + in + if status r <> "ok" then fail "--two-process: eval %d was refused" n; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) (string_of_int n))) + then fail "--two-process: %d was never installed" n) + [ 43; 44 ]; + (* 44 was the old child's last line, so anything from here on is the + new child's. *) + Buffer.clear seen; + let taken = ref (ask "(:op \"describe\")") in + if not + (await ~ms:10000 (fun () -> + taken := ask "(:op \"rerun\")"; + status !taken = "ok")) + then + fail "--two-process: a rerun after the child finished: %s" + (Option.value ~default:(status !taken) + (Wire.string_field !taken "message")) + else begin + let note = Option.value ~default:"" (Wire.string_field !taken "note") in + if not (contains_sub note "globals start over") then + fail "--two-process: the rerun's note does not say the globals \ + start over: %S" note; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) "\n")) + then fail "--two-process: the new child printed nothing" + else if not (String.starts_with ~prefix:"44\n" (Buffer.contents seen)) + then + fail "--two-process: the new child did not start with the \ + redefinition: %S" (Buffer.contents seen); + (* And it is reachable: a delivery to the new child installs. *) + let r = + ask + "(:op \"eval\" :code \"(defn step [] i64 45)\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then fail "--two-process: eval after rerun refused"; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) "45")) + then fail "--two-process: the new child never installed a delivery" + end; ignore (ask "(:op \"close\")"); Unix.close tc end;