Joseph Ferano
d9ce1baa53
Every check of `abort' so far was of it being refused while the program runs. The accepted path -- the one that ends a program -- was code that had never run and answered `ok'. So the break block breaks its program once more, by installing a `step' that errors into the loop that calls it, and takes the exit: the daemon owns the program's lifetime, so no `close' is sent and the daemon coming down on its own is the assertion. And `restart' refuses a name with a control character in it. The agent's contract is one line per request; a newline in a name is a second request smuggled into the first. `completing-read' with require-match cannot produce one, but the guarantee belongs to the end holding the socket, and an editor is not the only thing that can speak to it.
419 lines
20 KiB
OCaml
419 lines
20 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;
|
|
(* ...and the other way out. Every check above is of an abort being
|
|
*refused*; the accepted path is the one that must not be left as code
|
|
that has never run, because it is the one that ends a program. Break
|
|
it once more — the daemon's own program calls [step] every time round
|
|
its loop, so a body that errors stops it — and take the exit. *)
|
|
(match
|
|
ask
|
|
"(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (error (Missing {:id 9})) 0) (use-placeholder [] -1)))\" :file \"/tmp/buf.flan\")"
|
|
with
|
|
| r when status r <> "ok" ->
|
|
fail "installing a body that errors: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
| _ ->
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the program never stopped on the body that errors"
|
|
else begin
|
|
let r = ask "(:op \"abort\")" in
|
|
if status r <> "ok" then
|
|
fail "abort was refused by a stopped program: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
end);
|
|
Unix.close c;
|
|
(* No [close] op: an abort ends the program, and the daemon owns the
|
|
program's lifetime, so it comes down on its own. A daemon still
|
|
running here would be one waiting on a socket nobody will use. *)
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] bpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
fail "the daemon outlived the program it aborted";
|
|
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
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)"
|