Joseph Ferano
635d12782d
A global is program state a frame happened to touch, not part of it, so nesting it under one implies an ownership that is not there and repeats the name once per frame that reads it. One section instead, holding the union of the globals every frame on the stack references — the compiler does the choosing, since Reach.expr_refs already answers a body's reference set, and listing every global a program has would bury the one that matters under the prelude's PRNG state. Each entry says which frames touch it, by the index the stack section already numbers them with, which recovers what per-frame nesting would have told you at no cost in duplication. Ordered by the innermost frame that touches it: a deep stack makes the union large and proximity to the error is what puts the likely culprit on top. Simpler than locals, because a global is reached by name rather than by address. Emit.redefinition writes a global the host has as external, so the thunk binds to the program's own storage and nothing is asked of the stopped thread — no dev-slot round trip and no not-yet-bound case to refuse. A frame that cannot be attributed contributes nothing and is named in :skipped; the union being incomplete and the union being complete are different answers. The hole in that is stated rather than papered over: slot_fingerprint hashes a body's slots, which is the right cut for locals and not for this, so a body that names different globals while binding the same locals is not caught. The test drives the case that is. MANUAL.md also loses a stale paragraph claiming the fingerprint check never fires with a failing test pinned to it. It fires, and test_dev covers it.
1655 lines
74 KiB
OCaml
1655 lines
74 KiB
OCaml
(** [flan dev]: one long-lived session, the program it belongs to running
|
|
beside it, and a socket an editor talks to.
|
|
|
|
This is the piece between an editor and everything else. What it adds over
|
|
[flan reload] is that the session *persists*: a [defvar] added by one
|
|
evaluation is part of the program the next one is checked against, and the
|
|
set of names the running process was built with is the one from the build
|
|
this daemon actually made. A CLI that rebuilds its session from source each
|
|
time cannot have either.
|
|
|
|
It owns the build, which is what makes its layout rules mean anything: a
|
|
session's struct layouts and global types describe the memory of a process
|
|
only if it is the session that compiled it. So the daemon launches the
|
|
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 = {
|
|
session : Session.t;
|
|
child : int; (* the running program *)
|
|
agent : string; (* where it listens for modules *)
|
|
dir : string; (* modules are built here, one per eval *)
|
|
stdout : Unix.file_descr; (* the program's output, on its way to here *)
|
|
out : Buffer.t; (* ...buffered until an editor asks for it *)
|
|
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
|
|
it. That makes draining it a *liveness* requirement and not a nicety: a pipe
|
|
nobody reads fills at 64K and the next write blocks the program forever. So
|
|
it is read from the accept loop's select, not only when someone asks. *)
|
|
let capacity = 256 * 1024
|
|
|
|
let drain t =
|
|
let b = Bytes.create 8192 in
|
|
let rec go () =
|
|
match Unix.select [ t.stdout ] [] [] 0. with
|
|
| [], _, _ -> ()
|
|
| _ ->
|
|
(match Unix.read t.stdout b 0 8192 with
|
|
| 0 -> ()
|
|
| n ->
|
|
Buffer.add_subbytes t.out b 0 n;
|
|
(* Bounded: a program that prints every frame must not grow this
|
|
process without limit. The newest text is the useful end. *)
|
|
if Buffer.length t.out > capacity then begin
|
|
let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in
|
|
Buffer.clear t.out;
|
|
Buffer.add_string t.out keep
|
|
end;
|
|
go ()
|
|
| exception Unix.Unix_error (Unix.EAGAIN, _, _) -> ()
|
|
| exception Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
|
|
| exception Unix.Unix_error _ -> ())
|
|
in
|
|
go ()
|
|
|
|
let take t =
|
|
drain t;
|
|
let s = Buffer.contents t.out in
|
|
Buffer.clear t.out;
|
|
s
|
|
|
|
let await ?(ms = 5000) f =
|
|
let rec go ms =
|
|
if f () then true
|
|
else if ms <= 0 then false
|
|
else begin ignore (Unix.select [] [] [] 0.005); go (ms - 5) end
|
|
in
|
|
go ms
|
|
|
|
(* ── Delivery ──────────────────────────────────────────────────────── *)
|
|
|
|
(* The agent answers "ok" when it has queued a module, and anything else is a
|
|
refusal with a reason. Reporting that back rather than swallowing it is what
|
|
keeps a failed delivery from looking like a successful evaluation — the
|
|
whole class of bug this socket makes possible. *)
|
|
let deliver t path =
|
|
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
Fun.protect
|
|
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
|
|
(fun () ->
|
|
Unix.connect s (Unix.ADDR_UNIX t.agent);
|
|
let msg = path ^ "\n" in
|
|
ignore (Unix.write_substring s msg 0 (String.length msg));
|
|
let b = Bytes.create 1024 in
|
|
let buf = Buffer.create 64 in
|
|
let rec drain () =
|
|
match Unix.read s b 0 1024 with
|
|
| 0 -> ()
|
|
| n -> Buffer.add_subbytes buf b 0 n; drain ()
|
|
| exception Unix.Unix_error _ -> ()
|
|
in
|
|
drain ();
|
|
String.trim (Buffer.contents buf))
|
|
|
|
(* Read back the value of the last expression evaluated, with the counter that
|
|
says whether it is a new one. The thunk runs on the game thread whenever the
|
|
program next reaches a frame boundary, which is not a moment the daemon gets
|
|
to know about, so this waits for the counter to move rather than assuming it
|
|
has. *)
|
|
let result t =
|
|
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
Fun.protect
|
|
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
|
|
(fun () ->
|
|
Unix.connect s (Unix.ADDR_UNIX t.agent);
|
|
ignore (Unix.write_substring s "result\n" 0 7);
|
|
let b = Bytes.create 4096 in
|
|
let buf = Buffer.create 256 in
|
|
let rec drain () =
|
|
match Unix.read s b 0 4096 with
|
|
| 0 -> ()
|
|
| n -> Buffer.add_subbytes buf b 0 n; drain ()
|
|
| exception Unix.Unix_error _ -> ()
|
|
in
|
|
drain ();
|
|
let text = Buffer.contents buf in
|
|
match String.index_opt text '\n' with
|
|
| None -> None
|
|
| Some i ->
|
|
let header = String.sub text 0 i in
|
|
let body = String.sub text (i + 1) (String.length text - i - 1) in
|
|
(match String.split_on_char ' ' header with
|
|
| [ g; _ ] ->
|
|
(match Int64.of_string_opt g with
|
|
| Some g -> Some (g, body)
|
|
| None -> None)
|
|
| _ -> None))
|
|
|
|
(* ── The break state ───────────────────────────────────────────────── *)
|
|
|
|
(* Everything above is about changing a *running* program. This is the other
|
|
half: an unhandled [error] does not kill a dev build, it stops the game
|
|
thread on the frame that erred and waits. The agent's socket is where that
|
|
shows, and the daemon is the only thing holding that socket — so an editor
|
|
asks here or not at all.
|
|
|
|
One line out, one line back, exactly like [result]: the agent is not a
|
|
protocol and must not become one. *)
|
|
let ask t verb =
|
|
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
Fun.protect
|
|
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
|
|
(fun () ->
|
|
Unix.connect s (Unix.ADDR_UNIX t.agent);
|
|
let msg = verb ^ "\n" in
|
|
ignore (Unix.write_substring s msg 0 (String.length msg));
|
|
let b = Bytes.create 4096 in
|
|
let buf = Buffer.create 128 in
|
|
let rec drain () =
|
|
match Unix.read s b 0 4096 with
|
|
| 0 -> ()
|
|
| n -> Buffer.add_subbytes buf b 0 n; drain ()
|
|
| exception Unix.Unix_error _ -> ()
|
|
in
|
|
drain ();
|
|
Buffer.contents buf)
|
|
|
|
type state =
|
|
| Running
|
|
| Stopped of string (* the condition's class name *)
|
|
| Unreachable of string (* no answer: exited, or never listened *)
|
|
|
|
(* [status] is answered whether or not the program is stopped — "running" is an
|
|
answer, not a refusal. Everything else the break loop offers is refused
|
|
while running, and rightly: there is no restart stack to walk. But the
|
|
question an editor asks *without already knowing* is this one, so it had to
|
|
have an answer in both states or there would be nothing to poll. *)
|
|
let state t =
|
|
match ask t "status" with
|
|
| "" -> Unreachable "the program is not answering on its socket"
|
|
| text ->
|
|
let line = String.trim (List.hd (String.split_on_char '\n' text)) in
|
|
if line = "running" then Running
|
|
else if String.length line > 8 && String.sub line 0 8 = "stopped " then
|
|
Stopped (String.sub line 8 (String.length line - 8))
|
|
else Unreachable ("the program answered " ^ line)
|
|
| exception Unix.Unix_error (e, _, _) -> Unreachable (Unix.error_message e)
|
|
|
|
(* Innermost first, terminated by a line that is a single dot — the agent's
|
|
framing, not this one's. A refusal comes back as a line starting "err ", and
|
|
is passed on rather than turned into an empty list: no restarts and cannot
|
|
say are different answers.
|
|
|
|
Each line is [I ± NAME]: the index it is taken by, whether it can be taken,
|
|
and the name. The index is the identity — two frames may offer [retry] and
|
|
a name cannot say which — and it is the program's number, not this end's
|
|
position in a list, so it is carried rather than recomputed. *)
|
|
let restarts t =
|
|
match ask t "restarts" with
|
|
| text ->
|
|
let lines = String.split_on_char '\n' text in
|
|
if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines
|
|
then Error (String.trim text)
|
|
else begin
|
|
let parse line =
|
|
match String.index_opt line ' ' with
|
|
| None -> None
|
|
| Some i ->
|
|
(match int_of_string_opt (String.sub line 0 i) with
|
|
| None -> None
|
|
| Some idx ->
|
|
let rest = String.sub line (i + 1) (String.length line - i - 1) in
|
|
if String.length rest < 2 then None
|
|
else
|
|
Some
|
|
( idx,
|
|
rest.[0] = '+',
|
|
String.sub rest 2 (String.length rest - 2) ))
|
|
in
|
|
Ok
|
|
(List.filter_map parse
|
|
(List.filter
|
|
(fun l -> l <> "" && l <> ".")
|
|
(List.map String.trim lines)))
|
|
end
|
|
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
|
|
|
|
(* Where a stopped program is, one frame per line, innermost first — the same
|
|
framing [restarts] uses, terminated by a lone dot, because it comes back
|
|
over the same one-line-out socket.
|
|
|
|
Each line is [I ± NSLOTS SIG LOC NAME]. [SIG] is the slot fingerprint of
|
|
the body this frame was compiled from — [Emit.slot_fingerprint] over the
|
|
name and the type of every slot — and it is how [locals] tells a frame whose
|
|
body has been redefined underneath it from one that still matches. It stays
|
|
off the wire: a hash is not something a client can act on, and the refusal
|
|
it produces says the fact in words instead. It sits before [LOC] because
|
|
[NAME] is the only field that can contain a space and so has to be last.
|
|
|
|
The flag says whether the frame belongs
|
|
to the program or to the C-x C-e thunk the break happens to be inside: a
|
|
break inside an evaluation has that evaluation's frames on top, and
|
|
answering "where is my program" with [eval/7] would be true and useless.
|
|
[LOC] is the frame's own — it travels in the module that defined the body,
|
|
so a redefined function reports where the *installed* body is written and
|
|
not where the one this daemon first built was. A frame with none says [?].
|
|
|
|
A truncated backtrace ends [... N] before the dot; deep recursion is the
|
|
case, and the innermost frames are the ones the question is about. *)
|
|
let backtrace t =
|
|
match ask t "backtrace" with
|
|
| text ->
|
|
let lines =
|
|
List.map String.trim (String.split_on_char '\n' text)
|
|
in
|
|
if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines
|
|
then Error (String.trim text)
|
|
else begin
|
|
let more = ref 0 in
|
|
let parse line =
|
|
if String.length line > 4 && String.sub line 0 4 = "... " then begin
|
|
(match int_of_string_opt (String.sub line 4 (String.length line - 4)) with
|
|
| Some n -> more := n
|
|
| None -> ());
|
|
None
|
|
end
|
|
else
|
|
match String.split_on_char ' ' line with
|
|
| idx :: flag :: nslots :: sig_ :: loc :: rest when rest <> [] ->
|
|
(match
|
|
int_of_string_opt idx, int_of_string_opt nslots,
|
|
int_of_string_opt sig_
|
|
with
|
|
| Some _, Some k, Some g ->
|
|
Some (String.concat " " rest, (if loc = "?" then "" else loc),
|
|
flag = "+", k, g)
|
|
| _ -> None)
|
|
| _ -> None
|
|
in
|
|
let frames =
|
|
List.filter_map parse
|
|
(List.filter (fun l -> l <> "" && l <> ".") lines)
|
|
in
|
|
Ok (frames, !more)
|
|
end
|
|
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
|
|
|
|
(* Which of a frame's slots have been reached. One line per slot, [I ±], the
|
|
same framing as everything else the agent answers.
|
|
|
|
Asked before a thunk is built rather than after: an unbound slot is a null
|
|
address, and a thunk that rendered one would take a fault on the game
|
|
thread of a program that is already stopped — which is the one place a
|
|
crash costs the most, because it is where someone is standing over the
|
|
wreck deciding what to do about it. *)
|
|
let bound_slots t ~frame =
|
|
match ask t (Printf.sprintf "locals %d" frame) with
|
|
| text ->
|
|
let lines = List.map String.trim (String.split_on_char '\n' text) in
|
|
if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines
|
|
then Error (String.trim text)
|
|
else
|
|
Ok
|
|
(List.filter_map
|
|
(fun l ->
|
|
match String.split_on_char ' ' l with
|
|
| [ i; "+" ] -> int_of_string_opt i
|
|
| _ -> None)
|
|
(List.filter (fun l -> l <> "" && l <> ".") lines))
|
|
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
|
|
|
|
let alive t =
|
|
match Unix.waitpid [ Unix.WNOHANG ] t.child with
|
|
| 0, _ -> true
|
|
| _ -> 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 -> ""
|
|
|
|
(* 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
|
|
and never has to guess whether a missing field means failure. *)
|
|
let ok fields =
|
|
"(:status \"ok\"" ^ String.concat "" (List.map (fun f -> " " ^ f) fields) ^ ")"
|
|
|
|
(* Anything the program printed since the last reply rides along with this one.
|
|
An editor that had to ask separately would miss the output an evaluation
|
|
itself caused, which is the output anyone actually wants to see. *)
|
|
let with_output t reply =
|
|
match take t with
|
|
| "" -> reply
|
|
| text ->
|
|
let i = String.length reply - 1 in
|
|
String.sub reply 0 i ^ " :output " ^ Wire.quote text ^ ")"
|
|
|
|
(* The break state rides along with every reply, exactly as the program's own
|
|
output does, and for the same reason: a program can stop at any moment and
|
|
nothing in a request/response protocol will mention it unless every response
|
|
does. An editor that had to *ask* would find out about a stop only when it
|
|
happened to wonder — and the most common moment for a program to stop is the
|
|
instant after an evaluation, which is a reply it is already reading.
|
|
|
|
It is the annotation, not the ops, that decides these two fields, so that
|
|
there is one place in the daemon that says whether the program is stopped
|
|
and the break ops cannot disagree with the poll. *)
|
|
let with_break t reply =
|
|
let fields =
|
|
match state t with
|
|
| Stopped c -> " :stopped t :condition " ^ Wire.quote c
|
|
| Running -> " :stopped nil"
|
|
(* Unreachable is not "running": the honest shape of "it exited" is
|
|
[:alive nil] from [describe], and claiming a state we could not read
|
|
would be the [ok]-means-probably failure in miniature. *)
|
|
| Unreachable _ -> " :stopped nil"
|
|
in
|
|
String.sub reply 0 (String.length reply - 1) ^ fields ^ ")"
|
|
|
|
let error ?loc msg =
|
|
"(:status \"error\" :message " ^ Wire.quote msg
|
|
^ (match loc with None -> "" | Some l -> " :loc " ^ Wire.quote l)
|
|
^ ")"
|
|
|
|
let eval t ~code ~origin =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match Session.eval ~origin t.session code with
|
|
| c when not c.Session.installs ->
|
|
(* Accepted into the session and nothing to send: a declaration the
|
|
program already has, with no body and no new storage. Saying "ok" and
|
|
shipping an empty module would report success for a change that cannot
|
|
have taken effect. *)
|
|
ok
|
|
[ ":names " ^ Wire.strings c.Session.names; ":fns ()";
|
|
":note " ^ Wire.quote "nothing to install" ]
|
|
| c ->
|
|
t.n <- t.n + 1;
|
|
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;
|
|
Build.debug = t.session.Session.debug }
|
|
~ir:c.Session.ir ~out () with
|
|
| timing ->
|
|
(match deliver t out with
|
|
| "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
|
|
[ ":names " ^ Wire.strings c.Session.names;
|
|
":fns " ^ Wire.strings c.Session.fns;
|
|
Printf.sprintf ":ms %.1f"
|
|
(timing.Build.llc_ms +. timing.Build.link_ms) ]
|
|
| reply -> error ("the program refused the module: " ^ reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error
|
|
("cannot reach the program on " ^ t.agent ^ ": "
|
|
^ Unix.error_message e))
|
|
| exception Failure m -> error m)
|
|
| exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg
|
|
|
|
(* Redefining a name installs a body; evaluating an expression has no name to
|
|
install into, so the module carries a thunk the agent runs once. The value
|
|
comes back through the runtime rather than through this reply, because the
|
|
frame boundary it runs at is the program's to choose. *)
|
|
let eval_expr t ~code ~origin =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match Session.eval_expr ~origin t.session code with
|
|
| c ->
|
|
let before = match result t with Some (g, _) -> g | None -> 0L in
|
|
t.n <- t.n + 1;
|
|
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
|
|
(match Build.shared
|
|
~opts:{ Build.default with Build.dev = true;
|
|
Build.debug = t.session.Session.debug }
|
|
~ir:c.Session.ir ~out () with
|
|
| _ ->
|
|
(match deliver t out with
|
|
| "ok" ->
|
|
let rec wait ms =
|
|
match result t with
|
|
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
|
| _ when ms <= 0 -> None
|
|
| _ ->
|
|
ignore (Unix.select [] [] [] 0.005);
|
|
if alive t then wait (ms - 5) else None
|
|
in
|
|
(match wait 5000 with
|
|
| Some v -> ok [ ":value " ^ Wire.quote v ]
|
|
| None ->
|
|
error
|
|
"the program did not reach a frame boundary; is it calling \
|
|
(agent/poll)?")
|
|
| reply -> error ("the program refused the module: " ^ reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e))
|
|
| exception Failure m -> error m)
|
|
| exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg
|
|
|
|
let describe t =
|
|
ok
|
|
[ ":fns "
|
|
^ Wire.strings
|
|
(List.map (fun (f : Tast.fn) -> f.Tast.name)
|
|
t.session.Session.program.Tast.fns);
|
|
":globals "
|
|
^ Wire.strings
|
|
(List.map (fun (g : Tast.global) -> g.Tast.gname)
|
|
t.session.Session.program.Tast.globals);
|
|
":alive " ^ (if alive t then "t" else "nil") ]
|
|
|
|
(* [describe] answers what exists; this answers what each one *is*. Its own op
|
|
rather than more fields on [describe], because [describe] is polled — an
|
|
editor uses it to drain the program's output — and this is asked once on
|
|
connect and again after each install. Putting signatures on the poll would
|
|
pay for them every time anyone looked at the output buffer.
|
|
|
|
One entry per name: (name kind signature loc). Four strings, so the editor
|
|
reads it with [read] and nothing here needs a new wire type. [loc] is empty
|
|
where there is none to give — only [Tast.fn] carries one — and an editor
|
|
that finds it empty must say so rather than guess a file.
|
|
|
|
Parameter *names* are not in the Tast, so a signature shows types only. *)
|
|
let signature_of_fn (f : Tast.fn) =
|
|
Printf.sprintf "%s [%s] %s" f.Tast.name
|
|
(String.concat " " (List.map Types.to_string f.Tast.params))
|
|
(Types.to_string f.Tast.ret)
|
|
|
|
let entry ~name ~kind ~sign ~loc =
|
|
Wire.list [ Wire.quote name; Wire.quote kind; Wire.quote sign; Wire.quote loc ]
|
|
|
|
let defs t =
|
|
let p = t.session.Session.program in
|
|
let fns =
|
|
List.filter_map
|
|
(fun (f : Tast.fn) ->
|
|
match f.Tast.fparent with
|
|
(* A handler-bind clause the checker lifted out. Nobody wrote this
|
|
name, so completing it is noise and jumping to it is meaningless. *)
|
|
| Some _ -> None
|
|
| None ->
|
|
Some
|
|
(entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
|
|
~loc:(Loc.to_string f.Tast.floc)))
|
|
p.Tast.fns
|
|
in
|
|
let globals =
|
|
List.map
|
|
(fun (g : Tast.global) ->
|
|
entry ~name:g.Tast.gname
|
|
~kind:(if g.Tast.gconst then "const" else "var")
|
|
~sign:
|
|
(Printf.sprintf "%s %s" g.Tast.gname (Types.to_string g.Tast.gty))
|
|
~loc:"")
|
|
p.Tast.globals
|
|
in
|
|
let externs =
|
|
List.map
|
|
(fun (e : Tast.extern) ->
|
|
entry ~name:e.Tast.ename ~kind:"extern"
|
|
~sign:
|
|
(Printf.sprintf "%s [%s] %s" e.Tast.ename
|
|
(String.concat " " (List.map Types.to_string e.Tast.eparams))
|
|
(Types.to_string e.Tast.eret))
|
|
~loc:"")
|
|
p.Tast.externs
|
|
in
|
|
ok [ ":defs " ^ Wire.list (fns @ globals @ externs) ]
|
|
|
|
(* [(:op "layout" :type T)] — a struct's fields and their types.
|
|
|
|
The daemon can answer this with no running program at all: [Tast.structs] is
|
|
what it built the process from, and a layout is a fact about the build. That
|
|
is why it is the one thing the conditions buffer can fill in while the
|
|
condition's *values* stay refused.
|
|
|
|
**The type is a name, and the name is the qualified one.** [Load] qualifies
|
|
every declaration as it imports it — [Defstruct (qualify alias n, ...)] — so
|
|
the names in [Tast.structs] are a flat namespace in which two packages each
|
|
declaring [Missing] are [a/Missing] and [b/Missing] and no collision is
|
|
possible. That makes the name a type identity rather than a class name, with
|
|
no id table to keep in step, and it is the same string on both ends of the
|
|
wire already: [Emit.struct_name_of] puts [Types.Named n] into [flan_error],
|
|
the agent holds it in [condition_name], and [break] answers it as
|
|
[:condition]. Handing that string straight back as [:type] therefore
|
|
resolves, by construction.
|
|
|
|
A bare name is **refused, not resolved**, even when only one struct's last
|
|
segment matches: resolving it is exactly the ambiguity that made this op
|
|
need a rule, and a rule with an exception cannot be relied on by a client.
|
|
The refusal lists the qualified names it could have meant, so a person who
|
|
typed [Missing] is one copy-paste from the answer and a client can offer
|
|
them as completions.
|
|
|
|
Field types are spelled by [Types.to_string], which is what [defs] spells a
|
|
signature with — so [(Option T)], [[T]], [[n T]] and [(Ptr T)] read here
|
|
exactly as they read in a signature and in the source. A field that is
|
|
itself a struct shows its qualified name, which is a [:type] this op
|
|
accepts: nesting is another request rather than a second walk, and nothing
|
|
here can recurse forever. [Render] is the other walk over a type and is not
|
|
reused, because it walks a *value* and emits code that prints it; this emits
|
|
text about the type and never touches the program. *)
|
|
let layout t ~ty =
|
|
let structs = t.session.Session.program.Tast.structs in
|
|
match
|
|
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty)
|
|
structs
|
|
with
|
|
| Some s ->
|
|
ok
|
|
[ ":type " ^ Wire.quote s.Tast.sname;
|
|
":fields "
|
|
^ Wire.list
|
|
(List.map
|
|
(fun (f : Tast.field) ->
|
|
Wire.list
|
|
[ Wire.quote f.Tast.fname;
|
|
Wire.quote (Types.to_string f.Tast.fty) ])
|
|
s.Tast.fields) ]
|
|
| None ->
|
|
(* Two types the checker knows and this op cannot describe. An enum's
|
|
members are erased to i32 before [Tast.program] exists, which is the
|
|
same fact that makes a defenum unreloadable; a union is declared and
|
|
has no values yet. Either way, saying which kind it is beats "no such
|
|
type" for a name that plainly exists. *)
|
|
if Hashtbl.mem t.session.Session.env.Check.enums ty then
|
|
error (ty ^ " is an enum, not a struct; its members are erased to i32")
|
|
else if
|
|
List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname ty)
|
|
t.session.Session.program.Tast.unions
|
|
then
|
|
error (ty ^ " is a union, not a struct; union values are milestone 6")
|
|
else
|
|
let suffix = "/" ^ ty in
|
|
let candidates =
|
|
List.filter_map
|
|
(fun (s : Tast.structure) ->
|
|
let n = s.Tast.sname in
|
|
let k = String.length n - String.length suffix in
|
|
if k >= 0 && String.equal (String.sub n k (String.length suffix)) suffix
|
|
then Some n else None)
|
|
structs
|
|
in
|
|
(match candidates with
|
|
| [] -> error ("no struct is named " ^ ty)
|
|
| cs ->
|
|
(* Resolved on the client's side, deliberately: two packages can each
|
|
declare [Missing], and picking one of them here would answer a
|
|
layout for a type the asker did not mean. *)
|
|
"(:status \"error\" :message "
|
|
^ Wire.quote
|
|
(ty ^ " is not a qualified name; a package qualifies its \
|
|
declarations, so say which one")
|
|
^ " :candidates " ^ Wire.strings cs ^ ")")
|
|
|
|
(* What is on offer where the program stopped. [:stopped] and [:condition] are
|
|
not here: the annotation puts them on this reply as it puts them on every
|
|
other, so an editor reads the same two keys whatever it asked. What this op
|
|
adds is the restart names, which cost a second round trip to the program and
|
|
are wanted only when someone is about to choose one. *)
|
|
let break t =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match state t with
|
|
| Running -> ok []
|
|
| Unreachable m -> error ("cannot ask the program whether it stopped: " ^ m)
|
|
| Stopped _ ->
|
|
(match restarts t with
|
|
| Ok rs ->
|
|
(* [:restarts] stays a list of names, positional and innermost first,
|
|
with duplicates kept — the position *is* the index, which is what
|
|
[restart-at] takes. [:unreachable] names the positions that are on
|
|
the list and cannot be chosen: a restart below the evaluation the
|
|
break is inside has nowhere for a transfer to land. They are shown
|
|
rather than filtered, because a client that quietly dropped them
|
|
would leave someone asking where their restart went. *)
|
|
ok
|
|
[ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs);
|
|
":unreachable "
|
|
^ Wire.ints
|
|
(List.filter_map
|
|
(fun (i, ok, _) -> if ok then None else Some i)
|
|
rs) ]
|
|
| Error m -> error ("the program refused to list its restarts: " ^ m))
|
|
|
|
(* [(:op "backtrace")] — the frames of a stopped program, innermost first.
|
|
NEXT.md's "Asked for by the editor lanes" had this blocked on exactly the
|
|
frame metadata the shadow stack now carries.
|
|
|
|
Refused while the program is running, and that is not a gap in the feature:
|
|
the chain is the game thread's, it is pushed and popped on every call, and
|
|
a walk of it from this end while that thread runs would produce a plausibly
|
|
shaped answer that was never true. Stopped, the thread is parked in the
|
|
break loop and the program itself takes the snapshot.
|
|
|
|
Each frame is [(name loc origin nslots)] — four fields in the shape [defs]
|
|
already uses, so an editor reads it with [read] and nothing else. [origin]
|
|
is "program" or "eval": a break inside a C-x C-e thunk has the thunk's
|
|
frames above the program's, and they are shown and labelled rather than
|
|
hidden, the same decision [:unreachable] makes for the restarts under one.
|
|
[nslots] is how many slots the frame has, which is what a client asks about
|
|
before asking for any of them. *)
|
|
let backtrace_op t =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match state t with
|
|
| Running ->
|
|
error
|
|
"the program is running; a backtrace is only taken while it is stopped, \
|
|
because the frame chain is the game thread's and it is changing"
|
|
| Unreachable m -> error ("cannot ask the program where it is: " ^ m)
|
|
| Stopped _ ->
|
|
(match backtrace t with
|
|
| Ok (frames, more) ->
|
|
ok
|
|
[ ":frames "
|
|
^ Wire.list
|
|
(List.map
|
|
(fun (name, loc, mine, nslots, _sig) ->
|
|
Wire.list
|
|
[ Wire.quote name; Wire.quote loc;
|
|
Wire.quote (if mine then "program" else "eval");
|
|
string_of_int nslots ])
|
|
frames);
|
|
Printf.sprintf ":more %d" more ]
|
|
| Error m -> error ("the program refused to say where it is: " ^ m))
|
|
|
|
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
|
|
|
|
The half of a break loop that the author actually wanted, and the reason
|
|
the shadow stack was built rather than more DWARF: DWARF would have put
|
|
these in lldb, and the point is to need lldb less often.
|
|
|
|
Nothing is copied out of the program. A Flan value has no header, so bytes
|
|
read from another process would be bytes with no meaning; what this end has
|
|
is the *type* — [Tast.fn.slots], from the build it owns — and the name
|
|
beside it in [snames]. So it compiles a thunk that renders those types at
|
|
those addresses, in the program, on the stopped thread, and reads the text
|
|
back the way [C-x C-e] does. The only thing that comes from the running
|
|
program is where the frame is.
|
|
|
|
Three refusals, each by name and with its reason rather than by omission:
|
|
a slot the compiler invented and nobody named; a slot whose binding had not
|
|
run when the program stopped, which is a null address and would be a fault;
|
|
and a type the structural printer has no arm for. A local that is missing
|
|
and a local that could not be printed are different facts, and a list that
|
|
showed neither would be the same lie twice.
|
|
|
|
And two whole frames it refuses: one belonging to a [C-x C-e] thunk, which
|
|
this session does not keep the [Tast] of, and one whose *body* is not the
|
|
body this session holds. The second is the one that needed a fingerprint
|
|
rather than a count: installing while stopped is deliberately allowed — it
|
|
is the fix-it-and-retry loop — so the frame on the stack and the body here
|
|
can be two bodies of one function, and a redefinition that renames a local
|
|
changes neither the count nor the types. [Emit.slot_fingerprint] hashes
|
|
every slot's name together with the spelling of its type, the frame carries
|
|
the value for the body it was compiled from, and this end recomputes it
|
|
from the body it holds. A collision is possible in principle — it is a
|
|
30-bit hash — but only between two differing bodies of the function whose
|
|
qualified name already matched, since [find_fn] gates the comparison. *)
|
|
let locals t ~frame =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match state t with
|
|
| Running ->
|
|
error
|
|
"the program is running; locals are read from a stopped frame, and \
|
|
nothing in a frame that is still executing holds still"
|
|
| Unreachable m -> error ("cannot ask the program for its locals: " ^ m)
|
|
| Stopped _ ->
|
|
(match backtrace t with
|
|
| Error m -> error ("the program refused to say where it is: " ^ m)
|
|
| Ok (frames, _) ->
|
|
(match List.nth_opt frames frame with
|
|
| None ->
|
|
error
|
|
(Printf.sprintf "there is no frame %d; the backtrace has %d" frame
|
|
(List.length frames))
|
|
| Some (name, _, mine, nslots, sig_) ->
|
|
if not mine then
|
|
error
|
|
(name
|
|
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
|
|
else
|
|
match find_fn t name with
|
|
| None ->
|
|
error
|
|
(name
|
|
^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from")
|
|
| Some fn ->
|
|
(* The two body checks come first, including for a frame
|
|
with no slots. "every slot in it is one the compiler made
|
|
up" is a claim about the body this session holds, and a
|
|
zero-slot frame whose body has since been replaced by one
|
|
with slots is a frame that claim is false about. *)
|
|
if nslots <> Array.length fn.Tast.slots then
|
|
error
|
|
(Printf.sprintf
|
|
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
|
|
name nslots name (Array.length fn.Tast.slots))
|
|
else if sig_ <> Emit.slot_fingerprint fn then
|
|
(* The count matching is not the same as the body matching.
|
|
A redefinition that renames a local, or changes its type
|
|
to one of the same shape, keeps the count — and then
|
|
every name here would be the new body's read against the
|
|
old body's storage, which is the "visible rather than
|
|
correct" answer this project refuses to give. Said by
|
|
name, because a frame that is missing and a frame that
|
|
cannot be trusted are different facts. *)
|
|
error
|
|
(Printf.sprintf
|
|
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
|
|
name name)
|
|
else if nslots = 0 then
|
|
ok
|
|
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
|
|
":note "
|
|
^ Wire.quote
|
|
"that frame records no slots; every slot in it is one the compiler made up" ]
|
|
else
|
|
match bound_slots t ~frame with
|
|
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
|
|
| Ok bound ->
|
|
let c, refused = Session.render_locals t.session ~frame ~fn ~bound in
|
|
let before = match result t with Some (g, _) -> g | None -> 0L in
|
|
t.n <- t.n + 1;
|
|
let out = Filename.concat t.dir (Printf.sprintf "l%d.so" t.n) in
|
|
(match Build.shared
|
|
~opts:{ Build.default with Build.dev = true;
|
|
Build.debug = t.session.Session.debug }
|
|
~ir:c.Session.ir ~out () with
|
|
| _ ->
|
|
(match deliver t out with
|
|
| "ok" ->
|
|
let rec wait ms =
|
|
match result t with
|
|
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
|
| _ when ms <= 0 -> None
|
|
| _ ->
|
|
ignore (Unix.select [] [] [] 0.005);
|
|
if alive t then wait (ms - 5) else None
|
|
in
|
|
(match wait 5000 with
|
|
| Some v ->
|
|
(* One line per slot, name and type and value,
|
|
tab separated — safe because every string the
|
|
renderer emits is escaped. *)
|
|
let entries =
|
|
List.filter_map
|
|
(fun line ->
|
|
match String.split_on_char '\t' line with
|
|
| [ n; ty; value ] ->
|
|
Some
|
|
(Wire.list
|
|
[ Wire.quote n; Wire.quote ty;
|
|
Wire.quote value ])
|
|
| _ -> None)
|
|
(String.split_on_char '\n' v)
|
|
in
|
|
ok
|
|
[ ":frame " ^ Wire.quote name;
|
|
":locals " ^ Wire.list entries;
|
|
":refused "
|
|
^ Wire.list
|
|
(List.map
|
|
(fun (n, why) ->
|
|
Wire.list
|
|
[ Wire.quote n; Wire.quote why ])
|
|
refused) ]
|
|
| None ->
|
|
error
|
|
"the program did not reach a frame boundary; is \
|
|
it calling (agent/poll)?")
|
|
| reply -> error ("the program refused the module: " ^ reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e))
|
|
| exception Failure m -> error m)))
|
|
|
|
(* [(:op "globals")] — the globals the stopped stack reaches, in one section.
|
|
|
|
Locals were the half the shadow stack was built for; these are arguably the
|
|
more useful half in this language. A game keeps most of its state in
|
|
top-level [defvar]s and sand.flan holds its entire grid that way, so "what
|
|
is the program's state right now" is a question about globals and there was
|
|
nowhere to ask it.
|
|
|
|
**Not per frame, and that is the design.** A global is not part of a frame —
|
|
it is program state the frame happened to touch — so nesting it under one
|
|
implies an ownership that is not there, and repeats the name once per frame
|
|
that reads it. So: one section, whose contents are the union of the globals
|
|
every frame on the current stack references.
|
|
|
|
**The compiler does the choosing.** [Reach.expr_refs] is the walk that
|
|
already computes what a function refers to — it is how the link drops a
|
|
package nothing calls — and pointed at one body it answers that body's
|
|
reference set. Listing *all* of a program's globals instead would bury the
|
|
one that matters under the prelude's PRNG state; taking only what the stack
|
|
reaches is the filter the compiler can apply and a person cannot.
|
|
|
|
Direct references only, with no transitive closure through the calls a body
|
|
makes. A callee that reads a global is either on this stack — in which case
|
|
it is contributing its own references already — or it is not, in which case
|
|
it is not part of where the program stopped.
|
|
|
|
**Each entry says which frames touch it**, by index, which is what the stack
|
|
section already numbers them by. That recovers what per-frame nesting would
|
|
have told you — "the whole chain is reading this" reads differently from
|
|
"only the innermost does" — at no cost in duplication.
|
|
|
|
**Ordered by the innermost frame that touches it.** A deep stack makes the
|
|
union large, and proximity to the error is what puts the likely culprit on
|
|
top. Ties keep declaration order, which is the order the source has them in.
|
|
|
|
**A frame that cannot be attributed contributes nothing and says so.** An
|
|
eval frame has no declaration in this session; a lifted handler clause has
|
|
none of its own; and a frame whose body has been redefined since it was
|
|
entered holds a body whose reference set is a claim about different code.
|
|
In every case the honest answer is that the union is incomplete and which
|
|
frame made it so — [:skipped] — rather than a list that silently is not the
|
|
union it says it is. The *values* would still have been right; the
|
|
attribution is what goes wrong, and attribution is what this op is for.
|
|
|
|
**And the hole in that, stated rather than papered over.**
|
|
[Emit.slot_fingerprint] hashes a body's *slots* — every slot's name with the
|
|
spelling of its type — so it catches a redefinition that binds differently
|
|
and misses one that does not. For [locals] that is exactly the right cut:
|
|
if the slots are identical then the names still describe the storage and
|
|
the answer is still true. Here it is not, because a body can change which
|
|
globals it names without touching a single slot, and then this section
|
|
shows the *new* body's reference set attributed to the *old* frame.
|
|
|
|
The values stay correct — they come from the program's storage by name —
|
|
and so does everything the other frames contribute. What can be wrong is
|
|
one frame's membership in the union and the frame numbers beside an entry.
|
|
Closing it means a second fingerprint over the reference set itself, which
|
|
is a change to [%fninfo] and to the agent that reads it; it is not done,
|
|
and the failure it leaves is narrow enough to name here rather than to
|
|
pretend away with a check that does not check it.
|
|
|
|
Nothing is copied out of the program here either, and the mechanism is one
|
|
step simpler than [locals]: a global is reached by name rather than by
|
|
address, because [Emit.redefinition] writes a global the host already has as
|
|
[external] and the dynamic linker binds the thunk to the program's own
|
|
storage. So there is no [bound_slots] round trip and no not-yet-bound case —
|
|
a global's storage exists from the moment the process started. *)
|
|
let globals_op t =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match state t with
|
|
| Running ->
|
|
error
|
|
"the program is running; globals are read against a stopped stack, and \
|
|
the stack is what decides which of them to show"
|
|
| Unreachable m -> error ("cannot ask the program for its globals: " ^ m)
|
|
| Stopped _ ->
|
|
(match backtrace t with
|
|
| Error m -> error ("the program refused to say where it is: " ^ m)
|
|
| Ok (frames, _) ->
|
|
let all = t.session.Session.program.Tast.globals in
|
|
let is_global n =
|
|
List.exists (fun (g : Tast.global) -> String.equal g.Tast.gname n) all
|
|
in
|
|
(* name -> the frame indices that reference it, innermost lowest *)
|
|
let touched : (string, int list) Hashtbl.t = Hashtbl.create 32 in
|
|
let skipped = ref [] in
|
|
List.iteri
|
|
(fun i (name, _, mine, nslots, sig_) ->
|
|
let skip why =
|
|
skipped := (Printf.sprintf "%d: %s" i name, why) :: !skipped
|
|
in
|
|
if not mine then
|
|
skip
|
|
"a frame of the expression this break is inside, not of the \
|
|
program; its thunk is not part of the session, so there is no \
|
|
record of what it refers to"
|
|
else
|
|
match find_fn t name with
|
|
| None ->
|
|
skip
|
|
"not a function this session holds; a lifted handler clause \
|
|
has no declaration of its own to read references from"
|
|
| Some fn ->
|
|
if nslots <> Array.length fn.Tast.slots then
|
|
skip
|
|
"the frame is running a body that has been redefined \
|
|
since, so what this session holds is a different body's \
|
|
reference set"
|
|
else if sig_ <> Emit.slot_fingerprint fn then
|
|
skip
|
|
"this frame's body was redefined since it was entered, so \
|
|
what it refers to here is a claim about different code"
|
|
else begin
|
|
(* Once per frame per name: a body that reads the grid in
|
|
four places touches it once as far as this is
|
|
concerned. *)
|
|
let seen = Hashtbl.create 8 in
|
|
let note n =
|
|
if is_global n && not (Hashtbl.mem seen n) then begin
|
|
Hashtbl.add seen n ();
|
|
let prev =
|
|
try Hashtbl.find touched n with Not_found -> []
|
|
in
|
|
Hashtbl.replace touched n (prev @ [ i ])
|
|
end
|
|
in
|
|
List.iter (Reach.expr_refs note) fn.Tast.body;
|
|
List.iter (Reach.expr_refs note) fn.Tast.fdefers
|
|
end)
|
|
frames;
|
|
let skipped = List.rev !skipped in
|
|
let wanted =
|
|
(* Declaration order first, so a tie on the innermost frame breaks
|
|
the way the source reads. [stable_sort] then keeps it. *)
|
|
List.filter
|
|
(fun (g : Tast.global) -> Hashtbl.mem touched g.Tast.gname)
|
|
all
|
|
in
|
|
let innermost (g : Tast.global) =
|
|
List.fold_left min max_int (Hashtbl.find touched g.Tast.gname)
|
|
in
|
|
let ordered =
|
|
List.stable_sort
|
|
(fun a b -> compare (innermost a) (innermost b))
|
|
wanted
|
|
in
|
|
let where (g : Tast.global) =
|
|
Wire.list
|
|
(List.map string_of_int
|
|
(List.sort_uniq compare (Hashtbl.find touched g.Tast.gname)))
|
|
in
|
|
let skipped_field =
|
|
":skipped "
|
|
^ Wire.list
|
|
(List.map
|
|
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
|
|
skipped)
|
|
in
|
|
if ordered = [] then
|
|
ok
|
|
[ ":globals ()"; ":refused ()"; skipped_field;
|
|
":note "
|
|
^ Wire.quote
|
|
"no frame on this stack references a global; there is \
|
|
nothing here that is not already in the locals" ]
|
|
else begin
|
|
let c, refused = Session.render_globals t.session ~globals:ordered in
|
|
let before = match result t with Some (g, _) -> g | None -> 0L in
|
|
t.n <- t.n + 1;
|
|
let out = Filename.concat t.dir (Printf.sprintf "g%d.so" t.n) in
|
|
match Build.shared
|
|
~opts:{ Build.default with Build.dev = true;
|
|
Build.debug = t.session.Session.debug }
|
|
~ir:c.Session.ir ~out () with
|
|
| _ ->
|
|
(match deliver t out with
|
|
| "ok" ->
|
|
let rec wait ms =
|
|
match result t with
|
|
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
|
| _ when ms <= 0 -> None
|
|
| _ ->
|
|
ignore (Unix.select [] [] [] 0.005);
|
|
if alive t then wait (ms - 5) else None
|
|
in
|
|
(match wait 5000 with
|
|
| Some v ->
|
|
(* One line per global, name and type and value, tab
|
|
separated — safe because every string the renderer emits
|
|
is escaped. The frames are added back here, from the
|
|
table above, because the thunk knows nothing about the
|
|
stack it was chosen for. *)
|
|
let by_name = Hashtbl.create 32 in
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
Hashtbl.replace by_name g.Tast.gname (where g))
|
|
ordered;
|
|
let entries =
|
|
List.filter_map
|
|
(fun line ->
|
|
match String.split_on_char '\t' line with
|
|
| [ n; ty; value ] ->
|
|
Some
|
|
(Wire.list
|
|
[ Wire.quote n; Wire.quote ty; Wire.quote value;
|
|
(try Hashtbl.find by_name n
|
|
with Not_found -> Wire.list []) ])
|
|
| _ -> None)
|
|
(String.split_on_char '\n' v)
|
|
in
|
|
ok
|
|
[ ":globals " ^ Wire.list entries;
|
|
":refused "
|
|
^ Wire.list
|
|
(List.map
|
|
(fun (n, why) ->
|
|
Wire.list [ Wire.quote n; Wire.quote why ])
|
|
refused);
|
|
skipped_field ]
|
|
| None ->
|
|
error
|
|
"the program did not reach a frame boundary; is it calling \
|
|
(agent/poll)?")
|
|
| reply -> error ("the program refused the module: " ^ reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e))
|
|
| exception Failure m -> error m
|
|
end)
|
|
|
|
(* A choice is validated by the *program*, on its listener thread, against a
|
|
stack the stopped game thread is holding still — not here. The daemon has no
|
|
copy of that stack and anything it checked would be a guess that was true a
|
|
moment ago.
|
|
|
|
"ok" therefore means accepted, and says so: the resume happens when the
|
|
stopped thread next comes round its loop, which is microseconds away and
|
|
still not now. An editor that read [ok] as "running again" would poll once,
|
|
find it stopped, and re-open the prompt it had just answered. *)
|
|
let choose_at t ~index ~name =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else if
|
|
match name with
|
|
| Some n -> String.exists (fun c -> Char.code c < 32 || Char.code c = 127) n
|
|
| None -> false
|
|
then error "a restart name cannot contain a control character"
|
|
else
|
|
let verb =
|
|
"restart-at " ^ string_of_int index
|
|
^ match name with Some n -> " " ^ n | None -> ""
|
|
in
|
|
match ask t verb with
|
|
| reply when String.trim reply = "ok" ->
|
|
ok
|
|
[ ":index " ^ string_of_int index;
|
|
":note "
|
|
^ Wire.quote
|
|
"accepted; the program resumes at its next pass of the break loop"
|
|
]
|
|
| reply -> error (String.trim reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e)
|
|
|
|
let choose t ~name =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else if String.exists (fun c -> Char.code c < 32 || Char.code c = 127) name then
|
|
(* The agent's contract is one line per request. A name carrying a newline
|
|
would be a second request smuggled into the first, and the guarantee is
|
|
this end's to keep: [completing-read] cannot produce one, but the daemon
|
|
is what holds the socket and an editor is not the only thing that can
|
|
speak to it. *)
|
|
error "a restart name cannot contain a control character"
|
|
else
|
|
match ask t ("restart " ^ name) with
|
|
| reply when String.trim reply = "ok" ->
|
|
ok
|
|
[ ":restart " ^ Wire.quote name;
|
|
":note "
|
|
^ Wire.quote "accepted; the program resumes at its next pass of the break loop" ]
|
|
| reply -> error (String.trim reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e)
|
|
|
|
(* The other way out. The program exits 134 where it stopped, which ends this
|
|
daemon too — it owns the program's lifetime and has nothing left to serve.
|
|
Refused while running, by the program, for the same reason a restart is. *)
|
|
let abort t =
|
|
if not (alive t) then error "the program exited; restart flan dev"
|
|
else
|
|
match ask t "abort" with
|
|
| reply when String.trim reply = "ok" ->
|
|
ok [ ":note " ^ Wire.quote "the program is exiting; flan dev ends with it" ]
|
|
| reply -> error (String.trim reply)
|
|
| exception Unix.Unix_error (e, _, _) ->
|
|
error ("cannot reach the program: " ^ Unix.error_message e)
|
|
|
|
(* ── Disassembly ───────────────────────────────────────────────────── *)
|
|
|
|
(* [flan emit --dev] can print the IR of a whole source file, which is a
|
|
different question from the one an editor asks: not "what would this compile
|
|
to" but "what is the code the running program is calling for this name".
|
|
Only the daemon can answer that, because it built every module it sent and
|
|
still has the .ll and the .so on disk.
|
|
|
|
What it cannot do is read a cell back. The agent's socket takes a module
|
|
path, [result], [status], [restarts], [restart] and [abort] — there is no
|
|
verb that reports an address, [flan_dev_cell] lives in the program's address
|
|
space, and an expression evaluated through [eval-expr] renders a pointer as
|
|
[<ptr>] on purpose. So the answer is the last module *delivered* for the
|
|
name, and the reply says exactly that rather than implying more; see
|
|
[basis]. The one case that is certain is the case where nothing has been
|
|
delivered at all, and it says that too.
|
|
|
|
SBCL's presentation is worth two things here and not a third. Offsets from
|
|
the function's own start rather than file addresses, because an address into
|
|
a .so means nothing to a reader; and labels for branch targets inside the
|
|
function, which is most of the difference between readable and not. The
|
|
third is source interleaving, which SBCL can do because it has the mapping
|
|
and this build has no line tables — so it is refused by name in the reply
|
|
instead of being faked by printing the listing with no source in it. *)
|
|
|
|
let objdump = try Sys.getenv "FLAN_OBJDUMP" with Not_found -> "objdump"
|
|
|
|
let run_capture cmd =
|
|
let ic = Unix.open_process_in (cmd ^ " 2>&1") in
|
|
let b = Buffer.create 4096 in
|
|
let chunk = Bytes.create 4096 in
|
|
let rec go () =
|
|
match input ic chunk 0 4096 with
|
|
| 0 -> ()
|
|
| n -> Buffer.add_subbytes b chunk 0 n; go ()
|
|
| exception End_of_file -> ()
|
|
in
|
|
go ();
|
|
let code = match Unix.close_process_in ic with Unix.WEXITED c -> c | _ -> -1 in
|
|
(code, Buffer.contents b)
|
|
|
|
let contains 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
|
|
|
|
(* The IR of one function out of a module's text. [Emit] writes a define's
|
|
closing brace at column 0 and nowhere else, so the end is unambiguous
|
|
without parsing LLVM. One .ll can carry several bodies — [C-c C-k] sends a
|
|
buffer's worth as one module — which is why this slices rather than
|
|
returning the file. *)
|
|
let ir_of ~ir name =
|
|
let sym = Emit.fname name in
|
|
let rec take = function
|
|
| [] -> []
|
|
| "}" :: _ -> [ "}" ]
|
|
| l :: rest -> l :: take rest
|
|
in
|
|
let rec find = function
|
|
| [] -> None
|
|
| l :: rest ->
|
|
if String.length l > 7 && String.sub l 0 7 = "define " && contains l (sym ^ "(")
|
|
then Some (String.concat "\n" (take (l :: rest)))
|
|
else find rest
|
|
in
|
|
find (String.split_on_char '\n' ir)
|
|
|
|
(* objdump's own output, rebased and labelled. A line is
|
|
[" 250:<tab>bytes<tab>mnemonic"], with a continuation line carrying only
|
|
bytes when an instruction's encoding does not fit the column. *)
|
|
type insn = { off : int; bytes : string; text : string }
|
|
|
|
let parse_listing ~sym text =
|
|
let head = "<" ^ sym ^ ">:" in
|
|
let lines = String.split_on_char '\n' text in
|
|
let rec drop = function
|
|
| [] -> []
|
|
| l :: rest -> if contains l head then rest else drop rest
|
|
in
|
|
(* objdump prints a blank line after the last instruction of a symbol and
|
|
then whatever follows it in the section. Stopping at that line is what
|
|
keeps a one-function listing from running into the next function. *)
|
|
let rec upto = function
|
|
| [] -> []
|
|
| l :: rest -> if String.trim l = "" then [] else l :: upto rest
|
|
in
|
|
let body = upto (drop lines) in
|
|
let base = ref None in
|
|
let out = ref [] in
|
|
List.iter
|
|
(fun l ->
|
|
match String.split_on_char '\t' l with
|
|
| addr :: bytes :: rest ->
|
|
let a = String.trim addr in
|
|
let a =
|
|
if String.length a > 0 && a.[String.length a - 1] = ':' then
|
|
String.sub a 0 (String.length a - 1)
|
|
else a
|
|
in
|
|
(match int_of_string_opt ("0x" ^ a) with
|
|
| None -> ()
|
|
| Some n ->
|
|
if !base = None then base := Some n;
|
|
let b = match !base with Some b -> b | None -> n in
|
|
out :=
|
|
{ off = n - b; bytes = String.trim bytes;
|
|
text = String.trim (String.concat "\t" rest) }
|
|
:: !out)
|
|
| _ -> ())
|
|
body;
|
|
(List.rev !out, !base <> None)
|
|
|
|
(* A branch inside the function shows as [<flan.step+0x79>] or, for the entry,
|
|
[<flan.step>]. Those become [L0]..[Ln] in address order, as SBCL labels
|
|
them; anything else objdump annotated — a cell, a plt entry, another
|
|
function — is left exactly as it wrote it. *)
|
|
let target_of ~sym text =
|
|
if not (contains text ("<" ^ sym)) then None
|
|
else
|
|
match String.index_opt text '<' with
|
|
| None -> None
|
|
| Some i ->
|
|
let rest = String.sub text i (String.length text - i) in
|
|
if String.length rest < 3 || rest.[String.length rest - 1] <> '>' then None
|
|
else
|
|
let inner = String.sub rest 1 (String.length rest - 2) in
|
|
if String.equal inner sym then Some 0
|
|
else
|
|
let p = String.length sym in
|
|
if String.length inner > p + 1 && String.sub inner 0 (p + 1) = sym ^ "+"
|
|
then
|
|
int_of_string_opt (String.sub inner (p + 1) (String.length inner - p - 1))
|
|
else None
|
|
|
|
let render_listing ~sym insns =
|
|
let targets =
|
|
List.sort_uniq compare
|
|
(List.filter_map (fun i -> target_of ~sym i.text) insns)
|
|
in
|
|
let label n =
|
|
let rec idx k = function
|
|
| [] -> None
|
|
| x :: r -> if x = n then Some (Printf.sprintf "L%d" k) else idx (k + 1) r
|
|
in
|
|
idx 0 targets
|
|
in
|
|
let b = Buffer.create 4096 in
|
|
List.iter
|
|
(fun i ->
|
|
(match label i.off with
|
|
| Some lb -> Buffer.add_string b (lb ^ ":\n")
|
|
| None -> ());
|
|
let text =
|
|
match target_of ~sym i.text with
|
|
| Some n ->
|
|
(match label n with
|
|
| Some lb ->
|
|
(* [jmp 1d9 <flan.step+0x89>] becomes [jmp L1]. The bare number
|
|
objdump prints is the address the branch encodes *in the
|
|
file*, which is the one number on the line that means nothing
|
|
once the listing is rebased — so it goes with the symbol it
|
|
duplicates. *)
|
|
let j = String.index i.text '<' in
|
|
let head = String.sub i.text 0 j in
|
|
let k = ref (String.length head) in
|
|
while !k > 0 && head.[!k - 1] = ' ' do decr k done;
|
|
while !k > 0
|
|
&& (match head.[!k - 1] with
|
|
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
|
|
| _ -> false)
|
|
do decr k done;
|
|
String.sub head 0 !k ^ lb
|
|
| None -> i.text)
|
|
| None -> i.text
|
|
in
|
|
if text = "" then
|
|
Buffer.add_string b (Printf.sprintf " %04x %s\n" i.off i.bytes)
|
|
else
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %04x %-22s %s\n" i.off i.bytes text))
|
|
insns;
|
|
Buffer.contents b
|
|
|
|
let asm_of ~obj name =
|
|
let sym = "flan." ^ name in
|
|
let code, text =
|
|
run_capture
|
|
(String.concat " "
|
|
[ Filename.quote objdump; "-d";
|
|
"--disassemble=" ^ Filename.quote sym; Filename.quote obj ])
|
|
in
|
|
if code <> 0 then
|
|
Error
|
|
(Printf.sprintf "%s failed on %s (exit %d): %s" objdump obj code
|
|
(String.trim text))
|
|
else
|
|
match parse_listing ~sym text with
|
|
| _, false -> Error (Printf.sprintf "%s found no symbol %s in %s" objdump sym obj)
|
|
| insns, true -> Ok (render_listing ~sym insns)
|
|
|
|
(* Where a name's body was last built, and how much of that is a claim about
|
|
the running process rather than about this daemon's disk. *)
|
|
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 = 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 ->
|
|
let m = Filename.basename o.oso in
|
|
( 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 — 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
|
|
"%s — the last module delivered for this name, accepted for install; \
|
|
the program installs it at its next frame boundary and the daemon \
|
|
cannot read the cell back to confirm that it has"
|
|
m
|
|
| Unreachable r ->
|
|
Printf.sprintf
|
|
"%s — the last module delivered for this name; the program is not \
|
|
answering (%s), so whether it installed cannot be said"
|
|
m r )
|
|
|
|
let kind_of t name =
|
|
let p = t.session.Session.program in
|
|
if List.exists (fun (g : Tast.global) -> String.equal g.Tast.gname name)
|
|
p.Tast.globals
|
|
then Some "a global"
|
|
else if
|
|
List.exists (fun (e : Tast.extern) -> String.equal e.Tast.ename name)
|
|
p.Tast.externs
|
|
then Some "an extern"
|
|
else None
|
|
|
|
let disassemble t ~name ~form =
|
|
if form <> "ir" && form <> "asm" then
|
|
error
|
|
(Printf.sprintf
|
|
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
|
|
else
|
|
match find_fn t name with
|
|
| None ->
|
|
(match kind_of t name with
|
|
| Some k ->
|
|
error
|
|
(Printf.sprintf
|
|
"%s is %s, not a function: there is no generated code to show for it"
|
|
name k)
|
|
| None -> error (Printf.sprintf "no function named %s in this session" name))
|
|
| Some f ->
|
|
let o, why = basis t name in
|
|
let common =
|
|
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
|
|
":generation " ^ string_of_int o.ogen;
|
|
":signature " ^ Wire.quote (signature_of_fn f);
|
|
(* [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
|
|
match read_file o.oll with
|
|
| text ->
|
|
(match ir_of ~ir:text name with
|
|
| Some body ->
|
|
ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
|
|
| None ->
|
|
error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
|
|
| exception Sys_error m ->
|
|
error ("the IR this body was built from is gone: " ^ m)
|
|
else if not (Sys.file_exists o.oso) then
|
|
error ("the object this body was linked into is gone: " ^ o.oso)
|
|
else
|
|
match asm_of ~obj:o.oso name with
|
|
| Ok text ->
|
|
ok
|
|
(common
|
|
@ [ ":object " ^ Wire.quote o.oso;
|
|
":note "
|
|
^ Wire.quote
|
|
"source interleaving needs line tables this build does not \
|
|
emit";
|
|
":text " ^ Wire.quote text ])
|
|
| Error m -> error m
|
|
|
|
let handle t req =
|
|
match Wire.string_field req "op" with
|
|
| Some "eval" ->
|
|
(match Wire.string_field req "code" with
|
|
| Some code ->
|
|
let origin =
|
|
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
|
in
|
|
eval t ~code ~origin
|
|
| None -> error "eval needs :code")
|
|
| Some "eval-expr" ->
|
|
(match Wire.string_field req "code" with
|
|
| Some code ->
|
|
let origin =
|
|
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
|
in
|
|
eval_expr t ~code ~origin
|
|
| None -> error "eval-expr needs :code")
|
|
| Some "describe" -> describe t
|
|
| Some "defs" -> defs t
|
|
| Some "break" -> break t
|
|
| Some "backtrace" -> backtrace_op t
|
|
| Some "locals" ->
|
|
locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0)
|
|
(* No :frame, and that is the point: the section is the stack's, not a
|
|
frame's. See [globals_op]. *)
|
|
| Some "globals" -> globals_op t
|
|
| Some "layout" ->
|
|
(match Wire.string_field req "type" with
|
|
| Some ty -> layout t ~ty
|
|
| None -> error "layout needs :type")
|
|
| Some "restart" ->
|
|
(match Wire.string_field req "name" with
|
|
| Some name -> choose t ~name
|
|
| None -> error "restart needs :name")
|
|
(* By index, which is the one that can name a shadowed restart. [:name] is
|
|
optional and is not the lookup: it is checked against the name the program
|
|
has at that index and refused if they have drifted apart, so a client that
|
|
listed and then chose cannot take a different restart than the one it
|
|
showed. *)
|
|
| Some "restart-at" ->
|
|
(match Wire.int_field req "index" with
|
|
| Some index -> choose_at t ~index ~name:(Wire.string_field req "name")
|
|
| None -> error "restart-at needs :index")
|
|
| Some "abort" -> abort t
|
|
| Some "disassemble" ->
|
|
(match Wire.string_field req "name" with
|
|
| Some name ->
|
|
let form =
|
|
match Wire.string_field req "form" with Some f -> f | None -> "asm"
|
|
in
|
|
disassemble t ~name ~form
|
|
| None -> error "disassemble needs :name")
|
|
| Some "close" -> ok []
|
|
| Some op -> error ("unknown op: " ^ op)
|
|
| None -> error "no :op"
|
|
|
|
(* ── The loop ──────────────────────────────────────────────────────── *)
|
|
|
|
(* One connection at a time. An editor is one client, evaluations are
|
|
sequential by nature — each one is checked against the program the last one
|
|
left behind — and a second concurrent evaluation would be racing for the
|
|
same session anyway. *)
|
|
(* Returns whether the client asked to end the session. One editor per daemon,
|
|
so [close] shuts the whole thing down rather than waiting for another
|
|
connection nobody is going to make. *)
|
|
let serve t fd =
|
|
let rec go () =
|
|
match Wire.recv fd with
|
|
| src ->
|
|
let op, reply =
|
|
match Wire.parse src with
|
|
| req -> (Wire.string_field req "op", handle t req)
|
|
| exception Loc.Error (_, m) -> (None, error ("bad request: " ^ m))
|
|
in
|
|
Wire.send fd (with_output t (with_break t reply));
|
|
if op = Some "close" then true else go ()
|
|
| exception Wire.Closed -> false
|
|
| exception Unix.Unix_error _ -> false
|
|
in
|
|
go ()
|
|
|
|
(* [debug] is off by default, which keeps [flan dev] exactly what it was: a
|
|
-O2 host and -O2 modules. It is opt-in rather than always-on because a debug
|
|
build is an -O0 build — [llvm.dbg.declare] describes an alloca and mem2reg
|
|
deletes it — and silently making every reloaded body -O0 would change the
|
|
frame time of the one function you are iterating on, in the loop whose whole
|
|
point is watching that number. *)
|
|
let start ?(debug = false) ~file ~sock () =
|
|
let t0 = Unix.gettimeofday () in
|
|
(* Absolute, because every location this daemon ever reports is derived from
|
|
it and an editor is not in this process's working directory. [flan dev
|
|
src/game.flan] run from a project root would otherwise send back
|
|
"src/game.flan:12:7", which the editor can only resolve by guessing which
|
|
directory it was relative to. *)
|
|
let file = try Unix.realpath file with Unix.Unix_error _ -> file in
|
|
let session, l = Session.create ~debug ~file () in
|
|
let dir =
|
|
Filename.concat (Filename.get_temp_dir_name ())
|
|
(Printf.sprintf "flan-dev-%d" (Unix.getpid ()))
|
|
in
|
|
(try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
|
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. *)
|
|
(* The host and the modules are one decision. DWARF in a redefinition is
|
|
only half a debuggable dev loop: lldb re-resolves a *name* breakpoint
|
|
against each module as it loads either way, but a breakpoint set on a line
|
|
in the .flan buffer needs a line table on both sides — the host's to fire
|
|
before the first C-c C-c, the module's to follow the reload. *)
|
|
ignore
|
|
(Build.executable
|
|
~opts:{ Build.default with Build.dev = true; Build.keep = true;
|
|
Build.debug }
|
|
~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
|
|
|
|
(* The program's source names some socket path; the daemon is the one that
|
|
knows where it wants to talk to it, so it overrides through the
|
|
environment. Guessing instead would fail silently — everything compiles,
|
|
the module is built, and nothing ever receives it. *)
|
|
Unix.putenv "FLAN_AGENT_SOCKET" agent;
|
|
(* Through a pipe, so the program's own output can reach an editor instead of
|
|
only the terminal the daemon was started in. *)
|
|
let rd, wr = Unix.pipe ~cloexec:false () in
|
|
let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
|
|
Unix.close wr;
|
|
Unix.set_nonblock rd;
|
|
|
|
(* Wait for it to bind before accepting an evaluation. One that arrives first
|
|
would fail for a reason that reads like a compiler bug. *)
|
|
if not (await (fun () -> Sys.file_exists agent)) then begin
|
|
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
|
failwith
|
|
("the program never listened on " ^ agent
|
|
^ " — does it call (agent/start ...)?")
|
|
end;
|
|
|
|
let t =
|
|
{ session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0;
|
|
gen = 0; owners = Hashtbl.create 32; host_ll }
|
|
in
|
|
(try Unix.unlink sock with Unix.Unix_error _ -> ());
|
|
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
Unix.bind ls (Unix.ADDR_UNIX sock);
|
|
Unix.listen ls 4;
|
|
Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
|
|
((Unix.gettimeofday () -. t0) *. 1000.);
|
|
(* [accept] would block past the program's own exit, so it is waited on with
|
|
a timeout and the child checked each time round: a daemon whose program
|
|
has finished has nothing left to do, and an editor waiting on it would
|
|
wait forever. *)
|
|
let rec accept_loop () =
|
|
if alive t then
|
|
(* The program's pipe is in the same select as the listening socket: it
|
|
has to be drained whether or not an editor is asking for anything. *)
|
|
match Unix.select [ ls; t.stdout ] [] [] 0.2 with
|
|
| [], _, _ -> accept_loop ()
|
|
| ready, _, _ when not (List.mem ls ready) -> drain t; accept_loop ()
|
|
| _ ->
|
|
(match Unix.accept ls with
|
|
| fd, _ ->
|
|
let closed = serve t fd in
|
|
(try Unix.close fd with Unix.Unix_error _ -> ());
|
|
if not closed then accept_loop ()
|
|
| exception Unix.Unix_error (Unix.EINTR, _, _) -> accept_loop ())
|
|
| exception Unix.Unix_error (Unix.EINTR, _, _) -> accept_loop ()
|
|
in
|
|
Fun.protect
|
|
~finally:(fun () ->
|
|
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
|
(try Unix.close ls with Unix.Unix_error _ -> ());
|
|
(try Unix.close rd with Unix.Unix_error _ -> ());
|
|
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
|
|
accept_loop
|