Keep the text each body was built from

A module's .ll is deleted by the build and the host's lives in a working
directory named after the process rather than the module, so ten reloads
in there is nothing left on disk that says what a given function was
compiled from. The daemon owns the build and is the only thing that could
have kept it, so it keeps it: one .ll beside each .so, and a table from
function name to the last module that carried a body for it.
This commit is contained in:
Joseph Ferano 2026-09-12 03:50:44 +07:00
parent 540b2aaadd
commit bd5892eccd

View File

@ -13,6 +13,16 @@
only if it is the session that compiled it. So the daemon launches the only if it is the session that compiled it. So the daemon launches the
program rather than attaching to one. *) program rather than attaching to one. *)
(* Where a function's body was last built. The daemon owns the build, so it is
the only thing that can answer "which module defines this name now" but
see [basis] below for what that answer honestly is. *)
type origin = {
ogen : int; (* reload generation; 0 is the host's *)
oso : string; (* the object the body was linked into *)
oll : string; (* the IR it was built from *)
oloc : string; (* where the source it came from was written *)
}
type t = { type t = {
session : Session.t; session : Session.t;
child : int; (* the running program *) child : int; (* the running program *)
@ -21,6 +31,12 @@ type t = {
stdout : Unix.file_descr; (* the program's output, on its way to here *) stdout : Unix.file_descr; (* the program's output, on its way to here *)
out : Buffer.t; (* ...buffered until an editor asks for it *) out : Buffer.t; (* ...buffered until an editor asks for it *)
mutable n : int; (* dlopen caches by path: never reuse one *) mutable n : int; (* dlopen caches by path: never reuse one *)
(* Bookkeeping for disassembly, and the reason it can exist at all: the
daemon compiled every module it sent, so the .ll and the .so are on its
own disk. What it does not have is a way back into the process's cells. *)
mutable gen : int; (* accepted deliveries, in order *)
owners : (string, origin) Hashtbl.t; (* fn name -> the last module sent *)
host_ll : string; (* the IR the running program was built from *)
} }
(* The program's stdout is a pipe into this process, so that an editor can see (* The program's stdout is a pipe into this process, so that an editor can see
@ -199,6 +215,29 @@ let alive t =
| _ -> false | _ -> false
| exception Unix.Unix_error _ -> false | exception Unix.Unix_error _ -> false
(* ── What a body was built from ─────────────────────────────────────── *)
let write_file path text =
let oc = open_out_bin path in
Fun.protect ~finally:(fun () -> close_out oc) (fun () -> output_string oc text)
let read_file path =
let ic = open_in_bin path in
Fun.protect
~finally:(fun () -> close_in ic)
(fun () -> really_input_string ic (in_channel_length ic))
let find_fn t name =
List.find_opt
(fun (f : Tast.fn) ->
String.equal f.Tast.name name && f.Tast.fparent = None)
t.session.Session.program.Tast.fns
let fn_loc t name =
match find_fn t name with
| Some f -> Loc.to_string f.Tast.floc
| None -> ""
(* ── Ops ───────────────────────────────────────────────────────────── *) (* ── Ops ───────────────────────────────────────────────────────────── *)
(* Every reply is a plist with a :status, so an editor can dispatch on one key (* Every reply is a plist with a :status, so an editor can dispatch on one key
@ -258,11 +297,24 @@ let eval t ~code ~origin =
| c -> | c ->
t.n <- t.n + 1; t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "m%d.so" t.n) in let out = Filename.concat t.dir (Printf.sprintf "m%d.so" t.n) in
(* [Build.shared] deletes its own .ll unless asked to keep it, and what it
keeps is in a working directory named after this process rather than
after the module. Writing our own copy beside the .so is what makes
[disassemble] able to show the IR of a body installed ten reloads ago:
nothing else on this machine still has that text. *)
let ll = Filename.concat t.dir (Printf.sprintf "m%d.ll" t.n) in
write_file ll c.Session.ir;
(match Build.shared ~opts:{ Build.default with Build.dev = true } (match Build.shared ~opts:{ Build.default with Build.dev = true }
~ir:c.Session.ir ~out () with ~ir:c.Session.ir ~out () with
| timing -> | timing ->
(match deliver t out with (match deliver t out with
| "ok" -> | "ok" ->
t.gen <- t.gen + 1;
List.iter
(fun n ->
Hashtbl.replace t.owners n
{ ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
c.Session.fns;
ok ok
[ ":names " ^ Wire.strings c.Session.names; [ ":names " ^ Wire.strings c.Session.names;
":fns " ^ Wire.strings c.Session.fns; ":fns " ^ Wire.strings c.Session.fns;
@ -511,9 +563,21 @@ let start ~file ~sock =
in in
(try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); (try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
let exe = Filename.concat dir "program" in let exe = Filename.concat dir "program" in
(* [keep] so the host's own IR survives the build. It is the text [llc] was
actually given, not a second emission of it, which is the difference
between showing what the process was built from and showing what it
probably was. [Build.executable] leaves it in its own working directory
under the module's basename; it is moved here so that nothing else in this
process can reuse the name. *)
ignore ignore
(Build.executable ~opts:{ Build.default with Build.dev = true } (Build.executable
~opts:{ Build.default with Build.dev = true; Build.keep = true }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe); ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe);
let host_ll = Filename.concat dir "host.ll" in
(try
Sys.rename (Filename.concat (Build.workdir ()) (Filename.basename exe ^ ".ll"))
host_ll
with Sys_error _ -> ());
let agent = Filename.concat dir "agent.sock" in let agent = Filename.concat dir "agent.sock" in
(* The program's source names some socket path; the daemon is the one that (* The program's source names some socket path; the daemon is the one that
@ -538,7 +602,8 @@ let start ~file ~sock =
end; end;
let t = let t =
{ session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0 } { session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0;
gen = 0; owners = Hashtbl.create 32; host_ll }
in in
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in