JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

flan dev is one process, and the socket does not know it

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-12 21:52:35 +07:00
commit a915140f17
4 changed files with 654 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
bin/main.ml
View File

@ -79,7 +79,16 @@ let debug_flag = "--debug"
what each of the two sanitizers actually reaches. *)
let sanitize_flag = "--sanitize"
let flags = [ no_checks_flag; dev_flag; debug_flag; sanitize_flag ]
(* [flan dev] builds one binary that is the program and holds the compiler,
and serves the editor from a thread inside it. This asks for the old shape
instead — a compiler process that launches the program and talks to it over
a socket. It is the escape hatch for a machine that cannot build the
compiler object (no ocamlfind, no flan.cmxa beside this binary), not a
preference, and it goes away with the transport it drives. *)
let two_process_flag = "--two-process"
let flags =
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag ]
(* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike
the flags above, a target
@ -323,16 +332,18 @@ let () =
each redefinition module to still be firing after C-c C-c. It implies
-O0 on both, so it is asked for rather than assumed. *)
let debug = List.mem debug_flag rest in
let merged = not (List.mem two_process_flag rest) in
let rest = List.filter (fun a -> not (is_flag a)) rest in
let sock =
match rest with
| [ "-s"; s ] -> s
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
| _ ->
prerr_endline "usage: flan dev <program.flan> [-s socket] [--debug]";
prerr_endline
"usage: flan dev <program.flan> [-s socket] [--debug] [--two-process]";
exit 2
in
with_errors path (fun () -> Flan.Dev.start ~debug ~file:path ~sock ())
with_errors path (fun () -> Flan.Dev.start ~debug ~merged ~file:path ~sock ())
(* One redefinition, built the way an editor will ask for it: a session over
the program the process was built from, and a file of the forms that

568
lib/dev.ml
View File

@ -25,7 +25,11 @@ type origin = {
type t = {
session : Session.t;
child : int; (* the running program *)
(* The running program. [Some pid] is the two-process daemon, which launched
it; [None] is the merged build, where the program is *this* process and
the compiler is a thread inside it. That is the whole of the difference at
this layer — see [merged_setup] for why there is no third case. *)
child : int option;
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 *)
@ -37,6 +41,12 @@ type t = {
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 *)
host_exe : string; (* ...and the binary it was linked into *)
(* Set when the program's stdout reads EOF. In the two-process daemon that
happens because the child died and [waitpid] is the authority anyway; in
the merged build it is the signal itself — the program's exit closes fd 1
and parks, and this is how the compiler finds out. *)
mutable finished : bool;
}
(* The program's stdout is a pipe into this process, so that an editor can see
@ -52,7 +62,8 @@ let drain t =
| [], _, _ -> ()
| _ ->
(match Unix.read t.stdout b 0 8192 with
| 0 -> ()
(* EOF on a pipe: every writer is gone, so the program has finished. *)
| 0 -> t.finished <- true
| n ->
Buffer.add_subbytes t.out b 0 n;
(* Bounded: a program that prints every frame must not grow this
@ -319,11 +330,17 @@ let bound_slots t ~frame =
(List.filter (fun l -> l <> "" && l <> ".") lines))
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
(* In the merged build the program is this process, so the question answers
itself: if this code is running, so is the program. The two-process daemon
has to ask the kernel. *)
let alive t =
match Unix.waitpid [ Unix.WNOHANG ] t.child with
| 0, _ -> true
| _ -> false
| exception Unix.Unix_error _ -> false
match t.child with
| None -> not t.finished
| Some child ->
(match Unix.waitpid [ Unix.WNOHANG ] child with
| 0, _ -> true
| _ -> false
| exception Unix.Unix_error _ -> false)
(* ── What a body was built from ─────────────────────────────────────── *)
@ -1476,7 +1493,7 @@ let asm_of ~obj name =
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;
( { ogen = 0; oso = t.host_exe; 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" )
@ -1695,13 +1712,37 @@ let serve t fd =
in
go ()
(* [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. In the merged build [alive] is always true and the loop ends the
only way it can — the process does, taking the program with it. *)
let accept_loop t ls =
let rec go () =
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
| [], _, _ -> go ()
| ready, _, _ when not (List.mem ls ready) -> drain t; go ()
| _ ->
(match Unix.accept ls with
| fd, _ ->
let closed = serve t fd in
(try Unix.close fd with Unix.Unix_error _ -> ());
if not closed then go ()
| exception Unix.Unix_error (Unix.EINTR, _, _) -> go ())
| exception Unix.Unix_error (Unix.EINTR, _, _) -> go ()
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 two_process ?(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
@ -1761,8 +1802,9 @@ let start ?(debug = false) ~file ~sock () =
end;
let t =
{ session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0;
gen = 0; owners = Hashtbl.create 32; host_ll }
{ session; child = Some child; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false }
in
(try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
@ -1770,30 +1812,494 @@ let start ?(debug = false) ~file ~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
(fun () -> accept_loop t ls)
(* ── One process: the program and the compiler in the same binary ──── *)
(* Everything above this line works the same either way. What follows is the
merged build: one executable that is the compiled Flan program *and* holds
the whole OCaml compiler, with the editor's socket served from a thread
inside it. DISCUSS.md item 14 is the spike this is built from.
The shape, and it is this way round for a reason:
main() C, the game's thread. Runs the Flan program.
+ a pthread caml_startup, then [merged_setup] and
[merged_serve] — the compiler and the
editor's listener.
+ a pthread flan_agent.c's accept loop, as today.
The game keeps main() because on macOS a window has to be on the main
thread. The compiler goes to the side, beside the listener that was already
there. Nothing about that is Linux-specific.
TWO RULES, and neither is a style preference. Both are the reason this is
safe at all, and both are silently broken by one convenient shortcut.
1. THE GAME THREAD MUST NEVER CALL INTO OCAML. OCaml's collector stops
OCaml threads at safe points. A pure native thread has none, so it cannot
be stopped — which is exactly why the GC will never pause a frame. That
holds only while the game thread is not inside an OCaml call: one direct
call from the frame loop and a major collection can land in the middle of
it. Requests reach the compiler by being *left somewhere and picked up*,
never by a call. The agent already works this way — a socket, a ring and
two atomics — and it stays that way. If a future handler wants something
from the game thread, it leaves a request and waits; it does not call.
2. NEVER STORE AN OCAML [value] IN FLAN STORAGE. Not in an arena, not in a
[Vec], not in a global, not across an allocation. The collector moves its
own blocks and will not update a word it does not know is a root;
[caml_register_global_root] (or the generational one) is the only legal
way. The boundary passes pointers and scalars. This is the chief way the
"the GC does not touch Flan's memory" measurement stops being true, and
it would fail intermittently rather than loudly.
WHERE REPL-FIRST WOULD DIFFER, noted now because it is much cheaper to leave
room for than to retrofit. Today [main] runs the program and the compiler
comes up beside it. The SBCL arrangement is the same binary with the two
swapped: the C [main] would not call [flan_program_main] at all, it would
park, and opening the window would be something typed at the prompt — one
more op that asks the game thread to run a named function. The startup below
is the only place that decides, and it decides in three lines of C. What is
genuinely open is the *session*: [Session.create ~file] is the only entry
there is, so a REPL that starts empty and accumulates as files are loaded
needs [Session] to have a second constructor. It already accumulates; it
just cannot start from nothing. *)
let ocamlfind = try Sys.getenv "FLAN_OCAMLFIND" with Not_found -> "ocamlfind"
(* The C that owns the process. A string here rather than a file under
[runtime/] for the reason [Build.wasm_main_source] is one: the compiler
carries the C it needs instead of looking for it on disk, and only the two
files [lib/dune] already embeds are reachable that way. *)
let merged_main_source = {c|
/* Generated by flan dev. The merged build's entry point: the Flan program owns
* the main thread, the OCaml compiler comes up on a thread beside it.
*
* See lib/dev.ml for the two rules this arrangement depends on. The short
* form: this thread — the one running flan_program_main — must never enter
* OCaml, and no OCaml value may be stored in Flan memory. */
#include <caml/callback.h>
#include <caml/mlvalues.h>
#include <pthread.h>
#include <fcntl.h>
#include <stdatomic.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <unistd.h>
/* The Flan program's entry point. Emit writes it as @main; flan dev renames it
* in the IR so that this file can own main() instead. */
extern int flan_program_main(int argc, char **argv);
/* flan_rt.c's, and the reason the program's exit does not end the session. */
extern void (*flan_exit_hook)(int32_t status);
/* Installed on flan_rt.c's hook, which a Flan main reaches instead of
* returning: Emit ends @main with a call to flan_exit and an unreachable.
*
* In one process that call cannot be allowed to end the process — it would
* take the compiler, the editor's socket and the session down with a program
* that merely finished. So it flushes, closes stdout so that the compiler
* learns the program is done exactly as the daemon learned it (the pipe reads
* EOF, which is what the child's death used to cause), and parks.
*
* Parking rather than exiting is also the REPL-first shape in miniature: the
* process outliving the program is the whole of the difference between "run a
* program with a REPL attached" and "an image you run programs in". */
static void flan_merged_exit(int32_t status) {
(void)status;
fflush(NULL);
close(1);
/* ...and take fd 1 straight back, because POSIX hands out the lowest free
* descriptor: leave it open and the compiler thread's next socket or file
* becomes this process's stdout, and the next llc inherits it. The EOF is
* unaffected — the pipe's write end is genuinely gone. */
if (open("/dev/null", O_WRONLY) < 0) { /* nothing useful to do about it */ }
for (;;) pause();
}
static char **g_argv;
/* Atomic, not a plain int: this is the only happens-before edge between the
* two threads, and everything the compiler set up before it — the listening
* socket, the redirected stdout — has to be visible to the program after it. */
static atomic_int compiler_ready = 0;
static void flan_merged_nap(long ms) {
struct timespec t;
t.tv_sec = ms / 1000;
t.tv_nsec = (ms % 1000) * 1000000L;
nanosleep(&t, NULL);
}
static const value *flan_merged_need(const char *n) {
const value *f = caml_named_value(n);
if (!f) {
fprintf(stderr, "flan dev: %s is not registered in this binary\n", n);
fflush(NULL);
_exit(70);
}
return f;
}
static void *flan_merged_compiler(void *unused) {
(void)unused;
caml_startup(g_argv);
/* Two callbacks and not one: setup has to have finished — the socket bound,
* stdout redirected — before the program starts, and serve never returns. */
caml_callback(*flan_merged_need("flan_merged_setup"), Val_unit);
atomic_store(&compiler_ready, 1);
caml_callback(*flan_merged_need("flan_merged_serve"), Val_unit);
fflush(NULL);
_exit(0);
}
int main(int argc, char **argv) {
pthread_t compiler;
int rc;
g_argv = argv;
flan_exit_hook = flan_merged_exit;
if (pthread_create(&compiler, NULL, flan_merged_compiler, NULL) != 0) {
fprintf(stderr, "flan dev: could not start the compiler thread\n");
return 1;
}
while (!atomic_load(&compiler_ready)) flan_merged_nap(1);
/* From here the main thread is the program's and nothing else's. It does not
* enter OCaml, and it is not joined with the compiler thread — that thread
* is in an accept loop it never leaves. */
/* Does not come back: a Flan main ends in flan_exit, which is hooked above.
* The lines below are for a program that somehow does return. */
rc = flan_program_main(argc, argv);
/* _exit, not exit, for the reason the break loop gives: the atexit chain and
* the ELF destructors want the loader lock the agent's listener may be
* holding inside dlopen, and the merged build adds OCaml's own shutdown to
* that chain. The streams are flushed by hand instead.
*
* This is also the line REPL-first would delete: park here instead, and the
* window becomes something the prompt asks for rather than the thing the
* process is. */
fprintf(stderr,
"flan dev: the program returned %d; the session ends with it\n", rc);
fflush(NULL);
_exit(rc);
}
|c}
(* The OCaml half's roots. [-output-complete-obj] links a .cmxa the way an
executable does — only the modules something refers to — so this file is
what pulls [Flan.Dev] and everything under it into the object. *)
let merged_entry_source =
"let () =\n\
\ Callback.register \"flan_merged_setup\" Flan.Dev.merged_setup;\n\
\ Callback.register \"flan_merged_serve\" Flan.Dev.merged_serve\n"
(* Where [flan.cmxa] is, which is the one thing the merged build needs that a
normal build does not. The compiler finds its own library beside itself;
[FLAN_LIBDIR] overrides for an install layout that does not match. *)
let libdir () =
let exe =
try Unix.realpath Sys.executable_name
with Unix.Unix_error _ -> Sys.executable_name
in
let bin = Filename.dirname exe in
let candidates =
(match Sys.getenv_opt "FLAN_LIBDIR" with Some d -> [ d ] | None -> [])
@ [ Filename.concat (Filename.dirname bin) "lib" ]
in
List.find_opt
(fun d -> Sys.file_exists (Filename.concat d "flan.cmxa"))
candidates
(* The whole compiler as one object file, cached. Keyed on a digest of
[flan.cmxa] and [flan.a] rather than on their existence: without that, an
edit to this very file rebuilds the library and the merged binary goes on
running the previous one — which costs an hour of chasing a ghost. *)
let compiler_object () =
match libdir () with
| None ->
failwith
"cannot find flan.cmxa beside this binary, so the compiler cannot be \
linked into the program. Set FLAN_LIBDIR, or run flan dev \
--two-process."
| Some lib ->
let cmxa = Filename.concat lib "flan.cmxa" in
let arch = Filename.concat lib "flan.a" in
let dg f = try Digest.to_hex (Digest.file f) with Sys_error _ -> "-" in
let key =
Digest.to_hex
(Digest.string
(String.concat "\000"
[ "flan-merged-compiler-1"; dg cmxa; dg arch;
Build.stamp_of ocamlfind; merged_entry_source ]))
in
let obj = Filename.concat (Build.cachedir ()) ("compiler-" ^ key ^ ".o") in
if not (Sys.file_exists obj) then begin
let dir = Build.workdir () in
let ml = Filename.concat dir "flan_merged_entry.ml" in
Build.write ml merged_entry_source;
let tmp =
Printf.sprintf "%s.%d.o" (Filename.remove_extension obj)
(Unix.getpid ())
in
(* [-output-complete-obj], not [-output-obj]: it bundles the runtime, so
there is no libasmrun to hunt for. The two [-I]s are dune's own object
directories — the .cmi and the .cmx of the library the entry module
refers to. *)
let cmd =
String.concat " "
[ Filename.quote ocamlfind; "ocamlopt"; "-thread";
"-package"; "unix,threads.posix"; "-linkpkg";
"-output-complete-obj";
"-I"; Filename.quote (Filename.concat lib ".flan.objs/byte");
"-I"; Filename.quote (Filename.concat lib ".flan.objs/native");
"-o"; Filename.quote tmp;
Filename.quote cmxa; Filename.quote ml ]
in
let code = Sys.command cmd in
if code <> 0 then
failwith
(Printf.sprintf
"%s could not build the compiler object (exit %d); flan dev \
--two-process still works" ocamlfind code);
(try Unix.rename tmp obj with Unix.Unix_error _ -> ())
end;
obj
let ocaml_where =
lazy
(match run_capture "ocamlopt -where" with
| 0, s -> String.trim s
| _ -> "")
(* [@main] renamed out of the way, so the C above can own the process. On the
emitted text rather than in [Emit], because [lib/emit.ml] belongs to another
lane — and because the spike proved the rename is all it takes. *)
let rename_program_main ir =
let needle = "define i32 @main(" in
let n = String.length needle and len = String.length ir in
let rec find i =
if i + n > len then None
else if String.sub ir i n = needle then Some i
else find (i + 1)
in
match find 0 with
| None ->
failwith
"no @main in the emitted IR — the merged build renames it so a C main \
can own the process"
| Some i ->
String.sub ir 0 i ^ "define i32 @flan_program_main("
^ String.sub ir (i + n) (len - i - n)
(* The link, which is [Build.executable]'s with three additions: the program's
[@main] renamed, the C above, and the compiler object.
It is spelled here rather than as a mode of [Build.executable] because
[lib/build.ml] belongs to another lane this week. The duplication is real
and should collapse into [Build] once that lane lands — every piece it uses
([compile_c], [cflags], [target_flags], [select_csrcs], [select_lflags]) is
already [Build]'s and already public. Native only: a wasm target has no
dlopen, no OCaml runtime and no use for any of this. *)
let merged_executable ~opts ~csrcs ~lflags ~pnames (p : Tast.program) ~out ~ll =
let open Build in
(* [Build.executable] forces this and the disassembly machinery believes it:
a --debug build that came out -O2 makes [basis] and the listing lie. *)
let opts = if opts.debug then { opts with opt = "-O0" } else opts in
let tflags = target_flags opts in
let ir =
Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames
~sanitize:opts.sanitize p
in
write ll (rename_program_main ir);
let cc src name = compile_c ~opts ~tflags ~src ~name () in
let objs =
(cc Runtime_src.source "flan_rt.c"
:: [ cc Runtime_src.dev_source "flan_dev.c" ])
@ (match p.Tast.cshim with
| [] -> []
| parts ->
[ cc (String.concat "" (List.map snd parts)) "flan_shim.c" ])
@ List.map (fun c -> cc (read_file c) (Filename.basename c))
(select_csrcs opts csrcs)
(* The caml/ headers, so the entry point can call caml_startup. They ride
in on [tflags], which is part of the object cache key — an entry point
compiled against one OCaml must not be served to another. *)
@ [ compile_c ~opts
~tflags:(tflags @ [ "-I"; Filename.quote (Lazy.force ocaml_where) ])
~src:merged_main_source ~name:"flan_merged_main.c" () ]
in
let cmd =
String.concat " "
([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
@ cflags opts
(* Still needed, and for the same reason: a delivered module reaches the
host's cells and globals through the dynamic symbol table. *)
@ (if opts.dev then [ "-rdynamic" ] else [])
@ tflags
@ [ Filename.quote ll ]
@ List.map Filename.quote objs
@ [ Filename.quote (compiler_object ()) ]
@ select_lflags opts lflags
(* -lzstd is OCaml 5's, not this project's: 5.x's marshaller is
compressed, and the missing ZSTD_* symbols are the first thing a
naive link of the runtime fails on. *)
@ [ "-lm"; "-lpthread"; "-ldl"; "-lzstd" ]
@ [ "-o"; Filename.quote out ])
in
let code = Sys.command cmd in
if code <> 0 then
failwith
(Printf.sprintf
"%s failed (exit %d) linking the merged build; the IR is at %s" clang
code ll);
out
(* ── The merged process's own two entry points ─────────────────────── *)
(* Held between [merged_setup] and [merged_serve], which are two calls because
the program must not start until the first has finished and the second never
returns. *)
let merged_state = ref None
let need_env k =
match Sys.getenv_opt k with
| Some v when v <> "" -> v
| _ ->
failwith
(k ^ " is not set: this binary is a [flan dev] build and is started by it")
(* Called from the compiler thread, once, before the program runs. *)
let merged_setup () =
try
let t0 = Unix.gettimeofday () in
let file = need_env "FLAN_DEV_SOURCE" in
let sock = need_env "FLAN_DEV_SOCK" in
let dir = need_env "FLAN_DEV_DIR" in
let host_ll = need_env "FLAN_DEV_HOST_LL" in
let agent = need_env "FLAN_AGENT_SOCKET" in
let debug = Sys.getenv_opt "FLAN_DEV_DEBUG" = Some "1" in
(* The session is built a second time here rather than carried across the
exec. It is the frontend only — about 12ms — and the alternative is
marshalling a [Session.t] through a file, which buys nothing: the source
cannot have changed between the two, because the build that produced
this binary is the one that exec'd it. *)
let session, _ = Session.create ~debug ~file () in
(* The program's output has to reach an editor exactly as it did when the
daemon held the other end of a pipe. Same pipe, one process: fd 1 is
replaced before the program starts, and the accept loop drains it —
which is a liveness requirement and not a nicety, since a pipe nobody
reads fills at 64K and the next print blocks the game thread for ever. *)
flush Stdlib.stdout;
let rd, wr = Unix.pipe ~cloexec:false () in
Unix.dup2 wr Unix.stdout;
Unix.close wr;
Unix.set_nonblock rd;
let exe =
try Unix.realpath Sys.executable_name
with Unix.Unix_error _ -> Sys.executable_name
in
let t =
{ session; child = None; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false }
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;
merged_state := Some (t, ls, sock);
Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file
sock ((Unix.gettimeofday () -. t0) *. 1000.)
with e ->
Printf.eprintf "flan dev: %s\n%!"
(match e with Failure m -> m | e -> Printexc.to_string e);
exit 1
(* Called from the compiler thread after the program has started. Never
returns: the process ends here or not at all. *)
let merged_serve () =
match !merged_state with
| None -> prerr_endline "flan dev: serve was called before setup"; exit 1
| Some (t, ls, sock) ->
(* The agent is bound by the program on the main thread, which only starts
once [merged_setup] has returned — so unlike the daemon, this waits
*after* it is already serving. An editor connecting in the meantime is
answered; only a delivery needs the agent. A program that never calls
[agent/start] is a warning rather than a failure now, because the thing
the daemon would have killed for it is this process. *)
if not (await ~ms:10000 (fun () -> Sys.file_exists t.agent)) then
Printf.eprintf
"flan dev: the program is not listening on %s — does it call \
(agent/start ...)?\n%!" t.agent;
(match accept_loop t ls with
| () -> ()
| exception e ->
Printf.eprintf "flan dev: %s\n%!" (Printexc.to_string e));
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ());
(* [close] from the editor ends the session, and in one process that means
the program too — which is what the daemon did by killing its child.
[_exit] for the loader-lock reason the break loop gives. *)
flush_all ();
Unix._exit 0
(* ── Starting a session ────────────────────────────────────────────── *)
(* The merged build is made here and then [exec]'d, so what an editor talks to
is the program itself rather than something that launched it. The launcher
does not survive: there is one process from the first reply onwards. *)
let start_merged ?(debug = false) ~file ~sock () =
let t0 = Unix.gettimeofday () in
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
(* The host's IR goes straight to its final home rather than being written
into the build's working directory and moved: the merged link is spelled
in this file, so it can simply be told where to put it. It is the text
clang was given, with [@main] renamed — which is what this binary really
was built from, and what [basis] must not misreport. *)
let host_ll = Filename.concat dir "host.ll" in
ignore
(merged_executable
~opts:{ Build.default with Build.dev = true; Build.debug }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags ~pnames:[]
session.Session.host ~out:exe ~ll:host_ll);
let agent = Filename.concat dir "agent.sock" in
(* Every one of these is read by the exec'd binary and by nothing else. They
are set before the exec rather than by the compiler thread afterwards, so
that the game thread's [getenv] cannot race the compiler thread's
[putenv]: there is no ordering left to get wrong. *)
Unix.putenv "FLAN_AGENT_SOCKET" agent;
Unix.putenv "FLAN_DEV_SOURCE" file;
Unix.putenv "FLAN_DEV_SOCK" sock;
Unix.putenv "FLAN_DEV_DIR" dir;
Unix.putenv "FLAN_DEV_HOST_LL" host_ll;
Unix.putenv "FLAN_DEV_DEBUG" (if debug then "1" else "0");
(try Unix.unlink sock with Unix.Unix_error _ -> ());
Printf.eprintf "flan dev: built %s in %.0fms\n%!" (Filename.basename file)
((Unix.gettimeofday () -. t0) *. 1000.);
Unix.execv exe [| exe |]
(* [two_process] is still here and still works. It is the escape hatch for a
machine where the compiler object cannot be built — no ocamlfind, no
flan.cmxa beside the binary — and it is what every behaviour in this file
was written against, so it stays until the transport it exists to drive is
actually deleted. *)
let start ?(debug = false) ?(merged = true) ~file ~sock () =
if merged then start_merged ~debug ~file ~sock ()
else two_process ~debug ~file ~sock ()

11
runtime/flan_rt.c
View File

@ -173,8 +173,19 @@ void flan_write_stdout(const uint8_t *p, int64_t n) {
if (n > 0) fwrite(p, 1, (size_t)n, stdout);
}
/* The merged dev build's way out, and null everywhere else.
*
* A Flan [main] does not return: [Emit] ends it with a call to this and an
* [unreachable], because stdout is a FILE* and the acceptance tests read it.
* That is fine when the program is its own process and wrong when the compiler
* is in the same one — [exit] would take the session down with the program.
* The merged entry point installs a hook that flushes, tells the compiler the
* program is done, and parks instead. See lib/dev.ml. */
void (*flan_exit_hook)(int32_t status) = 0;
void flan_exit(int32_t status) {
fflush(stdout);
if (flan_exit_hook) flan_exit_hook(status); /* does not return */
exit((int)status);
}

92
test/test_dev.ml
View File

@ -47,6 +47,14 @@ let request fd sexp =
let status r =
match Wire.string_field r "status" with Some s -> s | None -> "<none>"
let contains_sub hay needle =
let n = String.length needle in
let rec go i =
i + n <= String.length hay
&& (String.equal (String.sub hay i n) needle || go (i + 1))
in
go 0
let () =
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
| 0 ->
@ -72,6 +80,31 @@ let () =
every step waits for the program to have got there. "ok" from an eval
means the module was queued, not that it has been installed. *)
let c = connect sock in
(* One process, which is the whole claim of the merge and the one thing
a reply cannot show. [flan dev] builds a binary that is the compiled
program *and* holds the compiler, and execs it — so the pid this test
launched as [flan] is the program, and there is no child to find. The
path pins it further: the build directory is named for the pid that
made it, so finding it under /proc/<pid>/exe says the process that
built the program is the process now running it.
Linux only, by /proc. Elsewhere it is skipped rather than faked: what
is being checked is the process table, and there is no portable way to
ask. *)
if Sys.file_exists (Printf.sprintf "/proc/%d/exe" pid) then begin
let want =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" pid))
"program"
in
match Unix.readlink (Printf.sprintf "/proc/%d/exe" pid) with
| link when link = want -> ()
| link ->
fail "flan dev is still two processes: %s is running %s, not %s"
(string_of_int pid) link want
| exception Unix.Unix_error _ -> ()
end;
(* The daemon owns the program's lifetime and kills it on [close], so
every step waits for the program to have got there. "ok" from an eval
means the module was queued, not that it has been installed. Output
@ -1689,6 +1722,65 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]
end;
(* ── The escape hatch, which still has to work ─────────────────── *)
(* [--two-process] is the old shape: a compiler process that builds the
program, launches it as a child and talks to it over the agent socket.
It exists for a machine that cannot build the compiler object — no
ocamlfind, no flan.cmxa beside the binary — and it is what every
behaviour above was originally written against, so it is worth one
round trip rather than none. The same three questions, briefly: it
answers, it installs, and the program's output comes back. *)
let tsock = tmp "twoproc.sock" and tout = tmp "twoproc.out" in
(try Sys.remove tsock with Sys_error _ -> ());
let tfd =
Unix.openfile tout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let tpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; tsock; "--two-process" |]
Unix.stdin tfd Unix.stderr
in
Unix.close tfd;
if not (await (fun () -> Sys.file_exists tsock)) then
fail "--two-process never listened"
else begin
let tc = connect tsock in
let seen = Buffer.create 64 in
let ask q =
let r = Wire.parse (Wire.send tc q; Wire.recv tc) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string seen t
| None -> ());
r
in
if status (ask "(:op \"describe\")") <> "ok" then
fail "--two-process: describe was refused";
(* Two processes is the claim here, and it is the opposite one: the pid
launched is the compiler, and the program is a child of it. *)
if Sys.file_exists (Printf.sprintf "/proc/%d/exe" tpid) then begin
match Unix.readlink (Printf.sprintf "/proc/%d/exe" tpid) with
| link when Filename.basename link = "program" ->
fail "--two-process became the program"
| _ | exception Unix.Unix_error _ -> ()
end;
let r =
ask
"(:op \"eval\" :code \"(defn step [] i64 42)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "--two-process: an eval was refused";
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "42"))
then fail "--two-process: the reload was never installed";
ignore (ask "(:op \"close\")");
Unix.close tc
end;
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] tpid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ tsock; tout ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
if !failures = 0 then print_endline "dev: all tests passed"