diff --git a/TODO.org b/TODO.org index ef81b3c1..d721a04c 100644 --- a/TODO.org +++ b/TODO.org @@ -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 diff --git a/lib/dev.ml b/lib/dev.ml index 3d5854d6..299cfbbd 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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 diff --git a/lib/session.ml b/lib/session.ml index dd6c2292..14a2fc2a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 diff --git a/test/test_dev.ml b/test/test_dev.ml index e487f855..d59907bc 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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