Joseph Ferano
4723e49e4d
test_session.ml asserts that a debug session emits the metadata, which is the unpassed-argument defect itself. It cannot see the other half: it is Build.shared that turns the flag into -g and -O0 on the module, and a daemon that dropped Build.debug from its opts would still emit perfect IR and then compile it away — llvm.dbg.declare describes an alloca and mem2reg deletes the alloca, so the symptom would be a module that looks right in every text assertion and has no locals in the debugger. So this drives a real `flan dev --debug`, sends one redefinition, and runs llvm-dwarfdump over the .so the daemon actually wrote. The line table is the needle because it is what a breakpoint in a .flan buffer resolves against, and it names the file the form was typed in rather than anything on disk. Skipped where there is no llvm-dwarfdump.
789 lines
37 KiB
OCaml
789 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 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 ];
|
|
|
|
(* --debug, and the half the IR cannot show.
|
|
|
|
[test_session.ml] asserts that a debug session *emits* the metadata,
|
|
which is the unpassed-argument defect itself. It cannot see the other
|
|
half: [Build.shared] is what turns the flag into [-g] and [-O0] on the
|
|
module, and a daemon that dropped [Build.debug] from its opts would
|
|
still emit perfect IR and then compile it away — [llvm.dbg.declare]
|
|
describes an alloca and mem2reg deletes the alloca. So this goes to the
|
|
.so the daemon actually wrote and asks the object, not the text.
|
|
|
|
The line table is the needle because it is what a breakpoint in a .flan
|
|
buffer resolves against, and it names the file the form was typed in
|
|
rather than any file on disk. *)
|
|
if Sys.command "command -v llvm-dwarfdump > /dev/null 2>&1" = 0 then begin
|
|
let gsock = tmp "dbg.sock" and gout = tmp "dbg.out" in
|
|
(try Sys.remove gsock with Sys_error _ -> ());
|
|
let gfd =
|
|
Unix.openfile gout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
|
in
|
|
let gpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; gsock; "--debug" |]
|
|
Unix.stdin gfd Unix.stderr
|
|
in
|
|
Unix.close gfd;
|
|
if not (await (fun () -> Sys.file_exists gsock)) then begin
|
|
fail "the --debug daemon never listened";
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect gsock in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (let [n (i64 3)] (set ticks (+ ticks n)) ticks))\" :file \"/tmp/dbg.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a --debug daemon refused an ordinary redefinition: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
(* The daemon builds into /tmp/flan-dev-<pid>, one module per eval,
|
|
and never reuses a name — dlopen caches by path. The first is
|
|
m1.so. *)
|
|
let so =
|
|
Filename.concat
|
|
(Filename.concat (Filename.get_temp_dir_name ())
|
|
(Printf.sprintf "flan-dev-%d" gpid))
|
|
"m1.so"
|
|
in
|
|
if not (Sys.file_exists so) then
|
|
fail "the --debug daemon left no module at %s" so
|
|
else begin
|
|
let dump = tmp "dbg.dwarf" in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "llvm-dwarfdump --debug-line %s > %s 2>&1"
|
|
(Filename.quote so) (Filename.quote dump))
|
|
in
|
|
let text =
|
|
if code <> 0 then ""
|
|
else In_channel.with_open_bin dump In_channel.input_all
|
|
in
|
|
(try Sys.remove dump with Sys_error _ -> ());
|
|
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
|
|
if not (has text "dbg.flan") then
|
|
fail
|
|
"a --debug daemon's module carries no line table for the form's \
|
|
file, so a line breakpoint would stay pending across C-c C-c"
|
|
end
|
|
end;
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]
|
|
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)"
|