From 940d70b4094826d704f106bd688968e843e0fa01 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 04:10:07 +0700 Subject: [PATCH] Two ways the disassembly said more than it knew MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A stopped program was said not to have installed what was delivered. The commonest way to stop is to install a body and have it error, so that asserted non-installation in precisely the case where the body is running; the daemon cannot read a cell back either way, and now says that. What is certain is only that nothing further installs until it resumes. And the source location came from the session rather than from the build it was showing. Session.eval replaces the checked program the moment a form checks — before the build, before delivery — so an evaluation that checked and then failed to build left a reply showing the host's code, saying nothing had been delivered, and pointing at a buffer whose code never landed. A daemon whose llc is [false] is the whole test. --- lib/dev.ml | 36 +++++++++++++++-- test/test_dev.ml | 100 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 132 insertions(+), 4 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 9f0f3da..0cb1dfc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -238,6 +238,23 @@ let fn_loc t name = | Some f -> Loc.to_string f.Tast.floc | None -> "" +(* Where the *running process* has this function written, which is not where + the session has it. [Session.eval] replaces the checked program as soon as a + form checks — before the build, before delivery — so a body that checked and + then failed to build leaves the session holding a location in a buffer whose + code never landed. [host] is the program the process was launched from and + nothing mutates it, so it is the only honest answer for a name no module has + been accepted for. *) +let host_loc t name = + match + List.find_opt + (fun (f : Tast.fn) -> + String.equal f.Tast.name name && f.Tast.fparent = None) + t.session.Session.host.Tast.fns + with + | Some f -> Loc.to_string f.Tast.floc + | None -> "" + (* ── Ops ───────────────────────────────────────────────────────────── *) (* Every reply is a plist with a :status, so an editor can dispatch on one key @@ -699,7 +716,7 @@ let basis t name = match Hashtbl.find_opt t.owners name with | None -> ( { ogen = 0; oso = Filename.concat t.dir "program"; oll = t.host_ll; - oloc = fn_loc t name }, + oloc = host_loc t name }, "the host executable — nothing defining this name has been delivered in \ this session, so the program's cell still holds this body" ) | Some o -> @@ -707,9 +724,17 @@ let basis t name = ( o, match state t with | Stopped c -> + (* Not "so it is not installed yet". The commonest way to stop is to + install a body and have it error, so a stopped program is more + likely to be running this code than not — the daemon simply cannot + read the cell back to find out, and saying otherwise would be the + [ok]-means-probably failure in the one field that exists to prevent + it. What is certain is only the second half. *) Printf.sprintf - "%s — delivered and accepted, but the program is stopped on %s and \ - has not reached a frame boundary since, so this is not installed yet" + "%s — the last module delivered for this name, accepted for install; \ + the program is stopped on %s and the daemon cannot read the cell \ + back to say whether it installed this before stopping. Nothing \ + further installs until it resumes" m c | Running -> Printf.sprintf @@ -755,7 +780,10 @@ let disassemble t ~name ~form = [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form; ":generation " ^ string_of_int o.ogen; ":signature " ^ Wire.quote (signature_of_fn f); - ":loc " ^ Wire.quote (Loc.to_string f.Tast.floc); + (* [o.oloc], not the session's: the session moves on as soon as a + form checks, and this has to name the source the code being shown + was built from. *) + ":loc " ^ Wire.quote o.oloc; ":basis " ^ Wire.quote why ] in if form = "ir" then diff --git a/test/test_dev.ml b/test/test_dev.ml index 8d7f68e..911e835 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -582,6 +582,38 @@ let () = 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 @@ -597,6 +629,74 @@ let () = end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ]; + (* ── A location that survives an evaluation that did not land ───── *) + + (* [Session.eval] replaces the checked program the moment a form checks, + which is before the build and before delivery. So there is a window in + which the session holds a body the running process has never seen, and a + disassembly that took its source location from the session would point + into the buffer of code that never landed — while showing the host's + code and saying, correctly, that nothing had been delivered. One reply + contradicting itself in two fields. + + A daemon whose [llc] is [false] reproduces it exactly and cheaply: the + host is built by clang and runs, every redefinition checks and then + fails to build, and nothing is ever delivered. *) + let ssock = tmp "stale.sock" and sout = tmp "stale.out" in + (try Sys.remove ssock with Sys_error _ -> ()); + let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let env = + Array.append (Unix.environment ()) [| "FLAN_LLC=false" |] + in + let spid = + Unix.create_process_env flan + [| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |] + env Unix.stdin sfd Unix.stderr + in + Unix.close sfd; + if not (await (fun () -> Sys.file_exists ssock)) then begin + fail "the daemon with no working llc never listened"; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect ssock in + let has hay needle = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + n > 0 && go 0 + in + let r = + request c + "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")" + in + if status r <> "error" then + fail "an evaluation that cannot be built was reported as installed"; + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if status r <> "ok" then + fail "disassembling after a build that failed: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + let loc = Option.value ~default:"" (Wire.string_field r "loc") in + if has loc "never-landed" then + fail "the location is a buffer whose code was never delivered: %s" loc; + if not (has loc "dev-repl.flan") then + fail "the location is not the source the process was built from: %s" loc + end; + ignore (request c "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] spid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()) + end + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ]; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; if !failures = 0 then print_endline "dev: all tests passed"