Joseph Ferano
5f4005e61d
The break loop was reachable from a raw socket. This is the half that makes it reachable from an editor, and it all follows from one fact: a program stops at a moment nobody asked about. So the state is learned twice, on purpose. It rides on every reply, beside the program's output and for the same reason -- the likeliest instant for a program to stop is the one just after an evaluation, which is a reply the client is already reading, and learning it a second later from a poll would mean learning it after the echo area had said the evaluation was fine. And a timer asks anyway, once a second with `describe', because a program that stops in a frame of its own game loop produces no reply at all and folding state into replies that never come says nothing. The timer never reconnects -- that would quietly erase the `lost' state that exists to be seen -- and skips while a request is in flight, since accept-process-output runs timers and a poll firing inside a read would eat that read's reply. Three ops: `break' for the restart names, `restart' and `abort'. The annotation owns :stopped and :condition rather than the ops, so one place in the daemon decides whether the program is stopped and the poll and the prompt cannot disagree. "ok" from `restart' means accepted, not resumed: the choice is validated against the stopped stack and taken when that thread next comes round, so it says so and the client clears its own flag rather than polling once, finding it stopped, and re-opening the prompt it just answered. The agent grew one verb, `status', answered in both states. Everything else the break loop offers is refused while running, rightly; but the question an editor asks without already knowing had to have an answer either way or there would be nothing to poll. And flan_agent_poll had to become re-entrant, which was a bug rather than an addition. A C-x C-e thunk may itself error, and the break loop that catches it polls again from inside that call. The old loop cached both indices and stored tail at the end, rewinding over everything the nested poll consumed -- re-running the thunk that had just stopped the program, which is an unbounded recursion of breaks. Each job is now claimed before it is run. test_dev.ml evaluates an expression that errors and resumes it, which fails against the old shape.
386 lines
18 KiB
OCaml
386 lines
18 KiB
OCaml
(* [flan dev]: the daemon an editor talks to (NEXT.md, the dev loop).
|
|
|
|
What it adds over [flan reload] is that the session persists between
|
|
evaluations and that the daemon owns the build, so its idea of the running
|
|
process is not a guess. Both are tested here by sending a sequence: a name
|
|
the program was never built with, then a second evaluation that uses it. If
|
|
the session were rebuilt per request the second one would not even check. *)
|
|
|
|
open Flan
|
|
|
|
let failures = ref 0
|
|
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
|
|
|
let scratch = Filename.get_temp_dir_name ()
|
|
let tmp n = Filename.concat scratch ("flan-devtest-" ^ n)
|
|
|
|
let rec await ?(ms = 5000) f =
|
|
if f () then true
|
|
else if ms <= 0 then false
|
|
else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
|
|
|
|
let rec connect ?(ms = 5000) path =
|
|
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
match Unix.connect s (Unix.ADDR_UNIX path) with
|
|
| () -> s
|
|
| exception Unix.Unix_error (_, _, _) when ms > 0 ->
|
|
Unix.close s;
|
|
ignore (Unix.select [] [] [] 0.005);
|
|
connect ~ms:(ms - 5) path
|
|
|
|
(* The program's own output arrives on the replies, not on a file: the daemon
|
|
reads its stdout through a pipe so an editor can see it. Every reply is
|
|
drained into here, which is also what an editor does. *)
|
|
let output = Buffer.create 256
|
|
|
|
let request fd sexp =
|
|
let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in
|
|
(match Wire.string_field r "output" with
|
|
| Some t -> Buffer.add_string output t
|
|
| None -> ());
|
|
r
|
|
|
|
let status r =
|
|
match Wire.string_field r "status" with Some s -> s | None -> "<none>"
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
|
|
| 0 ->
|
|
let sock = tmp "dev.sock" in
|
|
let out = tmp "prog.out" in
|
|
(try Sys.remove sock with Sys_error _ -> ());
|
|
let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
(* The daemon is run as a subprocess rather than in-process because that is
|
|
how an editor meets it, and because it launches and owns a program of
|
|
its own. Its child's stdout is what we read the result off. *)
|
|
let flan = "../bin/main.exe" in
|
|
let pid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock |]
|
|
Unix.stdin fd Unix.stderr
|
|
in
|
|
Unix.close fd;
|
|
|
|
if not (await (fun () -> Sys.file_exists sock)) then
|
|
fail "the daemon never listened"
|
|
else begin
|
|
(* The daemon owns the program's lifetime and kills it on [close], so
|
|
every step waits for the program to have got there. "ok" from an eval
|
|
means the module was queued, not that it has been installed. *)
|
|
let c = connect sock in
|
|
(* The daemon owns the program's lifetime and kills it on [close], so
|
|
every step waits for the program to have got there. "ok" from an eval
|
|
means the module was queued, not that it has been installed. Output
|
|
only rides along with a reply, so asking is how it is collected, and
|
|
[describe] is the cheapest question there is. *)
|
|
let lines () =
|
|
List.length (String.split_on_char '\n' (Buffer.contents output)) - 1
|
|
in
|
|
let settle n =
|
|
await (fun () ->
|
|
ignore (request c "(:op \"describe\")");
|
|
lines () >= n)
|
|
in
|
|
|
|
(* describe: what the daemon believes about the program it launched. *)
|
|
let r = request c "(:op \"describe\")" in
|
|
if status r <> "ok" then fail "describe: %s" (status r);
|
|
|
|
(* [defs] is its own op rather than more fields on [describe], because
|
|
[describe] is what an editor polls to drain the program's output. It
|
|
carries what eldoc, completion and find-definition each need: a kind,
|
|
a signature, and where the name is written where that is knowable.
|
|
An empty location is the honest answer for a global — Tast.global has
|
|
no Loc — and an editor is expected to refuse rather than guess. *)
|
|
let r = request c "(:op \"defs\")" in
|
|
if status r <> "ok" then fail "defs: %s" (status r);
|
|
(match Wire.field r "defs" with
|
|
| Some { Form.v = Form.List entries; _ } ->
|
|
let find name =
|
|
List.find_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List
|
|
({ Form.v = Form.Str n; _ }
|
|
:: { Form.v = Form.Str kind; _ }
|
|
:: { Form.v = Form.Str sign; _ }
|
|
:: { Form.v = Form.Str loc; _ } :: [])
|
|
when String.equal n name -> Some (kind, sign, loc)
|
|
| _ -> None)
|
|
entries
|
|
in
|
|
(match find "step" with
|
|
| Some ("fn", "step [] i64", loc) when String.length loc > 0 ->
|
|
(* Absolute, because an editor is not in this process's working
|
|
directory and cannot resolve a relative one. *)
|
|
if loc.[0] <> '/' then fail "a fn's location is relative: %s" loc
|
|
| Some (k, s, l) -> fail "step is described as (%s, %s, %s)" k s l
|
|
| None -> fail "defs did not mention step");
|
|
(match find "ticks" with
|
|
| Some ("var", "ticks i64", "") -> ()
|
|
| Some (k, s, l) -> fail "ticks is described as (%s, %s, %s)" k s l
|
|
| None -> fail "defs did not mention ticks");
|
|
(match find "agent/wait-raw" with
|
|
| Some ("extern", _, _) -> ()
|
|
| Some (k, _, _) -> fail "an extern is described as %s" k
|
|
| None -> fail "defs did not mention an imported extern")
|
|
| _ -> fail "defs did not answer with a list");
|
|
|
|
(* A form that does not check comes back as an error with a location,
|
|
and must not disturb the session. *)
|
|
let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error" then fail "a bad form was accepted";
|
|
(match Wire.string_field r "loc" with
|
|
| Some l when String.length l > 0 -> ()
|
|
| _ -> fail "an error carried no location");
|
|
|
|
(* A name the program was never built with, then a second evaluation
|
|
that uses it. The second one only checks at all because the session
|
|
kept the first. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "adding a var: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
(* Wait for the program to have installed it before sending the next.
|
|
Both queued at once is a legitimate thing for the agent to do — one
|
|
poll installs everything pending — but then only the last is observed
|
|
and the sequencing is not what was tested. *)
|
|
if not (settle 2) then fail "the first reload was never installed";
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "reusing a var added earlier: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
|
|
(* A change the running process cannot be told, refused with the reason
|
|
rather than delivered. *)
|
|
let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error"
|
|
|| not
|
|
(match Wire.string_field r "message" with
|
|
| Some m -> String.length m > 0
|
|
| None -> false)
|
|
then fail "retyping a global was not refused";
|
|
|
|
if not (settle 3) then fail "the second reload was never installed";
|
|
|
|
(* A restart-case in a body the process was never built with. The frame
|
|
it offers is an alloca in the newly loaded module's text, the call it
|
|
guards goes through the host's cell, and the transfer starts in a
|
|
handler and crosses [probe], which the host was compiled with. None of
|
|
those three meet anywhere else in the tests. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a redefinition with a restart-case: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (settle 4) then fail "the third reload was never installed";
|
|
|
|
(* Expression evaluation, which is a different primitive: no name to
|
|
install a body into, so a thunk runs at a frame boundary and the value
|
|
comes back rendered. The program has stopped reaching frame boundaries
|
|
by now, so this only checks that the types that have no printer say so
|
|
rather than guessing — the live path is test_repl. *)
|
|
let r = request c "(:op \"eval-expr\" :code \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error" then fail "a declaration was accepted as an expression";
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
(* Closing the connection ends the program, and its transcript is the
|
|
proof: 1 before any reload, 5 from a body over a var that did not
|
|
exist when it started, 105 from a second body reading the same one,
|
|
and 777 from a restart clause in a third — reached by a transfer that
|
|
started in a handler and crossed a function the host was built with. *)
|
|
ignore (Unix.waitpid [] pid);
|
|
let text = Buffer.contents output in
|
|
let wanted = "1\n5\n105\n777\n" in
|
|
if text <> wanted then
|
|
fail "program transcript\n got: %S\n wanted: %S" text wanted
|
|
end;
|
|
|
|
(* ── The break loop, from the editor's side ────────────────────── *)
|
|
|
|
(* A second daemon, over a program that stops on its first frame. The
|
|
claims are that an editor can find out it stopped without having been
|
|
told, that everything an editor does still works while it is stopped —
|
|
C-x C-e most of all, since the break loop *is* the poll loop — and that
|
|
a choice comes back refused or accepted, never "probably".
|
|
|
|
Its own daemon, its own program and its own output buffer: the block
|
|
above ends by checking a transcript, and sharing either with this would
|
|
make that check about two programs at once. *)
|
|
let bsock = tmp "break.sock" and bout = tmp "break.out" in
|
|
(try Sys.remove bsock with Sys_error _ -> ());
|
|
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let bpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-break.flan"; "-s"; bsock |]
|
|
Unix.stdin bfd Unix.stderr
|
|
in
|
|
Unix.close bfd;
|
|
if not (await (fun () -> Sys.file_exists bsock)) then begin
|
|
fail "the break daemon never listened";
|
|
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let boutput = Buffer.create 256 in
|
|
let c = connect bsock in
|
|
let ask sexp =
|
|
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
(match Wire.string_field r "output" with
|
|
| Some t -> Buffer.add_string boutput t
|
|
| None -> ());
|
|
r
|
|
in
|
|
(* [:stopped] is on every reply, whatever was asked. An editor that had
|
|
to ask would find out only when it happened to wonder, and a program
|
|
stops at moments nobody is wondering about. *)
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
let condition r =
|
|
match Wire.string_field r "condition" with Some c -> c | None -> ""
|
|
in
|
|
let last = ref (ask "(:op \"describe\")") in
|
|
if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last))
|
|
then fail "a stopped program never said so on a reply it was already sending"
|
|
else begin
|
|
if condition !last <> "Missing" then
|
|
fail "the condition is reported as %S, wanted %S" (condition !last)
|
|
"Missing";
|
|
|
|
(* What is on offer, innermost first. [break] carries the names and
|
|
nothing else — the state is the annotation's business, so there is
|
|
one place in the daemon that decides it. *)
|
|
let r = ask "(:op \"break\")" in
|
|
if status r <> "ok" then fail "break: %s" (status r);
|
|
(match Wire.field r "restarts" with
|
|
| Some { Form.v = Form.List names; _ } ->
|
|
let names =
|
|
List.filter_map
|
|
(fun (n : Form.t) ->
|
|
match n.Form.v with Form.Str s -> Some s | _ -> None)
|
|
names
|
|
in
|
|
if names <> [ "retry"; "use-placeholder" ] then
|
|
fail "restarts on offer: %s" (String.concat ", " names)
|
|
| _ -> fail "break did not list the restarts");
|
|
|
|
(* The payoff. The break loop is the poll loop, so an expression
|
|
evaluated here is a module the listener queues and the *stopped*
|
|
thread runs — which is the only reason C-x C-e works at the one
|
|
moment anybody wants it to. *)
|
|
let r =
|
|
ask "(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if Wire.string_field r "value" <> Some "23" then
|
|
fail "C-x C-e while stopped: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
|
|
(* And installing, which the break loop deliberately allows: there is
|
|
no frame in progress, so the rule about swapping a body that is on
|
|
the stack does not apply. This is the fix-it-and-retry loop. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 100)) ticks)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
|
|
(* A name nothing offers is refused against the live stack, on the
|
|
program's listener thread, before the reply. *)
|
|
let r = ask "(:op \"restart\" :name \"nonesuch\")" in
|
|
if status r <> "error" then fail "a restart nobody offers was accepted";
|
|
|
|
let r = ask "(:op \"restart\" :name \"retry\")" in
|
|
if status r <> "ok" then
|
|
fail "choosing a restart: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
|
|
(* [retry] returns 7 and [use-placeholder] returns -1, so the number in
|
|
the transcript is the proof that this choice and not the other one
|
|
was taken. *)
|
|
let printed () =
|
|
ignore (ask "(:op \"describe\")");
|
|
List.exists (String.equal "7")
|
|
(String.split_on_char '\n' (Buffer.contents boutput))
|
|
in
|
|
if not (await printed) then fail "the chosen restart never resumed";
|
|
|
|
(* Running again, and now every break verb is refused by name. There is
|
|
no restart stack to walk from a running program, and answering an
|
|
empty list would read as "no restarts are active". *)
|
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
|
fail "the program still reads as stopped after resuming"
|
|
else begin
|
|
let r = ask "(:op \"restart\" :name \"retry\")" in
|
|
if status r <> "error" then
|
|
fail "a restart was accepted by a running program";
|
|
let r = ask "(:op \"abort\")" in
|
|
if status r <> "error" then
|
|
fail "an abort was accepted by a running program";
|
|
(* ...and an ordinary evaluation works again on the far side of it. *)
|
|
let r =
|
|
ask "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if Wire.string_field r "value" <> Some "2" then
|
|
fail "an expression after the break: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
|
|
(* An expression that stops *itself*. The thunk runs on the game
|
|
thread from inside a poll, and the break loop it lands in polls
|
|
again from inside that very call — so the agent's poll has to be
|
|
re-entrant. One that cached its indices and wrote them back at the
|
|
end would rewind over everything the nested poll consumed and run
|
|
this same thunk again, which is not a stumble but an unbounded
|
|
recursion of breaks.
|
|
|
|
The evaluation cannot answer from in there and says so, with the
|
|
reason, rather than waiting forever or claiming a value. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval-expr\" :code \"(i64 (fetch 2))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "error" then
|
|
fail "an expression that stopped the program answered anyway";
|
|
if not (stopped r) then
|
|
fail "an expression that stopped the program did not report it";
|
|
let r = ask "(:op \"restart\" :name \"use-placeholder\")" in
|
|
if status r <> "ok" then
|
|
fail "resuming an expression that stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
|
fail "the stopped expression never resumed"
|
|
else
|
|
let r =
|
|
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
(* Still there, and evaluating once per evaluation: a thunk run
|
|
twice by a rewound queue would have broken a second time. *)
|
|
if Wire.string_field r "value" <> Some "4" then
|
|
fail "an expression after a break inside a thunk: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
end
|
|
end;
|
|
ignore (ask "(:op \"close\")");
|
|
Unix.close c;
|
|
ignore (Unix.waitpid [] bpid)
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ sock; out; bsock; bout ];
|
|
if !failures = 0 then print_endline "dev: all tests passed"
|
|
else begin
|
|
Printf.printf "\n%d failure(s)\n" !failures;
|
|
exit 1
|
|
end
|
|
| _ -> print_endline "dev: skipped (no clang or llc on PATH)"
|