(** [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; (* 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 *) 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 *) host_exe : string; (* ...and the binary it was linked into *) (* Set when the program's stdout reads EOF, which in the two-process daemon means the child died — and [waitpid] is the authority there anyway. It used to be the merged build's signal as well: a program that finished closed fd 1 on its way to the park, and the EOF was how the compiler found out. That could not survive a program that can be run again, because a pipe delivers EOF once and the second run would have had nowhere to print. The merged build keeps fd 1 open across runs now and is asked instead — see [liveness] and [Program.state]. *) mutable finished : bool; } (* 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. The accept loop is not enough on its own, and that is the other half of the same requirement: it is not running while [serve] is handling a request, and two of the things [serve] does are five-second waits for the game thread to reach a frame boundary. A thread blocked in [fwrite] reaches none. So [drain] is called from those waits as well — see [eval_expr], which carries the argument. *) 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 (* 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 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 (* ── Asking the agent ──────────────────────────────────────────────── *) (* One line out, one line back. The agent is not a protocol and must not become one, and every verb below goes through here. Two ways to ask, and the caller cannot tell them apart. In a merged build the agent is in this process and the answer is a function call — the socket would be a connect, a write and a read looping back into this same address space, which is the transport the merge exists to remove. In [--two-process] there is no agent here, so it is the socket, exactly as before. Which one is not a flag: [Agent.request] is [None] when the linker resolved a weak symbol to null, so it is [None] in precisely the binaries that have no agent to call. A flag could disagree with reality; this cannot. *) let over_socket t line = 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 = line ^ "\n" in ignore (Unix.write_substring s msg 0 (String.length msg)); 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 (); Buffer.contents buf) let request t line = match Agent.request line with | Some answer -> answer | None -> over_socket t line (* ── 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 hand-off makes possible. "Queued", still, and not "installed", in one process as in two: the store happens on the game thread at a frame boundary, and a direct call that installed on the spot would be a frame running half in the old code and half in the new. *) let deliver t path = String.trim (request t path) (* The same, for a module that may only run from a break. The word goes in front of the path rather than into the module, which is what keeps this change out of both emitters and out of the [.so]'s ABI. The agent's own note says why it belongs on the request: what is stopped-only is the *question*, not the code. *) let deliver_stopped_only t path = deliver t ("stopped-only " ^ path) (* How many stopped-only modules the program has thrown away for reaching the game thread while it was running, and the sentence the agent says about it. Both come from the agent because the sentence lives there, once. Reading it here and keeping a second copy of the words would be the same refusal in two places, drifting apart the first time either is reworded — and this one is the sentence somebody reads in the minibuffer when their inspection comes back empty, so the wording is the whole of its value. [None] where the program cannot be reached or answers something else: a count that could not be read is not a count that did not move, and the caller treats it as "no evidence" rather than as zero. *) let refusals t : (int * string) option = match request t "refusals" with | exception Unix.Unix_error _ -> None | text -> (match String.index_opt text '\n' with | None -> None | Some i -> (match int_of_string_opt (String.trim (String.sub text 0 i)) with | None -> None | Some n -> Some (n, String.trim (String.sub text (i + 1) (String.length text - i - 1))))) (* 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 compiler gets to know about, so this waits for the counter to move rather than assuming it has. *) let result t = let text = request t "result" 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 is where that shows, and the session is the only thing holding it — so an editor asks here or not at all. *) (* One sentence the agent cannot write, rewritten in the one place every verb passes through. [vendor/agent/flan_agent.c] answers a backtrace, a locals or a globals request from a program with no shadow-stack frames with "this program was not built with --dev". That was true of exactly one thing when it was written -- a release build, which has no frames because it has no dev machinery at all -- and it stopped being true when [lib/x86.ml] became the default for [flan dev]. An x86 dev host has its cells, its globals and its registry; what it has not got is the frame push, so it stops on an error and then cannot say where. The agent has no way to tell the two apart: it sees an empty chain either way, and it is inside the program, which knows nothing about the backend that compiled it. The session does know, so it is the one that corrects the sentence. Rewriting the reply rather than teaching the agent a new environment variable keeps the claim where the fact is -- and a message that names [--llvm] is the whole of what the reader needs, where "not built with --dev" sends them to look for a flag they did not leave off. *) let mentions hay needle = let n = String.length hay and m = String.length needle in let rec go i = i + m <= n && (String.sub hay i m = needle || go (i + 1)) in m = 0 || go 0 let ask t verb = let text = request t verb in if t.session.Session.x86 && mentions text "was not built with --dev" then "err the x86 dev backend pushes no shadow-stack frames, so a stopped \ program built by it cannot say where it is -- no backtrace, no locals and \ no globals. It is the default for flan dev because it is about twice as \ fast; restart the daemon with flan dev --llvm to inspect frames.\n" else text type state = | Running | Stopped of string (* the condition's class name *) | Unreachable of string (* no answer: exited, or never listened *) (* [status] is answered whether or not the program is stopped — "running" is an answer, not a refusal. Everything else the break loop offers is refused while running, and rightly: there is no restart stack to walk. But the question an editor asks *without already knowing* is this one, so it had to have an answer in both states or there would be nothing to poll. *) let state t = match ask t "status" with | "" -> Unreachable "the program is not answering on its socket" | text -> let line = String.trim (List.hd (String.split_on_char '\n' text)) in if line = "running" then Running else if String.length line > 8 && String.sub line 0 8 = "stopped " then Stopped (String.sub line 8 (String.length line - 8)) else Unreachable ("the program answered " ^ line) | exception Unix.Unix_error (e, _, _) -> Unreachable (Unix.error_message e) (* Innermost first, terminated by a line that is a single dot — the agent's framing, not this one's. A refusal comes back as a line starting "err ", and is passed on rather than turned into an empty list: no restarts and cannot say are different answers. Each line is [I ± NAME]: the index it is taken by, whether it can be taken, and the name. The index is the identity — two frames may offer [retry] and a name cannot say which — and it is the program's number, not this end's position in a list, so it is carried rather than recomputed. *) let restarts t = match ask t "restarts" with | text -> let lines = String.split_on_char '\n' text in if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines then Error (String.trim text) else begin let parse line = match String.index_opt line ' ' with | None -> None | Some i -> (match int_of_string_opt (String.sub line 0 i) with | None -> None | Some idx -> let rest = String.sub line (i + 1) (String.length line - i - 1) in if String.length rest < 2 then None else Some ( idx, rest.[0] = '+', String.sub rest 2 (String.length rest - 2) )) in Ok (List.filter_map parse (List.filter (fun l -> l <> "" && l <> ".") (List.map String.trim lines))) end | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e) (* Where a stopped program is, one frame per line, innermost first — the same framing [restarts] uses, terminated by a lone dot, because it comes back over the same one-line-out socket. Each line is [I ± NSLOTS SIG RSIG LOC NAME]. [SIG] is the slot fingerprint of the body this frame was compiled from — [Emit.slot_fingerprint] over the name and the type of every slot — and it is how [locals] tells a frame whose body has been redefined underneath it from one that still matches. [RSIG] is [Reach.ref_fingerprint] over the globals that body names, which is the same question asked about a different part of the body: the slots can be identical while the globals are not, and then it is the globals section that must not trust the frame while [locals] still can. Both stay off the wire: a hash is not something a client can act on, and the refusals they produce say the fact in words instead. They sit before [LOC] because [NAME] is the only field that can contain a space and so has to be last. The flag says whether the frame belongs to the program or to the C-x C-e thunk the break happens to be inside: a break inside an evaluation has that evaluation's frames on top, and answering "where is my program" with [eval/7] would be true and useless. [LOC] is the frame's own — it travels in the module that defined the body, so a redefined function reports where the *installed* body is written and not where the one this daemon first built was. A frame with none says [?]. A truncated backtrace ends [... N] before the dot; deep recursion is the case, and the innermost frames are the ones the question is about. *) let backtrace t = match ask t "backtrace" with | text -> let lines = List.map String.trim (String.split_on_char '\n' text) in if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines then Error (String.trim text) else begin let more = ref 0 in let parse line = if String.length line > 4 && String.sub line 0 4 = "... " then begin (match int_of_string_opt (String.sub line 4 (String.length line - 4)) with | Some n -> more := n | None -> ()); None end else match String.split_on_char ' ' line with | idx :: flag :: nslots :: sig_ :: rsig :: loc :: rest when rest <> [] -> (match int_of_string_opt idx, int_of_string_opt nslots, int_of_string_opt sig_, int_of_string_opt rsig with | Some _, Some k, Some g, Some r -> Some (String.concat " " rest, (if loc = "?" then "" else loc), flag = "+", k, g, r) | _ -> None) | _ -> None in let frames = List.filter_map parse (List.filter (fun l -> l <> "" && l <> ".") lines) in Ok (frames, !more) end | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e) (* Which of a frame's slots have been reached. One line per slot, [I ±], the same framing as everything else the agent answers. Asked before a thunk is built rather than after: an unbound slot is a null address, and a thunk that rendered one would take a fault on the game thread of a program that is already stopped — which is the one place a crash costs the most, because it is where someone is standing over the wreck deciding what to do about it. *) let bound_slots t ~frame = match ask t (Printf.sprintf "locals %d" frame) with | text -> let lines = List.map String.trim (String.split_on_char '\n' text) in if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines then Error (String.trim text) else Ok (List.filter_map (fun l -> match String.split_on_char ' ' l with | [ i; "+" ] -> int_of_string_opt i | _ -> None) (List.filter (fun l -> l <> "" && l <> ".") lines)) | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e) (* ── Whether there is still a program, and whether it is running ────── *) (* Three states and not two, because the merged build grew a third. A program that finishes no longer takes the process with it: its main thread parks, holding every global the run left, and [rerun] sends it round [main] again. So "the program exited; restart flan dev" — which every op in this file used to say when [alive] was false — is now wrong about the commonest case there is, somebody closing a window. [Parked] is not a shade of [Gone] and not a shade of [Live]. The session is whole, the globals are readable storage, and the next thing the person wants is usually to run it again. Answering either of the old two states would send them to the wrong place — [Gone] to a restart they do not need, [Live] to a five-second wait and "is it calling (agent/poll)?", which is a true sentence about the wrong cause. What it is *not* is a state in which nothing can be asked of the program. That is how it started, and the refusals were written on the assumption that the only place a thunk could run was the game thread's frame-boundary poll. The park services the agent's ring now — see [eval_expr] and [flan_merged_park] — so an expression runs on the parked thread itself, which is safe for the reason the frame boundary is: while parked there is no concurrency to be unsafe against. Every op that still refuses [Parked] refuses it for a reason of its own, and each says which. *) type liveness = | Live (* running: the program is between frames *) | Parked (* finished, and can be run again *) | Gone (* the process is not there any more *) (* Split out so that it can be tested. The merged arm turns on a C symbol that only a merged binary has — [Program.state] is [Absent] in the test binary and in the compiler itself — so the three-way decision has to be reachable from somewhere other than a running merged build, or the only thing checking it is the end-to-end case that takes a compile. [finished] is the pipe's EOF, which the merged build no longer produces: its program keeps fd 1 open across runs now, because a pipe delivers EOF once and spending it would cost the second run its output. It is still read here for the [Absent] case — a merged-shaped session with no program thread is what every unit test is — and it is still the two-process daemon's own answer, arrived at by [waitpid] above it. *) let liveness_of ~child_alive ~finished ~program = match child_alive with | Some true -> Live | Some false -> Gone | None -> (match program with | Program.Running -> Live | Program.Parked -> Parked | Program.Absent -> if finished then Gone else Live) let liveness t = let child_alive = match t.child with | None -> None | Some child -> Some (match Unix.waitpid [ Unix.WNOHANG ] child with | 0, _ -> true | _ -> false | exception Unix.Unix_error _ -> false) in liveness_of ~child_alive ~finished:t.finished ~program:(Program.state ()) (* ── 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. [:parked] rides along for exactly the same reason and was added when the program stopped being something the process could only do once. Finishing is as unannounced as stopping — more so, since the commonest way to finish is somebody closing a window with the mouse — and an editor that had to ask would show "live" until it next happened to wonder. The two are not alternatives and are not folded together: a stopped program is inside a frame with restarts on offer, a parked one has no frames at all, and the only thing they have in common is that neither is running. It is the annotation, not the ops, that decides these fields, so that there is one place in the daemon that says what the program is doing and the 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 let fields = fields ^ (if liveness t = Parked then " :parked t" else " :parked 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) ^ ")" (* One module, built by whichever backend wrote it. The choice travels on the change rather than being asked again here, so the text and the builder can never come from two different answers — and an [--x86] host therefore gets [--x86] modules by construction, which is the licence [lib/x86.ml] rests on. [flan.abi.x86] is the backstop if this is ever got wrong: a crossed pair fails the [dlopen] naming both backends. The extension follows for the same reason. What [Build.shared_x86] is handed is assembly, and the copy kept beside the [.so] is what [disassemble] reads back ten reloads later. *) let module_ext (c : Session.change) = if c.Session.x86 then ".s" else ".ll" let build_module (c : Session.change) ~debug ~out = if c.Session.x86 then Build.shared_x86 ~opts:{ Build.default with Build.dev = true; Build.x86 = true; Build.debug = debug } ~asm:c.Session.ir ~out () else Build.shared ~opts:{ Build.default with Build.dev = true; Build.debug = debug } ~ir:c.Session.ir ~out () (* The two refusals that are about the *state* rather than about the request, spelled once so that every op tells the same story. [gone] is what all of them used to say and is now said only where it is true: there is no process left and nothing short of a new one will help. [parked] is the new half, and the sentence it appends is the whole point of the distinction. Somebody reading it has a program that is *there* — its globals are intact, its session is whole, this daemon is answering — and what they need is not a diagnosis but the name of the verb that starts it. Each site says in its own words why it in particular cannot be answered from a parked program, because "parked" is the state and not the reason: an op refused for want of a frame boundary and an op refused for want of a stopped stack are refused by the same state for different causes, and a reader who cannot tell them apart cannot tell what to do instead. *) let gone = "the program exited; restart flan dev" let parked_msg why = why ^ "; the program has finished and its process is parked, holding everything \ the run left in the globals — M-x flan-rerun starts it again, and this \ answers once it is running" let parked why = error (parked_msg why) (* Parked and stopped at the same time, which is a pair of states that could not both hold until the park learned to run a thunk. An expression evaluated against a parked program runs on the parked thread, and a thunk can error or reach a [(pause)] exactly as one run at a frame boundary can — so the thread is then in the break loop, holding a condition with restarts on offer, with [liveness] still answering [Parked] because no run has started. Every op below that refused [Parked] outright would refuse the break as well, and the restart ops among them are the way out of it: a thunk nobody can resume is a parked program nobody can evaluate against twice. So those ops ask this instead of the state alone. [state t] is the discriminator and is a reliable one. The agent's listener answers "running" for a parked program with no break engaged — it knows nothing about runs, only about whether its own break loop is entered — so [Stopped] here means a break and can mean nothing else. *) let parked_break t = match state t with Stopped _ -> true | _ -> false 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 (* A module the agent would not take, said in the daemon's words rather than only in the agent's. The agent refuses a full reload ring with "the program is not calling agent/poll", which is the right cause for a program that is running and the wrong one for a program that has finished. A parked process is not failing to poll: it has no game thread left to poll with, it is waiting in the park for somebody to give it something to do — so the sixty-fifth module queued since it parked is refused for the very behaviour [eval] below promises it, that a body redefined while parked installs by the time the program runs again. A reader told to check their [agent/poll] calls would go looking at a loop that is not running. The park does drain the ring now, and that does not soften this: it drains when it is asked to, by an evaluation or by a re-run, and a run of redefinitions with neither in it fills the ring exactly as before. What changed is only that there is a second way out, and the sentence names the one anybody in this position wants. The agent cannot say this itself. Parking is the merged shim's state and the agent is vendored beside it knowing nothing about runs; what knows is this daemon, which has just asked [liveness] and is about to quote a reply. So the substitution is made here, on a substring of a reply this side did not write — the same move [abi_mismatch] makes on [dlerror]'s text, and made for the same reason: the component that has the words does not have the context. *) let refusal ~parked reply = if parked && contains reply "reload queue full" then "the program refused the module: its reload ring is full, and a parked \ program drains it only when it is asked to — every module queued since it \ finished is still waiting, and M-x flan-rerun is what runs them all; this \ one was not taken, so send it again after that run" else "the program refused the module: " ^ reply (* [pause], when given, is the position of the form to stop at — §9. It rides beside the code rather than in it, and the reply echoes it back so an editor marks the buffer only for a mark the session actually applied. Accepted by a parked program, and it was for a while the only op that was — the reason being the shape of the verb rather than a favour done to it: this checks, builds and hands the module to the agent, which queues it. It does not wait for anything. The game thread picks a delivery up at its next frame boundary, and a parked program's next frame boundary is the first call of its next run — so a body redefined while parked is installed by the re-run and is what that run executes. Refusing here would mean closing a window, being told to run the program again, and only then being allowed to fix the thing you closed it over, which is the loop this whole feature exists to remove. What does change is the note: "at its next frame boundary" is not a promise anyone can read while the program is parked. *) let eval t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in (* What the session was before the form was checked, and every failure below puts it back. [Session.eval] commits as soon as the check succeeds, which is two fallible steps too early: the build can fail and the agent can refuse, and a session left holding a declaration no module was accepted for hands the *next* module a name to intern a cell for and nothing to put in it — a null cell the first call through jumps to. See [Session.held]. Only the failures restore. The [installs = false] arm is a real acceptance: there is nothing to build and nothing to deliver, so there is nothing that can go wrong after it. *) let before = Session.held t.session in let refused msg = Session.restore t.session before; error msg in if now = Gone then error gone else match Session.eval ~origin ?pause 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 -> (* Everything from here to the delivery is inside the restore, and by exception type as well as by arm. The three named below are the ones with a sentence to say; what is left is every other way a file system can refuse — [write_file] cannot create its copy of the module's text, the working directory went away underneath the daemon — which used to leave through [serve]'s guard with the session already holding the declaration. That is the same stranding under a different exception, and [serve] still writes the reply: this only puts the session back on the way past. [accepted] is what the catch-all needs to know and the arms cannot tell it. Once the agent has said "ok" the module is the program's, whatever goes wrong while this reply is being written, and rolling the session back then would strand the declaration the other way round — the process holding a body the session has forgotten. *) let accepted = ref false in (try 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%s" t.n (module_ext c)) in write_file ll c.Session.ir; (match build_module c ~debug:t.session.Session.debug ~out with | timing -> (match deliver t out with | "ok" -> accepted := true; 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) ] @ (match pause with | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] | None -> []) @ (if parked_now then [ ":note " ^ Wire.quote "queued; the program is parked, so this installs no \ later than its next run rather than at its next \ frame boundary — an expression evaluated in the \ meantime takes it first, because the poll that runs \ a thunk installs whatever is queued ahead of it" ] else [])) | reply -> refused (refusal ~parked:parked_now reply) | exception Unix.Unix_error (e, _, _) -> refused ("cannot reach the program on " ^ t.agent ^ ": " ^ Unix.error_message e)) | exception Failure m -> refused m) with e when not !accepted -> Session.restore t.session before; raise e) (* Nothing to put back: the check itself raised, so [Session.eval] never reached its assignments. The restore is written anyway rather than reasoned about at each arm — a refusal that costs one record copy is cheaper than a reader working out which of the four fields this one could have moved. *) | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> Session.restore t.session before; 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. ── AND A PARKED PROGRAM RUNS ONE TOO ───────────────────────────────── It did not, and the refusal it gave was the complaint this arm answers: somebody typed [(+ 1 1)] at the top of a buffer and was told that an expression is evaluated at a frame boundary and a parked program reaches none. Every word of that was true and none of it was the point. [(+ 1 1)] needs nothing from the program at all, and the expression that does — one reading a global the finished run left — needs storage the parked process is still holding. What was actually missing was somewhere for the thunk to run, and the answer was to make a second such place rather than to relax what a place has to be. THE PARK IS ONE, and the reason is that a parked process has no concurrency in it: the program's thread is asleep on a condition variable, no frame is executing, and nothing is mutating a global. Those are precisely the conditions a frame boundary provides, which is what the boundary discipline was ever for — so the park loop services the ring the way it already services a re-run, on the program's own thread, and the break loop is the precedent it follows. [Program.wake] is the nudge; [flan_merged_park] is where it lands. The state does not move. A thunk is not a run: the program is [Parked] before, during and after, [:parked t] rides on this very reply, [rerun] still works, and the globals are as the finished run left them plus whatever the expression did to them on purpose. Common Lisp's answer to the same question was not copied and would not have fitted. SWANK spawns a worker thread per evaluation and SBCL has no parked state to spawn it beside; the price is that eval races the application and the race is documented as the programmer's problem. There is no race to document here, because there is nothing running to race. *) let eval_expr t ~code ~origin ~pause = match liveness t with | Gone -> error gone | Live | Parked -> (* The same rollback [eval] takes, for the same reason and a smaller cargo. A thunk is not a declaration and never joins the session, but the generic instances the expression forced *are* kept — [Session.eval_expr] says why — and they are kept before this module has been built or taken. An instance the session holds and no module ever defined is a null cell exactly as a stranded [defn] is, and the next expression that mentions the same instantiation would list it as already there. *) let held = Session.held t.session in let refused msg = Session.restore t.session held; error msg in match Session.eval_expr ~origin ~pause 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_module c ~debug:t.session.Session.debug ~out with | _ -> (match deliver t out with | "ok" -> (* Strictly after the delivery, and that ordering is the whole of it: the sleeper is woken to look at a ring, so waking it before the module is in one buys an empty poll and a five-second wait. Nothing here checks whether there was a parked thread to wake — a running program polls its own ring at the next frame boundary, and a process whose program is elsewhere has no ring of ours to drain, so both refusals mean somebody else has it in hand. *) Program.wake (); (* Three-way, and the middle case exists only because of [:pause]. A thunk that stopped in the break loop produces no value and never will until someone resumes it — which is exactly what a program that never reached a frame boundary looks like from here. Reporting the timeout for it would call the working feature a failure. The [Stopped] question is asked only when a pause was requested. Without one, a thunk that stops did so by erroring, and the timeout message is the answer that path has always given — which [test_dev.ml] pins. And it asks for [Pause] by name, not for "stopped at all". The break loop allows evaluating, so this is reachable from a program already parked on something else — and [Stopped _] would then answer for a thunk that has not run yet, on a reply whose own [:condition] says the other condition's name. Asked by name it waits through the outer break until the thunk reaches its own [(pause)], which the agent reports because a nested break overwrites [condition_name] and restores it on the way out. A program already parked on a [Pause] is the one case this cannot tell apart, and nothing could: both answers are "stopped at a pause". *) let stopped () = pause && (match state t with Stopped "Pause" -> true | _ -> false) in let rec wait ms = (* The pipe is drained on every tick, and that is what makes this a wait rather than a deadlock. In the merged build fd 1 is a 64K pipe back into this process, and its only other reader is the select in [accept_loop] — which is not running, because it is further up this very call stack, inside [serve]. A program that prints as it goes (and a game loop prints as it goes; sand.flan does) fills those 64K while the module below was being built, and the game thread is then stopped inside [flan_write_stdout], in an [fwrite] that will not return until somebody reads. It never reaches the frame boundary the thunk needs. Five seconds later this answered "is it calling (agent/poll)?" — a true sentence about a program that is calling it and cannot get there, which is the worst kind of diagnostic there is. [drain] and not [take]: the text belongs in [t.out] until [with_output] puts it on this reply on the way out of [serve]. Taking it here would empty the buffer into nothing and lose exactly the output the evaluation itself caused. And the drain goes *beside* the sleep rather than into it. Putting [t.stdout] in the select's read set is the obvious shape and is wrong: a readable pipe returns from select immediately, so a tick stops costing 5ms and [ms - 5] counts the whole five seconds out in a fraction of one — the same wrong sentence, arrived at faster. The timeout is a clock, so the sleep has to stay a sleep. *) drain t; match result t with | Some (g, v) when Int64.compare g before > 0 -> `Value v | _ when stopped () -> `Stopped | _ when ms <= 0 -> `Timeout | _ -> ignore (Unix.select [] [] [] 0.005); (* Not [Gone], where it used to be exactly [Live]. The old test was right while the park ran nothing: a program that parked mid-wait would never produce a value, so spinning out the rest of the five seconds said nothing more than stopping now did. A park that drains the ring makes it false in both directions — a thunk delivered to a parked program is waiting on this very wait, and a run that finishes while a thunk is in flight parks and then polls it. What is left as a reason to stop early is the process being gone, which is the one state no amount of waiting recovers from. *) if liveness t <> Gone then wait (ms - 5) else `Timeout in (match wait 5000 with | `Value v -> ok [ ":value " ^ Wire.quote v ] (* No [:value], because there is not one yet and there will not be one until the break is resumed. [:stopped t :condition "Pause"] rides on this reply as it does on every other — [with_break] puts it there — so the editor already has what it needs, and the note says which of the two silences this is. *) | `Stopped -> ok [ ":note " ^ Wire.quote "stopped at (pause)" ] (* Two sentences, because there are two causes and the running one is nonsense about a parked program — it is the sentence this verb's old refusal quoted, which is exactly the thing not to relocate here. A parked thread is woken for the ring and nothing else can be holding it up, so what has gone wrong is the thunk itself: it stopped on something and is sitting in the break loop waiting to be told what to do. That is a state the editor can act on, and [:stopped] on this reply names it. *) | `Timeout -> if liveness t = Parked then error "the expression produced no value in five seconds. The \ program is parked, so nothing is competing with it: the \ thunk is most likely stopped on a condition inside the \ break loop, which restart or abort answers" else error "the program did not reach a frame boundary; is it calling \ (agent/poll)?") (* A module that was taken is the program's from here on, whatever the wait then says: a timeout is a frame boundary not reached yet, not a module refused, so the instances in it stay in the session. Only the two arms below, where nothing was accepted, put the session back. *) | reply -> refused (refusal ~parked:(liveness t = Parked) reply) | exception Unix.Unix_error (e, _, _) -> refused ("cannot reach the program: " ^ Unix.error_message e)) | exception Failure m -> refused m) | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg (* What a macro call expands to — [C-c C-m], and the one verb here that never touches the program. Deliberately not gated on [liveness t]. Every other verb in this file is a question about a running process and says so when there is not one; expansion is a question about the *compiler*, answered out of the macros the session holds, and it is still answerable after the program has exited. That is worth having rather than tidying away: the moment you most want to know what a macro produced is often just after the code it produced crashed. No [Loc.Error] arm either, and that is not an omission. The guard round [handle] in [serve] catches everything non-fatal and answers it with [reply_of_exn] — which is where the two non-termination refusals land, with the call site's location on them, rather than in a hang that would leave the editor waiting on a daemon with the program still on screen. *) let macroexpand t ~code ~origin ~all = let x = Session.macroexpand ~origin ~all t.session code in ok ([ (* Line breaks in, columns left to the editor: see [Form.pretty]. *) ":text " ^ Wire.quote (Form.pretty x.Session.xafter); (* And the same thing on one line, for a client with no indenter and for the echo area. *) ":flat " ^ Wire.quote (Form.to_source x.Session.xafter); ":source " ^ Wire.quote (Form.to_source x.Session.xbefore); (if all then ":all t" else ":all nil"); (if x.Session.xchanged then ":expanded t" else ":expanded nil") ] @ (match x.Session.xmacro with | Some n -> [ ":macro " ^ Wire.quote n ] | None -> []) @ (* The two ways of coming back unchanged are different facts and the editor should not have to guess which it has. Only the one where a macro *did* run is a statement about that macro. *) match (x.Session.xchanged, x.Session.xmacro) with | true, _ -> [] | false, None -> [ ":note " ^ Wire.quote "the head of this form is not a macro this session holds — the \ prelude's, an import's, and every defmacro evaluated since it \ started are what it can expand" ] | false, Some n -> [ ":note " ^ Wire.quote (n ^ " expanded to the call it was given, unchanged") ]) 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); (* Two keys for three states, and [:alive] keeps the meaning it has always had: is there still a session on the other end of this socket. A parked program is therefore [:alive t], because everything about the process is intact — it is [:parked], which [with_break] puts on this reply as it puts it on every other, that says the program is not running. Folding both into one key would either tell a client the session had gone when it had not, or leave the new state unsayable. *) ":alive " ^ (if liveness t = Gone then "nil" else "t") ] (* [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 doc). Five 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. [doc] carries a line of prose, and today only a builtin has one. A [defn] does not, and that is not an oversight this op can fix: the Tast keeps no docstring, so the field would be empty for every program name until the parser and the Tast both learn to hold one. It is a fifth string rather than a sixth op because it is the same question — what is this name — asked at the same two moments. 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 ?(doc = "") () = Wire.list [ Wire.quote name; Wire.quote kind; Wire.quote sign; Wire.quote loc; Wire.quote doc ] 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 (* Last, so a program's own names sort ahead of them in every list an editor builds out of this — a completion table above all, where 78 compiler names interleaved with a handful of a program's own would bury the ones being worked on. The kind is what separates them, and it is on every entry already, so an editor that wants only the program's names filters rather than asking a second op. [loc] is empty here as it is for a global, but for a different reason, and the editor has to say the difference: a global was written somewhere and the Tast dropped the location, while a builtin was never written down at all. So the honest sentence names the compiler, and the kind is what an editor keys it on. *) let builtins = List.map (fun (name, sign, doc) -> entry ~name ~kind:"builtin" ~sign ~loc:"" ~doc ()) Check.builtins in ok [ ":defs " ^ Wire.list (fns @ globals @ externs @ builtins) ] (* [(:op "layout" :type T)] — a struct's fields and their types. The daemon can answer this with no running program at all: [Tast.structs] is what it built the process from, and a layout is a fact about the build. That is why it is the one thing the conditions buffer can fill in while the condition's *values* stay refused. **The type is a name, and the name is the qualified one.** [Load] qualifies every declaration as it imports it — [Defstruct (qualify alias n, ...)] — so the names in [Tast.structs] are a flat namespace in which two packages each declaring [Missing] are [a/Missing] and [b/Missing] and no collision is possible. That makes the name a type identity rather than a class name, with no id table to keep in step, and it is the same string on both ends of the wire already: [Emit.struct_name_of] puts [Types.Named n] into [flan_error], the agent holds it in [condition_name], and [break] answers it as [:condition]. Handing that string straight back as [:type] therefore resolves, by construction. A bare name is **refused, not resolved**, even when only one struct's last segment matches: resolving it is exactly the ambiguity that made this op need a rule, and a rule with an exception cannot be relied on by a client. The refusal lists the qualified names it could have meant, so a person who typed [Missing] is one copy-paste from the answer and a client can offer them as completions. Field types are spelled by [Types.to_string], which is what [defs] spells a signature with — so [(Option T)], [[T]], [[n T]] and [(Ptr T)] read here exactly as they read in a signature and in the source. A field that is itself a struct shows its qualified name, which is a [:type] this op accepts: nesting is another request rather than a second walk, and nothing here can recurse forever. [Render] is the other walk over a type and is not reused, because it walks a *value* and emits code that prints it; this emits text about the type and never touches the program. *) let layout t ~ty = let structs = t.session.Session.program.Tast.structs in match List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty) structs with | Some s -> ok [ ":type " ^ Wire.quote s.Tast.sname; ":fields " ^ Wire.list (List.map (fun (f : Tast.field) -> Wire.list [ Wire.quote f.Tast.fname; Wire.quote (Types.to_string f.Tast.fty) ]) s.Tast.fields) ] | None -> (* Two types the checker knows and this op cannot describe. An enum's members are erased to i32 before [Tast.program] exists, which is the same fact that makes a defenum unreloadable; a data type is declared and has no values yet. Either way, saying which kind it is beats "no such type" for a name that plainly exists. *) if Hashtbl.mem t.session.Session.env.Check.enums ty then error (ty ^ " is an enum, not a struct; its members are erased to i32") else if List.exists (fun (u : Tast.data) -> String.equal u.Tast.dname ty) t.session.Session.program.Tast.datas then (* Data types have landed, so "milestone 6" was stale — but what replaces it is not a layout. This op's reply is a flat [:fields] list, and a data type is a tag and one payload per case: there is no one field list to answer with, and flattening the cases into one would describe storage no value ever has. So it says which kind of type this is, and where the question it was probably asked for *is* answered — the renderer walks a data type now, so a data type value prints in a frame's locals and at `C-x C-e' with its case and that case's fields. *) error (ty ^ " is a data type, not a struct; a data type is a tag and one payload per case, so it has no single field list for this op to answer with. Its value renders with its case and fields in a frame's locals and at C-x C-e") 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 = match liveness t with | Gone -> error gone (* Before [state t] and not after it, which is the ordering every guard below shares. The agent's listener thread is alive while the program is parked and no break is engaged, so [status] answers "running" — and "the program is running" is exactly the wrong thing to tell somebody whose program has finished. *) | Parked when not (parked_break t) -> parked "a parked program has not stopped on anything, so there are no restarts \ to offer" (* And when it has, which is a thunk evaluated against the park that erred or paused. The restarts are that thunk's and the ones its call reached; the answer is the same shape and the same walk, because it is the same break loop on the same thread. *) | Live | Parked -> match state t with | Running -> ok [] | Unreachable m -> error ("cannot ask the program whether it stopped: " ^ m) | Stopped _ -> (match restarts t with | Ok rs -> (* [:restarts] stays a list of names, positional and innermost first, with duplicates kept — the position *is* the index, which is what [restart-at] takes. [:unreachable] names the positions that are on the list and cannot be chosen: a restart below the evaluation the break is inside has nowhere for a transfer to land. They are shown rather than filtered, because a client that quietly dropped them would leave someone asking where their restart went. *) ok [ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs); ":unreachable " ^ Wire.ints (List.filter_map (fun (i, ok, _) -> if ok then None else Some i) rs) ] | Error m -> error ("the program refused to list its restarts: " ^ m)) (* [(:op "backtrace")] — the frames of a stopped program, innermost first. NEXT.md's "Asked for by the editor lanes" had this blocked on exactly the frame metadata the shadow stack now carries. Refused while the program is running, and that is not a gap in the feature: the chain is the game thread's, it is pushed and popped on every call, and a walk of it from this end while that thread runs would produce a plausibly shaped answer that was never true. Stopped, the thread is parked in the break loop and the program itself takes the snapshot. Each frame is [(name loc origin nslots)] — four fields in the shape [defs] already uses, so an editor reads it with [read] and nothing else. [origin] is "program" or "eval": a break inside a C-x C-e thunk has the thunk's frames above the program's, and they are shown and labelled rather than hidden, the same decision [:unreachable] makes for the restarts under one. [nslots] is how many slots the frame has, which is what a client asks about before asking for any of them. *) let backtrace_op t = match liveness t with | Gone -> error gone (* Not the running refusal below and not an empty list either. The chain is genuinely empty — the park clears it, because the frames a finished run pushed are allocas in stack the next run will write over — but answering with no frames would read as "your program is nowhere", when what is true is that it is between runs. *) | Parked when not (parked_break t) -> parked "a backtrace is the frames of a stopped program, and a parked one has \ no frames at all" (* Unless a thunk it is running stopped, and then the chain is that thunk's: the park cleared what the finished run pushed, so every frame here is an eval frame and the listing says so in the third field. That is a shorter backtrace than a break in a running program gives and it is the whole truth about where this one is. *) | Live | Parked -> match state t with | Running -> error "the program is running; a backtrace is only taken while it is stopped, \ because the frame chain is the game thread's and it is changing" | Unreachable m -> error ("cannot ask the program where it is: " ^ m) | Stopped _ -> (match backtrace t with | Ok (frames, more) -> ok [ ":frames " ^ Wire.list (List.map (fun (name, loc, mine, nslots, _sig, _rsig) -> Wire.list [ Wire.quote name; Wire.quote loc; Wire.quote (if mine then "program" else "eval"); string_of_int nslots ]) frames); Printf.sprintf ":more %d" more ] | Error m -> error ("the program refused to say where it is: " ^ m)) (* Build a render thunk, hand it to the program, and read back what it wrote. The same five steps for every verb that renders something inside the stopped program — [locals], [globals] and [inspect] — and they are here once rather than three times because the note this file already carries about the fingerprint applies to plumbing too: four of five hand-offs present looks exactly like one hand-off dropping a step, and that is a bug nobody sees until the one path that lost it is the one being used. [tag] only names the [.so] on disk, which is what someone reads when they go looking at [t.dir] to find out which verb produced what. ── [stopped_only], and why only one of the three wants it ──────────── Everything between the gate and the thunk takes time the gate does not cover. The verb checks that the program is stopped, the agent checks it again, and then a module is *built* — a third of a second of llc and a linker — and delivered, and waited on for up to five seconds. A [restart] arriving anywhere in there resumes the game thread, and the thunk runs at the next frame boundary instead of from the break. The wait below does not even notice: it keeps waiting while liveness is [Live], and a resumed program is the liveliest thing there is. What that costs depends entirely on what the thunk holds. [inspect] by *address* holds a number. [Dev.render_addr] bakes the address into the module as an integer literal, because the registry's blessing — "something live is there, and it is a [Foo]" — was given at build time by a table that the running program is exactly the thing that changes. Run that thunk after a resume and it dereferences an address whose blessing expired, possibly into storage the program has since freed. So it is delivered stopped-only, and the agent drops it rather than running it. [locals], [inspect] by *slot* and [globals] hold no address at all, and that is the line. A local is reached through [flan/dev-slot], which is [flan_agent_frame_slot], which asks [snap_top] for the frame *when the thunk runs* — and [snap_top] is empty once the break that pushed it has been resumed past. A global is reached by name: [Emit.redefinition] leaves it [external], the dynamic linker binds it to the program's own storage, and that storage has existed since the process started. Neither carries a permission that can go stale between the asking and the running, because neither was given one. Tagging them stopped-only would refuse work that is sound, which is the other way to lose an answer. *) let run_render_thunk ?(stopped_only = false) t ~tag ~(c : Session.change) : (string, string) result = let before = match result t with Some (g, _) -> g | None -> 0L in (* Read *before* the build, not before the wait: the resume this is watching for can land while llc is still running, and the job it kills is this one. [None] when the program cannot say, in which case nothing below compares against it — a missing count is no evidence either way. *) let refused_before = if stopped_only then refusals t else None in let resumed () = match (refused_before, if stopped_only then refusals t else None) with | Some (before, _), Some (now, why) when now > before -> Some why | _ -> None in t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "%s%d.so" tag t.n) in match build_module c ~debug:t.session.Session.debug ~out with | exception Failure m -> Error m | _ -> (match (if stopped_only then deliver_stopped_only t out else deliver t out) with | exception Unix.Unix_error (e, _, _) -> Error ("cannot reach the program: " ^ Unix.error_message e) | "ok" -> let rec wait ms = (* Drained every tick for the reason [eval_expr]'s own wait spells out: this loop is inside [serve], so the accept loop's select is not reading the program's pipe, and a program that has filled it is a program stopped in [fwrite] rather than one that is ignoring [agent/poll]. A render thunk is asked for while the program is *stopped* at a break, which is the state in which the last thing printed matters most — so losing it to [take] would be worse here than anywhere. *) drain t; match result t with | Some (g, v) when Int64.compare g before > 0 -> Ok v (* Asked every tick and not once at the end, because the five seconds are the point: a dropped job produces no value, so without this the answer would be the timeout's sentence — "is it calling (agent/poll)?" — which names the wrong cause and sends the reader to look at a loop that was polling perfectly well. *) | _ -> match resumed () with | Some why -> Error why | None -> (* Two sentences for the same silence, because there are two causes and each names a different thing to go and look at. The frame-boundary one is about a game loop that is not polling; said about a parked program it would be the sentence this whole verb's parked refusal used to be, which is the one thing not to say here. A parked thread has nothing competing with it, so what it is doing is holding a break — the thunk asked for a stopped stack and the stop has been let go of. *) let gave_up = if liveness t = Parked then Error "the inspection produced nothing in five seconds. The \ program is parked, so nothing is competing with the thunk: \ the break it was built against has most likely been \ resumed since, and a stopped-only job is dropped rather \ than run against a resumed program" else Error "the program did not reach a frame boundary; is it calling \ (agent/poll)?" in if ms <= 0 then gave_up else begin ignore (Unix.select [] [] [] 0.005); (* Not [Gone], for the reason [eval_expr]'s own wait now gives: a park that services the ring reaches the equivalent of a frame boundary, and a render job asked for at a break the park is holding is running in that break's own poll. Gone is the only state no amount of waiting recovers from. *) if liveness t <> Gone then wait (ms - 5) else gave_up end in wait 5000 | reply -> Error ("the program refused the module: " ^ reply)) (* The frame checks, which every verb that reads a *frame* has to make and must make the same way. [inspect] exists precisely because the listing is frame-accurate and the inspector was not, so it sharing this function with [locals] rather than repeating four conditions is the point: an inspector that sidestepped the fingerprint would read stale slots out of a frame the listing above it is already refusing. [what] goes into the wording — "read slot names from" is not the sentence [inspect] wants — and nothing else differs. *) let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = match liveness t with | Gone -> Error gone | Parked when not (parked_break t) -> Error (parked_msg (Printf.sprintf "%s is read from a stopped frame, and a parked program's frames \ went with the run that pushed them" what)) (* Except where a thunk evaluated against the park stopped, and then there are frames again and they are worth reading. The thunk's own are refused below, by name, the way they are at any other break — but a program function the thunk *called* pushed an ordinary frame with ordinary slots, and its locals are as readable here as anywhere. Which is the whole argument for routing this through the same check rather than a second one: a parked break and a running one differ in how the thread got there, not in what is on its stack. *) | Live | Parked -> match state t with | Running -> Error (Printf.sprintf "the program is running; %s is read from a stopped frame, and \ nothing in a frame that is still executing holds still" what) | Unreachable m -> Error ("cannot ask the program where it is: " ^ m) | Stopped _ -> (match backtrace t with | Error m -> Error ("the program refused to say where it is: " ^ m) | Ok (frames, _) -> (match List.nth_opt frames frame with | None -> Error (Printf.sprintf "there is no frame %d; the backtrace has %d" frame (List.length frames)) | Some (name, _, mine, nslots, sig_, _rsig) -> if not mine then Error (name ^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called") else match find_fn t name with | None -> Error (name ^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from") | Some fn -> (* The two body checks come first, including for a frame with no slots. "every slot in it is one the compiler made up" is a claim about the body this session holds, and a zero-slot frame whose body has since been replaced by one with slots is a frame that claim is false about. *) if nslots <> Array.length fn.Tast.slots then Error (Printf.sprintf "%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess" name nslots name (Array.length fn.Tast.slots)) else if sig_ <> Emit.slot_fingerprint fn then (* The count matching is not the same as the body matching. A redefinition that renames a local, or changes its type to one of the same shape, keeps the count — and then every name here would be the new body's read against the old body's storage, which is the "visible rather than correct" answer this project refuses to give. Said by name, because a frame that is missing and a frame that cannot be trusted are different facts. *) Error (Printf.sprintf "%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values" name name) else Ok (name, fn))) (* [(:op "locals" :frame N)] — what a stopped frame's named locals hold. The half of a break loop that the author actually wanted, and the reason the shadow stack was built rather than more DWARF: DWARF would have put these in lldb, and the point is to need lldb less often. Nothing is copied out of the program. A Flan value has no header, so bytes read from another process would be bytes with no meaning; what this end has is the *type* — [Tast.fn.slots], from the build it owns — and the name beside it in [snames]. So it compiles a thunk that renders those types at those addresses, in the program, on the stopped thread, and reads the text back the way [C-x C-e] does. The only thing that comes from the running program is where the frame is. Three refusals, each by name and with its reason rather than by omission: a slot the compiler invented and nobody named; a slot whose binding had not run when the program stopped, which is a null address and would be a fault; and a type the structural printer has no arm for. A local that is missing and a local that could not be printed are different facts, and a list that showed neither would be the same lie twice. And two whole frames it refuses: one belonging to a [C-x C-e] thunk, which this session does not keep the [Tast] of, and one whose *body* is not the body this session holds. The second is the one that needed a fingerprint rather than a count: installing while stopped is deliberately allowed — it is the fix-it-and-retry loop — so the frame on the stack and the body here can be two bodies of one function, and a redefinition that renames a local changes neither the count nor the types. [Emit.slot_fingerprint] hashes every slot's name together with the spelling of its type, the frame carries the value for the body it was compiled from, and this end recomputes it from the body it holds. A collision is possible in principle — it is a 30-bit hash — but only between two differing bodies of the function whose qualified name already matched, since [find_fn] gates the comparison. *) let locals t ~frame = match stopped_frame t ~frame ~what:"locals" with | Error m -> error m | Ok (name, fn) -> if Array.length fn.Tast.slots = 0 then ok [ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()"; ":note " ^ Wire.quote "that frame records no slots; every slot in it is one the compiler made up" ] else (match bound_slots t ~frame with | Error m -> error ("the program refused to say which slots are bound: " ^ m) | Ok bound -> let c, refused = Session.render_locals t.session ~frame ~fn ~bound in (match run_render_thunk t ~tag:"l" ~c with | Error m -> error m | Ok v -> (* One line per slot — name, type, value, slot index — tab separated, and safe because every string the renderer emits is escaped. The index is last and it is what [i] in the break buffer hands back to [inspect]: two slots can share a name, so the name is not an identifier and the position in this list is not one either, since a refused slot is not in it. *) let entries = List.filter_map (fun line -> match String.split_on_char '\t' line with | [ n; ty; value; slot ] -> Some (Wire.list [ Wire.quote n; Wire.quote ty; Wire.quote value; slot ]) | _ -> None) (String.split_on_char '\n' v) in ok [ ":frame " ^ Wire.quote name; ":locals " ^ Wire.list entries; ":refused " ^ Wire.list (List.map (fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ]) refused) ])) (* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second rooting mode. [docs/BUILT.md]'s "Two ways to root a walk" says what each root can and cannot do; this is the half that names a frame. [i] in the break buffer used to send a local's *name* to be evaluated as an expression. On the innermost frame that happens to be right; on any other it is evaluated wherever the evaluator stands, so it may resolve to a global, to a different binding of the same name, or to nothing — with the listing right above it showing the frame's own storage and nothing saying the two disagree. This roots the walk where the listing roots it: a frame and a slot index, which is the address the shadow stack knows, plus the type [Tast.fn.slots] knows. A step into a field is then an address plus an offset with that field's type, which is arithmetic [Render.render] already does — see [Session.render_slot], which is [render_locals] with a path applied to the root and one line out instead of one per slot. The frame checks are [locals]'s, by construction: both go through [stopped_frame]. An inspector that made its own would be free to read a frame whose body was redefined since it was entered, which is exactly the stale-slot answer the listing refuses. The slot is named by *index* and not by name, because a name is not unique: [check.ml]'s [fresh_slot] only ever allocates, so (let [v 22] …) inside (let [v 11] …) is two slots both called [v], and both are in the listing. The index travels out with each line of [locals] for exactly this. [:path] is a list the reader parses: a string is a field, an integer is an element, and the symbol [some] is an option's payload. Empty means the slot itself. *) let inspect t ~frame ~slot ~path = match stopped_frame t ~frame ~what:"a local" with | Error m -> error m | Ok (name, fn) -> (match bound_slots t ~frame with | Error m -> error ("the program refused to say which slots are bound: " ^ m) | Ok bound -> if not (List.mem slot bound) then (* The same refusal the listing gives, and for the same reason: an unbound slot's entry is null, and a thunk that rendered it would fault on the game thread of a program that is already stopped. *) error (Printf.sprintf "slot %d of %s was not bound yet at the point the program \ stopped; there is nothing at that address to read" slot name) else match Session.render_slot t.session ~frame ~fn ~slot ~path with | Error why -> error why | Ok (c, label, ty) -> (match run_render_thunk t ~tag:"i" ~c with | Error m -> error m | Ok v -> (* One value and nothing else, so the whole of what came back is it — minus the trailing newline the renderer does not write here, because there is no second line to separate it from. *) ok [ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ])) (* ── The allocation registry, read from this end ───────────────────── *) (* [docs/BUILT.md]'s "An address answers with a type" is what the table is and why. What follows is the reader: three verbs that ask the agent for what is recorded, and one of them turns a recorded *name* back into a type. Nothing here is emitted and nothing here is in a release build. A release binary's table is a null pointer, so every one of these comes back with the agent saying the registry is off — which is an answer, and is the same answer [programs/registry.flan]'s release row asserts. *) type reg_entry = { rlive : bool; roff : int; (* how far into the block the address lands *) rbytes : int; (* the block's extent *) relem : int; (* one element, or 0 where the block is not an array *) rseq : int; (* when it was recorded *) rdied : int; (* when it was released, or 0 while it is live *) rtype : string } (* the Flan spelling the compiler wrote beside the call *) (* [reg at ADDR] answers one of three things and they are three different facts: a row, "never heard of it", or "there is no table". Kept apart here rather than collapsed into an option, because an address the registry never saw is a stack local or a pointer from C — a perfectly good address with no entry — and a release build is a build that records nothing about any address at all. A caller that could not tell them apart would report the second as the first. *) let reg_at t ~addr : (reg_entry option, string) result = match request t (Printf.sprintf "reg at %d" addr) with | exception Unix.Unix_error (e, _, _) -> Error ("cannot reach the program: " ^ Unix.error_message e) | text -> let line = String.trim (List.hd (String.split_on_char '\n' text)) in if line = "none" then Ok None else if String.length line > 4 && String.sub line 0 4 = "err " then Error (String.sub line 4 (String.length line - 4)) else (* "ok LIVE OFF BYTES ELEM SEQ DIED\tTYPE". The type is last and behind a tab because a spelling holds spaces — "(Vec i32)" — and nothing else on the line does. *) (match String.index_opt line '\t' with | None -> Error ("the program answered " ^ line) | Some tab -> let head = String.sub line 0 tab and ty = String.sub line (tab + 1) (String.length line - tab - 1) in (match String.split_on_char ' ' head with | [ "ok"; live; off; bytes; elem; seq; died ] -> (match List.map int_of_string_opt [ live; off; bytes; elem; seq; died ] with | [ Some live; Some off; Some bytes; Some elem; Some seq; Some died ] -> Ok (Some { rlive = live <> 0; roff = off; rbytes = bytes; relem = elem; rseq = seq; rdied = died; rtype = ty }) | _ -> Error ("the program answered " ^ line)) | _ -> Error ("the program answered " ^ line))) (* The recorded name, back to a [Types.t]. This is the one thing item 3 needed that nothing else in the registry did, and the whole of the difficulty is that **the table records a string**. It has to: the note is built in [check.ml] at the allocation site, where the concrete type exists, and what crosses into the runtime is bytes — an [ABI] that carried a type would be an ABI that had to agree with the checker's representation of one, which is the coupling the whole no-header-no-tag-word design refuses. What closes it is that the string is not a description. It is [Types.to_string] of the type, which is the *source spelling* — that is said in [check.ml]'s [reg_note] as the reason the name is worth printing at all — so the round trip is the language's own reader, the language's own type-expression parser, and the session's own resolver. `Enemy' resolves against the structs this session holds, `(Vec i32)' rebuilds through [Tapp], `[3 i32]' through [Tarray]. No table of spellings is written down anywhere, so nothing can fall behind [Types.to_string]. And it is allowed to fail, which matters more than it looks. Not every recorded name need be a type this session can spell — a note's name is whatever string the noting site chose, not Flan source — so a name that does not resolve is refused with the name quoted, and never defaulted to bytes. *) let type_of_spelling t spelling : (Types.t, string) result = let refuse why = Error (Printf.sprintf "%s is not a type this session can resolve: %s" (Wire.quote spelling) why) in match Reader.read_all ~file:"" spelling with | exception Loc.Error { Loc.dmsg = why; _ } -> refuse why | [] -> refuse "there is nothing in it" | _ :: _ :: _ -> refuse "it is more than one form" | [ f ] -> (match Check.resolve t.session.Session.env (Parse.texpr f) with | ty -> Ok ty | exception Loc.Error { Loc.dmsg = why; _ } -> refuse why) (* The extern that hands a number back as a pointer. The one piece an address-rooted thunk cannot work out for itself, and it is the same arrangement [flan/dev-slot] has for a frame's slot: Flan has no integer-to-pointer cast, deliberately, and the inspector is not a Flan program. Everything after this is ordinary — a pointer-to-pointer cast and a render, which is what [Session.render_slot] already does at a slot's address. *) let addr_extern : Tast.extern = { Tast.ename = "flan/dev-addr"; esym = "flan_dev_reg_addr"; eparams = [ Types.Int Types.I64 ]; eret = Types.Ptr (Types.Int Types.U8) } (* Renders the value [(Ptr ty)] holding [addr], in the program. **A pointer and not the pointee, and that is the design.** Rendering the [ty] at that address directly would read the storage whatever the registry said, which is the hex dump this project does not want to be. Rendering a [(Ptr ty)] puts the walk through [render.ml]'s pointer arm, which is the arm that asks first: live, and the pointee is rendered one level deeper; dead, and the epitaph says what died there instead. So an address root and a slot root reach the same two answers by the same path, and the permission question is asked in exactly one place in the compiler. Built here rather than in [session.ml] because it is the inspector's rooting mode and not the session's: a session renders what a *program* holds — a frame's slot, a global — and an address handed in from outside is neither of those. *) let render_addr (s : Session.t) ~addr ~(ty : Types.t) : (Session.change, string) result = let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = { Render.structs = s.Session.program.Tast.structs; datas = s.Session.program.Tast.datas; unions = s.Session.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.Session.env.Check.enums []; emit = Session.dev_emitter; ptrs = Some Session.dev_pointers; alloc = (fun ty -> let i = !nslots in incr nslots; extra := ty :: !extra; i) } in let pty = Types.Ptr ty in let root = { Tast.e = Tast.Prim (Tast.Cast pty, [ { Tast.e = Tast.Call ("flan/dev-addr", [ { Tast.e = Tast.Int (Int64.of_int addr, Types.I64); ty = Types.Int Types.I64; loc } ]); ty = Types.Ptr (Types.Int Types.U8); loc } ]); ty = pty; loc } in match Render.render c 0 root with | exception Loc.Error { Loc.dmsg = why; _ } -> Error why | parts -> let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in s.Session.thunks <- s.Session.thunks + 1; let name = Printf.sprintf "at/%d" s.Session.thunks in let thunk : Tast.fn = { Tast.name; params = []; ret = Types.Unit; body = (nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ]; fdefers = []; fparent = None; floc = loc; slots = Array.of_list (List.rev !extra); (* Every slot in here is the walk's own scratch: what is being shown is storage this thunk reaches by address. *) snames = Array.make (List.length !extra) None } in let program = { s.Session.program with Tast.fns = s.Session.program.Tast.fns @ [ thunk ]; externs = s.Session.program.Tast.externs @ Session.externs @ [ addr_extern ] } in (* Through the session's own chooser, so that this thunk is compiled by whichever backend built the process it is about to be loaded into. *) let ir = Session.redefinition s ~call:name program ~fns:[ name ] in Ok { Session.ir; x86 = s.Session.x86; names = []; fns = []; installs = true } (* [(:op "at" :addr N :type "Enemy")] — point at any heap address. The inspector's third rooting mode, and the one that needs no frame. [locals] and [inspect] root at a frame and a slot, which is the address the shadow stack knows and the type [Tast.fn.slots] knows. This roots at an address somebody has in their hand — out of a C debugger, out of a printed [Ptr], out of a leak report — and there is no frame to read a type off. **So the type comes from the registry when it is not given**, which is what the table was carrying a string for all along and what nothing had yet read. See [type_of_spelling] for how the string becomes a [Types.t] and why it is allowed to refuse. **A given [:type] wins over the recorded one**, and is not checked against it. Overriding is the point of being able to say it: a pointer into the middle of a block, a struct the registry recorded under a container's spelling, a reinterpretation someone is doing on purpose. What is *not* silent is the disagreement — the reply carries [:recorded] whenever the table had a name, so a client showing one type while the allocator wrote down another can say so. **Refused while running**, the same as [inspect] and for a related reason rather than the same one: there is no frame here to be redefined under us, but there is a table, and live-or-dead is exactly the thing a running program is changing. An answer read off a program mid-frame is an answer about a moment that has already gone. **Refused at an address the block does not divide.** When the entry records an element size and the offset is not a multiple of it, the address is inside an element rather than at one, and rendering the element type there would read one element's tail as another's head — a plausible-looking answer, which is the worst kind. Said with the offset, so the reader can see how far off it is, and overridable by naming a [:type] the way any other reinterpretation is. **No [:path].** A path steps from the pointee, and the pointee is what the registry has only just been asked to bless: the whole answer here is the pointer arm's branch. Somebody who wants to walk from what they found reaches it the way the break buffer already does — the value is rendered, and stepping into it is a different root. *) let inspect_addr t ~addr ~want_type = if addr <= 0 then error "an address is a positive number" else match liveness t with | Gone -> error gone (* The registry outlives the run, so the entry is still there — and that is the trap. Rendering what is at the address means building a thunk and having the program run it, and a parked program runs nothing; the answer would be a five-second wait. *) | Parked when not (parked_break t) -> parked "whether an address is still live is read from a stopped program, and \ a parked one has not stopped on anything" (* The thunk this builds is delivered stopped-only, and a park with a stopped thunk in it satisfies that check exactly as a running program's break does: the agent asks its own [depth], which the break loop raised, and knows nothing about runs. So this needs no special case beyond being allowed through — and it wants one, because the registry outlived the run and an address out of a leak report from the last run is a thing somebody has in their hand precisely while the program is parked. *) | Live | Parked -> match state t with | Running -> error "the program is running; whether an address is still live is exactly \ what a running program is changing, so it is read from a stopped one" | Unreachable m -> error ("cannot ask the program about that address: " ^ m) | Stopped _ -> (match reg_at t ~addr with | Error m -> error m | Ok entry -> let recorded = Option.map (fun e -> e.rtype) entry in let chosen = match want_type with | Some spelling -> type_of_spelling t spelling | None -> (match entry with | Some e -> type_of_spelling t e.rtype | None -> Error "the registry has never seen that address and no :type was \ given, so there is nothing to say what is there — a stack \ local, a global or a pointer from C is deliberately not in \ the table, and the shadow stack answers for the first two \ by name") in (match chosen with | Error m -> error m | Ok ty -> let misaligned = match (want_type, entry) with | None, Some e when e.relem > 0 && e.roff mod e.relem <> 0 -> Some e | _ -> None in (match misaligned with | Some e -> error (Printf.sprintf "that address is %d bytes into a block of %s, whose \ elements are %d bytes: it is inside an element rather \ than at one, and reading %s there would show one \ element's tail as another's head. Name a :type to read \ it anyway." e.roff e.rtype e.relem e.rtype) | None -> let told = match recorded with | None -> [ ":recorded nil" ] | Some r -> [ ":recorded " ^ Wire.quote r ] in let where = match entry with | None -> [] | Some e -> [ Printf.sprintf ":offset %d" e.roff; Printf.sprintf ":bytes %d" e.rbytes; Printf.sprintf ":elem %d" e.relem; Printf.sprintf ":step %d" e.rseq; Printf.sprintf ":freed %d" e.rdied ] in let live = match entry with Some e when e.rlive -> "t" | _ -> "nil" in (match render_addr t.session ~addr ~ty with | Error m -> error m | exception Failure m -> error m | Ok c -> (* Stopped-only, and the only one of the three that is. The gate above was read three round trips and a build ago; this is what holds it. See [run_render_thunk]. *) (match run_render_thunk ~stopped_only:true t ~tag:"a" ~c with | Error m -> error m | Ok v -> ok ([ Printf.sprintf ":addr %d" addr; ":type " ^ Wire.quote (Types.to_string (Types.Ptr ty)); ":value " ^ Wire.quote v; ":live " ^ live ] @ told @ where)))))) (* [reg types] and [reg leaks] — the table grouped by type spelling. The walk and the group-by are one function in [flan_dev.c], because a leak report is a breakdown with the dead left out and two walks would drift. What this end adds is the order: biggest first, by bytes. A breakdown read in table order is a list of everything and tells you nothing; a breakdown read biggest-first is the answer to "where did the memory go", which is the only reason either verb exists. [:overflow] is carried rather than swallowed. A table that filled has blocks in the program that are in nobody's row, so every number below it is a floor and not a count, and a reader that could not tell would quote them as counts. *) let reg_rows t ~verb = match request t verb with | exception Unix.Unix_error (e, _, _) -> Error ("cannot reach the program: " ^ Unix.error_message e) | text -> (match String.split_on_char '\n' text with | [] -> Error "the program answered nothing" | hdr :: rest -> let hdr = String.trim hdr in if String.length hdr > 4 && String.sub hdr 0 4 = "err " then Error (String.sub hdr 4 (String.length hdr - 4)) else (match String.split_on_char ' ' hdr with | [ n; over ] when int_of_string_opt n <> None -> let rows = List.filter_map (fun line -> match String.index_opt line '\t' with | None -> None | Some tab -> let ty = String.sub line (tab + 1) (String.length line - tab - 1) in (match List.map int_of_string_opt (String.split_on_char ' ' (String.sub line 0 tab)) with | [ Some count; Some bytes ] -> Some (ty, count, bytes) | _ -> None)) rest in let rows = List.stable_sort (fun (_, _, a) (_, _, b) -> compare b a) rows in Ok (rows, over <> "0") | _ -> Error ("the program answered " ^ hdr))) let reg_listing t ~verb ~note = match reg_rows t ~verb with | Error m -> error m | Ok (rows, overflow) -> let blocks = List.fold_left (fun a (_, c, _) -> a + c) 0 rows and bytes = List.fold_left (fun a (_, _, b) -> a + b) 0 rows in ok [ ":types " ^ Wire.list (List.map (fun (ty, c, b) -> Wire.list [ Wire.quote ty; string_of_int c; string_of_int b ]) rows); Printf.sprintf ":blocks %d" blocks; Printf.sprintf ":bytes %d" bytes; (if overflow then ":overflow t" else ":overflow nil"); ":note " ^ Wire.quote note ] (* [(:op "globals")] — the globals the stopped stack reaches, in one section. Locals were the half the shadow stack was built for; these are arguably the more useful half in this language. A game keeps most of its state in top-level [defvar]s and sand.flan holds its entire grid that way, so "what is the program's state right now" is a question about globals and there was nowhere to ask it. **Not per frame, and that is the design.** A global is not part of a frame — it is program state the frame happened to touch — so nesting it under one implies an ownership that is not there, and repeats the name once per frame that reads it. So: one section, whose contents are the union of the globals every frame on the current stack references. **The compiler does the choosing.** [Reach.expr_refs] is the walk that already computes what a function refers to — it is how the link drops a package nothing calls — and pointed at one body it answers that body's reference set. Listing *all* of a program's globals instead would bury the one that matters under the prelude's PRNG state; taking only what the stack reaches is the filter the compiler can apply and a person cannot. Direct references only, with no transitive closure through the calls a body makes. A callee that reads a global is either on this stack — in which case it is contributing its own references already — or it is not, in which case it is not part of where the program stopped. **Each entry says which frames touch it**, by index, which is what the stack section already numbers them by. That recovers what per-frame nesting would have told you — "the whole chain is reading this" reads differently from "only the innermost does" — at no cost in duplication. **Ordered by the innermost frame that touches it.** A deep stack makes the union large, and proximity to the error is what puts the likely culprit on top. Ties keep declaration order, which is the order the source has them in. **A frame that cannot be attributed contributes nothing and says so.** An eval frame has no declaration in this session; a lifted handler clause has none of its own; and a frame whose body has been redefined since it was entered holds a body whose reference set is a claim about different code. In every case the honest answer is that the union is incomplete and which frame made it so — [:skipped] — rather than a list that silently is not the union it says it is. The *values* would still have been right; the attribution is what goes wrong, and attribution is what this op is for. **And the frame check that [locals]'s is not.** [Emit.slot_fingerprint] hashes a body's *slots* — every slot's name with the spelling of its type — so it catches a redefinition that binds differently and misses one that does not. For [locals] that is exactly the right cut: if the slots are identical then the names still describe the storage and the answer is still true. Here it is not, because a body can change which globals it names without touching a single slot, and then this section would show the *new* body's reference set attributed to the *old* frame. So a second fingerprint, [Reach.ref_fingerprint], over the set of globals the body names, carried beside the slot one in [%fninfo] and checked here the same way. Two numbers and not one, because they are two facts: a frame whose slots match and whose globals do not has readable locals and unusable attribution, and combining the hashes would make [locals] refuse a frame nothing is wrong with. The values were never the exposure — they come from the program's storage by name — and what was, one frame's membership in the union and the frame numbers beside an entry, is now a named refusal like every other. Nothing is copied out of the program here either, and the mechanism is one step simpler than [locals]: a global is reached by name rather than by address, because [Emit.redefinition] writes a global the host already has as [external] and the dynamic linker binds the thunk to the program's own storage. So there is no [bound_slots] round trip and no not-yet-bound case — a global's storage exists from the moment the process started. *) let globals_op t = match liveness t with | Gone -> error gone (* Refused for the mechanism and not for the policy, which is worth saying because the storage really is readable: a global's memory exists from the moment the process started and is exactly as the finished run left it, which is the whole of what makes a re-run worth having. What does not exist while parked is the renderer. A globals section is a thunk built here, delivered, and run by the program at a frame boundary, the same as [locals] and [inspect]; the stack that decides which globals to show went with the run as well. *) | Parked when not (parked_break t) -> parked "a globals section is the globals a stopped stack reaches, and a parked \ program's stack went with the run that built it" (* When a thunk evaluated against the park has stopped there is a stack, and this answers against it. Mostly that is a short section and sometimes an empty one — a thunk's own frames are eval frames and contribute nothing but a line in [:skipped] — which is the honest answer rather than a poor one: what the union is built from is what the stack reaches, and this stack reaches what the expression called. *) | Live | Parked -> match state t with | Running -> error "the program is running; globals are read against a stopped stack, and \ the stack is what decides which of them to show" | Unreachable m -> error ("cannot ask the program for its globals: " ^ m) | Stopped _ -> (match backtrace t with | Error m -> error ("the program refused to say where it is: " ^ m) | Ok (frames, _) -> let all = t.session.Session.program.Tast.globals in let is_global n = List.exists (fun (g : Tast.global) -> String.equal g.Tast.gname n) all in (* name -> the frame indices that reference it, innermost lowest *) let touched : (string, int list) Hashtbl.t = Hashtbl.create 32 in let skipped = ref [] in List.iteri (fun i (name, _, mine, nslots, sig_, rsig) -> let skip why = skipped := (Printf.sprintf "%d: %s" i name, why) :: !skipped in if not mine then skip "a frame of the expression this break is inside, not of the \ program; its thunk is not part of the session, so there is no \ record of what it refers to" else match find_fn t name with | None -> skip "not a function this session holds; a lifted handler clause \ has no declaration of its own to read references from" | Some fn -> if nslots <> Array.length fn.Tast.slots then skip "the frame is running a body that has been redefined \ since, so what this session holds is a different body's \ reference set" else if sig_ <> Emit.slot_fingerprint fn then skip "this frame's body was redefined since it was entered, so \ what it refers to here is a claim about different code" else if rsig <> Reach.ref_fingerprint ~is_global fn then (* The check the slot fingerprint cannot make. A body that binds the same locals and names different globals passes every test above and is still the wrong body to read a reference set out of: what would go into the union is the *new* body's globals, attributed to the frame of the old one, and the frame numbers beside an entry would say a frame touches something it does not. The values are not what breaks — those are read from the program's own storage by name — so this refuses the frame's attribution and nothing else. [locals] deliberately does not make this check: the slots still describe the storage, so that frame is still readable. *) skip "this frame's body names different globals than the one \ this session holds, so which globals it contributes to \ this union would be the new body's answer about the old \ body's frame" else begin (* Once per frame per name: a body that reads the grid in four places touches it once as far as this is concerned. *) let seen = Hashtbl.create 8 in let note n = if is_global n && not (Hashtbl.mem seen n) then begin Hashtbl.add seen n (); let prev = try Hashtbl.find touched n with Not_found -> [] in Hashtbl.replace touched n (prev @ [ i ]) end in List.iter (Reach.expr_refs note) fn.Tast.body; List.iter (Reach.expr_refs note) fn.Tast.fdefers end) frames; let skipped = List.rev !skipped in let wanted = (* Declaration order first, so a tie on the innermost frame breaks the way the source reads. [stable_sort] then keeps it. *) List.filter (fun (g : Tast.global) -> Hashtbl.mem touched g.Tast.gname) all in let innermost (g : Tast.global) = List.fold_left min max_int (Hashtbl.find touched g.Tast.gname) in let ordered = List.stable_sort (fun a b -> compare (innermost a) (innermost b)) wanted in let where (g : Tast.global) = Wire.list (List.map string_of_int (List.sort_uniq compare (Hashtbl.find touched g.Tast.gname))) in let skipped_field = ":skipped " ^ Wire.list (List.map (fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ]) skipped) in if ordered = [] then ok [ ":globals ()"; ":refused ()"; skipped_field; ":note " ^ Wire.quote "no frame on this stack references a global; there is \ nothing here that is not already in the locals" ] else begin let c, refused = Session.render_globals t.session ~globals:ordered in match run_render_thunk t ~tag:"g" ~c with | Error m -> error m | Ok v -> (* One line per global, name and type and value, tab separated — safe because every string the renderer emits is escaped. The frames are added back here, from the table above, because the thunk knows nothing about the stack it was chosen for. *) let by_name = Hashtbl.create 32 in List.iter (fun (g : Tast.global) -> Hashtbl.replace by_name g.Tast.gname (where g)) ordered; let entries = List.filter_map (fun line -> match String.split_on_char '\t' line with | [ n; ty; value ] -> Some (Wire.list [ Wire.quote n; Wire.quote ty; Wire.quote value; (try Hashtbl.find by_name n with Not_found -> Wire.list []) ]) | _ -> None) (String.split_on_char '\n' v) in ok [ ":globals " ^ Wire.list entries; ":refused " ^ Wire.list (List.map (fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ]) refused); skipped_field ] end) (* A choice is validated by the *program*, on its listener thread, against a stack the stopped game thread is holding still — not here. The daemon has no copy of that stack and anything it checked would be a guess that was true a moment ago. "ok" therefore means accepted, and says so: the resume happens when the stopped thread next comes round its loop, which is microseconds away and still not now. An editor that read [ok] as "running again" would poll once, find it stopped, and re-open the prompt it had just answered. *) let choose_at t ~index ~name = match liveness t with | Gone -> error gone | Parked when not (parked_break t) -> parked "a restart is taken on a stopped program's stack, and a parked one has \ no stack to resume into" (* A thunk evaluated against the park can stop, and then this is not a convenience but the way out: the thread is in the break loop and stays there until a restart is taken or an abort ends the process, and a re-run asked for meanwhile waits on the same resume. Refusing here for the state rather than for the stack would have made the first paused expression against a parked program the last thing that session did. *) | Live | Parked -> 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 = match liveness t with | Gone -> error gone | Parked when not (parked_break t) -> parked "a restart is taken on a stopped program's stack, and a parked one has \ no stack to resume into" | Live | Parked -> 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 = match liveness t with | Gone -> error gone (* The one refusal here that is good news. Abort exists to end a program stopped somewhere it cannot continue from; a parked program has already ended, of its own accord, and the process it would have taken with it is the session. *) | Parked when not (parked_break t) -> parked "the program has already finished, so there is nothing to abort and \ nothing that would end by aborting it but this session" (* The one exception, and it is the same exception the restarts are: a thunk stopped in the break loop on the parked thread is something to abort, and for a condition with no restart worth taking it is the only thing that ends it. What it costs is unchanged and is what the reply has always said — the process goes, and the session with it. *) | Live | Parked -> 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) (* Run [main] again. The verb this file was missing, and the one everything above it about [Parked] is in aid of. The complaint it answers, in the words it was made in: you run a program under [flan dev], it opens a window, you close the window, main returns — and there is no way to get a new window back short of tearing down the whole session with [flan-restart-program], which throws away the build, the session and every global. In Common Lisp or Clojure the image outlives main, so you call it again. The process here already outlived main; it simply had nothing that could wake it. NOTHING IS RESET, and that is the decision rather than a corner not yet swept. The process never died, so the second run sees the globals exactly as the first left them — a counter goes on counting, an arena stays as full as it was, a cached texture handle is still whatever the closed window made it. That is what CL and Clojure do and it is what was asked for: a clean slate is a thing you ask for by hand, in one evaluation, and it cannot be had back the other way round if this zeroed by default. The state is asked twice — here, to say something useful about [Gone], and again inside [Program.rerun], which is the answer that counts. The C does its test and its signal under one lock, so the window between them that this check cannot see is a window that does not exist there. *) let rerun t = match liveness t with | Gone -> error gone | Live | Parked -> (match Program.rerun () with | Ok () -> (* Taken is not always started, and the one case where it is not needs saying rather than a mechanism. A thunk evaluated against the park can stop in the break loop, and the parked thread is then inside that loop rather than in the wait that reads this request — so the flag is set, the park sees it the moment the poll returns, and the run begins when the break is resumed or aborted. Queueing it is exactly right here, unlike the running case the C refuses: there is no second main about to start, only one waiting for the thread to be free. *) let note = if liveness t = Parked && parked_break t then "accepted; an expression evaluated against the park is stopped in \ the break loop, so main starts once that is resumed or aborted" else "running main again; the globals are as the last run left them, and \ anything delivered while it was parked installs at the first frame \ boundary" in ok [ ":note " ^ Wire.quote note ] | Error m -> error m) (* ── 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 [] 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) (* 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:bytesmnemonic"], 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 [] or, for the entry, []. 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 ] 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 = 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" ) | 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 (* [state t] answers [Running] for a parked program — the agent's listener is alive and nothing has stopped — so the frame-boundary sentence below would be said about a program that will not reach one until somebody runs it again. Asked of [liveness] first, for the same reason every guard in this file is. *) | Running when liveness t = Parked -> Printf.sprintf "%s — the last module delivered for this name, accepted for install; \ the program has finished and is parked, so it installs no later \ than the first frame boundary of the next run — sooner if an \ expression is evaluated first, since the poll that runs a thunk \ takes everything queued ahead of it" m | 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 (* There is no LLVM IR in an x86 session, and until now the way that was reported was a grep that found nothing in a file whose name ends [.s]: "no define for @flan.step in .../host.s", which reads like a compiler that lost track of its own output. The view that does exist is the other one -- [:form "asm"] disassembles the object, and an x86 session has objects like any other -- so this says which of the two questions it cannot answer rather than failing at the text of an answer it was never going to find. *) if form = "ir" && t.session.Session.x86 then error "this session was compiled by the x86 dev backend, so there is no \ LLVM IR to show — the listing it produced is assembly. C-c C-a \ disassembles the object, which works here; for the IR view, restart \ the daemon with flan dev --llvm" else 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 (* ── The watch table ───────────────────────────────────────────────── *) (* Read the table the *program* fills, and arm and disarm it. This op is the opposite shape from every other one here, and the reason is worth stating because the obvious design is the wrong one. Everything else in this file answers a question by *compiling something*: a locals listing, an inspection, a globals section are each a thunk built from the types, sent over, and run at a frame boundary. That is affordable at the rate a person presses a key and ruinous at the rate a HUD refreshes — an evaluation here is a module and a [dlopen], tens of milliseconds and a new .so in a directory nothing sweeps, so a 5Hz poll is hundreds of shared objects a minute. So the program pushes instead. It calls [flan_dev_watch_*] from inside its own loop, which renders the value and stores it under a name; this reads the table, which is memory. Nothing is compiled, nothing is loaded, and the answer is as cheap as [status]. Two things fall out of that which a poll could not have. The values update at *frame rate* rather than at whatever the editor's timer is. And they are still here while the program is *stopped* — a break loop is exactly when a thunk cannot be run at a frame boundary, because there are no more frames, and it is exactly when you want to see the last one's values. *) (* On and off are a message rather than something inferred, because the writer is the program: the table is untouched while it is off, which is what makes a watch call in a program nobody is debugging a load and a not-taken branch. See [flan_dev_watch_enable]. *) let watch_enable t ~on = match String.trim (request t (if on then "watch on" else "watch off")) with | "ok" -> ok [ (if on then ":watching t" else ":watching nil") ] | reply -> error ("the program refused the watch request: " ^ reply) | exception Unix.Unix_error (e, _, _) -> error ("cannot reach the program: " ^ Unix.error_message e) (* [NAME VALUE] per line, after a header of [COUNT DROPPED]. Tab is safe as the separator for [render_locals]'s reason: every string that reaches a value goes through an emitter that escapes tab and newline, so neither can appear inside one. [OVERFLOW] is carried rather than dropped — a name that found no slot is a value that never appears, and a buffer that said nothing about it would be lying by omission. It is a flag and not a count on purpose: the only number available is of write *attempts* that missed, which at frame rate says "3847 names" about one name. *) (* [~reset] opens a new accumulation window for the numeric slots, *after* the read rather than instead of it. A read that reset as a side effect would make looking change what is there, so anything that polls would silently shorten the window and come back with a count that means nothing. Two messages down a unix socket, one of which is four bytes of reply. *) let watch_read t ~reset = match request t "watch" with | text -> let finish result = if reset then (try ignore (request t "watch reset") with Unix.Unix_error _ -> ()); result in let lines = String.split_on_char '\n' text in finish @@ (match lines with | [] -> error "the program gave an empty watch reply" | hdr :: rows when not (String.length hdr >= 3 && String.sub hdr 0 3 = "err") -> let overflow = match String.split_on_char ' ' (String.trim hdr) with | [ _; d ] -> d <> "0" | _ -> false in let pair line = match String.index_opt line '\t' with | None -> None | Some i -> Some (Wire.list [ Wire.quote (String.sub line 0 i); Wire.quote (String.sub line (i + 1) (String.length line - i - 1)) ]) in ok [ ":watch " ^ Wire.list (List.filter_map pair rows); (if overflow then ":overflow t" else ":overflow nil") ] | hdr :: _ -> error (String.trim hdr)) | exception Unix.Unix_error (e, _, _) -> error ("cannot reach the program: " ^ Unix.error_message e) 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 -> "" in eval t ~code ~origin ~pause:(Wire.pos_field req "pause") | 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 -> "" in (* [:pause t], a flag, where [eval] takes a position: the editor sends [C-x C-e]'s text as a raw substring with no line padding, so buffer coordinates do not survive that path — and they are not needed, since the expression sent is the whole of the target. Absent or [nil] is false and anything else true, the same spelling [:on] uses. *) let pause = match Wire.field req "pause" with | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in eval_expr t ~code ~origin ~pause | None -> error "eval-expr needs :code") (* [:all], absent or [nil] being false and anything else true — the spelling [:pause], [:on] and [:reset] already use. One step is the default because it is the one that can name the macro that ran: a full expansion of a macro that quasiquotes a call to another is stamped with the outermost name only, [Loc.from_macro] being outermost-wins, so the intermediate is unnameable by the time it settles. *) | Some "macroexpand" -> (match Wire.string_field req "code" with | Some code -> let origin = match Wire.string_field req "file" with Some f -> f | None -> "" in let all = match Wire.field req "all" with | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in macroexpand t ~code ~origin ~all | None -> error "macroexpand needs :code") | Some "describe" -> describe t | Some "defs" -> defs t | Some "break" -> break t | Some "backtrace" -> backtrace_op t | Some "locals" -> locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0) (* The path is read by the language's own reader, so it arrives as a form and is matched here rather than parsed out of a string: a string element is a field, an integer is an element, and the symbol [some] is an option's payload. Anything else is refused by name rather than skipped — a path with a step silently dropped out of it would render a *different* value and say nothing. *) | Some "inspect" -> (match Wire.int_field req "slot" with | None -> error "inspect needs :slot, the index the locals listing gave" | Some slot -> let frame = match Wire.int_field req "frame" with Some n -> n | None -> 0 in let steps = match Wire.field req "path" with | Some { Form.v = Form.List l; _ } -> List.fold_left (fun acc (e : Form.t) -> match acc with | Error _ -> acc | Ok got -> (match e.Form.v with | Form.Str f -> Ok (Session.Sfield f :: got) | Form.Int i -> Ok (Session.Sindex (Int64.to_int i) :: got) | Form.Sym "some" -> Ok (Session.Ssome :: got) | _ -> Error "a :path step is a string for a field, an integer for an element, or `some' for an option's payload")) (Ok []) l |> Result.map List.rev (* Emacs prints an empty list as [nil], because it has no other spelling for one. Taking it is cheaper than making every client in that language special-case the empty path, and [nil] is not a step under any other reading. *) | Some { Form.v = Form.Sym "nil"; _ } -> Ok [] | Some _ -> Error "inspect's :path is a list" | None -> Ok [] in (match steps with | Error m -> error m | Ok path -> inspect t ~frame ~slot ~path)) (* No :frame, and that is the point: the section is the stack's, not a frame's. See [globals_op]. *) | Some "globals" -> globals_op t (* [(:op "at" :addr N)] and an optional [:type]. The rooting mode with no frame in it: an address somebody has in their hand, and the registry's own answer for what is there when none is named. See [inspect_addr]. *) | Some "at" -> (match Wire.int_field req "addr" with | None -> error "at needs :addr, the address to point at; it is the one thing this \ verb cannot work out for itself" | Some addr -> inspect_addr t ~addr ~want_type:(Wire.string_field req "type")) (* What this program is made of, by type. Everything the table holds, live and dead both — the dead are the bulk of it in a long-running program and they are what says where the allocation went, not only where it stayed. *) | Some "allocations" -> reg_listing t ~verb:"reg types" ~note: "every block the registry recorded, live and dead, grouped by the \ type the allocator's caller named" (* And what is still held. "At exit" is the question this answers and it needs saying plainly, because the obvious reading does not survive contact with a game. A program killed by a signal — which is how a program under this editor usually ends — runs no handler at all, so nothing written inside it could report anything. There are therefore two readers and they are not alternatives: this verb, which reads the same table over the agent socket and can be asked at any moment, including the last one before the kill; and an atexit hook in [flan_dev.c] for the program that returns from main on its own, which is off unless FLAN_DEV_LEAKS is set, because a dev build's output is read by the acceptance table. *) | Some "leaks" -> reg_listing t ~verb:"reg leaks" ~note: "what the registry still holds live at the moment it was asked; a \ program that is killed runs no exit handler, so this verb and not a \ hook is what answers for one" | 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 (* No fields: the only thing it could take is which function to run, and the answer is main — the whole claim is that the process is an image the program can be started in again, not a way to call arbitrary names, which is what [eval-expr] already is. *) | Some "rerun" -> rerun t (* [:on] is how the buffer says it opened or closed. Without it the table is never written, which is the point: a program with watch calls in it and nobody looking pays a load and a branch and nothing else. *) | Some "watch-enable" -> watch_enable t ~on:(match Wire.field req "on" with | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true) | Some "watch" -> (* Same shape as [:on] above: absent or [nil] is false, anything else is true. Absent is the important half — a reader that does not ask to reset must not, so a second editor or a test polling the table cannot cut the window short under the one that does. *) watch_read t ~reset:(match Wire.field req "reset" with | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true) | 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 request boundary ──────────────────────────────────────────── *) (* Every op above answers with a reply; this is what makes that true for the ones that raise instead of returning. The ops used to catch [Loc.Error] each at its own call site, which was enough while the frontend was the only thing that could refuse a form. It is not any more: expansion is part of evaluating, so both [eval] and [eval-expr] now run a clang driver — [Build.macro_module] fails with [Failure], a macro module that will not dlopen fails with [Failure] out of [Dynload], and a file that moved fails with [Sys_error]. None of those is a [Loc.Error], so none of them was answered, and an exception that escapes [serve] is not a refused evaluation: it is a dead daemon. The program is still on screen, the session is gone, and the editor's next request finds a closed socket. So the boundary is here, once, around the whole of a request — rather than a new arm at each of the dozens of calls, which is the arrangement that let this happen in the first place. NEXT.md's rule is that a form that does not check leaves the session exactly as it was, and that is only true if every way a build or a check can fail comes back as a reply. What is deliberately *not* caught: [Out_of_memory], [Stack_overflow] and [Sys.Break]. Those three say the process cannot continue, or that someone at the terminal asked it to stop — they are not statements about the form that was sent, and answering "error" to them would be claiming the session survived something it did not. Everything else is about the form: a clang exit status, a dlopen with no such symbol, a missing file. *) let fatal = function | Out_of_memory | Stack_overflow | Sys.Break -> true | _ -> false (* The message an editor shows. A [Failure] out of the clang driver carries the compiler's own words and a [Sys_error] carries the path, so they are passed through as they are: "internal error" for either would throw away the only part of the reply anybody can act on. The catch-all keeps the exception's name, which at least says which of these arms to add next. *) let message_of_exn = function | Loc.Error { Loc.dmsg = m; _ } -> m (* Only a whole-file driver raises the list and the daemon evaluates one form — but [lib/parse.ml] says in as many words that a list arriving here was a dead session, so it is answered rather than left to the catch-all to print as a constructor name. *) | Loc.Errors ds -> String.concat "; " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) | Failure m | Sys_error m -> m | Unix.Unix_error (e, fn, arg) -> Printf.sprintf "%s: %s%s" fn (Unix.error_message e) (if arg = "" then "" else " (" ^ arg ^ ")") | e -> "internal error: " ^ Printexc.to_string e (* Shaped exactly as the [Loc.Error] arms it replaces: [:loc] where there is one to give, and nothing where there is not — an editor that highlights a span must not be handed a made-up one. *) let reply_of_exn e = match e with | Loc.Error { Loc.dloc = l; _ } | Loc.Errors ({ Loc.dloc = l; _ } :: _) -> error ~loc:(Loc.to_string l) (message_of_exn e) | _ -> error (message_of_exn e) (* ── 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 -> (* Parsed once, and the verb taken out of it before anything that can fail: [close] has to be honoured even when the handler for it did not return normally, and a tuple whose two halves are [Wire.string_field] and [handle] leaves that to an evaluation order OCaml does not promise. *) let parsed = match Wire.parse src with | req -> Either.Left req | exception e when not (fatal e) -> Either.Right (error ("bad request: " ^ message_of_exn e)) in let op = match parsed with | Either.Left req -> Wire.string_field req "op" | Either.Right _ -> None in let reply = match parsed with | Either.Right r -> r | Either.Left req -> (match handle t req with | r -> r | exception e when not (fatal e) -> reply_of_exn e) in (* The two annotations are inside the boundary as well, and not because they are likely to raise: [with_break] asks the program for its state and [with_output] drains its pipe, so they touch the same things the ops do. A reply that raised on its way out would be a reply never sent, which is the same dead session one line lower down. The fallback is the unannotated reply — worse than a full one, and the whole point is that the editor gets an answer. *) let annotated = match with_output t (with_break t reply) with | r -> r | exception e when not (fatal e) -> reply in (* The write is guarded and the guard is not decoration: an [exception] case on a [match] covers the scrutinee only, so before this an [EPIPE] here went straight past the two below and out of the accept loop, ending the session. An editor that left before its reply arrived is a closed connection and nothing more, which is what [false] says. *) (match Wire.send fd annotated with | () -> if op = Some "close" then true else go () | exception Unix.Unix_error _ -> false) | exception Wire.Closed -> false | exception Unix.Unix_error _ -> false in go () (* An editor that goes away between its request and the reply to it leaves this process writing into a socket with no reader, and a write into a socket with no reader is SIGPIPE — whose default action is to kill the process. In the two-process daemon that would lose the session; in the merged build it kills the program, the compiler and the listener together, and leaves the socket file behind for the next client to get ECONNREFUSED on. That is not a theoretical shape: `M-x flan' reconnects a dead connection, Emacs tears the old process down when it does, and a reply already on its way out lands in the gap. Ignored rather than handled, because [serve] already treats a failed write as a closed connection: with the signal out of the way [Wire.send] raises [EPIPE] like any other [Unix_error], the connection is dropped, and the accept loop goes back to waiting for the next one. The program's own listener in flan_agent.c reached the same conclusion from the other side and passes MSG_NOSIGNAL; this is that decision for the half written in OCaml. *) let ignore_sigpipe () = try Sys.set_signal Sys.sigpipe Sys.Signal_ignore with Invalid_argument _ -> () (* ── Whether the editor is ever coming back ────────────────────────── *) (* The loop below used to have exactly one way out that anybody ever took: [close], which Emacs sends when it is quitting on purpose. An editor that is *killed* — SIGKILL, a crash, a laptop that slept and came back to a dead X session — sends nothing, and the daemon went on accepting connections that nobody was ever going to make. Four of the eight orphans found on the author's machine were exactly that, and FIX.org recorded it as a defect the PDEATHSIG work does not touch: that kills a *child* when the daemon dies, and this is a *daemon* whose client died. What makes this answerable without a new protocol is that the connection is per session and not per request. [emacs/flan-dev.el] opens one [make-network-process] in [flan-dev--open], keeps it in [flan-dev--connection], and reopens only when the process is dead; every site that tears it down deliberately sends [close] first. [serve] mirrors that shape — it loops on the one fd until EOF — so while an editor is attached this loop is not even cycling. An editor left open and idle overnight is therefore *attached* overnight, and the grace below can never accumulate under it. That is structural, not a number chosen to outlast human patience, and it is why no PID handshake and no heartbeat op is needed: holding the socket open is the heartbeat, and a client that only ever polls — or one that has [flan-dev-poll-interval] set to nil and polls never — is indistinguishable from any other attached client. So the signal is client *absence*, and the only absence this is allowed to read as death is one that follows a client having been there: [served]. A daemon started in a terminal while its author goes off to open an editor is not an orphan, and arming before the first connection would quietly change what [flan dev] means for anyone running it headless. Two graces rather than one, and the argument is visibility rather than work. A parked program has no window and no thread doing anything; it is invisible, which is precisely why four of them piled up unnoticed. A live one is a game on somebody's screen, and ending it out from under them is a loss they cannot undo — and one they can avoid by closing the window themselves, which parks it and starts the shorter clock. A non-positive grace turns the whole thing off, for a daemon that is meant to outlive every client it will ever have. *) let client_grace_default = 300. (* Split out from the loop for the reason [liveness_of] was: the loop needs a real session and a real socket, so the decision inside it is otherwise only reachable through a case that takes a compile. *) let orphan_grace ~grace = function | Live -> grace *. 6. | Parked | Gone -> grace let orphaned ~grace ~served ~idle live = grace > 0. && served && idle >= orphan_grace ~grace live let client_grace () = match Sys.getenv_opt "FLAN_DEV_CLIENT_GRACE" with | Some s -> (match float_of_string_opt (String.trim s) with | Some f -> f | None -> client_grace_default) | None -> client_grace_default (* [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 the loop ends the only way it can — the process does, on [close] or on the grace above running out. [Gone] and nothing narrower, and this is the one place where getting the three states the wrong way round is fatal rather than merely confusing. A parked program is a program somebody is about to ask to run again, and they ask over this socket; stopping the loop when it parked would shut the listener, return from [merged_serve], and [_exit] the process — closing a window would kill the session, which is the bug this whole change exists to remove, reintroduced one line further out. The grace does not reopen that hole: it reads the client, not the program, and all of an Emacs's windows share the one [flan-dev--connection], so closing one of them changes nothing this loop can see. *) let accept_loop ?grace t ls = let grace = match grace with Some g -> g | None -> client_grace () in (* [served] arms the clock and [since] is when the last client let go — set when [serve] returns rather than when [accept] fires, so a connection that is held for an hour is an hour of the clock not running. *) let served = ref false and since = ref (Unix.gettimeofday ()) in let rec go () = match liveness t with | Gone -> () | (Live | Parked) as live -> let idle = Unix.gettimeofday () -. !since in if orphaned ~grace ~served:!served ~idle live then (* The measured gap and not the threshold it crossed: the threshold is a constant a reader can look up, and the gap is the observation the decision was made on. *) Printf.eprintf "flan dev: no editor has been connected for %.0fs, so this session \ is ending; its client is gone\n%!" idle else (* 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, _ -> served := true; let closed = serve t fd in (try Unix.close fd with Unix.Unix_error _ -> ()); since := Unix.gettimeofday (); 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 two_process ?(debug = false) ?(x86 = true) ~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 ~x86 ~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; Build.x86 } ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe); (* Host and modules are chosen together, which is the whole licence: an [--x86] host gets [--x86] modules because one flag set both, and the source [Build.executable] kept is assembly rather than IR. *) let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in (try Sys.rename (Filename.concat (Build.workdir ()) (Filename.basename exe ^ if x86 then ".s" else ".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; (* And who its parent is, which is the child's licence to end itself. vendor/agent/flan_agent.c carries the argument at length; the half that belongs here is that this daemon is the only thing that ever kills its child, and it does so from a [Fun.protect ~finally] that a SIGKILL skips. A harness that tears a failed daemon down the hard way, or a watchdog that fires, therefore leaves a program with ppid 1 running a game loop nobody can reach — which is where the orphans on this machine came from. The pid rather than a flag because the child checks [getppid] against it to close the window between the fork and its own arming, and "reparented to 1" is not the same question under a subreaper. Set only here: a merged build must never arm this, because there the parent is whoever typed [flan dev] and not the session's owner. *) Unix.putenv "FLAN_DEV_PARENT" (string_of_int (Unix.getpid ())); (* Through a pipe, so the program's own output can reach an editor instead of only the terminal the daemon was started in. [~cloexec:true] on the pair and the dup onto the child's fd 1 is what actually gives it away: [create_process] dup2s [wr] onto the child's stdout and dup2 clears the flag, so the write end survives the exec while the read end — this daemon's own, and no business of the program's — does not. It used to be inherited, which is why a child held the read end of the pipe it was writing to; that also meant the pipe could never reach EOF while the child lived, so "wait for EOF on the daemon's end" was never the mechanism it looked like it could be. *) let rd, wr = Unix.pipe ~cloexec:true () 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 = 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 ignore_sigpipe (); (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.); 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 _ -> ())) (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. docs/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, and the half of it that has since been built. [main] still runs the program first and the compiler still comes up beside it, but the program finishing is no longer the end of anything: the main thread parks on a condition variable and the [rerun] op sends it round [main] again, which is the "opening the window is something the prompt asks for" half of the SBCL arrangement, arrived at from the other end. What is left of the difference is only the *first* run — [main] is entered because the process starts rather than because anybody asked — and the startup below is still the one place that 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. And [rerun] runs [main] and nothing else, deliberately — running a *named* function is what [eval-expr] already is, and the two should not grow into one verb with a mode. *) 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 #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); /* What a finished run leaves threaded through stack it no longer owns. Both * are emptied between runs; their own definitions say why. The frame chain is * flan_dev.c's, which is in every dev build and so in every merged one — weak * anyway, because a symbol that is only ever there by construction is exactly * the kind that stops being there quietly. */ extern void flan_condition_stacks_reset(void); extern void flan_dev_frames_reset(void) __attribute__((weak)); /* The agent's ring, drained on whatever thread calls this. Weak for the reason * the reset above is weak, and it is the same class of fact: a merged binary * links the agent by construction, which is exactly the kind of guarantee that * stops holding quietly. A build without one parks with no way to service a * thunk, which is the behaviour this file had before the park learned to. */ extern int32_t flan_agent_poll(void) __attribute__((weak)); /* ── The program's thread, between runs ────────────────────────────── */ /* A Flan main that finishes leaves this thread with nothing to do and the * process with everything still in it: the compiler, the session, the editor's * socket, and the program's own globals. Common Lisp and Clojure call that an * image, and the reason you can close a window and open another one there is * simply that main returning is not the end of anything. This is that, and it * is three pieces: somewhere for the thread to wait, a way for the compiler * thread to wake it, and a way back to main() from wherever the program * happened to finish. * * The thread matters and cannot be traded away. raylib's window, like every * GUI toolkit's, belongs to the thread that created it and on macOS belongs to * the *first* one; running the second main on a thread of its own would give * a window that does not draw and events that never arrive. So the main thread * is the one that parks and the one that is woken, and the compiler thread * only ever leaves a request here. * * Getting back to main() is a longjmp because there is no return to use. Emit * ends @main with a call to flan_exit and an unreachable, and flan_exit is * reached from wherever the program was — so the hook below is standing on the * finished run's stack with no way to unwind it. longjmp back to main()'s own * frame is the whole of the way out, and the two resets above are the price: * a longjmp pops no frame, so the handler, restart and shadow-frame chains * still point into stack the next run is about to write over. */ enum { PROGRAM_RUNNING = 0, PROGRAM_PARKED = 1 }; /* One lock over all three, so that "is it parked" and "wake it" cannot be * answered and acted on across a gap. The compiler thread takes it for a * comparison and a signal and nothing else — no dlopen, no allocation, no * call into OCaml — which is what keeps it clear of the loader lock this file * is careful about everywhere else. */ static pthread_mutex_t program_lock = PTHREAD_MUTEX_INITIALIZER; static pthread_cond_t program_wake = PTHREAD_COND_INITIALIZER; static int program_state = PROGRAM_RUNNING; static int program_asked = 0; /* a re-run has been requested */ static int program_poll = 0; /* something is waiting in the ring */ static int32_t program_status; /* what the last run ended with */ static jmp_buf program_return; /* main()'s frame, from anywhere */ /* 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. * * It used to close fd 1 here as well, so that the compiler thread learned the * program was done exactly as the two-process daemon learns it: the pipe reads * EOF, which is what the child's death used to cause. That cannot survive a * program that can run again. A pipe delivers EOF only once every write end is * gone, so the signal and the program's stdout were the same resource, and * spending it ended the program's ability to print for the rest of the * session. The second run would have had its output go nowhere. * * So fd 1 is left alone and the compiler reads [program_state] instead — a * question with an answer rather than an event with one delivery. The * descriptor hazard that made the old code reopen /dev/null onto fd 1 the * instant after closing it (POSIX hands out the lowest free descriptor, so the * compiler thread's next socket would have become this process's stdout, and * the next llc would have inherited it) goes away with the close that caused * it: fd 1 is never free. * * Nothing is flushed here either, and that is the same decision the park makes * one function down: a flush of a pipe nobody is reading is an unbounded wait, * and every line of it would be a line the compiler spends still believing the * program is running. [flan_merged_park] flushes once it has said otherwise. */ static void flan_merged_exit(int32_t status) { program_status = status; longjmp(program_return, 1); } /* Wait here until somebody asks for another run. * * The chains are cleared before the wait rather than after it, so that a * backtrace asked for while the program is parked walks an empty stack and * says so, instead of walking the finished run's. * * [while], not [if]: a condition variable may wake a waiter that nobody * signalled, and [program_asked] is the fact — the wakeup is only a hint that * it is worth looking again. * * THE STATE IS FLIPPED BEFORE ANYTHING IS FLUSHED, and the order is the whole * of a fix. stdout is a 64K pipe into this process, drained by the compiler * thread, which stops draining for as long as it is answering a request. A * program that printed as it ran leaves that pipe full when it finishes, so * the flush below can wait for a reader that is busy — and every moment it * waits is a moment [flan_merged_program_state] still answers RUNNING about a * program that is over. Close a window, press the key that runs it again, and * the answer was "the program is already running": the request itself was what * kept the reader from draining. The state flip is two stores under a lock and * cannot block on anything, so it goes first and the truth is available * immediately; the flush and the notice follow, and they are courtesies. * * What that widens is the window in which the program is PARKED and not yet * waiting. Nothing is lost in it: [flan_merged_rerun] sets [program_asked] and * signals under the same lock, a signal delivered to nobody is discarded, and * the [while] below reads the flag rather than the wakeup — so a request that * lands in the window is taken and the wait falls straight through. The one * visible cost is that two re-runs arriving in that window are both answered * "ok" for a single run. That race existed before and was a microsecond wide; * it is now as wide as a flush, which is the right trade against a refusal * that was simply false. * * ── THE SECOND THING THE PARK SERVICES ─────────────────────────────── * * A re-run was the only request this wait knew about, and that made the park * a state in which nothing at all could be asked of the program — so C-x C-e * on [(+ 1 1)] was refused with a sentence about frame boundaries, for an * expression that needs nothing from the program, in a process that is holding * every global the run left. The answer is not a second thread and not a * looser rule about where a thunk may run. It is that WHILE PARKED THERE IS NO * CONCURRENCY: this thread is asleep on a condition variable, no frame is * executing, nothing is mutating a global. Running the agent's ring here is * therefore exactly as safe as running it at a frame boundary, which is the * property the frame-boundary discipline exists to buy — and the break loop is * the precedent, a thread that is not running frames servicing the same ring * from the same poll. * * So the wait has two flags and not one, and the difference between them is * what the thread does next. [program_asked] leaves the park; [program_poll] * drains the ring and waits again. The program stays PROGRAM_PARKED across the * whole of the second — a thunk is not a run, and an editor that saw [:parked * nil] for the duration of a C-x C-e would show the program as live for a * moment that has no frames in it. * * A re-run is tested first, so a stream of evaluations cannot starve one. The * poll flag is cleared BEFORE the lock is dropped, which is what makes a * delivery landing during the poll set it again rather than be swallowed by a * clear on the way back; the cost is one empty poll, and the alternative is a * thunk that waits out the five seconds for no reason anyone can see. * * And the poll runs with the lock DROPPED, which is not an optimisation. It * dlopens, it runs Flan code, and that code may error into the break loop and * stay there until somebody resumes it — all of it while the compiler thread * is asking [flan_merged_program_state] on every reply it writes. Holding the * lock across any of that would deadlock the daemon against its own program. */ static void flan_merged_park(void) { flan_condition_stacks_reset(); if (flan_dev_frames_reset) flan_dev_frames_reset(); pthread_mutex_lock(&program_lock); program_state = PROGRAM_PARKED; pthread_mutex_unlock(&program_lock); fflush(NULL); fprintf(stderr, "flan dev: the program finished with %d; the process is parked and " "its globals are as it left them — M-x flan-rerun runs it again\n", (int)program_status); fflush(stderr); pthread_mutex_lock(&program_lock); for (;;) { while (!program_asked && !program_poll) pthread_cond_wait(&program_wake, &program_lock); if (program_asked) break; program_poll = 0; pthread_mutex_unlock(&program_lock); if (flan_agent_poll) flan_agent_poll(); /* The thunk's output is the reason anyone evaluated anything, and the * compiler thread puts it on the reply it is about to write. A run flushes * at its own pace and the park flushes once on the way in; neither covers * a thunk that printed after both. */ fflush(NULL); pthread_mutex_lock(&program_lock); } program_asked = 0; program_state = PROGRAM_RUNNING; pthread_mutex_unlock(&program_lock); } /* The two the compiler thread calls, through the weak symbols in * lib/dynload_stubs.c. Both are a lock, a couple of stores and an unlock: the * rule that the game thread never enters OCaml has a mirror image, which is * that the compiler thread must never do anything here that could take long * enough to be noticed on a frame. * * [flan_merged_rerun] refuses a program that is already running rather than * remembering the request, and that refusal is the only one there can be: the * test and the signal are under the same lock, so a request that arrives * between the finished run's longjmp and the park is either seen as running * (refused, and the program parks a moment later) or seen as parked (taken). * The park flips the state before it flushes, so the second is now the usual * answer rather than the lucky one, and what that widens is written out * there. Queueing it instead would mean a second main starting the * instant the first finished, which is never what somebody pressing a key * meant. */ int flan_merged_rerun(void) { int rc; pthread_mutex_lock(&program_lock); if (program_state != PROGRAM_PARKED) rc = 1; else { program_asked = 1; pthread_cond_signal(&program_wake); rc = 0; } pthread_mutex_unlock(&program_lock); return rc; } /* Tell a parked thread that its ring is not empty. * * The sibling of [flan_merged_rerun] and deliberately the smaller one: it sets * the other flag, so the thread wakes, drains the ring and waits again without * ever leaving the park. Nothing here decides what is in the ring or waits for * a result — that is the compiler thread's business, and a lock held across * either would be the one thing the note above [flan_merged_rerun] forbids. * * A running program is refused rather than woken, because there is nothing to * wake: its game thread reaches a frame boundary on its own and polls there. * The caller treats that as "no wake was needed", not as a failure. */ int flan_merged_wake(void) { int rc; pthread_mutex_lock(&program_lock); if (program_state != PROGRAM_PARKED) rc = 1; else { program_poll = 1; pthread_cond_signal(&program_wake); rc = 0; } pthread_mutex_unlock(&program_lock); return rc; } int flan_merged_program_state(void) { int s; pthread_mutex_lock(&program_lock); s = program_state; pthread_mutex_unlock(&program_lock); return s; } /* The socket is this process's to remove, and on every way out of it and not * only the tidy one. A merged daemon that dies through a runtime trap -- a * bounds failure, an unhandled condition, an abort taken at the break loop -- * leaves the path on disk with nothing behind it, and the next client's * connect is then ECONNREFUSED: a socket that plainly exists, refusing. That * message has already sent two investigations in this repository to the wrong * place. Gone is the honest state, and the client already has words for it. * * [atexit] covers exit(3), and what is left taking exit(3) here is narrower * than it was: the two places a program dies where it stands — rt_die in * flan_rt.c and die_now in flan_agent.c — both take _exit, because the atexit * chain and the ELF destructors want the loader lock a dlopening listener * thread may be holding, and in this build that chain also holds OCaml's * shutdown. Both therefore unlink this path by hand, so the same four lines * exist in three places rather than one — sharing them would mean a runtime * that links against the daemon, which is a worse trade than the repetition. * * What is left for this one is every exit(3) nobody planned — an OCaml fatal * on the compiler thread most of all, since [Stdlib.exit] ends in the C one. * Four lines on a path nobody means to take is the right price for a socket * that never sits on disk refusing connects. */ static void flan_merged_unlink_sock(void) { const char *s = getenv("FLAN_DEV_SOCK"); if (s != NULL && *s != '\0') unlink(s); } 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; volatile int rc = 0; g_argv = argv; atexit(flan_merged_unlink_sock); 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. * * A loop, and that is the feature. This used to be one call and an _exit * underneath it, with a note saying that the line REPL-first would delete is * exactly this one — park here instead, and the window becomes something the * prompt asks for rather than the thing the process is. This is that edit. * The process no longer ends when the program does; it goes back round. * * Two ways out of a run and both land here. A Flan main ends in flan_exit, * which the hook turns into a longjmp back into [setjmp] below — that is the * ordinary path, and the one closing a raylib window takes. A main that * somehow returns normally falls out of the call instead, and is worth no * different treatment: it finished, so it parks, and its status is the one * it returned. * * [volatile] because [rc] is written between the [setjmp] and the [longjmp] * and read after it, which is the one thing C promises nothing about. * * Nothing here _exits any more, so the old note about _exit against exit has * moved to [merged_serve], which is now the only place the process ends: 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 hand-written [flan_merged_unlink_sock] that * used to sit under this function's _exit went with it for the same reason — * there is no way out of here any more to unlink on. The [atexit] * registration above stays, and no longer because of the trap: rt_die takes * _exit now and unlinks for itself, exactly as die_now does. What is left * for it is written at [flan_merged_unlink_sock]. */ for (;;) { if (setjmp(program_return) == 0) { rc = flan_program_main(argc, argv); program_status = (int32_t)rc; } flan_merged_park(); } } |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"); (* [lib] again, as a library search path. The macro work gave [lib/dune] a [foreign_stubs] stanza, so [flan.cmxa] now records a dependency on [-lflan_stubs] and the linker has to be told where dune put the archive. Without this the merged object fails with "cannot find -lflan_stubs" and only [--two-process] works. *) "-cclib"; Filename.quote ("-L" ^ lib); "-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 same rename on assembly, for an [--x86] merged build. [X86.emit_main] writes exactly one [main] with no quotes around it -- every Flan symbol is quoted and prefixed, so ["flan.main"] cannot be confused for it -- and the two places it appears are the header and the [.size] that closes it. The spike's finding holds here too: the rename is all it takes. *) let rename_program_main_asm asm = let hdr = "\t.globl\tmain\n\t.type\tmain, @function\nmain:\n" and hdr' = "\t.globl\tflan_program_main\n\t.type\tflan_program_main, @function\n\ flan_program_main:\n" and siz = "\t.size\tmain, . - main\n" and siz' = "\t.size\tflan_program_main, . - flan_program_main\n" in let replace hay needle by = let n = String.length needle and h = String.length hay in let rec go i = if i + n > h then None else if String.sub hay i n = needle then Some i else go (i + 1) in match go 0 with | None -> failwith "no main in the emitted assembly — the merged build renames it so a C \ main can own the process" | Some i -> String.sub hay 0 i ^ by ^ String.sub hay (i + n) (h - i - n) in replace (replace asm hdr hdr') siz siz' (* 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 (* The same one fork [Build.executable] has: the dev backend hands clang an assembly file where LLVM hands it IR text, and clang takes either on its command line, so everything past this point is the same link. *) write ll (if opts.x86 then rename_program_main_asm (X86.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug p) else rename_program_main (Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames ~sanitize:opts.sanitize p)); 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" :: [ cc Runtime_src.dyn_source "flan_dyn.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 (* The hand-written DWARF 4 compile unit in the .s, for the reason [Build.executable] gives at the same place: the assembler's own stub line table is a DWARF 5 header otherwise, and readelf calls it corrupt. *) @ (if opts.x86 && opts.debug then [ "-gdwarf-4" ] else []) (* 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 let x86 = Sys.getenv_opt "FLAN_DEV_X86" = 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 ~x86 ~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 ignore_sigpipe (); (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 (* The executable has just replaced the launcher, and recreates the session above in order to own it for the rest of the dev run. That is still a frontend boundary: rendering [Loc.Error] as an exception constructor here loses the source location, the reason, its span, and any notes. It also made a source error look like a compiler crash after an apparently successful build. Keep this identical to the command driver's reporting for both the one-error and whole-file-error channels. *) | Loc.Error d -> Printf.eprintf "%s\n%!" (Loc.report d); exit 1 | Loc.Errors ds -> Printf.eprintf "%s\n%!" (Loc.report_all ds); exit 1 | Failure m -> Printf.eprintf "flan dev: %s\n%!" m; exit 1 | e -> Printf.eprintf "flan dev: %s\n%!" (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 so now does an editor that stopped being there; in one process either 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) ?(x86 = true) ~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 ~x86 ~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 (if x86 then "host.s" else "host.ll") in ignore (merged_executable ~opts:{ Build.default with Build.dev = true; Build.debug; Build.x86 } ~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"); (* The session is rebuilt inside the exec'd binary, and it has to come back with the same backend: the modules it emits are loaded into this very process, which was just compiled by that backend. *) Unix.putenv "FLAN_DEV_X86" (if x86 then "1" else "0"); (* Not read by the exec'd binary's dev path but by [Macro]: the merged binary expands the prelude a second time, and the object cache's macro key is keyed on the compiler's identity. Its own [Sys.executable_name] is this session's throwaway under /tmp, new on every start, so without this the macro module is rebuilt per session. See the note on [Macro.self]. *) Unix.putenv "FLAN_COMPILER_STAMP" (Build.stamp_of Sys.executable_name); (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) ?(x86 = true) ~file ~sock () = (* x86 unless told otherwise, and the default is here rather than only in [bin/main.ml] so that there is one answer to "what backend is a dev session". A library caller that starts a daemon starts the same daemon the editor does; the CLI passes this explicitly and never leans on it, but a default that disagreed with the command would be a second answer nobody had written down. *) (* [--x86] and [--debug] are refused together here, and only here: [flan build --x86 --debug] is deliberately allowed, because [X86.program] emits a hand-written DWARF 4 unit. [X86.redefinition] does not, so a [--debug] session would build a host with a line table and then send it modules with none -- a breakpoint on a line in the buffer would fire before the first C-c C-c and stop firing after it, which is worse than not offering the combination. Accepting the flag and ignoring it would be worse still. Now that x86 is the default, this is reachable only by asking for it: [bin/main.ml] lets [--debug] alone select LLVM, precisely so that the one flag a person types to get a debugger does not land on the backend that has no line table for a redefinition. Writing both is still writing both, and it is still refused. *) if x86 && debug then failwith "flan dev --x86 --debug: the dev backend emits DWARF for a whole program \ but not yet for a redefinition module, so a breakpoint set on a line \ would stop firing at the first C-c C-c. Drop --x86 and --debug will \ build this session with LLVM, which has both."; (* The merged daemon used to be refused here for [--x86] and no longer is, and what made the combination safe is worth stating where the refusal stood. A merged build is the program and the compiler in one process, and the compiler expands macros by [dlopen]ing a module [Build.macro_module] made -- through [Emit.program], always, so always LLVM whatever backend this session uses. A merged host is linked [-rdynamic] so a redefinition module can reach its cells, and that also exports every [flan.*] body the host has; ELF gives the executable precedence, so the macro module's own copy of a prelude function used to be interposed by the host's. In an LLVM session both copies are LLVM and nobody notices. In an [--x86] one the caller is LLVM and the body it landed in was this backend's, which is the crossed pair -- measured as a SIGSEGV inside [flan.\[clamp\]] during the *first* macro expansion, before the program had started. [Build.macro_module] now asks [Emit.program] for [~hidden:true], which takes every Flan definition in that module out of the dynamic symbol table and leaves only the [flan.macro.*] thunks [dlsym] has to find. There is nothing left for the host to interpose, so the two backends never meet inside an expansion however the host was built. Nothing about the host moved: it still exports its cells, its globals and [flan_dev_cell] to redefinition modules exactly as before, because the fix is on the module that is loaded and not on the process that is loading it. [--x86 --debug] above is still refused, and for a reason that has nothing to do with this one. *) if merged then start_merged ~debug ~x86 ~file ~sock () else two_process ~debug ~x86 ~file ~sock ()