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"