The session is put back however the module failed to land
The three named arms are not every way a step after the check can fail. write_file makes the daemon's copy of the module's text before llc is called at all, and a Sys_error from it went out through serve's guard with the session already holding the declaration — the same stranded declaration under a different exception. Dev.eval now restores on the way past anything that escapes, and carries an accepted flag so that a module the agent has already taken is never rolled back out from under the process. That is also the seam the crash can be reproduced through. test_dev takes the daemon's working directory away from it — its own, not the macro cache the two failures above use, which cannot fail a build with no macro in it — evaluates a defn, and then calls it. Without the restore the daemon lists probe-two in describe and the call closes the socket: the null cell, the game thread, and address 0.
This commit is contained in:
parent
d36c77ba6b
commit
b23dcf73f3
19
lib/dev.ml
19
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user