diff --git a/lib/dev.ml b/lib/dev.ml index 25d3ff7..a4a575f 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -603,6 +603,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 @@ -619,6 +636,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 -> @@ -647,6 +665,7 @@ let eval t ~code ~origin ~pause = ("cannot reach the program on " ^ t.agent ^ ": " ^ Unix.error_message e)) | 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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 05190c6..f366138 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -3215,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