The dev daemon re-runs under two processes, knows whose break it is, guards its socket, runs under sanitizers, and unloads evaluated modules
This commit is contained in:
commit
d5978aeab8
@ -262,9 +262,9 @@ driver at all — it goes `llc` + `ld -shared` + `dlopen`, which is what makes
|
||||
is a confusing shape of failure to meet without warning.
|
||||
|
||||
Variables beginning `FLAN_DEV_` other than `FLAN_DEV_LEAKS`, plus
|
||||
`FLAN_AGENT_SOCKET` and `FLAN_COMPILER_STAMP`, are internal: `flan dev` sets
|
||||
them across its own `exec` to hand the merged binary what it needs. Setting
|
||||
them by hand is not supported.
|
||||
`FLAN_AGENT_SOCKET`, `FLAN_AGENT_OWNER` and `FLAN_COMPILER_STAMP`, are
|
||||
internal: `flan dev` sets them across its own `exec` to hand the merged binary
|
||||
what it needs. Setting them by hand is not supported.
|
||||
|
||||
## Checking it
|
||||
|
||||
|
||||
52
TODO.org
52
TODO.org
@ -1484,10 +1484,6 @@ out the first element typing the rest.
|
||||
|
||||
* Dev loop
|
||||
|
||||
** TODO Every evaluated expression leaves its module mapped
|
||||
Each C-x C-e loads its own =.so= and never unloads it, so a session's mapping count
|
||||
grows by about four per evaluation; the kernel's limit (65530) ends a long session.
|
||||
|
||||
** TODO A prelude function shadowed live is reached by the prelude's own calls
|
||||
A defn of a prelude function's name sent to a running =flan dev= installs into the
|
||||
host's cell for that name, so the prelude's calls compiled into the host follow it;
|
||||
@ -1529,12 +1525,6 @@ A finished program parks instead of dying, and a daemon op wakes it and re-enter
|
||||
Globals are not reset between runs — the process never died. Rules out a fresh
|
||||
process per run.
|
||||
|
||||
** NEXT Re-run does not work under --two-process
|
||||
Decided 2026-09-25: re-run under =--two-process= starts a fresh child, installed redefinitions included, and says that globals start over because the process is new.
|
||||
A finished child process is genuinely gone, so there is nothing to wake. Re-run is
|
||||
merged-build only, and since the default backend runs merged it is no longer the
|
||||
blocked case.
|
||||
|
||||
** DONE An accepted re-run reads as running
|
||||
CLOSED: [2026-09-21]
|
||||
A caller that asked for a re-run and then waited for the program to park was
|
||||
@ -1570,14 +1560,6 @@ was delivered" is a generation number rather than a name, so evaluating from
|
||||
inside a break into a thunk that stops on the same condition class is settled by
|
||||
comparing two integers.
|
||||
|
||||
** NEXT Whose break it is, which no counter answers
|
||||
Decided 2026-09-25: fix it. A stop records whether the thread that stopped was running the evaluation's thunk or the program's own code, so the sentence is decided by the frame and not by the generation counter.
|
||||
A game loop that signals during the build or the wait bumps the generation exactly
|
||||
as a thunk would. The machine-readable fields stay right; what is wrong is the
|
||||
sentence. The per-frame program-or-eval label is computed by the daemon from
|
||||
ownership, not from anything in the frame, so this is not the shadow-stack gap it
|
||||
was once written down as. Not queued — the window is narrow.
|
||||
|
||||
** DONE The first evaluation no longer stalls behind the agent socket
|
||||
The accept loop used to sit behind a ten-second wait for the agent socket, so a
|
||||
program that binds its socket late — or not at all — looked ready and answered
|
||||
@ -1623,13 +1605,6 @@ prunes a package nothing calls into in a release build. =flan dev= links the
|
||||
agent's C into every program it builds whether or not the source imports it; a
|
||||
release build links it only when the program calls into it.
|
||||
|
||||
** NEXT FLAN_AGENT_SOCKET in a shell's environment steals the socket
|
||||
Decided 2026-09-25: narrow the gate. The daemon also exports its own pid, and the constructor binds the socket only when that pid is the program's parent (or the program itself, in a merged build).
|
||||
Binding unlinks the path first, and before the constructor that unlink was reached
|
||||
only by an explicit call. A sentence about the shape of the gate rather than an
|
||||
observed problem: only the daemon sets the variable and it never runs release
|
||||
builds. The fix, if it is ever felt, is a narrower gate.
|
||||
|
||||
** DONE The daemon's "has not called (agent/start ...)" note is unreachable
|
||||
CLOSED: [2026-09-25]
|
||||
Retired, with the matching arm of an evaluation's timeout, because it named the
|
||||
@ -1729,10 +1704,11 @@ out versioned bodies and trampolines, and redirecting a value taken before the
|
||||
change. =main= stays refused: its caller is startup code no cell reaches.
|
||||
docs/BUILT.md, "A signature change installs".
|
||||
|
||||
** DONE A module carrying a string literal is never unloaded
|
||||
The transient rule is that a module retaining nothing may go, and a string literal
|
||||
counts as something retained — which silently stopped every module carrying one
|
||||
from ever being unloaded. That is why frame descriptors got their own counter.
|
||||
** DONE An expression's module is unloaded unless it hands out a constant
|
||||
CLOSED: [2026-09-25]
|
||||
A thunk's string literal is a copy the process keeps, and registry names and initial
|
||||
images are copied by the runtime, so none of them pins the module; a condition's
|
||||
name or a restart's text still does. Rules out unloading on a guess about a literal.
|
||||
|
||||
** DONE A redefinition delivered while parked installs on the next re-run
|
||||
The park used to drain the agent ring only when something had asked it to poll,
|
||||
@ -1778,13 +1754,6 @@ nothing orders the two. The read raised on a closed socket and the test binary
|
||||
exited 1 with no failure line, which is the worst shape a failure can have when
|
||||
a lane is judged on the exit status.
|
||||
|
||||
** NEXT A program driven by a real flan dev daemon under a sanitizer
|
||||
Decided 2026-09-25: =flan dev --sanitize= builds the host under ASan/UBSan on the LLVM backend (refused by name with =--x86=), and the @sanitize alias gains a case driving a real session through reloads and a break.
|
||||
The daemon builds its host through its own path and the CLI has no way to pass a
|
||||
sanitizer flag to it. Named as the check worth adding next; a day rather than an
|
||||
hour. The x86 backend is not a gap here — that pair is refused by name, because
|
||||
there is no sanitizer pass over hand-written assembly.
|
||||
|
||||
** DONE A transient signal 11 on a globals daemon
|
||||
CLOSED: [2026-09-25]
|
||||
Not a segfault. The report was OCaml's signal number, and in OCaml's numbering
|
||||
@ -1836,11 +1805,12 @@ line and every later row unrun.
|
||||
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
|
||||
not.
|
||||
|
||||
** TODO An x86 dev session's dyn global sometimes reads wrong after an allocating thunk
|
||||
test_dev's =--x86: after a thunk that allocates (cycle 1) the parked program's dyn
|
||||
global reads "kept"= failed once in a full =dune test= on 2026-09-25 and passed three
|
||||
direct reruns. Intermittent and GC-shaped: a dyn global read after a collection a
|
||||
C-x C-e thunk triggered. Needs reproducing under load and fixing.
|
||||
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
|
||||
WAIT on a recurrence; the test now prints the failing read's own reply.
|
||||
The one failure's message came from a second read, which said "kept"; the failing
|
||||
reply itself was not recorded. Not reproduced in 350 churn-and-read cycles under
|
||||
8-way load, three concurrent test_dev runs, or a valgrind run of the cycle, which
|
||||
was clean.
|
||||
|
||||
* Editor
|
||||
|
||||
|
||||
12
bin/main.ml
12
bin/main.ml
@ -799,7 +799,11 @@ let () =
|
||||
which is the point of leaving it readable here — the combination stays
|
||||
refused by name, it is just no longer somewhere you arrive by typing one
|
||||
flag. *)
|
||||
let x86 = backend_x86 ~default:(not debug) rest in
|
||||
(* --sanitize takes [--llvm]'s side for the reason [--debug] does: the
|
||||
sanitizers are LLVM passes. [--x86] written as well is refused by name
|
||||
in [Dev.start]. *)
|
||||
let sanitize = List.mem sanitize_flag rest in
|
||||
let x86 = backend_x86 ~default:(not (debug || sanitize)) rest in
|
||||
let asked_x86 = List.mem x86_flag rest in
|
||||
let merged = not (List.mem two_process_flag rest) in
|
||||
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
||||
@ -809,8 +813,8 @@ let () =
|
||||
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
|
||||
| _ ->
|
||||
prerr_endline
|
||||
"usage: flan dev <program.flan> [-s socket] [--debug] [--llvm] \
|
||||
[--two-process]";
|
||||
"usage: flan dev <program.flan> [-s socket] [--debug] [--sanitize] \
|
||||
[--llvm] [--two-process]";
|
||||
exit 2
|
||||
in
|
||||
(* Only this command hands one over, and only when it chose the backend
|
||||
@ -826,7 +830,7 @@ let () =
|
||||
else None
|
||||
in
|
||||
with_errors ?x86_hint path (fun () ->
|
||||
Flan.Dev.start ~debug ~merged ~x86 ~file:path ~sock ())
|
||||
Flan.Dev.start ~debug ~sanitize ~merged ~x86 ~file:path ~sock ())
|
||||
|
||||
(* One redefinition, built the way an editor will ask for it: a session over
|
||||
the program the process was built from, and a file of the forms that
|
||||
|
||||
@ -1045,8 +1045,9 @@ the two builds are *supposed* to differ, since `flan_dev_crash_enable` checks a
|
||||
install the handler when ASan is in the process. So the case asserts ASan's report and the absence of the handler's
|
||||
line, built at `-O0` because at `-O2` a store through a zeroed `(Ptr u8)` is undefined and need not fault. That yield had
|
||||
never run in any build anywhere: it was behind a link that did not happen. Twenty-six seconds of the alias's 2m30 warm.
|
||||
What it still does not reach is a program driven by a real daemon under ASan: `flan dev` builds its host through its own
|
||||
path and has no `--sanitize` to pass it.
|
||||
`dev_session` drives a real `flan dev --sanitize` session — merged, LLVM, the compiler's OCaml in the same process as
|
||||
the sanitized host — through a break, three reloads and a second break; the modules it sends are still not
|
||||
instrumented.
|
||||
|
||||
**Two aliases were green only because `dune test` runs first, and that is the same disease in a different place.**
|
||||
`@sanitize` never listed the package directories `pkg-diamond.flan` imports and `@page` never listed `sand.flan`, which
|
||||
@ -1821,7 +1822,9 @@ shape TODO.org's "The compiler is a thread inside the program" landed on: **the
|
||||
program's process. It is SLIME's model — you start the image, it serves, the editor connects.
|
||||
|
||||
`--two-process` is the escape hatch, for a machine where the compiler object cannot be built (no `ocamlfind`, no
|
||||
`flan.cmxa` beside the binary). It has its own test and it stays.
|
||||
`flan.cmxa` beside the binary). It has its own test and it stays. A re-run there is a new child built from the session
|
||||
as it stands, so the redefinitions are in it and the globals start over; the daemon outlives a finished child to take
|
||||
that request.
|
||||
|
||||
**The editor socket and its wire protocol did not move.** Emacs cannot tell the difference, which is what made the merge
|
||||
testable: the whole existing suite is the check.
|
||||
|
||||
273
lib/dev.ml
273
lib/dev.ml
@ -28,11 +28,15 @@ type 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;
|
||||
this layer — see [merged_setup] for why there is no third case. A re-run
|
||||
under --two-process replaces the child with a new one. *)
|
||||
mutable 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 *)
|
||||
mutable stdout : Unix.file_descr; (* the program's output, on its way here *)
|
||||
(* --two-process only: build the program again from the session as it is
|
||||
now and start it, answering the new child and its stdout. *)
|
||||
relaunch : (unit -> int * Unix.file_descr) option;
|
||||
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
|
||||
@ -268,10 +272,41 @@ let deliver_at_stop t ~gen path =
|
||||
[None] where the program cannot be reached or answers something else, and
|
||||
the caller treats that the way it treats a missing refusal count: as no
|
||||
evidence, not as zero. Zero is a fact — it means running. *)
|
||||
let stop_gen t : int option =
|
||||
let stop_reply t =
|
||||
match request t "stop" with
|
||||
| exception Unix.Unix_error _ -> None
|
||||
| text -> int_of_string_opt (String.trim text)
|
||||
| text ->
|
||||
(match String.split_on_char ' ' (String.trim text) with
|
||||
| g :: rest ->
|
||||
Option.map (fun g -> (g, rest)) (int_of_string_opt g)
|
||||
| [] -> None)
|
||||
|
||||
let stop_gen t : int option = Option.map fst (stop_reply t)
|
||||
|
||||
(* How many evaluated expressions the agent has queued, and the highest one
|
||||
that has returned a value; [None] from an agent without the verb. *)
|
||||
let calls t : (int * int) option =
|
||||
match request t "calls" with
|
||||
| exception Unix.Unix_error _ -> None
|
||||
| text ->
|
||||
(match String.split_on_char ' ' (String.trim text) with
|
||||
| [ q; v ] ->
|
||||
(match int_of_string_opt q, int_of_string_opt v with
|
||||
| Some q, Some v -> Some (q, v)
|
||||
| _ -> None)
|
||||
| _ -> None)
|
||||
|
||||
(* The same stop with whose code it stopped in: [Some true] when the thread
|
||||
was running an evaluated thunk, [Some false] when it was in the program's
|
||||
own code, [None] from an agent that does not say. *)
|
||||
let stop_owner t : (int * bool option) option =
|
||||
Option.map
|
||||
(fun (g, rest) ->
|
||||
(g, match rest with
|
||||
| [ "eval" ] -> Some true
|
||||
| [ "program" ] -> Some false
|
||||
| _ -> None))
|
||||
(stop_reply t)
|
||||
|
||||
(* 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.
|
||||
@ -804,7 +839,8 @@ let build_module (c : Session.change) ~debug ~out =
|
||||
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.
|
||||
true: there is no process left and nothing short of a new one will help —
|
||||
which, under --two-process, a re-run is.
|
||||
|
||||
[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
|
||||
@ -815,7 +851,7 @@ let build_module (c : Session.change) ~debug ~out =
|
||||
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 gone = "the program exited; M-x flan-rerun starts it again"
|
||||
|
||||
let parked_msg why =
|
||||
why
|
||||
@ -1018,7 +1054,25 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
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
|
||||
if now = Gone && t.relaunch <> None then
|
||||
(* --two-process, the child ended: the form is checked into the session
|
||||
and nothing is sent, because the next process is built from the
|
||||
session whole ([rerun]). *)
|
||||
match
|
||||
Session.eval ~origin ?base ?forms ?pause ~running:false t.session code
|
||||
with
|
||||
| c ->
|
||||
ok
|
||||
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
|
||||
":note "
|
||||
^ Wire.quote
|
||||
"loaded; the program has ended, so this is in it when M-x \
|
||||
flan-rerun starts it again" ]
|
||||
@ extra)
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
Session.restore t.session before;
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
else if now = Gone then error gone
|
||||
else
|
||||
match
|
||||
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
|
||||
@ -1212,6 +1266,10 @@ let eval_expr t ~code ~origin ~pause =
|
||||
match Session.eval_expr ~origin ~pause t.session code with
|
||||
| c ->
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
(* This expression's number among those the agent has queued: an
|
||||
earlier one resumed by a restart can publish after this one is sent,
|
||||
and the result counter alone would take its value for this one's. *)
|
||||
let mine = Option.map (fun (q, _) -> q + 1) (calls t) in
|
||||
(* Read here, beside [before], and for the same kind of reason: all
|
||||
three are the "how things stood" half of a difference the wait below
|
||||
measures. A program already sitting in a break when the request
|
||||
@ -1225,17 +1283,9 @@ let eval_expr t ~code ~origin ~pause =
|
||||
the reason [stop_gen]'s note gives at its definition. The name is kept
|
||||
beside it as the fallback for an agent that cannot answer the verb.
|
||||
|
||||
As early as it usefully can be, and still not early enough to be
|
||||
exact: [build_module] below takes a couple of hundred milliseconds,
|
||||
and a game loop that signals *on its own* during them — or mid-wait,
|
||||
while the thunk is still perfectly fine — bumps the generation too.
|
||||
The reply then says "the expression stopped on X" about an expression
|
||||
that had not run. Its machine-readable half stays right, so the editor
|
||||
opens the break the program is actually in; only the sentence is
|
||||
wrong, and no counter closes this one, because the program's break and
|
||||
the thunk's are the same kind of event. Separating them wants the
|
||||
per-frame origin the backtrace carries, which is LLVM-only.
|
||||
TODO.org, "Whose break it is, which no counter answers" has it. *)
|
||||
A game loop that signals *on its own* while this is in flight bumps
|
||||
the generation too, so a fresh stop is not yet the thunk's. The stop
|
||||
itself says whose it is — see [settled] below. *)
|
||||
let entered = state t in
|
||||
let entered_gen = stop_gen t in
|
||||
t.n <- t.n + 1;
|
||||
@ -1323,12 +1373,17 @@ let eval_expr t ~code ~origin ~pause =
|
||||
re-stop between them could pair a stale name with a fresh
|
||||
generation; it cannot manufacture one, since the generation only
|
||||
climbs when a break really was entered. *)
|
||||
(* A fresh stop in the program's own code is not an answer: the
|
||||
thunk has not run, and the break loop that stop entered polls
|
||||
the ring, so the thunk runs inside it and its value arrives on
|
||||
a later tick. *)
|
||||
let settled now =
|
||||
match now with
|
||||
| Stopped c ->
|
||||
let fresh =
|
||||
match stop_gen t, entered_gen with
|
||||
| Some g, Some g0 -> g > g0
|
||||
match stop_owner t, entered_gen with
|
||||
| Some (_, Some false), _ -> false
|
||||
| Some (g, _), Some g0 -> g > g0
|
||||
| _ ->
|
||||
(match entered with Stopped c0 -> c0 <> c | _ -> true)
|
||||
in
|
||||
@ -1368,9 +1423,16 @@ let eval_expr t ~code ~origin ~pause =
|
||||
the sleep has to stay a sleep. *)
|
||||
drain t;
|
||||
let value () =
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ -> None
|
||||
let returned =
|
||||
match mine, calls t with
|
||||
| Some m, Some (_, v) -> v >= m
|
||||
| _ -> true
|
||||
in
|
||||
if not returned then None
|
||||
else
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ -> None
|
||||
in
|
||||
match value () with
|
||||
| Some v -> `Value v
|
||||
@ -3643,7 +3705,54 @@ let abort t =
|
||||
park, the next request went out while the first run had not started, and the
|
||||
pair of them produced one run — or, a moment later, a refusal saying the
|
||||
program was already running. Both faces are gone with the lag. *)
|
||||
(* Under --two-process a finished child is gone and there is no thread to
|
||||
wake, so a re-run is a new process: the program is built again from the
|
||||
session as it stands, which puts every accepted redefinition in it from
|
||||
the start, and its globals start over. *)
|
||||
let relaunch_child t relaunch =
|
||||
match liveness t with
|
||||
| Live | Parked ->
|
||||
error
|
||||
(if parked_break t then
|
||||
"the program is stopped at a break, so it cannot be started again \
|
||||
until that ends: resume it or abort it"
|
||||
else
|
||||
"the program is still running; a re-run starts it again in a new \
|
||||
process once this one has finished. Close its window, or let it \
|
||||
finish, and ask again")
|
||||
| Gone ->
|
||||
(* The whole program is checked again first ([Session.rehost]); a caller
|
||||
left compiled against a signature that has since changed is where
|
||||
that fails. *)
|
||||
let refused (d : Loc.diag) =
|
||||
error ~loc:(Loc.to_string d.Loc.dloc)
|
||||
("a re-run builds the whole program again, and it does not compile: "
|
||||
^ d.Loc.dmsg ^ ". Fix this and load it with C-c C-c, then ask again")
|
||||
in
|
||||
(match relaunch () with
|
||||
| child, rd ->
|
||||
drain t;
|
||||
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
|
||||
t.stdout <- rd;
|
||||
t.child <- Some child;
|
||||
t.finished <- false;
|
||||
t.died <- None;
|
||||
(* Every body is in the new host now, so no module owns one. *)
|
||||
Hashtbl.reset t.owners;
|
||||
ok
|
||||
[ ":note "
|
||||
^ Wire.quote
|
||||
"started the program again in a new process, built with every \
|
||||
change loaded so far; its globals start over, because the \
|
||||
process is new" ]
|
||||
| exception Failure m -> error m
|
||||
| exception Loc.Error d -> refused d
|
||||
| exception Loc.Errors (d :: _) -> refused d)
|
||||
|
||||
let rerun t =
|
||||
match t.relaunch with
|
||||
| Some relaunch -> relaunch_child t relaunch
|
||||
| None ->
|
||||
match liveness t with
|
||||
| Gone -> error gone
|
||||
(* A file started with no [main] runs a stub that returns at once; running
|
||||
@ -5062,8 +5171,11 @@ let accept_loop ?grace t ls =
|
||||
where a session with no editor attached spends its time. *)
|
||||
agent_check t;
|
||||
match liveness t with
|
||||
| Gone -> ()
|
||||
| (Live | Parked) as live ->
|
||||
| Gone when t.relaunch = None -> ()
|
||||
| live ->
|
||||
(* A --two-process child that has ended can be started again, so the
|
||||
session waits as a parked one does, on the parked grace. *)
|
||||
let live = if live = Gone then Parked else live in
|
||||
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
|
||||
@ -5076,7 +5188,10 @@ let accept_loop ?grace t ls =
|
||||
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
|
||||
(* Not once it has read EOF: an ended child's pipe is readable for
|
||||
ever, and the loop would spin on it. *)
|
||||
let fds = if t.finished then [ ls ] else [ ls; t.stdout ] in
|
||||
match Unix.select fds [] [] 0.2 with
|
||||
| [], _, _ -> go ()
|
||||
| ready, _, _ when not (List.mem ls ready) -> drain t; go ()
|
||||
| _ ->
|
||||
@ -5224,7 +5339,7 @@ let report_dropped ~file = function
|
||||
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 two_process ?(debug = false) ?(sanitize = 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
|
||||
@ -5251,19 +5366,22 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
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. *)
|
||||
let _, kept =
|
||||
Build.executable
|
||||
~opts:{ Build.default with Build.dev = true; Build.keep = true;
|
||||
Build.debug; Build.x86 }
|
||||
~csrcs ~lflags session.Session.host ~out:exe
|
||||
in
|
||||
(* 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
|
||||
(match kept with
|
||||
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
|
||||
| None -> ());
|
||||
let build_host () =
|
||||
let _, kept =
|
||||
Build.executable
|
||||
~opts:{ Build.default with Build.dev = true; Build.keep = true;
|
||||
Build.debug; Build.sanitize; Build.x86 }
|
||||
~csrcs ~lflags session.Session.host ~out:exe
|
||||
in
|
||||
match kept with
|
||||
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
|
||||
| None -> ()
|
||||
in
|
||||
build_host ();
|
||||
let agent = Filename.concat dir "agent.sock" in
|
||||
|
||||
(* The program's source names some socket path; the daemon is the one that
|
||||
@ -5271,6 +5389,10 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
environment. Guessing instead would fail silently — everything compiles,
|
||||
the module is built, and nothing ever receives it. *)
|
||||
Unix.putenv "FLAN_AGENT_SOCKET" agent;
|
||||
(* The child binds that path only if this pid is its parent, so a process
|
||||
that merely inherited the variable leaves the socket alone
|
||||
(flan_agent.c, [daemon_socket]). *)
|
||||
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
|
||||
(* 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
|
||||
@ -5295,23 +5417,39 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
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 did not open its agent socket at " ^ agent
|
||||
^ ". Under --two-process every edit reaches the program through that \
|
||||
socket.")
|
||||
end;
|
||||
let spawn () =
|
||||
(* A socket file a previous child left behind would answer the wait below
|
||||
before this child has bound anything. *)
|
||||
(try Unix.unlink agent with Unix.Unix_error _ -> ());
|
||||
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 _ -> ());
|
||||
(try Unix.close rd with Unix.Unix_error _ -> ());
|
||||
failwith
|
||||
("the program did not open its agent socket at " ^ agent
|
||||
^ ". Under --two-process every edit reaches the program through that \
|
||||
socket.")
|
||||
end;
|
||||
(child, rd)
|
||||
in
|
||||
let child, rd = spawn () in
|
||||
(* A re-run: the host is built again from the session as it stands, so
|
||||
every redefinition accepted so far is in the new process from its first
|
||||
instruction rather than delivered to it later. *)
|
||||
let relaunch () =
|
||||
Session.rehost session;
|
||||
build_host ();
|
||||
spawn ()
|
||||
in
|
||||
|
||||
let t =
|
||||
{ session; child = Some child; agent; dir; stdout = rd;
|
||||
relaunch = Some relaunch;
|
||||
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
|
||||
host_ll; host_exe = exe; finished = false; agent_watch = None;
|
||||
park_noted = false; died = None; dropped = 0 }
|
||||
@ -5325,9 +5463,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
((Unix.gettimeofday () -. t0) *. 1000.);
|
||||
Fun.protect
|
||||
~finally:(fun () ->
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
||||
(match t.child with
|
||||
| Some child ->
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ())
|
||||
| None -> ());
|
||||
(try Unix.close ls with Unix.Unix_error _ -> ());
|
||||
(try Unix.close rd with Unix.Unix_error _ -> ());
|
||||
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
|
||||
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
|
||||
(fun () -> accept_loop t ls);
|
||||
(* Here only when the loop returned: an exception out of it has already
|
||||
@ -6170,7 +6311,7 @@ let merged_setup () =
|
||||
with Unix.Unix_error _ -> Sys.executable_name
|
||||
in
|
||||
let t =
|
||||
{ session; child = None; agent; dir; stdout = rd;
|
||||
{ session; child = None; agent; dir; stdout = rd; relaunch = None;
|
||||
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
|
||||
host_ll; host_exe = exe; finished = false; agent_watch = None;
|
||||
park_noted = false; died = None; dropped = 0 }
|
||||
@ -6253,7 +6394,7 @@ let merged_serve () =
|
||||
(* 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 start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
let dir = session_dir ~file ~sock in
|
||||
let given = file in
|
||||
@ -6271,7 +6412,8 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
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 }
|
||||
~opts:{ Build.default with Build.dev = true; Build.debug;
|
||||
Build.sanitize; Build.x86 }
|
||||
~csrcs ~lflags ~pnames:[]
|
||||
session.Session.host ~out:exe ~ll:host_ll);
|
||||
(* Read by the park, so the first one says the session is waiting rather
|
||||
@ -6284,6 +6426,9 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
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;
|
||||
(* This pid, because the exec below keeps it: the program is the owner
|
||||
flan_agent.c's [daemon_socket] looks for. *)
|
||||
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
|
||||
Unix.putenv "FLAN_DEV_SOURCE" file;
|
||||
Unix.putenv "FLAN_DEV_SOCK" sock;
|
||||
Unix.putenv "FLAN_DEV_DIR" dir;
|
||||
@ -6309,7 +6454,17 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
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 () =
|
||||
let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true)
|
||||
~file ~sock () =
|
||||
(* The sanitizers are LLVM passes, and the x86 backend's host is written
|
||||
by hand with no pass run over it. The modules a session sends are not
|
||||
instrumented on either backend; what is checked is the host and the
|
||||
runtime, which is where a dev session's own bookkeeping lives. *)
|
||||
if x86 && sanitize then
|
||||
failwith
|
||||
"flan dev --x86 --sanitize: the sanitizers instrument LLVM's output, and \
|
||||
the x86 backend writes its code by hand, so the program's own code \
|
||||
would not be checked. Drop --x86 to build this session with LLVM.";
|
||||
(* 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
|
||||
@ -6359,5 +6514,5 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
|
||||
|
||||
[--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 ()
|
||||
if merged then start_merged ~debug ~sanitize ~x86 ~file ~sock ()
|
||||
else two_process ~debug ~sanitize ~x86 ~file ~sock ()
|
||||
|
||||
81
lib/emit.ml
81
lib/emit.ml
@ -539,6 +539,12 @@ type m = {
|
||||
[annot]. *)
|
||||
ann : bool;
|
||||
mutable nstr : int;
|
||||
(* Set while an expression thunk's module is emitted: a string literal's
|
||||
value is then a copy [flan_dev_literal] keeps for the life of the
|
||||
process, so storing it anywhere leaves nothing pointing into the module,
|
||||
and the literal is not counted in [nstr]. Without it every C-x C-e that
|
||||
wrote a string or a keyword kept its mapping. *)
|
||||
mutable pool : bool;
|
||||
(* The frame descriptors a dev build's shadow stack points at, counted apart
|
||||
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
|
||||
whether an expression thunk's module may be unloaded — a string literal in
|
||||
@ -2591,6 +2597,16 @@ and value_at f (e : Tast.expr) : string =
|
||||
| Tast.Int (n, _) -> Int64.to_string n
|
||||
| Tast.Float (x, k) -> float_const k x
|
||||
| Tast.Bool b -> if b then "true" else "false"
|
||||
| Tast.Str s when f.md.pool ->
|
||||
(* See [pool]: the bytes are still this module's, but only the copy
|
||||
leaves it, so they are [fi_bytes]' kind of constant and not
|
||||
[string_bytes']. The copy carries the NUL. *)
|
||||
let id, n = fi_bytes f.md s in
|
||||
let p = fresh f in
|
||||
ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n;
|
||||
let v = fresh f in
|
||||
ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p;
|
||||
v
|
||||
| Tast.Str s -> string_const f.md s
|
||||
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
||||
| Tast.Uninit _ -> "poison"
|
||||
@ -4992,6 +5008,8 @@ declare void @flan_dev_watch_emit_i64(i64)
|
||||
declare void @flan_dev_watch_emit_u64(i64)
|
||||
declare void @flan_dev_watch_emit_f64(double)
|
||||
declare void @flan_dev_watch_end()
|
||||
; An expression thunk's string literals, copied to storage the process keeps.
|
||||
declare ptr @flan_dev_literal(ptr, i64)
|
||||
declare i64 @flan_dyn_need_i64(i64)
|
||||
declare double @flan_dyn_need_f64(i64)
|
||||
declare i32 @flan_dyn_need_bool(i64)
|
||||
@ -5309,7 +5327,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
|
||||
globals = Hashtbl.create 16;
|
||||
externs = Hashtbl.create 32;
|
||||
checks; dev; gcfn = dev || makes_closures p;
|
||||
known; nstr = 0; nfi = 0; sanitize; ann = annotate;
|
||||
known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate;
|
||||
descs = Hashtbl.create 8;
|
||||
dbg = (if debug then Some (new_dbg p) else None);
|
||||
fsigs = fsigs_of p;
|
||||
@ -5752,6 +5770,43 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
|
||||
|
||||
String literals still have to come along: they are this module's own
|
||||
constants, and omitting them is an undefined [@.str.N] at link time. *)
|
||||
|
||||
(* Whether an expression thunk makes a function value anywhere in its body or
|
||||
in the clauses lifted out of it. Such a value's code address is in this
|
||||
module — a lambda's body, or the thick wrapper a named function is handed
|
||||
out through — and it may be stored anywhere, so the module must stay
|
||||
mapped. Both backends ask this before marking a thunk's module
|
||||
unloadable. *)
|
||||
let thunk_makes_fn_values (p : Tast.program) name =
|
||||
let mine = Hashtbl.create 8 in
|
||||
Hashtbl.replace mine name ();
|
||||
(* Lifted clauses nest: a lambda inside a lambda is lifted out of the
|
||||
outer one's body, so the set grows until nothing new joins it. *)
|
||||
let rec close () =
|
||||
let grew = ref false in
|
||||
List.iter
|
||||
(fun (f : Tast.fn) ->
|
||||
match f.Tast.fparent with
|
||||
| Some q when Hashtbl.mem mine q && not (Hashtbl.mem mine f.Tast.name) ->
|
||||
Hashtbl.replace mine f.Tast.name (); grew := true
|
||||
| _ -> ())
|
||||
p.Tast.fns;
|
||||
if !grew then close ()
|
||||
in
|
||||
close ();
|
||||
let found = ref false in
|
||||
List.iter
|
||||
(fun (f : Tast.fn) ->
|
||||
if Hashtbl.mem mine f.Tast.name then
|
||||
List.iter
|
||||
(Tast.walk (fun (e : Tast.expr) ->
|
||||
match e.Tast.e with
|
||||
| Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _ -> found := true
|
||||
| _ -> ()))
|
||||
f.Tast.body)
|
||||
p.Tast.fns;
|
||||
!found
|
||||
|
||||
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
?(known = fun _ -> true) ?(retains = true)
|
||||
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
|
||||
@ -5791,6 +5846,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
|
||||
in
|
||||
let m = new_module ~checks ~dev ~known ~debug ~annotate p in
|
||||
m.pool <- call <> None && retains;
|
||||
(* A thunk the module runs itself is excluded from all of this: it is called
|
||||
directly by [flan_reload_call], so it needs no cell, must not be published
|
||||
into one, and must not take a registry slot — there are 4096 of those and
|
||||
@ -5910,7 +5966,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
let t = fresh () in
|
||||
Buffer.add_string b
|
||||
(Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n"
|
||||
t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
|
||||
t (fi_cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
|
||||
new_fns;
|
||||
List.iter
|
||||
(fun (g : Tast.global) ->
|
||||
@ -5929,8 +5985,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
match initial_image p g with
|
||||
| None -> "null"
|
||||
| Some v ->
|
||||
let init = Printf.sprintf "@\".init.%d\"" m.nstr in
|
||||
m.nstr <- m.nstr + 1;
|
||||
(* Copied by the runtime and not kept, so not counted in
|
||||
[nstr]; a string inside it is, through [const]. *)
|
||||
let init = Printf.sprintf "@\".init.%d\"" m.nfi in
|
||||
m.nfi <- m.nfi + 1;
|
||||
Buffer.add_string m.strs
|
||||
(Printf.sprintf "%s = private constant %s %s\n" init
|
||||
(ll g.Tast.gty) (const m v));
|
||||
@ -5940,7 +5998,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
(Printf.sprintf
|
||||
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \
|
||||
store ptr %s, ptr %s\n"
|
||||
t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
|
||||
t (fi_cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
|
||||
(globalptr g.Tast.gname)))
|
||||
new_globals;
|
||||
(* A constant whose value the checker never consumed is just bytes in the
|
||||
@ -6009,10 +6067,12 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
expression may store one anywhere it likes — [(set msg "tuned")] on a
|
||||
string global leaves that global pointing into the mapping the agent
|
||||
is about to drop. The next thunk can be mapped at the same address, so
|
||||
the result is silent garbage rather than a fault. A module with no
|
||||
string constants has nothing in its image anyone could still be
|
||||
pointing at; one with any keeps its mapping, which costs a page and is
|
||||
the same bargain every redefinition already makes. *)
|
||||
the result is silent garbage rather than a fault. So a thunk's
|
||||
literal is a copy the process keeps (see [pool]) and is not counted;
|
||||
what [nstr] still counts is a constant something may go on pointing
|
||||
at, such as a condition's name, and a module with one keeps its
|
||||
mapping. The registry names above are not counted: flan_dev.c copies
|
||||
a name it keeps, and an initial image is copied on allocation. *)
|
||||
(* [retains = false] is a caller saying it knows where every literal in
|
||||
this module goes. The [m.nstr] test below is a conservative stand-in
|
||||
for that — an expression may store a string literal anywhere it likes,
|
||||
@ -6022,7 +6082,8 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
into the result buffer, so nothing outside the module holds an address
|
||||
inside it once the call has returned. Without this, clicking through
|
||||
the frames of a break loop costs a permanent mapping per click. *)
|
||||
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
|
||||
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0)
|
||||
&& not (thunk_makes_fn_values p fn) then
|
||||
Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
|
||||
| None -> ()
|
||||
end;
|
||||
|
||||
@ -98,6 +98,5 @@ let rerun ?(stopped = false) () =
|
||||
its window, or let it finish, and ask again"
|
||||
| _ ->
|
||||
Error
|
||||
"this session's program is a process of its own, so there is no parked \
|
||||
thread here to send round again; it is the merged build that can re-run \
|
||||
a program, not --two-process"
|
||||
"this process has no program thread of its own, so there is nothing \
|
||||
here to run again"
|
||||
|
||||
@ -65,7 +65,7 @@ type t = {
|
||||
mutable decls : Ast.decl list; (* post-Load: flat, one namespace *)
|
||||
mutable program : Tast.program; (* the last thing that checked *)
|
||||
mutable env : Check.env; (* the same, as the checker sees it *)
|
||||
host : Tast.program; (* what the process was built from *)
|
||||
mutable host : Tast.program; (* what the process was built from *)
|
||||
pkgs : Load.pkg list; (* alias, directory, names owned *)
|
||||
(* Every [defmacro] this session can expand a call to: the imports', under
|
||||
their aliases, and the buffer's own, under the names the buffer writes.
|
||||
@ -782,6 +782,24 @@ let restore t h =
|
||||
newest one and no older activation is left running. *)
|
||||
let rerun t = t.live <- SM.empty
|
||||
|
||||
(* The process is about to be built again from what the session holds now
|
||||
(a --two-process re-run), so that becomes what it was built from. Checked
|
||||
whole rather than taken from [program], which can hold a caller's old body
|
||||
beside a callee whose signature changed (see [eval]); a fresh build of that
|
||||
pair would be wrong, so it raises the checker's error instead. *)
|
||||
let rehost t =
|
||||
let p, env =
|
||||
let was = !Check.print_warnings in
|
||||
Check.print_warnings := false;
|
||||
Fun.protect ~finally:(fun () -> Check.print_warnings := was)
|
||||
(fun () -> Check.program_with_env t.decls)
|
||||
in
|
||||
t.program <- p;
|
||||
t.env <- env;
|
||||
t.host <- p;
|
||||
t.built <- record_built env p p.Tast.fns SM.empty;
|
||||
t.live <- SM.empty
|
||||
|
||||
(* [forms], when given, are [src] already read — [pruned] runs this over a
|
||||
file a form fewer each round and has no text for the subset. [base] is the
|
||||
file an [(import ...)] in them is resolved against, the session's own when
|
||||
|
||||
33
lib/x86.ml
33
lib/x86.ml
@ -491,7 +491,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
|
||||
globals; externs = Hashtbl.create 1; checks;
|
||||
dev; gcfn = dev || Emit.makes_closures p;
|
||||
known = (fun _ -> true); dbg = None; sanitize = false; ann = false;
|
||||
nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p }
|
||||
nstr = 0; pool = false; nfi = 0; descs = Hashtbl.create 8;
|
||||
fsigs = Emit.fsigs_of p }
|
||||
|
||||
let sizeof md t = fst (Emit.lay md t)
|
||||
|
||||
@ -1812,6 +1813,16 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
|
||||
let l = float_const f x ~f64 in
|
||||
fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64;
|
||||
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
|
||||
| Tast.Str s when f.md.Emit.pool ->
|
||||
(* [Emit]'s [pool]: an expression thunk's literal is a copy the process
|
||||
keeps, so nothing is left pointing into the module. *)
|
||||
let l, n = fi_bytes f s in
|
||||
lea f.b ~dst:rdi ~mm:(Sym (l, 0));
|
||||
imm_into f ~reg:rsi (Int64.of_int n);
|
||||
call_sym f.b "flan_dev_literal";
|
||||
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
||||
imm_into f ~reg:rax (Int64.of_int n);
|
||||
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
|
||||
| Tast.Str s ->
|
||||
(* A string and a [u8] slice are the same two words, which is why [Bytes]
|
||||
below is a non-instruction. *)
|
||||
@ -5316,6 +5327,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
p.Tast.globals
|
||||
in
|
||||
let md = layout_ctx ~checks ~dev p in
|
||||
md.Emit.pool <- call <> None && retains;
|
||||
let externs = Hashtbl.create 16 in
|
||||
List.iter
|
||||
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
|
||||
@ -5420,7 +5432,10 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
the same and [test_reload.ml] checks it there by grepping the IR text;
|
||||
there is no text to grep on this side, so the guarantee is this loop
|
||||
order and this comment. *)
|
||||
let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
|
||||
(* Not counted in [nstr]: flan_dev.c's registry copies a name it keeps, so
|
||||
nothing is left pointing at these once the lookup returns. Counted, every
|
||||
module after the session's first new name would keep its mapping. *)
|
||||
let cstr sym = let l = fi_cstring f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
|
||||
List.iter
|
||||
(fun (fn : Tast.fn) ->
|
||||
cstr (Mangle.sym fn.Tast.name);
|
||||
@ -5599,16 +5614,14 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
store one anywhere it likes -- [(set msg "tuned")] on a string global
|
||||
leaves that global pointing into the mapping the agent is about to drop.
|
||||
The next thunk can be mapped at the same address, so the result is silent
|
||||
garbage rather than a fault. A module with no string constants has nothing
|
||||
in its image anyone could still be pointing at; one with any keeps its
|
||||
mapping, which costs a page and is the same bargain every redefinition
|
||||
already makes. [string_const] is where the count is kept, and the install
|
||||
function's own registry names go through it too -- which is right rather
|
||||
than incidental, since a module that interned a name left something
|
||||
behind. *)
|
||||
garbage rather than a fault. So a thunk's literal is a copy the process
|
||||
keeps ([Emit]'s [pool]) and is not counted; what [string_const] still
|
||||
counts is a constant something may go on pointing at, such as a
|
||||
condition's name, and a module with one keeps its mapping. The install
|
||||
function's registry names are not counted: the registry copies them. *)
|
||||
(match call with
|
||||
| Some fn
|
||||
when fns = [ fn ] && consts = []
|
||||
when fns = [ fn ] && consts = [] && not (Emit.thunk_makes_fn_values p fn)
|
||||
&& ((not retains) || md.Emit.nstr = 0) ->
|
||||
Buffer.add_string out
|
||||
"\n\t.data\n\t.globl\tflan_reload_transient\n\
|
||||
|
||||
@ -436,6 +436,56 @@ void flan_dev_result_end(void) {
|
||||
* when it was sizing something to send through a socket. */
|
||||
uint64_t flan_dev_result_cap(void) { return RESULT_MAX; }
|
||||
|
||||
/* ── An expression thunk's string literals ──────────────────────────── */
|
||||
|
||||
/* A literal in an evaluated expression is a copy made here and kept for the
|
||||
* life of the process, one per distinct text, NUL after the bytes as the
|
||||
* module's own constants have. The expression may store it anywhere, so
|
||||
* pointing it into the thunk's module would keep that module mapped for ever
|
||||
* (Emit's [pool]); pointing it here lets the agent unload the module once the
|
||||
* thunk returns. Game thread only: thunks run there. */
|
||||
typedef struct lit { struct lit *next; int64_t len; uint8_t bytes[]; } lit;
|
||||
|
||||
static lit **lits;
|
||||
static size_t lits_cap, lits_n;
|
||||
|
||||
static uint64_t lit_hash(const uint8_t *p, int64_t n) {
|
||||
uint64_t h = 1469598103934665603ULL; /* FNV-1a */
|
||||
for (int64_t i = 0; i < n; i++) { h ^= p[i]; h *= 1099511628211ULL; }
|
||||
return h;
|
||||
}
|
||||
|
||||
const uint8_t *flan_dev_literal(const uint8_t *p, int64_t n) {
|
||||
if (n < 0) n = 0;
|
||||
if (lits_n >= lits_cap / 2) {
|
||||
size_t cap = lits_cap ? lits_cap * 2 : 64;
|
||||
lit **t = calloc(cap, sizeof *t);
|
||||
if (t == NULL) die("out of memory", "a string literal");
|
||||
for (size_t i = 0; i < lits_cap; i++)
|
||||
for (lit *e = lits[i], *nx; e != NULL; e = nx) {
|
||||
nx = e->next;
|
||||
size_t b = lit_hash(e->bytes, e->len) & (cap - 1);
|
||||
e->next = t[b];
|
||||
t[b] = e;
|
||||
}
|
||||
free(lits);
|
||||
lits = t;
|
||||
lits_cap = cap;
|
||||
}
|
||||
size_t b = lit_hash(p, n) & (lits_cap - 1);
|
||||
for (lit *e = lits[b]; e != NULL; e = e->next)
|
||||
if (e->len == n && memcmp(e->bytes, p, (size_t)n) == 0) return e->bytes;
|
||||
lit *e = malloc(sizeof *e + (size_t)n + 1);
|
||||
if (e == NULL) die("out of memory", "a string literal");
|
||||
e->len = n;
|
||||
if (n > 0) memcpy(e->bytes, p, (size_t)n);
|
||||
e->bytes[n] = 0;
|
||||
e->next = lits[b];
|
||||
lits[b] = e;
|
||||
lits_n++;
|
||||
return e->bytes;
|
||||
}
|
||||
|
||||
/* Called between the copy and the second read of the counter, when set. It
|
||||
* exists for test/dev_limits.c and nothing else sets it: the losing side of
|
||||
* the race is a write landing inside that window, and a second thread cannot
|
||||
|
||||
@ -140,7 +140,9 @@
|
||||
; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one
|
||||
; translation unit here that frees the most, which is what makes it worth a
|
||||
; sanitized run at all. See [dyn_sweep].
|
||||
(file dyn_ops.c))
|
||||
(file dyn_ops.c)
|
||||
; [dev_session] drives a real flan dev --sanitize.
|
||||
(file %{workspace_root}/bin/main.exe))
|
||||
(action (run ./test_sanitize.exe)))
|
||||
|
||||
; The corpus a third time, under Valgrind's memcheck. Its own alias for the
|
||||
|
||||
22
test/programs/dev-own-break.flan
Normal file
22
test/programs/dev-own-break.flan
Normal file
@ -0,0 +1,22 @@
|
||||
;;;; A program that stops on its own while an evaluation is in flight.
|
||||
;;;;
|
||||
;;;; Setting [go] from the editor starts it: the loop sees it, sleeps without
|
||||
;;;; polling for longer than a module takes to build, and then signals. An
|
||||
;;;; expression evaluated just after [go] is therefore waiting in the ring
|
||||
;;;; when the program's own break is entered, and runs inside that break's
|
||||
;;;; loop. The stop is the program's and the value is the expression's.
|
||||
(import agent "vendor:agent")
|
||||
|
||||
(declare-c usleep [us i32] i32 "usleep")
|
||||
|
||||
(defstruct Late [])
|
||||
|
||||
(defonce go i64)
|
||||
|
||||
(defn main [] i32
|
||||
(while (= go 0)
|
||||
(agent/wait 5))
|
||||
(usleep 1500000)
|
||||
(restart-case
|
||||
(do (error (Late {})) 0)
|
||||
(carry-on [] 0)))
|
||||
@ -61,6 +61,14 @@ let send path line =
|
||||
Unix.close s;
|
||||
Buffer.contents b
|
||||
|
||||
(* The pair the daemon sets: the path, and the pid it is meant for. This test
|
||||
binary is the parent of every program it starts, which is the
|
||||
--two-process shape. *)
|
||||
let daemon_env path =
|
||||
let me = string_of_int (Unix.getpid ()) in
|
||||
[| "FLAN_AGENT_SOCKET=" ^ path; "FLAN_AGENT_OWNER=" ^ me;
|
||||
"FLAN_DEV_PARENT=" ^ me |]
|
||||
|
||||
let () =
|
||||
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
|
||||
| 0 ->
|
||||
@ -298,7 +306,7 @@ let () =
|
||||
let bad = tmp "bad.out" in
|
||||
let bfd' = ofd bad in
|
||||
let benv =
|
||||
Array.append aenv [| "FLAN_AGENT_SOCKET=/nonexistent-dir/agent.sock" |]
|
||||
Array.append aenv (daemon_env "/nonexistent-dir/agent.sock")
|
||||
in
|
||||
let bpid' = Unix.create_process_env aexe [| aexe |] benv Unix.stdin bfd' bfd' in
|
||||
Unix.close bfd';
|
||||
@ -325,6 +333,79 @@ let () =
|
||||
"cannot listen\n"
|
||||
end;
|
||||
|
||||
(* ── The variable inherited by a process the daemon did not start ── *)
|
||||
|
||||
(* A shell opened from inside a [flan dev] program carries its
|
||||
FLAN_AGENT_SOCKET, and so does anything run from that shell. Binding
|
||||
unlinks the path first, so honouring it there would take the session's
|
||||
socket from its program. FLAN_AGENT_OWNER names the process the daemon
|
||||
launched; pid 1 is neither this program nor its parent, so the variable
|
||||
is not this program's, and it picks and announces a path of its own as
|
||||
if nothing were set. The file standing in for the session's socket has
|
||||
to still be the same file afterwards. *)
|
||||
let inherited ~shape ~owner =
|
||||
let stolen = tmp "stolen.sock" and serr = tmp "stolen.err" in
|
||||
Out_channel.with_open_bin stolen (fun oc ->
|
||||
output_string oc "the session's");
|
||||
let senv =
|
||||
Array.append aenv
|
||||
[| "FLAN_AGENT_SOCKET=" ^ stolen; "FLAN_AGENT_OWNER=" ^ owner |]
|
||||
in
|
||||
let s1 = ofd (tmp "stolen.out") and s2 = ofd serr in
|
||||
let spid = Unix.create_process_env aexe [| aexe |] senv Unix.stdin s1 s2 in
|
||||
Unix.close s1;
|
||||
Unix.close s2;
|
||||
let prefix = "flan agent: listening on " in
|
||||
let sannounced () =
|
||||
let text = In_channel.with_open_bin serr In_channel.input_all in
|
||||
List.find_map
|
||||
(fun l ->
|
||||
if String.length l > String.length prefix
|
||||
&& String.sub l 0 (String.length prefix) = prefix
|
||||
then Some (String.sub l (String.length prefix)
|
||||
(String.length l - String.length prefix))
|
||||
else None)
|
||||
(String.split_on_char '\n' text)
|
||||
in
|
||||
(match
|
||||
if await (fun () -> sannounced () <> None) then sannounced () else None
|
||||
with
|
||||
| None ->
|
||||
fail "%s: a program with someone else's FLAN_AGENT_SOCKET announced no \
|
||||
socket of its own" shape;
|
||||
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
| Some p ->
|
||||
if p = stolen then fail "%s: the inherited path was bound: %S" shape p;
|
||||
if not (await (fun () -> Sys.file_exists p)) then
|
||||
fail "%s: nothing was bound at the announced %S" shape p
|
||||
else ignore (send p aso);
|
||||
let reaped =
|
||||
await ~ms:5000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] spid with
|
||||
| 0, _ -> false
|
||||
| _ -> true)
|
||||
in
|
||||
if not reaped then begin
|
||||
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
fail "%s: the program with an inherited variable never finished" shape
|
||||
end);
|
||||
(match In_channel.with_open_bin stolen In_channel.input_all with
|
||||
| "the session's" -> ()
|
||||
| _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was replaced" shape
|
||||
| exception Sys_error _ ->
|
||||
fail "%s: the inherited FLAN_AGENT_SOCKET's file was removed" shape);
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ stolen; serr; tmp "stolen.out" ]
|
||||
in
|
||||
(* Nobody's pid. *)
|
||||
inherited ~shape:"an owner that is not this process" ~owner:"1";
|
||||
(* A merged build's owner is the program itself, so a process the program
|
||||
starts has the owner as its parent; with no FLAN_DEV_PARENT naming it,
|
||||
that is not the --two-process shape and the socket is not its. Here the
|
||||
test binary stands in for the program. *)
|
||||
inherited ~shape:"a child of a merged program"
|
||||
~owner:(string_of_int (Unix.getpid ()));
|
||||
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ aexe; aso; aout; aerr; bad ];
|
||||
|
||||
@ -359,7 +440,7 @@ let () =
|
||||
let nc = Session.eval nt "(defn tick [] i64 1000)" in
|
||||
ignore (Build.shared ~opts:dev ~ir:nc.Session.ir ~out:nso ());
|
||||
let nenv =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ nsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env nsock)
|
||||
in
|
||||
let nfd =
|
||||
Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
||||
@ -412,7 +493,7 @@ let () =
|
||||
bt.Session.host ~out:bexe);
|
||||
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let env =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ bsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env bsock)
|
||||
in
|
||||
let bpid =
|
||||
Unix.create_process_env bexe [| bexe |] env Unix.stdin bfd bfd
|
||||
@ -753,7 +834,7 @@ let () =
|
||||
lt.Session.host ~out:lexe);
|
||||
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let lenv =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ lsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env lsock)
|
||||
in
|
||||
let lpid = Unix.create_process_env lexe [| lexe |] lenv Unix.stdin lfd lfd in
|
||||
Unix.close lfd;
|
||||
|
||||
332
test/test_dev.ml
332
test/test_dev.ml
@ -5161,20 +5161,124 @@ let () =
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "42"))
|
||||
then fail "--two-process: the reload was never installed";
|
||||
(* And the one verb this shape cannot have. Running [main] again means
|
||||
waking a thread that parked inside this process, and here the program
|
||||
is a child: when it finishes it is gone, and there is nothing to wake.
|
||||
Refused by naming what this daemon is rather than with the message a
|
||||
merged one gives, because "the program is already running" would send
|
||||
somebody back to try again after it had exited — and [--x86] arrives
|
||||
here too, since it refuses the merged daemon for the -rdynamic reason
|
||||
given below. *)
|
||||
(* A re-run here is a new process. Refused while the child runs; once
|
||||
it has finished, the program is built again from the session, so the
|
||||
redefined [step] is what the new run's first line prints — the host
|
||||
the daemon started with would print 1. *)
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
let why = Option.value ~default:(status r) (Wire.string_field r "message") in
|
||||
if status r <> "error" then
|
||||
fail "--two-process answered a rerun it cannot perform"
|
||||
else if not (contains_sub why "two-process") then
|
||||
fail "--two-process refuses a rerun as: %s" why;
|
||||
if status r <> "error" || not (contains_sub why "still running") then
|
||||
fail "--two-process: a rerun while the child runs answered %s: %s"
|
||||
(status r) why;
|
||||
(* Two more deliveries take the program past its last two waits. *)
|
||||
List.iter
|
||||
(fun n ->
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code \"(defn step [] i64 %d)\" \
|
||||
:file \"/tmp/buf.flan\")" n)
|
||||
in
|
||||
if status r <> "ok" then fail "--two-process: eval %d was refused" n;
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) (string_of_int n)))
|
||||
then fail "--two-process: %d was never installed" n)
|
||||
[ 43; 44 ];
|
||||
(* 44 was the old child's last line, so anything from here on is the
|
||||
new child's. *)
|
||||
Buffer.clear seen;
|
||||
let taken = ref (ask "(:op \"describe\")") in
|
||||
if not
|
||||
(await ~ms:10000 (fun () ->
|
||||
taken := ask "(:op \"rerun\")";
|
||||
status !taken = "ok"))
|
||||
then
|
||||
fail "--two-process: a rerun after the child finished: %s"
|
||||
(Option.value ~default:(status !taken)
|
||||
(Wire.string_field !taken "message"))
|
||||
else begin
|
||||
let note = Option.value ~default:"" (Wire.string_field !taken "note") in
|
||||
if not (contains_sub note "globals start over") then
|
||||
fail "--two-process: the rerun's note does not say the globals \
|
||||
start over: %S" note;
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "\n"))
|
||||
then fail "--two-process: the new child printed nothing"
|
||||
else if not (String.starts_with ~prefix:"44\n" (Buffer.contents seen))
|
||||
then
|
||||
fail "--two-process: the new child did not start with the \
|
||||
redefinition: %S" (Buffer.contents seen);
|
||||
(* And it is reachable: a delivery to the new child installs. *)
|
||||
let r =
|
||||
ask
|
||||
"(:op \"eval\" :code \"(defn step [] i64 45)\" :file \"/tmp/buf.flan\")"
|
||||
in
|
||||
if status r <> "ok" then fail "--two-process: eval after rerun refused";
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "45"))
|
||||
then fail "--two-process: the new child never installed a delivery";
|
||||
(* A signature change leaves [user] compiled for the old one. The
|
||||
next build is of the whole program, so the re-run is refused at
|
||||
the stale call; a fix evaluated while the child has ended goes
|
||||
into the session, and the re-run after it builds. *)
|
||||
let ev code =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")"
|
||||
(Wire.quote code))
|
||||
in
|
||||
let alive () =
|
||||
match Wire.field (ask "(:op \"describe\")") "alive" with
|
||||
| Some { Form.v = Form.Sym "nil"; _ } -> false
|
||||
| _ -> true
|
||||
in
|
||||
List.iter
|
||||
(fun code ->
|
||||
if status (ev code) <> "ok" then
|
||||
fail "--two-process: %s was refused" code)
|
||||
[ "(defn helper [] i64 1)"; "(defn user [] i64 (helper))" ];
|
||||
if not (await ~ms:10000 (fun () -> not (alive ()))) then
|
||||
fail "--two-process: the new child did not finish"
|
||||
else begin
|
||||
let r = ev "(defn helper [x i64] i64 x)" in
|
||||
if status r <> "ok" then
|
||||
fail "--two-process: a change while the child has ended: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
if status r <> "error"
|
||||
|| not (contains_sub
|
||||
(Option.value ~default:"" (Wire.string_field r "loc"))
|
||||
"/tmp/buf.flan:1:")
|
||||
then
|
||||
fail "--two-process: a re-run over a stale caller answered %s \
|
||||
(%s)" (status r)
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
List.iter
|
||||
(fun code ->
|
||||
if status (ev code) <> "ok" then
|
||||
fail "--two-process: %s was refused" code)
|
||||
[ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ];
|
||||
Buffer.clear seen;
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
if status r <> "ok" then
|
||||
fail "--two-process: the re-run after the fix: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||
else if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "\n"))
|
||||
|| not (String.starts_with ~prefix:"5\n"
|
||||
(Buffer.contents seen))
|
||||
then
|
||||
fail "--two-process: the fixed program printed %S"
|
||||
(Buffer.contents seen)
|
||||
end
|
||||
end;
|
||||
ignore (ask "(:op \"close\")");
|
||||
Unix.close tc
|
||||
end;
|
||||
@ -6595,12 +6699,12 @@ let () =
|
||||
let answer r =
|
||||
Option.value ~default:"" (Wire.string_field r "value")
|
||||
in
|
||||
let read () =
|
||||
answer
|
||||
(request c
|
||||
"(:op \"eval-expr\" :code \"(get config :s)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")")
|
||||
let read_reply () =
|
||||
request c
|
||||
"(:op \"eval-expr\" :code \"(get config :s)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")"
|
||||
in
|
||||
let read () = answer (read_reply ()) in
|
||||
(* A hundred thousand small maps: flan_dyn.c collects at a
|
||||
one-megabyte floor, so this is several collections and not a
|
||||
heap that merely grew. *)
|
||||
@ -6620,11 +6724,17 @@ let () =
|
||||
if status r <> "ok" then
|
||||
fail "--%s: the churning thunk (cycle %d): %s" backend cycle
|
||||
(said r)
|
||||
else if not (contains_sub (read ()) "kept") then
|
||||
fail
|
||||
"--%s: after a thunk that allocates (cycle %d) the parked \
|
||||
program's dyn global reads %S"
|
||||
backend cycle (read ());
|
||||
else begin
|
||||
(* The failing reply itself, and not a second read: the one
|
||||
recorded failure here re-read and got "kept", so what the
|
||||
first read answered is the whole of the evidence. *)
|
||||
let r = read_reply () in
|
||||
if not (contains_sub (answer r) "kept") then
|
||||
fail
|
||||
"--%s: after a thunk that allocates (cycle %d) the \
|
||||
parked program's dyn global read %S (%s: %s)"
|
||||
backend cycle (answer r) (status r) (said r)
|
||||
end;
|
||||
(* And round main again, which re-enters the very code that
|
||||
pushed those roots. *)
|
||||
let r = request c "(:op \"rerun\")" in
|
||||
@ -6633,7 +6743,79 @@ let () =
|
||||
if not (await ~ms:20000 parked) then
|
||||
fail "--%s: the program did not park again (cycle %d)" backend
|
||||
cycle
|
||||
done
|
||||
done;
|
||||
(* An expression's module is unloaded once it returns, string
|
||||
literals and all: a literal is a copy the process keeps, so a
|
||||
global left holding one still reads it after the module that
|
||||
wrote it is gone and later ones have been mapped where it
|
||||
was. The mapping count is what the kernel limits. *)
|
||||
let ev code =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval-expr\" :code %s \
|
||||
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
|
||||
in
|
||||
let r =
|
||||
request c
|
||||
"(:op \"eval\" :code \"(defonce msg string)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")"
|
||||
in
|
||||
if status r <> "ok" then fail "--%s: defonce msg: %s" backend (said r)
|
||||
else begin
|
||||
ignore (ev "(do (set msg \"tuned\") 0)");
|
||||
let maps () =
|
||||
List.length
|
||||
(String.split_on_char '\n'
|
||||
(In_channel.with_open_bin
|
||||
(Printf.sprintf "/proc/%d/maps" dpid)
|
||||
In_channel.input_all))
|
||||
in
|
||||
let m0 = maps () in
|
||||
for i = 1 to 20 do
|
||||
ignore (ev (Printf.sprintf "(do (println \"other %d\") %d)" i i))
|
||||
done;
|
||||
let m1 = maps () in
|
||||
if m1 - m0 >= 20 then
|
||||
fail "--%s: twenty expressions with a string literal left %d \
|
||||
more mappings" backend (m1 - m0);
|
||||
let r = ev "msg" in
|
||||
if Wire.string_field r "value" <> Some "\"tuned\"" then
|
||||
fail "--%s: a literal stored by an unloaded module reads %S \
|
||||
(%s)" backend
|
||||
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||
(said r)
|
||||
end;
|
||||
(* A function value an expression makes has its code in that
|
||||
expression's module — a lambda's body, or the wrapper a named
|
||||
function is handed out through — so that module stays mapped.
|
||||
Later expressions are mapped between the store and the call,
|
||||
where an unloaded one would have been. *)
|
||||
let defd code =
|
||||
let r =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code %s \
|
||||
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
|
||||
in
|
||||
if status r <> "ok" then fail "--%s: %s: %s" backend code (said r)
|
||||
in
|
||||
defd "(defonce kept (Option (Fn [i64] i64)))";
|
||||
defd "(defn twice [x i64] i64 (* x 2))";
|
||||
let call_kept want what =
|
||||
for i = 1 to 3 do
|
||||
ignore (ev (Printf.sprintf "(do (println \"pad %d\") %d)" i i))
|
||||
done;
|
||||
let r = ev "(match kept (Some f) (f 1) (None) -1)" in
|
||||
if Wire.string_field r "value" <> Some want then
|
||||
fail "--%s: %s kept by an unloaded expression answered %S \
|
||||
(%s)" backend what
|
||||
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||
(said r)
|
||||
in
|
||||
ignore (ev "(do (set kept (Some (fn [x] (+ x 7)))) 0)");
|
||||
call_kept "8" "a lambda";
|
||||
ignore (ev "(do (set kept (Some twice)) 0)");
|
||||
call_kept "2" "a named function"
|
||||
end;
|
||||
ignore (request c "(:op \"close\")");
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
@ -8752,6 +8934,110 @@ let () =
|
||||
hook_block ~llvm:false;
|
||||
hook_block ~llvm:true;
|
||||
|
||||
(* ── --sanitize on the backend it cannot instrument ───────────── *)
|
||||
|
||||
(* Refused before anything is built, by name and with the way out. The
|
||||
session itself is driven under the sanitizers by @sanitize. *)
|
||||
let zerr = tmp "x86san.err" in
|
||||
let zfd = Unix.openfile zerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let zpid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; tmp "x86san.sock";
|
||||
"--x86"; "--sanitize" |]
|
||||
Unix.stdin zfd zfd
|
||||
in
|
||||
Unix.close zfd;
|
||||
(match Unix.waitpid [] zpid with
|
||||
| _, Unix.WEXITED 1 ->
|
||||
let said = In_channel.with_open_bin zerr In_channel.input_all in
|
||||
if not (contains_sub said "--x86 --sanitize"
|
||||
&& contains_sub said "Drop --x86") then
|
||||
fail "flan dev --x86 --sanitize was refused as: %S" said
|
||||
| _ -> fail "flan dev --x86 --sanitize was not refused");
|
||||
(try Sys.remove zerr with Sys_error _ -> ());
|
||||
|
||||
(* ── Whose break it is ─────────────────────────────────────────── *)
|
||||
|
||||
(* The program stops on its own while an evaluation is in flight: [go]
|
||||
makes it sleep for longer than a module takes to build and then
|
||||
signal, without polling in between. The stop is fresh, as a thunk's
|
||||
would be, and it is not the expression's; the expression runs inside
|
||||
the program's break loop and its value is the answer. On the default
|
||||
backend, because the stop's owner is the agent's and not the
|
||||
backend's. *)
|
||||
let osock = tmp "ownbreak.sock" and oout = tmp "ownbreak.out" in
|
||||
(try Sys.remove osock with Sys_error _ -> ());
|
||||
let ofd = Unix.openfile oout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let opid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-own-break.flan"; "-s"; osock |]
|
||||
Unix.stdin ofd Unix.stderr
|
||||
in
|
||||
Unix.close ofd;
|
||||
if not (listening ~pid:opid osock) then begin
|
||||
fail "the own-break daemon %s" !listen_why;
|
||||
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect osock in
|
||||
let said r =
|
||||
Option.value ~default:(status r) (Wire.string_field r "message")
|
||||
in
|
||||
let ev code =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval-expr\" :code %s :file \"programs/dev-own-break.flan\")"
|
||||
(Wire.quote code))
|
||||
in
|
||||
(* An expression stopped in a break and resumed by a restart finishes
|
||||
after the restart's reply, and here it finishes after the next
|
||||
expression has been sent: its value must not answer for that one. *)
|
||||
let r =
|
||||
ev "(restart-case (do (error (Late {})) 0) \
|
||||
(slow [] (do (usleep 500000) 5)))"
|
||||
in
|
||||
if status r <> "error" then
|
||||
fail "resumed value: the first expression did not stop: %s" (said r)
|
||||
else begin
|
||||
let r = request c "(:op \"restart\" :name \"slow\")" in
|
||||
if status r <> "ok" then fail "resumed value: restart: %s" (said r);
|
||||
let r = ev "(do (usleep 300000) 23)" in
|
||||
if Wire.string_field r "value" <> Some "23" then
|
||||
fail "resumed value: the next expression answered %S (%s)"
|
||||
(Option.value ~default:"" (Wire.string_field r "value")) (said r)
|
||||
end;
|
||||
let r = ev "(do (set go 1) 0)" in
|
||||
if status r <> "ok" then fail "own break: setting go: %s" (said r)
|
||||
else begin
|
||||
(* The sleep keeps the thunk running inside the program's break for
|
||||
many of the daemon's ticks, so a wait that took any fresh stop for
|
||||
the thunk's would answer before the value exists. *)
|
||||
let r = ev "(do (usleep 300000) 42)" in
|
||||
if status r <> "ok"
|
||||
|| Wire.string_field r "value" <> Some "42" then
|
||||
fail "own break: an expression in flight when the program stopped \
|
||||
on its own answered %s %S (value %S)"
|
||||
(status r) (said r)
|
||||
(Option.value ~default:"" (Wire.string_field r "value"));
|
||||
(match Wire.field r "condition" with
|
||||
| Some { Form.v = Form.Str "Late"; _ } -> ()
|
||||
| _ -> fail "own break: the reply does not carry the program's stop")
|
||||
end;
|
||||
ignore (aborted c);
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
if not
|
||||
(await ~ms:10000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] opid with
|
||||
| 0, _ -> false
|
||||
| _ -> true))
|
||||
then begin
|
||||
fail "own break: the daemon did not end on abort";
|
||||
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] opid) with Unix.Unix_error _ -> ())
|
||||
end
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ];
|
||||
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ sock; out; bsock; bout ];
|
||||
Test_support.report ~label:"dev" ()
|
||||
|
||||
@ -376,13 +376,8 @@ let dyn_sweep () =
|
||||
part that carries the weight; the run is what says the constructor the fix
|
||||
introduced actually calls both of the things it replaced.
|
||||
|
||||
Not covered, and worth naming rather than leaving to be discovered the way
|
||||
this bug was: a program driven by [flan dev] under ASan. The daemon builds
|
||||
its host through its own path and the CLI has no [--sanitize] to pass it,
|
||||
so that one wants a flag and a way through [Dev.serve]. See TODO.org, "A
|
||||
program driven by a real flan dev daemon under a sanitizer". The faulting
|
||||
dev build, which was on that list too, is covered now — see
|
||||
[dev_segv] below. *)
|
||||
A program driven by a real [flan dev] session is [dev_session] below, and
|
||||
the faulting dev build is [dev_segv]. *)
|
||||
let dev_corpus =
|
||||
[ (* The only [dev-*] program with no agent import: it prints and returns.
|
||||
Here because it is the one program in the tree written for a dev
|
||||
@ -474,6 +469,93 @@ let dev_segv () =
|
||||
prevent\n%s" text;
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
|
||||
(* A program driven by a real [flan dev --sanitize] session: the host and the
|
||||
runtime under ASan and UBSan, the modules the session sends built as
|
||||
always (llc and ld, not instrumented). dev-break stops on its first frame,
|
||||
so the session starts at a break; it is resumed, [step] is redefined three
|
||||
times with an expression evaluated after each, an expression is evaluated
|
||||
into a second break and resumed out of it, and the session is closed. The
|
||||
daemon's own output is the program's stderr, so a report anywhere in the
|
||||
session lands in it. *)
|
||||
let dev_session () =
|
||||
let flan = "../bin/main.exe" in
|
||||
let sock = Filename.concat scratch "flan-san-dev.sock" in
|
||||
let log = Filename.concat scratch "flan-san-dev.log" in
|
||||
let src = "programs/dev-break.flan" in
|
||||
(try Sys.remove sock with Sys_error _ -> ());
|
||||
let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let env =
|
||||
Array.append (Unix.environment ())
|
||||
[| "ASAN_OPTIONS=detect_leaks=0"; "UBSAN_OPTIONS=print_stacktrace=1" |]
|
||||
in
|
||||
let pid =
|
||||
Unix.create_process_env flan
|
||||
[| flan; "dev"; src; "-s"; sock; "--sanitize" |]
|
||||
env Unix.stdin fd fd
|
||||
in
|
||||
Unix.close fd;
|
||||
let said () = In_channel.with_open_bin log In_channel.input_all in
|
||||
if not (Test_support.listening ~ms:180000 ~pid sock) then begin
|
||||
fail "dev session: flan dev --sanitize %s\n%s" !Test_support.listen_why
|
||||
(said ());
|
||||
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = Test_support.connect sock in
|
||||
let ask q = Wire.parse (Wire.send c q; Wire.recv c) in
|
||||
let field r k = Option.value ~default:"" (Wire.string_field r k) in
|
||||
let stopped () =
|
||||
match Wire.field (ask "(:op \"describe\")") "stopped" with
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
| _ -> false
|
||||
in
|
||||
let expect what r =
|
||||
if field r "status" <> "ok" then
|
||||
fail "dev session: %s: %s" what (field r "message")
|
||||
in
|
||||
let f = Printf.sprintf ":file %S" src in
|
||||
if not (Test_support.await ~ms:30000 stopped) then
|
||||
fail "dev session: the program never reached its first break"
|
||||
else begin
|
||||
expect "retry" (ask "(:op \"restart\" :name \"retry\")");
|
||||
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
|
||||
fail "dev session: the program did not resume";
|
||||
for i = 1 to 3 do
|
||||
expect "a redefinition"
|
||||
(ask
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks \
|
||||
%d)) ticks)\" %s)" (100 * i) f));
|
||||
expect "an expression"
|
||||
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ ticks 1)\" %s)" f))
|
||||
done;
|
||||
let r = ask (Printf.sprintf "(:op \"eval-expr\" :code \"(divide 1 0)\" %s)" f) in
|
||||
if not (contains (field r "condition") "ArithError") then
|
||||
fail "dev session: (divide 1 0) did not stop on ArithError: %s"
|
||||
(field r "message");
|
||||
expect "use-zero" (ask "(:op \"restart\" :name \"use-zero\")");
|
||||
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
|
||||
fail "dev session: the program did not resume from the second break";
|
||||
expect "an expression after both breaks"
|
||||
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ 1 2)\" %s)" f))
|
||||
end;
|
||||
(try ignore (ask "(:op \"close\")") with _ -> ());
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
if not
|
||||
(Test_support.await ~ms:30000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] pid with
|
||||
| 0, _ -> false
|
||||
| _ -> true))
|
||||
then begin
|
||||
fail "dev session: the daemon did not end on close";
|
||||
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
|
||||
end;
|
||||
if reported (said ()) then
|
||||
fail "dev session: sanitizer report\n%s" (said ())
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; log ]
|
||||
|
||||
(* The positive controls, which are the only evidence that a clean sweep means
|
||||
anything. Both are written here rather than kept in test/programs because
|
||||
neither is a program anybody should build: one reads off the end of an
|
||||
@ -600,6 +682,7 @@ let () =
|
||||
dyn_sweep ();
|
||||
dev_sweep ();
|
||||
dev_segv ();
|
||||
dev_session ();
|
||||
unchecked_controls ();
|
||||
if !failures = 0 then print_endline "sanitizer sweep: clean"
|
||||
else Printf.printf "%d sanitizer failure(s)\n" !failures;
|
||||
|
||||
@ -1315,17 +1315,25 @@ let () =
|
||||
if has c.Session.ir "@flan_reload_transient" then
|
||||
fail "a module that publishes a body claimed to be unloadable";
|
||||
|
||||
(* And a third condition, about data rather than text. A string literal lives
|
||||
in the evaluating module's own image, and an expression may store one
|
||||
anywhere: [(set msg "x")] on a string global would leave that global
|
||||
pointing into a mapping the agent then drops — and since the next thunk can
|
||||
be mapped at the same address, the result is silent garbage rather than a
|
||||
fault. A module carrying any string constant keeps its mapping. *)
|
||||
(* And a third condition, about data rather than text. An expression may
|
||||
store a string literal anywhere — [(set msg "x")] on a string global — so
|
||||
a literal's value is a copy [flan_dev_literal] keeps for the process, and
|
||||
nothing is left pointing into the module. A string constant the module
|
||||
does hand out still keeps its mapping: a condition's name, which a handler
|
||||
may carry away. *)
|
||||
let str = Session.eval_expr t "(println \"tuned\")" in
|
||||
if not (has str.Session.ir ".str.0") then
|
||||
fail "the fixture stopped carrying a string constant, so it proves nothing";
|
||||
if has str.Session.ir "@flan_reload_transient" then
|
||||
fail "an expression holding a string claimed to be unloadable";
|
||||
if not (has str.Session.ir "@flan_dev_literal(ptr") then
|
||||
fail "an expression's string literal is not a kept copy";
|
||||
if has str.Session.ir ".str." then
|
||||
fail "an expression's string literal is still a constant of its module";
|
||||
if not (has str.Session.ir "@flan_reload_transient") then
|
||||
fail "an expression whose only string is a literal kept its mapping";
|
||||
let held =
|
||||
Session.eval_expr t
|
||||
"(restart-case (+ 1 2) (use-zero [] :report \"Answer 0\" 0))"
|
||||
in
|
||||
if has held.Session.ir "@flan_reload_transient" then
|
||||
fail "an expression establishing a restart claimed to be unloadable";
|
||||
|
||||
(* ── Generics in the dev loop ─────────────────────────────────────────
|
||||
A generic [defn] produces no [Tast.fn] of its own — only its copies do —
|
||||
@ -1523,7 +1531,7 @@ let () =
|
||||
(* And the slot names, in the packed form the runtime splits — which is
|
||||
what says the call carries *this* class's new list and not some
|
||||
other module's leftovers. *)
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") then
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\0Az\"") then
|
||||
fail "the registration did not carry the new slot list"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "adding a slot to a class was refused: %s" m);
|
||||
@ -1556,7 +1564,7 @@ let () =
|
||||
| c ->
|
||||
if not (has c.Session.ir "call void @flan_dyn_class_def") then
|
||||
fail "an unchanged class definition registered nothing";
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\00\"") then
|
||||
if not (has c.Session.ir "c\"x\\0Ay\"") then
|
||||
fail "an unchanged class registered some other slot list"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "re-evaluating an unchanged class was refused: %s" m);
|
||||
@ -1620,7 +1628,7 @@ let () =
|
||||
ignore (Session.eval t "(defn origin [] dyn (point 0 0))");
|
||||
match Session.eval t "(defclass point [x i64 y])" with
|
||||
| c ->
|
||||
if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then
|
||||
if not (has c.Session.ir "c\"x i64\\0Ay\"") then
|
||||
fail "a slot's new type did not reach the registration"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a slot's type changed under a compiled caller was refused: %s" m);
|
||||
|
||||
105
vendor/agent/flan_agent.c
vendored
105
vendor/agent/flan_agent.c
vendored
@ -214,8 +214,19 @@ typedef struct {
|
||||
void *handle;
|
||||
int stopped_only;
|
||||
int32_t at_stop;
|
||||
uint32_t call_id; /* its place among jobs with a call; 0 if none */
|
||||
} job;
|
||||
|
||||
/* Which evaluated expression the result buffer holds. Every job with a call
|
||||
* is numbered as the listener queues it, and a call that returns records its
|
||||
* number, so a daemon waiting for its own expression's value is not answered
|
||||
* by an earlier expression that a restart resumed and that published after
|
||||
* the new one was sent. The highest wins: an expression run inside another's
|
||||
* break returns first, and the outer one only resumes on a later request.
|
||||
* The [calls] verb answers both counts. */
|
||||
static _Atomic uint32_t calls_queued;
|
||||
static _Atomic uint32_t calls_valued;
|
||||
|
||||
/* Said once, in one place, and shipped to the daemon over [refusals] rather
|
||||
* than written down again at the other end. A refusal is a sentence naming
|
||||
* what actually happened, and the thing that actually happened is not "the
|
||||
@ -437,6 +448,15 @@ static const uint8_t abandon_report[] =
|
||||
* saved and restored around the call like [eval_boundary]. */
|
||||
static sigjmp_buf *eval_escape;
|
||||
|
||||
/* Whether the game thread is inside an evaluated thunk's call, at any depth,
|
||||
* rather than in the program's own code. A break records it, and it is what
|
||||
* says whose break that is: a game loop that signals on its own while an
|
||||
* evaluation is in flight stops exactly as a thunk would, and the stop
|
||||
* counter cannot tell the two apart. Not [eval_boundary], which a class
|
||||
* migration clears inside a thunk, nor [frame_floor], which it sets outside
|
||||
* one. Game thread only, saved and restored around the call. */
|
||||
static int in_thunk;
|
||||
|
||||
/* What the chains looked like when the evaluation was called, weak for the
|
||||
* reason the frame walk below is: the runtime is linked into every program
|
||||
* that links this, but not every build carries the dev and dyn halves. */
|
||||
@ -505,6 +525,7 @@ static int migrate_call(void *fn, uint64_t instance, uint64_t added,
|
||||
void flan_agent_run_reset(void) {
|
||||
eval_boundary = NULL;
|
||||
eval_escape = NULL;
|
||||
in_thunk = 0;
|
||||
restart_floor = 0;
|
||||
frame_floor = -1;
|
||||
}
|
||||
@ -567,6 +588,7 @@ static _Atomic int aborting;
|
||||
|
||||
typedef struct {
|
||||
int32_t gen; /* never reused, never 0 */
|
||||
int32_t in_eval; /* stopped inside a thunk */
|
||||
/* Whether *any* restart on this list can be taken, which is a property of
|
||||
* the break and not of the restarts. [reachable] answers a different
|
||||
* question — that one is per restart, and it is about the thunk boundary.
|
||||
@ -773,6 +795,7 @@ static int snap_push(int resumable, void *cond) {
|
||||
snapshot *s = &snaps[d];
|
||||
int32_t n = flan_restart_count();
|
||||
s->gen = ++snap_gen;
|
||||
s->in_eval = in_thunk;
|
||||
s->resumable = resumable;
|
||||
s->cond = cond;
|
||||
s->sitelen = 0;
|
||||
@ -1310,6 +1333,7 @@ int32_t flan_agent_poll(void) {
|
||||
* signal handler, and the jump leaves the handler. */
|
||||
sigjmp_buf escape;
|
||||
sigjmp_buf *oescape = eval_escape;
|
||||
int othunk = in_thunk;
|
||||
void *mh = NULL, *mr = NULL, *mf = NULL;
|
||||
int32_t md = 0;
|
||||
int64_t mroots = 0;
|
||||
@ -1318,9 +1342,12 @@ int32_t flan_agent_poll(void) {
|
||||
if (flan_dyn_root_mark) mroots = flan_dyn_root_mark();
|
||||
uint64_t mctx[2] = { 0, 0 };
|
||||
if (flan_context_save) flan_context_save(mctx);
|
||||
in_thunk = 1;
|
||||
if (sigsetjmp(escape, 1) == 0) {
|
||||
eval_escape = &escape;
|
||||
j.call();
|
||||
if (j.call_id > atomic_load(&calls_valued))
|
||||
atomic_store(&calls_valued, j.call_id);
|
||||
} else {
|
||||
if (flan_condition_stacks_restore) flan_condition_stacks_restore(mh, mr, md);
|
||||
if (flan_dev_frames_restore) flan_dev_frames_restore(mf);
|
||||
@ -1328,6 +1355,7 @@ int32_t flan_agent_poll(void) {
|
||||
if (flan_context_load) flan_context_load(mctx);
|
||||
}
|
||||
eval_escape = oescape;
|
||||
in_thunk = othunk;
|
||||
/* Popped whichever way the thunk left — returning with a value, or
|
||||
* unwinding past this frame because someone abandoned it. */
|
||||
flan_restart_pop_c(eval_boundary);
|
||||
@ -1903,10 +1931,23 @@ static void handle_line(char *line, sink *o) {
|
||||
* of those have readers in flight and a reply format is a thing two ends
|
||||
* agree on. Answered while running as well, for [status]'s reason: an
|
||||
* editor polls this without knowing the state already. */
|
||||
/* After the number, whose code stopped: "eval" when the thread was inside
|
||||
* an evaluated thunk, "program" when it was in the program's own code. */
|
||||
if (strcmp(line, "calls") == 0) {
|
||||
char hdr[48];
|
||||
int k = snprintf(hdr, sizeof hdr, "%u %u\n",
|
||||
(unsigned)atomic_load(&calls_queued),
|
||||
(unsigned)atomic_load(&calls_valued));
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
return;
|
||||
}
|
||||
if (strcmp(line, "stop") == 0) {
|
||||
snapshot *s = (atomic_load(&depth) > 0) ? snap_top() : NULL;
|
||||
char hdr[32];
|
||||
int k = snprintf(hdr, sizeof hdr, "%d\n", s == NULL ? 0 : s->gen);
|
||||
int k = s == NULL
|
||||
? snprintf(hdr, sizeof hdr, "0\n")
|
||||
: snprintf(hdr, sizeof hdr, "%d %s\n", s->gen,
|
||||
s->in_eval ? "eval" : "program");
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
return;
|
||||
}
|
||||
@ -2179,7 +2220,9 @@ static void handle_line(char *line, sink *o) {
|
||||
* is the failure being fixed. */
|
||||
if (!publish((job){ .install = f, .call = c,
|
||||
.handle = transient == NULL ? NULL : h,
|
||||
.stopped_only = stopped_only, .at_stop = at_stop }))
|
||||
.stopped_only = stopped_only, .at_stop = at_stop,
|
||||
.call_id = c == NULL ? 0
|
||||
: atomic_fetch_add(&calls_queued, 1) + 1 }))
|
||||
fprintf(stderr, "flan: reload queue full after it was checked\n");
|
||||
return;
|
||||
}
|
||||
@ -2459,17 +2502,49 @@ failed:
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* The daemon's socket for this process, or NULL when there is none.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET alone is not enough, because an environment is inherited:
|
||||
* a shell started from inside a [flan dev] program, or anything that program
|
||||
* starts, carries it too, and binding unlinks the path first, so such a
|
||||
* process would take the session's socket from the program it belongs to. So
|
||||
* the daemon also names the process it launched, in FLAN_AGENT_OWNER, and the
|
||||
* path is honoured only there: the owner is this process in a merged build,
|
||||
* where the launcher execs into the program, and this process's parent under
|
||||
* --two-process, where the daemon started it. */
|
||||
static const char *daemon_socket(void) {
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
const char *own = getenv("FLAN_AGENT_OWNER");
|
||||
char *end;
|
||||
long pid;
|
||||
if (env == NULL || env[0] == '\0' || own == NULL || own[0] == '\0')
|
||||
return NULL;
|
||||
pid = strtol(own, &end, 10);
|
||||
if (end == own || *end != '\0' || pid <= 0) return NULL;
|
||||
if (pid == (long)getpid()) return env;
|
||||
/* The parent only under --two-process, which is the one shape that sets
|
||||
* FLAN_DEV_PARENT, and to the same pid. In a merged build the owner is the
|
||||
* program itself, so a process it starts has the owner as its parent and
|
||||
* must not take the socket. */
|
||||
{
|
||||
const char *par = getenv("FLAN_DEV_PARENT");
|
||||
if (par != NULL && strcmp(par, own) == 0 && pid == (long)getppid())
|
||||
return env;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* [path] is a Flan string: ptr and len, not NUL-terminated.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET overrides it. A program's source has to name some path,
|
||||
* and the daemon that launches the program is the one that knows where it
|
||||
* The daemon's socket overrides it (see [daemon_socket]). A program's source
|
||||
* has to name some path, and the daemon that launches the program is the one that knows where it
|
||||
* wants to talk to it — without the override the daemon would have to guess,
|
||||
* and guessing wrong fails silently: everything compiles, the module is built,
|
||||
* and nothing ever receives it. */
|
||||
int32_t flan_agent_start(const uint8_t *path, int64_t len) {
|
||||
char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
|
||||
const char *env = daemon_socket();
|
||||
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
|
||||
if (len <= 0 || (size_t)len >= sizeof buf) return -1;
|
||||
memcpy(buf, path, (size_t)len);
|
||||
buf[len] = '\0';
|
||||
@ -2493,8 +2568,8 @@ int32_t flan_agent_start_auto(void) {
|
||||
char path[sizeof(((struct sockaddr_un *)0)->sun_path)];
|
||||
struct timespec ts;
|
||||
int32_t r;
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
|
||||
const char *env = daemon_socket();
|
||||
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
|
||||
if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0;
|
||||
snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock",
|
||||
(long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL));
|
||||
@ -2511,11 +2586,11 @@ int32_t flan_agent_start_auto(void) {
|
||||
/* And the call itself, gone. A program under [flan dev] that imports this
|
||||
* package gets the listener before main, without asking.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET is the whole condition, and it is the right one: the
|
||||
* daemon sets it in both shapes — before the fork in --two-process, before the
|
||||
* exec in the merged build — and nothing else on a machine sets it. So an
|
||||
* ordinary run of an ordinary program falls straight through here and this
|
||||
* costs it one getenv. (Not FLAN_DEV_PARENT, which is deliberately unset in
|
||||
* [daemon_socket] is the condition: the daemon sets both of its variables in
|
||||
* both shapes — before the fork in --two-process, before the exec in the
|
||||
* merged build — so an ordinary run of an ordinary program falls straight
|
||||
* through here, and so does a process that only inherited them. (Not
|
||||
* FLAN_DEV_PARENT, which is deliberately unset in
|
||||
* the merged build; gating on it would quietly skip half the daemon.)
|
||||
*
|
||||
* WHAT THIS DOES NOT REACH, because it is a fact about linking rather than a
|
||||
@ -2540,8 +2615,8 @@ int32_t flan_agent_start_auto(void) {
|
||||
* cannot, in either shape — it has an editor to hear from first, and a module
|
||||
* to compile after that. */
|
||||
__attribute__((constructor)) static void auto_start(void) {
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env == NULL || env[0] == '\0') return;
|
||||
const char *env = daemon_socket();
|
||||
if (env == NULL) return;
|
||||
/* The answer is dropped because there is nobody to give it to: this is ELF
|
||||
* init, before main, before the program has decided anything. What matters
|
||||
* is that a failure here is not final — [start_on] gives [started] back, so
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user