JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Pin the two claims the disassembly op makes

Browse Source 
Which module owns a name after a delivery, and the fact that a delivered
body is not thereby an installed one. Its own daemon over its own program:
a generation counter checked against a session four other cases have been
driving proves nothing about the counter.
This commit is contained in:
Joseph Ferano 2026-09-12 03:58:15 +07:00
parent c1a612abfb
commit 0fdb7a7cb0
1 changed files with 170 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

170
test/test_dev.ml
View File

@ -408,6 +408,176 @@ let () =
(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
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";
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 ];
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"