Joseph Ferano
404c810958
The `inspect' verb had no coverage. The discriminating case is not a path step, it is the frame: dev-inspect.flan gives `mark' to a global holding 99 and to a local of the OUTER frame holding a Point, so evaluating the name and rooting at the frame answer differently and not even with the same type. One `eval-expr' and one `inspect' of that name is the bug and the fix in a pair. The slot index comes off the locals listing's fourth element rather than being written as a literal, which exercises the field the editor depends on and keeps the test from passing for the wrong reason if slot allocation shifts. The rest is what a path can and cannot do: a struct field, an array element, an option's payload and a union case's field — the last two having offsets but no accessor form in the language — and four refusals, each checked for naming the step and saying why. A `:path' of `nil' is read as the slot itself, because Emacs has no other spelling for an empty list. Two claims about the frame, since `stopped_frame' being shared is an assertion about code rather than about behaviour until something proves it: the frame whose body was redefined under it is refused, and so is the whole stack once the program resumes.
1700 lines
81 KiB
OCaml
1700 lines
81 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
|
|
|
|
(* The watchdog first: a hang is the one failure mode that reports
|
|
nothing at all. See watchdog.ml. *)
|
|
let () = Watchdog.arm ~seconds:900 "test_dev"
|
|
|
|
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");
|
|
|
|
(* [layout]: a struct's fields and their types, out of [Tast.structs],
|
|
with no running program involved at all. *)
|
|
let strings_of f =
|
|
match f with
|
|
| Some { Form.v = Form.List xs; _ } ->
|
|
List.filter_map
|
|
(fun (x : Form.t) ->
|
|
match x.Form.v with Form.Str s -> Some s | _ -> None)
|
|
xs
|
|
| _ -> []
|
|
in
|
|
let fields r =
|
|
match Wire.field r "fields" with
|
|
| Some { Form.v = Form.List fs; _ } ->
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.List
|
|
[ { Form.v = Form.Str n; _ }; { Form.v = Form.Str t; _ } ] ->
|
|
Some (n ^ " " ^ t)
|
|
| _ -> None)
|
|
fs
|
|
| _ -> []
|
|
in
|
|
let r = request c "(:op \"layout\" :type \"Missing\")" in
|
|
if status r <> "ok" then
|
|
fail "layout Missing: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if Wire.string_field r "type" <> Some "Missing" then
|
|
fail "layout answered a different type than it was asked for";
|
|
if fields r <> [ "id i32" ] then
|
|
fail "Missing's fields: %s" (String.concat ", " (fields r))
|
|
end;
|
|
|
|
(* The prelude's structs are in [Tast.structs] because [Check.program]
|
|
prepends the prelude, and they are answered for the same reason the
|
|
REPL's renderer resolves against the same list: an editor that could
|
|
see a type printed and not ask about it would be the two disagreeing.
|
|
[Rune] also pins the spelling — the types read exactly as [defs]
|
|
spells a signature, because both go through [Types.to_string]. *)
|
|
let r = request c "(:op \"layout\" :type \"Split\")" in
|
|
if fields r <> [ "rest [u8]"; "sep u8"; "more bool" ] then
|
|
fail "Split's fields: %s" (String.concat ", " (fields r));
|
|
|
|
let r = request c "(:op \"layout\" :type \"Nonesuch\")" in
|
|
if status r <> "error" then fail "a type that does not exist got a layout";
|
|
|
|
(* A name that plainly exists and is not a struct is refused by *kind*.
|
|
Both of these are types the checker knows and this op cannot
|
|
describe, and "no struct is named X" would read as "X does not
|
|
exist". *)
|
|
let refusal r =
|
|
Option.value ~default:(status r) (Wire.string_field r "message")
|
|
in
|
|
let contains hay needle =
|
|
let n = String.length needle in
|
|
let rec go i =
|
|
i + n <= String.length hay
|
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
|
in
|
|
go 0
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defenum Colour [red 0 green 1])\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then fail "a new enum: %s" (refusal r)
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"Colour\")" in
|
|
if status r <> "error" then fail "an enum answered a struct layout"
|
|
else if not (contains (refusal r) "is an enum") then
|
|
fail "an enum is refused as: %s" (refusal r)
|
|
end;
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defunion Shape [(Circle [r f32])])\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then fail "a new union: %s" (refusal r)
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"Shape\")" in
|
|
if status r <> "error" then fail "a union answered a struct layout"
|
|
else if not (contains (refusal r) "is a union") then
|
|
fail "a union is refused as: %s" (refusal r)
|
|
end;
|
|
|
|
(* The identity rule, and the case NEXT.md named: a second [Blob] typed
|
|
into a package is [agent/Blob], the qualified name resolves, and the
|
|
bare one is refused with the names it could have meant rather than
|
|
resolved to either. The daemon derives the package from the path, so
|
|
the file this is sent with is the one the import qualified. *)
|
|
let agent_file =
|
|
let p = "../vendor/agent/agent.flan" in
|
|
try Unix.realpath p with Unix.Unix_error _ -> p
|
|
in
|
|
let r =
|
|
request c
|
|
(Printf.sprintf
|
|
"(:op \"eval\" :code \"(defstruct Blob [id i32])\" :file %s)"
|
|
(Wire.quote agent_file))
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a struct typed into a package: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"agent/Blob\")" in
|
|
if status r <> "ok" || fields r <> [ "id i32" ] then
|
|
fail "a qualified name did not resolve: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let r = request c "(:op \"layout\" :type \"Blob\")" in
|
|
if status r <> "error" then
|
|
fail "a bare package-qualified name was resolved rather than refused"
|
|
else if strings_of (Wire.field r "candidates") <> [ "agent/Blob" ] then
|
|
fail "the refusal did not name what it could have meant: %s"
|
|
(String.concat ", " (strings_of (Wire.field r "candidates")))
|
|
end;
|
|
|
|
(* 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";
|
|
|
|
(* The identity claim, round-tripped: the string [break] reports is the
|
|
qualified struct name [Emit] put into [flan_error] and the agent
|
|
held in [condition_name], so handing it straight back as [:type]
|
|
has to resolve. This is the conditions buffer's whole path — it has
|
|
the condition's name and nothing else, and asks for the fields with
|
|
it. A layout that only answered a name typed by hand would leave
|
|
that path guessing. *)
|
|
let r =
|
|
ask
|
|
(Printf.sprintf "(:op \"layout\" :type %s)"
|
|
(Wire.quote (condition !last)))
|
|
in
|
|
if status r <> "ok" then
|
|
fail "the condition's own name did not resolve to a layout: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else
|
|
(match Wire.field r "fields" with
|
|
| Some { Form.v = Form.List [ { Form.v = Form.List
|
|
[ { Form.v = Form.Str "id"; _ }; { Form.v = Form.Str "i32"; _ } ]; _ } ]; _ } -> ()
|
|
| _ -> fail "the stopped program's condition has the wrong layout");
|
|
|
|
(* 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");
|
|
|
|
(* Where it is, which is the other half of what a stopped program can
|
|
be asked. The shadow stack is dev-only and the daemon owns the
|
|
build, so a frame per Flan call is there to be walked; the names
|
|
come off the frames themselves rather than out of any DWARF, which
|
|
is what makes this work in the break loop rather than in lldb.
|
|
|
|
Innermost first, [main] last, and both marked as the program's:
|
|
nothing is being evaluated here, so nothing is the evaluation's. *)
|
|
let frames r =
|
|
match Wire.field r "frames" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List
|
|
({ Form.v = Form.Str n; _ }
|
|
:: { Form.v = Form.Str loc; _ }
|
|
:: { Form.v = Form.Str origin; _ } :: _) ->
|
|
Some (n, loc, origin)
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let r = ask "(:op \"backtrace\")" in
|
|
if status r <> "ok" then
|
|
fail "backtrace: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
match frames r with
|
|
| [ ("fetch", floc, "program"); ("main", _, "program") ] ->
|
|
(* Absolute and pointing into the program's own source, for the
|
|
same reason [defs] is: an editor is not in this process's
|
|
working directory. It comes off the frame, not off this end's
|
|
session, so a redefined body reports where the *installed* one
|
|
is written. *)
|
|
if String.length floc = 0 || floc.[0] <> '/' then
|
|
fail "a frame's location is not absolute: %s" floc
|
|
| fs ->
|
|
fail "backtrace of a stopped program: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, _, o) -> n ^ "/" ^ o) fs))
|
|
end;
|
|
|
|
(* 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));
|
|
(* And the backtrace says the same thing the restart list does, in its
|
|
own words: the two frames on top belong to the evaluation, the two
|
|
below them to the program. A backtrace that did not draw that line
|
|
would answer "where is my program" with [eval/1], which is true and
|
|
not the question. *)
|
|
(match frames (ask "(:op \"backtrace\")") with
|
|
| [ ("fetch", _, "eval"); (thunk, _, "eval"); ("fetch", _, "program");
|
|
("main", _, "program") ]
|
|
when String.length thunk > 5 && String.sub thunk 0 5 = "eval/" -> ()
|
|
| fs ->
|
|
fail "backtrace at a break inside a thunk: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, _, o) -> n ^ "/" ^ o) fs)));
|
|
(* 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";
|
|
(* Refused for the same reason, and it is not a missing feature: the
|
|
frame chain is the game thread's and it is pushed and popped on
|
|
every call, so a walk from this end would have the shape of a
|
|
backtrace and the contents of a race. *)
|
|
let r = ask "(:op \"backtrace\")" in
|
|
if status r <> "error" then
|
|
fail "a running program answered with a backtrace";
|
|
(* ...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
|
|
(* The claim this test exists for, and the one thing about a shadow
|
|
stack that is easy to get wrong: **the pop happens on the
|
|
transfer path too**. Five breaks have been taken and resumed by
|
|
now, every one of them by a condition transfer that unwound past
|
|
the frame that erred. A pop written only on the normal return
|
|
path would have left one dead frame behind each time, and this
|
|
backtrace would be [step, main] with a pile of stale [fetch]es
|
|
under it. It is two frames or the feature is a liar. *)
|
|
(match
|
|
List.map (fun (n, _, o) -> (n, o))
|
|
(match Wire.field (ask "(:op \"backtrace\")") "frames" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List
|
|
({ Form.v = Form.Str n; _ }
|
|
:: { Form.v = Form.Str loc; _ }
|
|
:: { Form.v = Form.Str o; _ } :: _) ->
|
|
Some (n, loc, o)
|
|
| _ -> None)
|
|
l
|
|
| _ -> [])
|
|
with
|
|
| [ ("step", "program"); ("main", "program") ] -> ()
|
|
| fs ->
|
|
fail "frames left on the shadow stack by five handled errors: %s"
|
|
(String.concat ", " (List.map (fun (n, o) -> n ^ "/" ^ o) fs)));
|
|
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;
|
|
(* ── The locals of a stopped frame ─────────────────────────────── *)
|
|
|
|
(* A third daemon, over a program that stops with something worth looking
|
|
at. This is the half of the shadow stack the backtrace was built for:
|
|
the frame chain gives the addresses, [Tast.fn] gives the types and the
|
|
names, and a thunk compiled here renders those types at those addresses
|
|
inside the stopped program. Nothing is copied out — a Flan value has no
|
|
header, so bytes read from another process would be bytes with no
|
|
meaning.
|
|
|
|
Its own daemon and its own program, for the same reason the break block
|
|
has: the claims are about one frame of one program. *)
|
|
let lsock = tmp "locals.sock" and lout = tmp "locals.out" in
|
|
(try Sys.remove lsock with Sys_error _ -> ());
|
|
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let lpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-locals.flan"; "-s"; lsock |]
|
|
Unix.stdin lfd Unix.stderr
|
|
in
|
|
Unix.close lfd;
|
|
if not (await (fun () -> Sys.file_exists lsock)) then begin
|
|
fail "the locals daemon never listened";
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect lsock in
|
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the locals program never stopped"
|
|
else begin
|
|
let pairs r key =
|
|
match Wire.field r key with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List ({ Form.v = Form.Str a; _ }
|
|
:: { Form.v = Form.Str b; _ } :: rest) ->
|
|
Some (a, b,
|
|
match rest with
|
|
| { Form.v = Form.Str c; _ } :: _ -> c
|
|
| _ -> "")
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "ok" then
|
|
fail "locals: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
(* One of each shape the structural printer has an arm for, rendered
|
|
in the program and read back as text. The values are the ones
|
|
[look] was called with, which is the claim: this is the frame's
|
|
own storage and not a guess from the source. *)
|
|
let got =
|
|
List.map (fun (n, ty, v) -> (n, ty, v)) (pairs r "locals")
|
|
in
|
|
let want =
|
|
[ ("n", "i64", "3");
|
|
("label", "string", "\"hello\"");
|
|
(* The *renderer's* output, not source — and it is a dot now.
|
|
[render.ml] and [emacs/flan-inspect.el] are the two ends of
|
|
one wire format, and they moved together, which is what the
|
|
note here used to say was still owed. *)
|
|
("p", "Point", "(Point {.x 1.5 .y 2.5})");
|
|
("xs", "[3 i32]", "[ 10 20 30]");
|
|
("flag", "bool", "true") ]
|
|
in
|
|
if got <> want then
|
|
fail "locals of the stopped frame: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
|
|
(* And the one that must not be rendered. [after] is bound inside
|
|
the restart-case *past* the error, so its slot is storage nothing
|
|
has written: the frame records a null for it, and a thunk that
|
|
printed it would dereference that null on the game thread of a
|
|
program that is already stopped. Refused by name, with the
|
|
reason, rather than left off the list — a local that is missing
|
|
and a local that could not be read are different facts. *)
|
|
match List.filter (fun (n, _, _) -> n = "after") (pairs r "refused") with
|
|
| [ (_, why, _) ] when why <> "" -> ()
|
|
| _ ->
|
|
fail "a slot bound after the error was not refused by name: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
|
|
end;
|
|
(* A frame whose every slot the compiler invented is not an error and
|
|
is not an empty answer either: it says which it is. *)
|
|
let r = ask "(:op \"locals\" :frame 1)" in
|
|
if status r <> "ok" then fail "locals of main: %s" (status r);
|
|
(* Out of range is refused with the depth, so a client can tell a bad
|
|
index from a frame with nothing in it. *)
|
|
let r = ask "(:op \"locals\" :frame 9)" in
|
|
if status r <> "error" then fail "a frame index past the end answered";
|
|
|
|
(* The inverse, first, because it is the cheap half of the same
|
|
claim: a redefinition that really does change the slots must be
|
|
refused too, and that one a count comparison can see. This body
|
|
drops [flag] and keeps the signature, so the frame on the stack has
|
|
one slot more than the body this session now holds. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [p (Point {.x 1.5 .y 2.5}) xs [10 20 30]] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with fewer slots while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "the frame of a body whose slots changed answered anyway"
|
|
end;
|
|
|
|
(* And the case that makes this a fingerprint rather than a slot
|
|
count. Installing while stopped is deliberately allowed — it is the
|
|
fix-it-and-retry loop — so the body on the stack and the body the
|
|
session holds can be two different bodies of one function. This one
|
|
renames every local and keeps the count and the types, which a
|
|
count comparison cannot see: without the hash, [q] would be shown
|
|
holding [p]'s value and nothing would say so. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0)] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a renamed body while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "the frame of a superseded body answered with the new body's names";
|
|
(* And the other half of that claim, which is the one a fingerprint
|
|
that never matched would fail: redefining [look] says nothing
|
|
about [main], and its frame must still answer. A refusal that
|
|
fires for every frame would pass the test above and make the
|
|
whole verb useless. *)
|
|
let r = ask "(:op \"locals\" :frame 1)" in
|
|
if status r <> "ok" then
|
|
fail "redefining one function refused an untouched frame: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
end
|
|
end;
|
|
(* Running again, and then the locals verb is refused: a frame that is
|
|
still executing does not hold still long enough to be read. *)
|
|
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
|
if status r <> "ok" then
|
|
fail "resuming the locals program: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
|
fail "the locals program never resumed"
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "a running program answered with its locals"
|
|
end;
|
|
ignore (ask "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] lpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
|
|
(* ── Which frame the inspector answered from ───────────────────── *)
|
|
|
|
(* The locals listing was already frame-accurate; the inspector was not.
|
|
`i' in the break buffer sent the local's *name* to be evaluated, and an
|
|
expression is evaluated where the evaluator stands — the right frame
|
|
only when the frame is the innermost one.
|
|
|
|
dev-inspect.flan is built so that failing to root at the frame is
|
|
visible in the value rather than only in the reasoning: `mark' is a
|
|
global holding 99 and a local of the *outer* frame holding a Point, and
|
|
the two are not even the same type. So the discriminating pair below is
|
|
one evaluation and one inspection of the same name.
|
|
|
|
It also carries the two shapes an expression cannot reach at all: an
|
|
option's payload, which no accessor form in the language names, and a
|
|
union case's field, whose offset depends on which case the value is
|
|
in. *)
|
|
let isock = tmp "inspect.sock" and iout = tmp "inspect.out" in
|
|
(try Sys.remove isock with Sys_error _ -> ());
|
|
let ifd = Unix.openfile iout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let ipid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-inspect.flan"; "-s"; isock |]
|
|
Unix.stdin ifd Unix.stderr
|
|
in
|
|
Unix.close ifd;
|
|
if not (await (fun () -> Sys.file_exists isock)) then begin
|
|
fail "the inspect daemon never listened";
|
|
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect isock in
|
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
let contains hay needle =
|
|
let n = String.length needle in
|
|
let rec go i =
|
|
i + n <= String.length hay
|
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
|
in
|
|
go 0
|
|
in
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the inspect program never stopped"
|
|
else begin
|
|
(* The slot travels by index and the index comes off the listing,
|
|
which is the fourth element of each entry. Reading it here rather
|
|
than writing 0 exercises the field the editor depends on, and keeps
|
|
this test from passing for the wrong reason if slot allocation ever
|
|
shifts. *)
|
|
let slot_of r name =
|
|
match Wire.field r "locals" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.fold_left
|
|
(fun acc (e : Form.t) ->
|
|
match acc with
|
|
| Some _ -> acc
|
|
| None ->
|
|
(match e.Form.v with
|
|
| Form.List
|
|
[ { Form.v = Form.Str n; _ }; _; _;
|
|
{ Form.v = Form.Int i; _ } ]
|
|
when String.equal n name ->
|
|
Some (Int64.to_int i)
|
|
| _ -> None))
|
|
None l
|
|
| _ -> None
|
|
in
|
|
let listing = ask "(:op \"locals\" :frame 1)" in
|
|
if status listing <> "ok" then
|
|
fail "locals of the outer frame: %s"
|
|
(Option.value ~default:(status listing) (Wire.string_field listing "message"))
|
|
else begin
|
|
let inspect ?(path = "()") slot =
|
|
ask
|
|
(Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)" slot
|
|
path)
|
|
in
|
|
let value r = Option.value ~default:"" (Wire.string_field r "value") in
|
|
let want name path ty v =
|
|
match slot_of listing name with
|
|
| None ->
|
|
fail "the locals listing gave no slot index for %s, so the \
|
|
inspector has nothing to root at" name
|
|
| Some slot ->
|
|
let r = inspect ~path slot in
|
|
if status r <> "ok" then
|
|
fail "inspect %s%s: %s" name path
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
if value r <> v then
|
|
fail "inspect %s%s rendered %s, not %s" name path (value r) v;
|
|
if Option.value ~default:"" (Wire.string_field r "type") <> ty then
|
|
fail "inspect %s%s says its type is %s, not %s" name path
|
|
(Option.value ~default:"" (Wire.string_field r "type")) ty
|
|
end
|
|
in
|
|
(* The pair the whole verb exists for. `mark' evaluated as an
|
|
expression is the global, because that is where the evaluator
|
|
stands; `mark' rooted at frame 1's slot is the frame's own
|
|
storage. Both answers are correct answers to different
|
|
questions, and the break buffer was asking the wrong one. *)
|
|
let r = ask "(:op \"eval-expr\" :code \"mark\" :file \"<t>\")" in
|
|
if status r <> "ok" || value r <> "99" then
|
|
fail "the global `mark' did not evaluate to 99: %s" (value r);
|
|
want "mark" "()" "Point" "(Point {.x 1.5 .y 2.5})";
|
|
(* A path step, which is an address plus an offset with that field's
|
|
type — the arithmetic the listing already does. *)
|
|
want "mark" "(\"x\")" "f32" "1.5";
|
|
want "xs" "(1)" "i32" "20";
|
|
(* And the two an expression cannot write at all. *)
|
|
want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})";
|
|
want "box" "(some \"x\")" "f32" "4.5";
|
|
want "s" "(\"Shape.Rect.w\")" "i32" "3";
|
|
(* Emacs prints an empty list as `nil' and has no other spelling for
|
|
one, so a client in that language cannot send `()'. *)
|
|
(match slot_of listing "mark" with
|
|
| None -> ()
|
|
| Some slot ->
|
|
let r = inspect ~path:"nil" slot in
|
|
if status r <> "ok" || value r <> "(Point {.x 1.5 .y 2.5})" then
|
|
fail "a :path of nil was not read as the slot itself: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message")));
|
|
(* Every step that does not fit the type in hand is refused by name
|
|
with its reason. A path with a step quietly dropped out of it
|
|
would render a *different* value and say nothing, which is the
|
|
failure this whole buffer is built to avoid. *)
|
|
List.iter
|
|
(fun (name, path, needle) ->
|
|
match slot_of listing name with
|
|
| None -> ()
|
|
| Some slot ->
|
|
let r = inspect ~path slot in
|
|
let m = Option.value ~default:"" (Wire.string_field r "message") in
|
|
if status r <> "error" then
|
|
fail "inspect %s%s answered instead of refusing: %s" name path
|
|
(value r)
|
|
else if
|
|
(* The refusal names the step and says why. *)
|
|
not
|
|
(contains m needle
|
|
&& contains m name)
|
|
then fail "inspect %s%s refused without saying why: %s" name path m)
|
|
[ ("mark", "(\"nope\")", "no field called nope");
|
|
("mark", "(some)", "not an option");
|
|
("xs", "(9)", "past the end");
|
|
(* A union field without its case: the payload's offset depends
|
|
on the case, so guessing one that two cases share would read
|
|
one case's layout over another's payload. *)
|
|
("s", "(\"w\")", "name the case") ]
|
|
end;
|
|
(* The innermost frame records no slots at all, and that is refused
|
|
with the reason rather than answered with something. *)
|
|
let r = ask "(:op \"inspect\" :frame 0 :slot 0 :path ())" in
|
|
if status r <> "error" then
|
|
fail "a frame with no slots answered the inspector anyway";
|
|
(* And the frame checks are the listing's, by construction: both go
|
|
through `stopped_frame'. An inspector with its own copy would be
|
|
free to read a frame whose body was redefined since it was entered,
|
|
which is exactly the stale-slot answer the listing refuses. This
|
|
body renames every local and keeps the count and the types, which
|
|
only the slot fingerprint can see. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn outer [] i64 (let [tag (Point {.x 9.0 .y 9.0}) ys [1 2 3] maybe (Some (Point {.x 0.0 .y 0.0})) sh (Shape.Rect {.w 1 .h 1})] (deeper)))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a renamed body while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
|
if status r <> "error" then
|
|
fail
|
|
"the inspector read a frame whose body was redefined under it: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "value"))
|
|
end
|
|
end;
|
|
(* And a running program has no frame to root at. The inspector says so
|
|
rather than falling back to evaluating the name somewhere else, which
|
|
is the behaviour it replaced. *)
|
|
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
|
if status r <> "ok" then
|
|
fail "resuming the inspect program: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
|
fail "the inspect program never resumed"
|
|
else begin
|
|
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
|
if status r <> "error" then
|
|
fail "a running program answered the inspector"
|
|
end;
|
|
ignore (ask "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] ipid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] ipid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
|
|
(* ── The globals a stopped stack reaches ───────────────────────── *)
|
|
|
|
(* The other half of what a break loop can show. Locals are one frame's;
|
|
these are the program's, and the question is which of them to show:
|
|
all of a program's globals would bury the one that matters under the
|
|
prelude's PRNG state, and per-frame nesting would imply an ownership a
|
|
global does not have and repeat the name once per frame that reads it.
|
|
|
|
So: one section, the union of what every frame on the stack references,
|
|
each entry saying which frames touch it, ordered by the innermost one
|
|
that does. [dev-globals.flan] is built so that all three of those
|
|
claims fail visibly if any of them is dropped. *)
|
|
let gsock = tmp "globals.sock" and gout = tmp "globals.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-globals.flan"; "-s"; gsock |]
|
|
Unix.stdin gfd Unix.stderr
|
|
in
|
|
Unix.close gfd;
|
|
if not (await (fun () -> Sys.file_exists gsock)) then begin
|
|
fail "the globals daemon never listened";
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect gsock in
|
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the globals program never stopped"
|
|
else begin
|
|
(* (name type value (frame ...)) — four fields, the fourth a list of
|
|
numbers, which is what makes the annotation readable against the
|
|
stack section's own numbering. *)
|
|
let rows r =
|
|
match Wire.field r "globals" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List [ { Form.v = Form.Str n; _ };
|
|
{ Form.v = Form.Str ty; _ };
|
|
{ Form.v = Form.Str v; _ };
|
|
{ Form.v = Form.List fs; _ } ] ->
|
|
Some
|
|
(n, ty, v,
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.Int i -> Some (Int64.to_int i)
|
|
| _ -> None)
|
|
fs)
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
let want =
|
|
(* [grid] before [pressure] because that is the order they are
|
|
declared in and both are touched by frame 0; [label] last
|
|
because the innermost frame that touches it is 1, even though
|
|
it is declared before either. Ordering by proximity to the
|
|
error is what puts the likely culprit on top of a deep stack,
|
|
and declaring [label] first is how this notices that the sort
|
|
happened at all.
|
|
|
|
[grid]'s two writes are the two frames: [main] set element 1
|
|
before calling, [inner] set element 0 after. The value is read
|
|
out of the program's own storage, so both are in it. *)
|
|
[ ("grid", "[4 i32]", "[ 7 5 0 0]", [ 0; 1 ]);
|
|
("pressure", "i64", "12", [ 0 ]);
|
|
("label", "string", "\"running\"", [ 1 ]) ]
|
|
in
|
|
let got = rows r in
|
|
if got <> want then
|
|
fail "the globals of the stopped stack: %s"
|
|
(String.concat ", "
|
|
(List.map
|
|
(fun (n, ty, v, fs) ->
|
|
Printf.sprintf "%s %s = %s (%s)" n ty v
|
|
(String.concat " " (List.map string_of_int fs)))
|
|
got));
|
|
(* And the one that must not be there. [untouched] is a global of
|
|
this program that no frame on this stack reads, and a section
|
|
that listed it would be the "all the globals" answer this op
|
|
exists instead of. The prelude's own globals are the same claim
|
|
at scale: [rand-state] is in the session too. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "a global no frame on the stack references was listed anyway";
|
|
if List.exists (fun (n, _, _, _) -> n = "rand-state") got then
|
|
fail "the prelude's globals were listed; the section is not scoped \
|
|
to the stack"
|
|
end;
|
|
(* A frame whose body has been redefined since it was entered cannot
|
|
be attributed: what this session holds is a different body's
|
|
reference set. It is named in [:skipped] rather than dropped,
|
|
because "the union is incomplete and here is why" and "these are
|
|
all of them" are different answers.
|
|
|
|
The redefinition binds a local, deliberately, because that is what
|
|
the detector can see. [Emit.slot_fingerprint] hashes a body's
|
|
*slots*, so a new body with the same slots and different global
|
|
references is not caught — the hole is stated in BUILT.md, and a
|
|
test that asserted otherwise would be asserting a mechanism that is
|
|
not there. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn inner [] i64 (let [z (i64 1)] (set untouched z)) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a new body while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals after a redefinition: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let skipped =
|
|
match Wire.field r "skipped" with
|
|
| Some { Form.v = Form.List l; _ } -> List.length l
|
|
| _ -> 0
|
|
in
|
|
if skipped = 0 then
|
|
fail "the frame of a superseded body was attributed anyway";
|
|
(* [main] is untouched by that redefinition and must still
|
|
contribute: a refusal that fired for every frame would pass the
|
|
check above and make the whole verb useless. *)
|
|
let got = rows r in
|
|
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
|
|
fail "redefining one function dropped an untouched frame's globals";
|
|
(* And the new body's references must not have leaked in under the
|
|
old frame. [untouched] is what the installed body reads and the
|
|
frame on the stack does not. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "a superseded frame contributed the *new* body's references"
|
|
end;
|
|
(* And the case the slot fingerprint cannot see, which is the one this
|
|
section needs its own fingerprint for. This body binds exactly the
|
|
locals the frame on the stack binds — none, and the same
|
|
temporaries, because every expression in it has the same shape —
|
|
and names [untouched] where the frame's body names [pressure]. The
|
|
slot check passes; only [Reach.ref_fingerprint] can tell that what
|
|
this session now holds refers to different program state.
|
|
|
|
Refused by name and for that reason, like everything else in the
|
|
break loop. What would happen without it is not an error message:
|
|
it is [untouched] appearing in the union marked as touched by frame
|
|
0, and [pressure] missing from it, both of which read as facts
|
|
about the stopped program and are not. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn inner [] i64 (set untouched 12) (set (at grid 0) 7) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with the same slots and other globals: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals after a reference-set change: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let whys =
|
|
match Wire.field r "skipped" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List [ _; { Form.v = Form.Str w; _ } ] -> Some w
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let mentions hay needle =
|
|
let n = String.length needle in
|
|
let rec go i =
|
|
i + n <= String.length hay
|
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
|
in
|
|
go 0
|
|
in
|
|
if not
|
|
(List.exists
|
|
(fun w -> mentions w "names different globals")
|
|
whys)
|
|
then
|
|
fail
|
|
"a frame whose body now names different globals was attributed \
|
|
anyway (skipped: %s)"
|
|
(String.concat " | " whys);
|
|
let got = rows r in
|
|
(* The new body's globals must not have leaked in under the old
|
|
frame, and the frame that did not change must still contribute:
|
|
a refusal that swallowed the whole stack would satisfy the check
|
|
above and say nothing. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "the new body's globals were attributed to the old frame";
|
|
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
|
|
fail "refusing one frame dropped an untouched frame's globals"
|
|
end
|
|
end;
|
|
(* Nothing handled the condition, so there is no restart to resume by
|
|
and [abort] is the only way out. The daemon owns the program's
|
|
lifetime, so it comes down on its own. *)
|
|
ignore (ask "(:op \"abort\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] gpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] gpid) 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)"
|