Joseph Ferano
a8f08eda6d
(:op "layout" :type T) needs no running program: the daemon owns the build, so Tast.structs is already in the session it compiled the process from. The open question was what T is, and it needs no new machinery — Load qualifies every declaration at import, so two packages' Missing are a/Missing and b/Missing and the name is the type id. Emit already writes that same qualified name into flan_error, so the string break reports as :condition resolves as :type by construction, which is the round trip the test makes. A bare name is refused with the candidates rather than resolved to a unique suffix: resolving it would put back the ambiguity the rule exists to remove.
1136 lines
48 KiB
OCaml
1136 lines
48 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)
|
|
|
|
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 ->
|
|
(* An enum is a type the checker knows and this op cannot describe: its
|
|
members are erased to i32 before [Tast.program] exists, which is the
|
|
same fact that makes a defenum unreloadable. 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
|
|
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))
|
|
|
|
(* 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 "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
|