Merge: a failed module leaves the session as it found it

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 Failure m -> refused m)
-    | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg
+       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))
+            refused ("cannot reach the program: " ^ Unix.error_message e))
-       | exception Failure m -> error m)
+       | 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

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 = "<eval>") ?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 = "<eval>") ?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:
+  (* Every one of these together, and after the last thing *here* that can
-     until this line the session is still the one the evaluation started
+     raise: until this line the session is still the one the evaluation started
-     against, which is what makes a refusal cost nothing. *)
+     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 = "<eval>") ?(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 }
 

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

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