JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A --two-process re-run checks the whole program before building it and refuses at a stale caller, and a change made while the child has ended waits in the session for the re-run

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 16:08:13 +07:00
parent 527da37633
commit 6c8f503ebf
4 changed files with 126 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
TODO.org
View File

@ -1718,10 +1718,11 @@ out versioned bodies and trampolines, and redirecting a value taken before the
change. =main= stays refused: its caller is startup code no cell reaches.
docs/BUILT.md, "A signature change installs".
** DONE A module carrying a string literal is never unloaded
The transient rule is that a module retaining nothing may go, and a string literal
counts as something retained — which silently stopped every module carrying one
from ever being unloaded. That is why frame descriptors got their own counter.
** DONE An expression's module is unloaded unless it hands out a constant
CLOSED: [2026-09-25]
A thunk's string literal is a copy the process keeps, and registry names and initial
images are copied by the runtime, so none of them pins the module; a condition's
name or a restart's text still does. Rules out unloading on a guess about a literal.
** DONE A redefinition delivered while parked installs on the next re-run
The park used to drain the agent ring only when something had asked it to poll,
@ -1818,12 +1819,12 @@ line and every later row unrun.
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
not.
** WAIT An x86 dev session's read after an allocating thunk once answered without the value
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
WAIT on a recurrence; the test now prints the failing read's own reply.
The one failure's message came from a second read, which said "kept", so the global
was intact and the first read's reply lacked the value: not the collector. Not
reproduced in 350 churn-and-read cycles under 8-way load, three concurrent test_dev
runs, or a valgrind run of the cycle, which was clean.
The one failure's message came from a second read, which said "kept"; the failing
reply itself was not recorded. Not reproduced in 350 churn-and-read cycles under
8-way load, three concurrent test_dev runs, or a valgrind run of the cycle, which
was clean.
* Editor

78
lib/dev.ml
View File

@ -1041,7 +1041,25 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
nothing that can go wrong after it. *)
let before = Session.held t.session in
let refused msg = Session.restore t.session before; error msg in
if now = Gone then error gone
if now = Gone && t.relaunch <> None then
(* --two-process, the child ended: the form is checked into the session
and nothing is sent, because the next process is built from the
session whole ([rerun]). *)
match
Session.eval ~origin ?base ?forms ?pause ~running:false t.session code
with
| c ->
ok
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
":note "
^ Wire.quote
"loaded; the program has ended, so this is in it when M-x \
flan-rerun starts it again" ]
@ extra)
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
Session.restore t.session before;
error ~loc:(Loc.to_string l) msg
else if now = Gone then error gone
else
match
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
@ -3679,37 +3697,33 @@ let relaunch_child t relaunch =
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))
(* The whole program is checked again first ([Session.rehost]); a caller
left compiled against a signature that has since changed is where
that fails. *)
let refused (d : Loc.diag) =
error ~loc:(Loc.to_string d.Loc.dloc)
("a re-run builds the whole program again, and it does not compile: "
^ d.Loc.dmsg ^ ". Fix this and load it with C-c C-c, then ask again")
in
(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
| exception Loc.Error d -> refused d
| exception Loc.Errors (d :: _) -> refused d)
let rerun t =
match t.relaunch with

17
lib/session.ml
View File

@ -783,10 +783,21 @@ let restore t h =
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. *)
(a --two-process re-run), so that becomes what it was built from. Checked
whole rather than taken from [program], which can hold a caller's old body
beside a callee whose signature changed (see [eval]); a fresh build of that
pair would be wrong, so it raises the checker's error instead. *)
let rehost t =
t.host <- t.program;
t.built <- record_built t.env t.program t.program.Tast.fns SM.empty;
let p, env =
let was = !Check.print_warnings in
Check.print_warnings := false;
Fun.protect ~finally:(fun () -> Check.print_warnings := was)
(fun () -> Check.program_with_env t.decls)
in
t.program <- p;
t.env <- env;
t.host <- p;
t.built <- record_built env p p.Tast.fns SM.empty;
t.live <- SM.empty
(* [forms], when given, are [src] already read — [pruned] runs this over a

57
test/test_dev.ml
View File

@ -5182,7 +5182,62 @@ let () =
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "45"))
then fail "--two-process: the new child never installed a delivery"
then fail "--two-process: the new child never installed a delivery";
(* A signature change leaves [user] compiled for the old one. The
next build is of the whole program, so the re-run is refused at
the stale call; a fix evaluated while the child has ended goes
into the session, and the re-run after it builds. *)
let ev code =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")"
(Wire.quote code))
in
let alive () =
match Wire.field (ask "(:op \"describe\")") "alive" with
| Some { Form.v = Form.Sym "nil"; _ } -> false
| _ -> true
in
List.iter
(fun code ->
if status (ev code) <> "ok" then
fail "--two-process: %s was refused" code)
[ "(defn helper [] i64 1)"; "(defn user [] i64 (helper))" ];
if not (await ~ms:10000 (fun () -> not (alive ()))) then
fail "--two-process: the new child did not finish"
else begin
let r = ev "(defn helper [x i64] i64 x)" in
if status r <> "ok" then
fail "--two-process: a change while the child has ended: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
let r = ask "(:op \"rerun\")" in
if status r <> "error"
|| not (contains_sub
(Option.value ~default:"" (Wire.string_field r "loc"))
"/tmp/buf.flan:1:")
then
fail "--two-process: a re-run over a stale caller answered %s \
(%s)" (status r)
(Option.value ~default:"" (Wire.string_field r "message"));
List.iter
(fun code ->
if status (ev code) <> "ok" then
fail "--two-process: %s was refused" code)
[ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ];
Buffer.clear seen;
let r = ask "(:op \"rerun\")" in
if status r <> "ok" then
fail "--two-process: the re-run after the fix: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "\n"))
|| not (String.starts_with ~prefix:"5\n"
(Buffer.contents seen))
then
fail "--two-process: the fixed program printed %S"
(Buffer.contents seen)
end
end;
ignore (ask "(:op \"close\")");
Unix.close tc