diff --git a/bin/main.ml b/bin/main.ml index 4c8e3aa..25b9a04 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 [-s socket] [--debug]"; + prerr_endline + "usage: flan dev [-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 diff --git a/lib/dev.ml b/lib/dev.ml index 3f9e49b..54ef201 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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,488 @@ 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 +#include +#include +#include +#include +#include +#include +#include +#include + +/* 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); + 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 () diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index cb82bf6..e38f01d 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -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); }