diff --git a/lib/dev.ml b/lib/dev.ml index c671d76..01762a5 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -527,6 +527,39 @@ let parked_msg why = let parked why = error (parked_msg why) +let contains hay needle = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + n = 0 || go 0 + +(* A module the agent would not take, said in the daemon's words rather than + only in the agent's. + + The agent refuses a full reload ring with "the program is not calling + agent/poll", which is the right cause for a program that is running and the + wrong one for a program that has finished. A parked process is not failing + to poll: it has no game thread left to poll with, it is waiting in the park + for somebody to run it again, and nothing drains the ring until then — so + the sixty-fifth module queued since it parked is refused for the very + behaviour [eval] below promises it — that a body redefined while parked + installs when the program is run again. A reader told to check their + [agent/poll] calls would go looking at a loop that is not running. + + The agent cannot say this itself. Parking is the merged shim's state and the + agent is vendored beside it knowing nothing about runs; what knows is this + daemon, which has just asked [liveness] and is about to quote a reply. So + the substitution is made here, on a substring of a reply this side did not + write — the same move [abi_mismatch] makes on [dlerror]'s text, and made for + the same reason: the component that has the words does not have the + context. *) +let refusal ~parked reply = + if parked && contains reply "reload queue full" then + "the program refused the module: its reload ring is full, and a parked \ + program drains none of it — every module queued since it finished is \ + still waiting for a frame boundary, and M-x flan-rerun is what gives them \ + one; this one was not taken, so send it again after that run" + else "the program refused the module: " ^ reply + (* [pause], when given, is the position of the form to stop at — §9. It rides beside the code rather than in it, and the reply echoes it back so an editor marks the buffer only for a mark the session actually applied. @@ -545,6 +578,18 @@ let parked why = error (parked_msg why) let eval t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in + (* What the session was before the form was checked, and every failure below + puts it back. [Session.eval] commits as soon as the check succeeds, which + is two fallible steps too early: the build can fail and the agent can + refuse, and a session left holding a declaration no module was accepted + for hands the *next* module a name to intern a cell for and nothing to put + in it — a null cell the first call through jumps to. See [Session.held]. + + Only the failures restore. The [installs = false] arm is a real + acceptance: there is nothing to build and nothing to deliver, so there is + 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 else match Session.eval ~origin ?pause t.session code with @@ -557,6 +602,23 @@ let eval t ~code ~origin ~pause = [ ":names " ^ Wire.strings c.Session.names; ":fns ()"; ":note " ^ Wire.quote "nothing to install" ] | c -> + (* Everything from here to the delivery is inside the restore, and by + exception type as well as by arm. The three named below are the ones + with a sentence to say; what is left is every other way a file system + can refuse — [write_file] cannot create its copy of the module's text, + the working directory went away underneath the daemon — which used to + leave through [serve]'s guard with the session already holding the + declaration. That is the same stranding under a different exception, + and [serve] still writes the reply: this only puts the session back on + the way past. + + [accepted] is what the catch-all needs to know and the arms cannot + tell it. Once the agent has said "ok" the module is the program's, + whatever goes wrong while this reply is being written, and rolling + the session back then would strand the declaration the other way + round — the process holding a body the session has forgotten. *) + let accepted = ref false in + (try t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "m%d.so" t.n) in (* [Build.shared] deletes its own .ll unless asked to keep it, and what it @@ -573,6 +635,7 @@ let eval t ~code ~origin ~pause = | timing -> (match deliver t out with | "ok" -> + accepted := true; t.gen <- t.gen + 1; List.iter (fun n -> @@ -595,13 +658,21 @@ let eval t ~code ~origin ~pause = when it is run again rather than at its next frame \ boundary" ] else [])) - | reply -> error ("the program refused the module: " ^ reply) + | reply -> refused (refusal ~parked:parked_now reply) | exception Unix.Unix_error (e, _, _) -> - error + refused ("cannot reach the program on " ^ t.agent ^ ": " ^ Unix.error_message e)) - | exception Failure m -> error m) - | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg + | exception Failure m -> refused m) + with e when not !accepted -> Session.restore t.session before; raise e) + (* Nothing to put back: the check itself raised, so [Session.eval] never + reached its assignments. The restore is written anyway rather than + reasoned about at each arm — a refusal that costs one record copy is + cheaper than a reader working out which of the four fields this one + could have moved. *) + | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> + Session.restore t.session before; + error ~loc:(Loc.to_string l) msg (* Redefining a name installs a body; evaluating an expression has no name to install into, so the module carries a thunk the agent runs once. The value @@ -620,6 +691,15 @@ let eval_expr t ~code ~origin ~pause = "an expression is evaluated at a frame boundary, and a parked program \ reaches none" | Live -> + (* The same rollback [eval] takes, for the same reason and a smaller + cargo. A thunk is not a declaration and never joins the session, but the + generic instances the expression forced *are* kept — [Session.eval_expr] + says why — and they are kept before this module has been built or taken. + An instance the session holds and no module ever defined is a null cell + exactly as a stranded [defn] is, and the next expression that mentions + the same instantiation would list it as already there. *) + let held = Session.held t.session in + let refused msg = Session.restore t.session held; error msg in match Session.eval_expr ~origin ~pause t.session code with | c -> let before = match result t with Some (g, _) -> g | None -> 0L in @@ -682,10 +762,19 @@ let eval_expr t ~code ~origin ~pause = error "the program did not reach a frame boundary; is it calling \ (agent/poll)?") - | reply -> error ("the program refused the module: " ^ reply) + (* A module that was taken is the program's from here on, whatever + the wait then says: a timeout is a frame boundary not reached + yet, not a module refused, so the instances in it stay in the + session. Only the two arms below, where nothing was accepted, + put the session back. + + No [refusal] either, and that is not an omission: this verb + refuses a parked program before it compiles anything, so the one + reply whose cause that rewrites cannot arrive here. *) + | reply -> refused ("the program refused the module: " ^ reply) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e)) - | exception Failure m -> error m) + refused ("cannot reach the program: " ^ Unix.error_message e)) + | exception Failure m -> refused m) | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg (* What a macro call expands to — [C-c C-m], and the one verb here that never @@ -2031,11 +2120,6 @@ let run_capture cmd = let code = match Unix.close_process_in ic with Unix.WEXITED c -> c | _ -> -1 in (code, Buffer.contents b) -let contains hay needle = - let n = String.length needle and h = String.length hay in - let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in - n = 0 || go 0 - (* The IR of one function out of a module's text. [Emit] writes a define's closing brace at column 0 and nowhere else, so the end is unambiguous without parsing LLVM. One .ll can carry several bodies — [C-c C-k] sends a diff --git a/lib/session.ml b/lib/session.ml index 0a3e4cb..f1c12e8 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -408,6 +408,67 @@ let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns = in fail loc "the x86 dev backend cannot compile this: %s" m +(* ── Undoing an acceptance ─────────────────────────────────────────── *) + +(* Checking is not the last thing that can fail, and until this existed the + session behaved as though it were. [eval] assigns the four mutable fields + the moment a form checks; the *build* and the *delivery* happen afterwards, + in the daemon, and either can refuse — llc can fail, and the agent's reload + ring can be full, which a parked program guarantees after enough queued + installs, since nothing drains the ring while the main thread waits. The + editor saw an error either way, so the evaluation looked refused; the + session went on holding the declaration anyway. + + That leftover is not untidiness, it is a segfault. A declaration the session + holds and the host does not export is a name every later module lists in its + install prologue, and the prologue interns a cell for it. A cell nothing + ever stored a body into is NULL, and a dev build's call through a cell is a + load and an indirect call with no test in front of it — so the next + [C-x C-e], the next locals render, the next globals refresh jumps the game + thread to address 0. One failed build, and the next thing anybody types + kills the program. + + So the four fields are one unit that can be put back. [held] is what the + session was before the evaluation and [restore] is the session being that + again — all four together, because they are four views of one answer: the + declarations, the checked program, the checker's environment, and the macros + a later form expands against. Putting back three of them would leave the + checker willing to accept a call to a name the program does not have, which + is the same crash by a longer road. + + What a restored session can claim is the honest sentence rather than the one + anyone would rather have: it holds no declaration that no module was + *accepted* for. Accepted is not installed — the agent queues a module and + the game thread installs it at a frame boundary — but a queued module is one + the process has and will run, and that is as far as this side can see. + + A [defmacro] evaluated in the same breath as a [defn] that fails to build + goes back with it, and that is right: they arrived as one form and were + accepted as one. A [defmacro] on its own never reaches a restore, because a + change with no body to install and no storage to allocate is answered before + anything is built. + + [thunks] is not in here. It is a counter that keeps two evaluations from + naming their thunks alike, not something the session believes about the + program, and the agent refuses a full ring *before* it dlopens — so a + rolled-back number would be reused for a module nothing ever mapped, and + reusing it is the one way to make two live modules share a symbol. *) +type held = { + hdecls : Ast.decl list; + hprogram : Tast.program; + henv : Check.env; + hmacros : Form.t list; +} + +let held t = + { hdecls = t.decls; hprogram = t.program; henv = t.env; hmacros = t.macros } + +let restore t h = + t.decls <- h.hdecls; + t.program <- h.hprogram; + t.env <- h.henv; + t.macros <- h.hmacros + let eval ?(origin = "") ?pause t src : change = let forms = Reader.read_all ~file:origin src in Parse.with_imported t.macros @@ fun () -> @@ -593,9 +654,15 @@ let eval ?(origin = "") ?pause t src : change = (fun (g : Tast.global) -> not (known t g.Tast.gname)) program.Tast.globals in - (* Every one of these together, and after the last thing that can raise: - until this line the session is still the one the evaluation started - against, which is what makes a refusal cost nothing. *) + (* Every one of these together, and after the last thing *here* that can + raise: until this line the session is still the one the evaluation started + against, which is what makes a refusal cost nothing. + + It is not the last thing that can fail, though, and this line used to be + written as if it were. The build and the delivery come after it, in the + daemon, and both can refuse — so the caller takes a [held] first and puts + it back when they do. See [restore] above for what a session that kept the + declaration anyway does to the program. *) t.macros <- !macros; t.decls <- decls; t.program <- program; @@ -1297,7 +1364,13 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = After [Emit], not before it: the session must not come to believe it holds a body that no module was ever written for. A daemon that answers and has - lost track of what the program contains is worse than one that died. *) + lost track of what the program contains is worse than one that died. + + Written for is as far as this line can get, and it is not far enough on + its own: the module still has to build and still has to be taken. The + caller closes that half by taking a [held] before this and restoring it + when either fails — a copy the session holds and no module defines is a + null cell exactly as a stranded declaration is. *) t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; { ir; x86 = t.x86; names = []; fns = []; installs = true } diff --git a/test/test_dev.ml b/test/test_dev.ml index 32c67df..f366138 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -152,6 +152,42 @@ let contains_sub hay needle = in go 0 +(* ── Whose fault a full reload ring is ──────────────────────────────── *) + +(* The agent refuses a module it has no room to queue with "the program is not + calling agent/poll", and for a running program that is the cause. For a + parked one it is the wrong cause said confidently: there is no game thread + left to poll with, the ring is full precisely *because* the program + finished, and [Dev.eval]'s own note promises exactly that a body redefined + while parked installs when the program is run again. Somebody sent + the sixty-fifth one, and the reply sent them to read a loop that is not + running. + + Pinned on the decision rather than end to end. Filling the ring means + sixty-four modules through a real clang, which is minutes of [dune test] to + assert one sentence; what the daemon *does* with the agent's words is the + whole of the change, and it is a function of two arguments. The pass-through + is asserted too: a running program's refusal must still arrive in the + agent's own words, because for it they are true. *) +let () = + let full = "err reload queue full; the program is not calling agent/poll" in + let parked = Dev.refusal ~parked:true full in + if contains_sub parked "not calling agent/poll" then + fail "a parked program's queue-full refusal still blames its poll: %S" + parked; + if not (contains_sub parked "flan-rerun") then + fail "a parked program's queue-full refusal names no way out: %S" parked; + let live = Dev.refusal ~parked:false full in + if not (contains_sub live "not calling agent/poll") then + fail "a running program's queue-full refusal lost the agent's reason: %S" + live; + (* Only that one reply is rewritten. Every other refusal a parked program + can give — a bad ABI, a module with no installer — is the agent's to + explain and is quoted as it stands. *) + let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in + if not (contains_sub other "flan.abi.x86") then + fail "a parked program's other refusals were rewritten too: %S" other + let () = match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with | 0 -> @@ -3179,6 +3215,92 @@ let () = | None -> fail "(probe-one) produced no value") | Some r -> fail "(probe-one): %s %s" (status r) (message r) | None -> ()); + + (* ── A form that checks and then fails to land ─────────────────── *) + + (* The two above fail inside the check — a macro module that will not + build is refused before [Session.eval] has committed anything, which + is the easy half. This is the other half, and it is the one that used + to end in a segfault: a form that checks, joins the session, and then + cannot be built or cannot be delivered. The editor reads an error and + the session goes on holding the declaration; the next module built for + that session lists the name in its install prologue, interns a cell + for it, stores nothing in it, and the first call through that cell + jumps the game thread to address 0. + + Reached by taking the daemon's own working directory away from it, + which is where a redefinition module is written — a different lever + from the cache above, and deliberately so: the cache is the macro + module's and cannot fail a build that has no macro in it. The + directory is named after the daemon's pid, which is the one this test + started. + + The last step is the crash. Pre-fix, [(probe-two)] compiled to a call + through a null cell and this file died with the program; the assertion + it now makes is that the daemon refuses by name instead. *) + let devdir = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-dev-%d" rpid) + in + let probe_two = "(defn probe-two [] i64 7)" in + let before = knows () in + (try Unix.chmod devdir 0o500 with Unix.Unix_error _ -> ()); + (match + ask_or "a redefinition the daemon cannot write its module for" + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote probe_two) (Wire.quote origin)) + with + | Some r -> + if status r <> "error" then + fail "a redefinition whose module could not be written answered %s" + (status r) + | None -> ()); + (try Unix.chmod devdir 0o700 with Unix.Unix_error _ -> ()); + (match knows () with + | k when k <> before -> + fail "a redefinition that never landed changed what the session \ + knows:\n was: %s\n now: %s" before k + | k -> + if contains_sub k "probe-two" then + fail "a redefinition that never landed left probe-two in the \ + session"); + (match + ask_or "an expression calling a redefinition that never landed" + (Printf.sprintf "(:op \"eval-expr\" :code \"(probe-two)\" :file %s)" + (Wire.quote origin)) + with + | Some r -> + if status r <> "error" then + fail "an expression calling a body no module carries answered %s" + (status r); + if not (contains_sub (message r) "probe-two") then + fail "the refusal did not name the body that never landed: %S" + (message r) + | None -> ()); + (* Usable afterwards, for the thing that just failed: the same form + again, and then the call that could not be made. *) + (match + ask_or "the redefinition after one that could not be written" + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote probe_two) (Wire.quote origin)) + with + | Some r when status r = "ok" -> () + | Some r -> + fail "the redefinition after one that could not be written: %s %s" + (status r) (message r) + | None -> ()); + (match + ask_or "a call to the body the recovered evaluation installed" + (Printf.sprintf "(:op \"eval-expr\" :code \"(probe-two)\" :file %s)" + (Wire.quote origin)) + with + | Some r when status r = "ok" -> + (match Wire.string_field r "value" with + | Some "7" -> () + | Some v -> fail "(probe-two) evaluated to %s, not 7" v + | None -> fail "(probe-two) produced no value") + | Some r -> fail "(probe-two): %s %s" (status r) (message r) + | None -> ()); (* ── An editor that leaves before its reply does ──────────────── *) (* The failure this closes was a flake in test_emacs, and it read like nothing it was: two break-loop checks failing, and then diff --git a/test/test_session.ml b/test/test_session.ml index 4d03c9c..cc7e2c5 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -189,6 +189,55 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a bad expression: %s" m); + (* The other half of "a refusal costs nothing", and the half that used to be + missing: a form can check and *then* fail, in the build or at the agent, + and the session that already accepted it has no way to hear about it + unless the caller puts it back. [Session.held] and [Session.restore] are + that way, and this is the crash they close. + + Rehearsed rather than simulated: neither llc nor a full reload ring can be + summoned from here, and what matters is not which of them failed but what + the session does afterwards. So the declaration is accepted, shown to be + callable — the module for an expression that calls it names it, which is + the name a later install prologue would intern a cell for and never store + a body into — and then the session is put back and asked again. + + Both sides are asserted. Without the first, a test that only checked the + refusal would pass on a session that had never accepted the [defn] at + all. *) + (let rt, _ = Session.create ~file:"programs/reload.flan" () in + let h = Session.held rt in + (match Session.eval rt "(defn stranded [] i64 7)" with + | c -> + if c.Session.fns <> [ "stranded" ] then + fail "a new declaration did not offer its body to install" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a new declaration was refused: %s" m); + (match Session.eval_expr rt "(println (stranded))" with + | e -> + if not (has e.Session.ir "stranded") then + fail "an expression calling a fresh declaration did not name it" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a fresh declaration was not callable: %s" m); + Session.restore rt h; + (* The module that would have jumped to address 0. After the restore the + name is simply not one this session has, which is the whole of the + fix: a refusal in the editor instead of a segfault in the program. *) + (match Session.eval_expr rt "(println (stranded))" with + | _ -> + fail "a restored session still let an undelivered declaration be called" + | exception Loc.Error { Loc.dmsg = m; _ } -> + if not (has m "stranded") then + fail "the refusal after a restore was about something else: %S" m); + (* And it is a restore, not a poisoning: the same form offered again is + accepted again, which is what an editor does after reading the error. *) + match Session.eval rt "(defn stranded [] i64 7)" with + | c -> + if c.Session.fns <> [ "stranded" ] then + fail "a re-sent declaration did not offer its body to install" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "the session was poisoned by a restore: %s" m); + (* A declaration the program already has, with no body and no new storage, is accepted and has nothing to send. Building a module for it would report success for a change that cannot have taken effect, and would cost the