Joseph Ferano
4a6a8fa0f7
Two frames offering `retry` put both on the break loop's list and only the inner one within reach: §4's walk takes the first frame offering a name, by definition, so the outer clause was drawn, offered, and unreachable. The old prompt showed `retry` twice and sent the string either way. An index is the only thing that can say which one, which is why SBCL identifies them positionally too. An index is worthless against a stack that moves, though, and this one moves: the break loop is the poll loop, so every restart-case an evaluation enters pushes and pops the same global list between the listing and the choice. So the list is read once on entry and copied — names into the agent's own buffer, frames as the addresses a transfer carries — and every answer comes from that. The name still travels with the index as a receipt, checked against the snapshot and refused if the two have drifted, so a bare integer can be wrong out loud. And the third state. A restart below the thunk a break is inside was accepted, announced, and silently not taken: `flan_reload_call` holds its own transfer channel and drops it on return, so the unwind stops at the thunk. The boundary is now recorded where it is made, at the call — frames a restart-case inside the thunk pushes are above it and still work — and such a restart is listed, marked, and refused with the reason. `break.flan` grew the shadowed pair, and 900 is a value no by-name lookup in that file can produce.
775 lines
37 KiB
OCaml
775 lines
37 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 break inside a thunk, and the frames it cannot reach ---- *)
|
|
|
|
(* Evaluating here runs a thunk through [flan_reload_call], which holds
|
|
its own transfer channel and drops it on return. So a restart below
|
|
that C frame — the two this program was already stopped on — has
|
|
nowhere for a transfer to land: it would unwind to the thunk, stop,
|
|
and the program would carry on as though nothing had been chosen.
|
|
It used to be accepted and announced and silently not taken, which
|
|
is the worst of the three things that could happen.
|
|
|
|
Now the list says so and the choice is refused with the reason. *)
|
|
let r =
|
|
ask "(:op \"eval-expr\" :code \"(i64 (fetch 9))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "error" then
|
|
fail "an expression that stopped inside a break answered anyway";
|
|
let r = ask "(:op \"break\")" in
|
|
if status r <> "ok" then fail "break inside a thunk: %s" (status r);
|
|
(* Four now: the thunk's own [fetch] frame over the one below it. *)
|
|
let names =
|
|
match Wire.field r "restarts" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (n : Form.t) ->
|
|
match n.Form.v with Form.Str x -> Some x | _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
if names <> [ "retry"; "use-placeholder"; "retry"; "use-placeholder" ]
|
|
then fail "restarts at a break inside a thunk: %s"
|
|
(String.concat ", " names);
|
|
let unreachable =
|
|
match Wire.field r "unreachable" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (n : Form.t) ->
|
|
match n.Form.v with
|
|
| Form.Int i -> Some (Int64.to_int i)
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
if unreachable <> [ 2; 3 ] then
|
|
fail "positions below the thunk: %s"
|
|
(String.concat ", " (List.map string_of_int unreachable));
|
|
(* Refused, and refused *here* — not accepted and dropped. *)
|
|
let r = ask "(:op \"restart-at\" :index 2 :name \"retry\")" in
|
|
if status r <> "error" then
|
|
fail "a restart below the thunk boundary was accepted";
|
|
(* The ones above it still work, so this refuses a case rather than
|
|
disabling the feature. *)
|
|
let r = ask "(:op \"restart-at\" :index 0 :name \"retry\")" in
|
|
if status r <> "ok" then
|
|
fail "a restart inside the thunk was refused: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
(* And the program is back on the *outer* break, which is the one it
|
|
was on before any of this — the inner resume must not have been
|
|
read as the outer one resuming. *)
|
|
if not
|
|
(await (fun () ->
|
|
let r = ask "(:op \"break\")" in
|
|
status r = "ok"
|
|
&& (match Wire.field r "restarts" with
|
|
| Some { Form.v = Form.List l; _ } -> List.length l = 2
|
|
| _ -> false)))
|
|
then fail "the outer break did not come back after the inner one";
|
|
|
|
(* 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;
|
|
(* ── Disassembly ───────────────────────────────────────────────── *)
|
|
|
|
(* A third daemon, over a program that keeps running, because the two
|
|
claims here are about *which* module owns a name and what the answer is
|
|
allowed to say it means — and both change the moment a body is
|
|
delivered. Its own session rather than a reuse of the first: the first
|
|
one's program has been reloaded four times and abandoned by the time it
|
|
gets here, and a generation counter tested against a session someone
|
|
else drove says nothing. *)
|
|
let dsock = tmp "disasm.sock" and dout = tmp "disasm.out" in
|
|
(try Sys.remove dsock with Sys_error _ -> ());
|
|
let dfd = Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let dpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; dsock |]
|
|
Unix.stdin dfd Unix.stderr
|
|
in
|
|
Unix.close dfd;
|
|
if not (await (fun () -> Sys.file_exists dsock)) then begin
|
|
fail "the disassembly daemon never listened";
|
|
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect dsock in
|
|
let generation r =
|
|
match Wire.field r "generation" with
|
|
| Some { Form.v = Form.Int n; _ } -> Some (Int64.to_int n)
|
|
| _ -> None
|
|
in
|
|
let text r = Option.value ~default:"" (Wire.string_field r "text") in
|
|
let basis r = Option.value ~default:"" (Wire.string_field r "basis") in
|
|
let has 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
|
|
in
|
|
let have_objdump =
|
|
Sys.command "command -v objdump > /dev/null 2>&1" = 0
|
|
in
|
|
|
|
(* Nothing has been delivered, so the cell still holds the body the
|
|
process was launched with. This is the one case where "what is
|
|
installed now" is knowable, and the reply has to say so rather than
|
|
hedging like the others. *)
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "the IR of a name the program was built with: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if generation r <> Some 0 then
|
|
fail "an untouched name is not generation 0";
|
|
if not (has (text r) "define") || not (has (text r) "flan.step") then
|
|
fail "the IR of step is not a define of it: %S" (text r);
|
|
(* One function, not the module: dev-repl.flan defines [main] too, and
|
|
a slice that ran past its own closing brace would carry it. *)
|
|
if has (text r) "flan.main" then
|
|
fail "the IR of step carried another function with it";
|
|
if not (has (basis r) "host executable") then
|
|
fail "an untouched name does not say it is the host's: %S" (basis r)
|
|
end;
|
|
|
|
(* Delivering one moves the ownership, and with it everything the reply
|
|
derives from it: the generation, the object, the location the body was
|
|
typed at, and what the answer is now allowed to claim. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 7)) ticks)\" :file \"/tmp/disasm.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body to disassemble: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "the IR of a redefined name: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if generation r <> Some 1 then
|
|
fail "a redefined name is not generation 1: %s"
|
|
(match generation r with Some n -> string_of_int n | None -> "none");
|
|
(* The body that was just sent, not the one the program was built
|
|
with — the two differ only in the constant. *)
|
|
if not (has (text r) "7") then
|
|
fail "the IR shown is not the body that was delivered: %S" (text r);
|
|
if Wire.string_field r "loc" <> Some "/tmp/disasm.flan:1:7" then
|
|
fail "the location is not where the new body was typed: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "loc"));
|
|
match Wire.string_field r "object" with
|
|
| Some o when Filename.check_suffix o ".ll" -> ()
|
|
| o ->
|
|
fail "the IR did not come from a .ll: %s" (Option.value ~default:"" o)
|
|
end;
|
|
(* The honesty rule, and the whole reason this op is not allowed to say
|
|
"installed": the daemon delivered a module and the agent queued it,
|
|
which is not the same as the game thread having stored it into a
|
|
cell — and there is no verb that would let the daemon find out. *)
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if has (basis r) "host executable" then
|
|
fail "a delivered body still claims to be the host's";
|
|
if not (has (basis r) "cannot read the cell back")
|
|
&& not (has (basis r) "not installed yet")
|
|
&& not (has (basis r) "cannot be said")
|
|
then fail "a delivered body claims more than delivery: %S" (basis r)
|
|
end;
|
|
|
|
if not have_objdump then
|
|
print_endline "dev: disassembly skipped (no objdump on PATH)"
|
|
else begin
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in
|
|
if status r <> "ok" then
|
|
fail "the machine code of a redefined name: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
(* Offsets from the function's own start, SBCL's way: an address into
|
|
a .so is the one number on the line a reader cannot use. The first
|
|
instruction is therefore at 0000 whatever the object's layout. *)
|
|
if not (has (text r) " 0000 ") then
|
|
fail "the listing is not rebased to the function's start: %S" (text r);
|
|
if not (has (text r) "ret") then
|
|
fail "the listing has no instructions in it: %S" (text r);
|
|
(* Not faked. There are no line tables in this build, so the reply
|
|
says that rather than printing a listing with no source in it. *)
|
|
if not (has (Option.value ~default:"" (Wire.string_field r "note"))
|
|
"line tables")
|
|
then fail "the listing does not say why there is no source in it";
|
|
match Wire.string_field r "object" with
|
|
| Some o when Filename.check_suffix o ".so" -> ()
|
|
| o -> fail "the code did not come from a .so: %s"
|
|
(Option.value ~default:"" o)
|
|
end;
|
|
(* The other presentation borrow, and the one that needs a body with
|
|
somewhere to jump to: a branch inside the function reads as [L0]
|
|
rather than as an address into an object nobody will open. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn wind [n i32] i32 (let [acc 0] (dotimes [i n] (set acc (+ acc i))) acc))\" :file \"/tmp/disasm.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with a loop in it: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else
|
|
let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in
|
|
if status r <> "ok" then
|
|
fail "the machine code of a loop: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else if not (has (text r) "L0:") then
|
|
fail "a branch target is not labelled: %S" (text r)
|
|
else if has (text r) "<flan.wind+" then
|
|
fail "a branch still names the function it is inside: %S" (text r)
|
|
end;
|
|
|
|
(* Refused by name, each for its own reason: [ok] would have to mean
|
|
"probably" otherwise. *)
|
|
let refused what req wanted =
|
|
let r = request c req in
|
|
if status r <> "error" then fail "%s was not refused" what
|
|
else
|
|
match Wire.string_field r "message" with
|
|
| Some m when has m wanted -> ()
|
|
| m ->
|
|
fail "%s was refused for the wrong reason: %s" what
|
|
(Option.value ~default:"" m)
|
|
in
|
|
refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")"
|
|
"not a function";
|
|
refused "a name nothing defines"
|
|
"(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")"
|
|
"no function named";
|
|
refused "a form that is neither ir nor asm"
|
|
"(:op \"disassemble\" :name \"step\" :form \"pdf\")"
|
|
"\"ir\" or";
|
|
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
|
|
"needs :name";
|
|
|
|
(* A stopped program has not thereby failed to install. The commonest way
|
|
to stop is to install a body and have it error, so the one thing the
|
|
basis must not say here is "not installed yet" — it would be asserting
|
|
non-installation in exactly the case where the body is running. *)
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (error (Missing {:id 3})))\" :file \"/tmp/disasm.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body that errors: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else if
|
|
not (await (fun () -> stopped (request c "(:op \"describe\")")))
|
|
then fail "the program never stopped on the body that errors"
|
|
else begin
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "disassembling while the program is stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if not (has (basis r) "stopped on Missing") then
|
|
fail "a stopped program is not mentioned in the basis: %S" (basis r);
|
|
if has (basis r) "not installed" then
|
|
fail "a stopped program is said not to have installed: %S" (basis r)
|
|
end
|
|
end;
|
|
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] dpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ];
|
|
|
|
(* ── A location that survives an evaluation that did not land ───── *)
|
|
|
|
(* [Session.eval] replaces the checked program the moment a form checks,
|
|
which is before the build and before delivery. So there is a window in
|
|
which the session holds a body the running process has never seen, and a
|
|
disassembly that took its source location from the session would point
|
|
into the buffer of code that never landed — while showing the host's
|
|
code and saying, correctly, that nothing had been delivered. One reply
|
|
contradicting itself in two fields.
|
|
|
|
A daemon whose [llc] is [false] reproduces it exactly and cheaply: the
|
|
host is built by clang and runs, every redefinition checks and then
|
|
fails to build, and nothing is ever delivered. *)
|
|
let ssock = tmp "stale.sock" and sout = tmp "stale.out" in
|
|
(try Sys.remove ssock with Sys_error _ -> ());
|
|
let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let env =
|
|
Array.append (Unix.environment ()) [| "FLAN_LLC=false" |]
|
|
in
|
|
let spid =
|
|
Unix.create_process_env flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |]
|
|
env Unix.stdin sfd Unix.stderr
|
|
in
|
|
Unix.close sfd;
|
|
if not (await (fun () -> Sys.file_exists ssock)) then begin
|
|
fail "the daemon with no working llc never listened";
|
|
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect ssock in
|
|
let has 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
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")"
|
|
in
|
|
if status r <> "error" then
|
|
fail "an evaluation that cannot be built was reported as installed";
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "disassembling after a build that failed: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let loc = Option.value ~default:"" (Wire.string_field r "loc") in
|
|
if has loc "never-landed" then
|
|
fail "the location is a buffer whose code was never delivered: %s" loc;
|
|
if not (has loc "dev-repl.flan") then
|
|
fail "the location is not the source the process was built from: %s" loc
|
|
end;
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] spid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ];
|
|
|
|
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)"
|