diff --git a/test/test_dev.ml b/test/test_dev.ml index 2b5a8fa..659a925 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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"