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
This commit is contained in:
parent
c30f52c5a7
commit
f67498c789
6
TODO.org
6
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
|
||||
|
||||
124
lib/dev.ml
124
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. *)
|
||||
(* 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
|
||||
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
|
||||
(* 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
|
||||
match kept with
|
||||
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
|
||||
| None -> ());
|
||||
| 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 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. *)
|
||||
(* 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 }
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user