From 37f8f77380a56e2af3bbca66a752900b46feaf3b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 19 Sep 2026 10:16:03 +0700 Subject: [PATCH] The inspector can store, and a write names the stop it was addressed to MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `(:op "set")` is `inspect`'s addressing with the arrow turned round: same frame, same slot index, same path steps, same fingerprint check, and a list of (path, expression) edits relative to what the buffer is showing. The thunk stores and then renders the same place, so what comes back is what the program holds afterwards rather than an echo of what was asked for. `stopped-only` was not enough for a write. It asks whether the program is stopped, and for a read that is the whole question — the worst a render can do against the wrong stop is print something true of a different frame. A module that *stores* through `flan/dev-slot` reaches its target through whatever snapshot is on top when the store runs, so a resume and a second stop inside the ~300ms build window lands it in the same slot index of a different stack. Not a fault: a plausible shape, in the wrong place, silently. So the agent grew `at-stop N` beside `stopped-only`, the generation `snap_push` already mints for the restart machinery, checked on the game thread at the moment the job is claimed. `stop` answers it, `inspect` carries it out on every reply, and a write that names a stop the program has left is refused before anything is built. Three refusals about where rather than what, and they are in session.ml above both backends because emit and x86 disagree about two of them. A data type's case field has no address that does not also settle the tag. An option's payload has none that does not settle whether there is one. A pointer would be an address this end made up, which is the blessing the registry exists to insist on. `Check.expression` grew a `want` and `Check.expressions` a shared frame: the first is why `3` into an `f32` field is an f32 three rather than "expected f32, found i32", and the second is why two edits in one commit are not two `let`s reading each other's storage. --- lib/check.ml | 48 ++++++- lib/dev.ml | 243 ++++++++++++++++++++++++++++++-- lib/session.ml | 282 ++++++++++++++++++++++++++++++++++++++ test/test_dev.ml | 235 +++++++++++++++++++++++++++++++ vendor/agent/flan_agent.c | 103 +++++++++++++- 5 files changed, 889 insertions(+), 22 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index a8bf82a..67008a4 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7070,17 +7070,55 @@ let instances_since env mark = (* One expression, checked against a program that is already running. The frame is empty — a REPL expression has no parameters and no enclosing - function — so the slots it needs are whatever its own [let]s allocate. *) -let expression env (e : Ast.expr) : - Tast.expr * Types.t array * string option array = + function — so the slots it needs are whatever its own [let]s allocate. + + [want] is the inspector's write verb and nothing else: [C-x C-e] has no + expectation to offer, but a store into a slot of type [f32] does, and the + whole value of passing it is that [3] arrives as an [f32] rather than as an + [i32] the store would then have to be refused for. The expectation flows + through [check] the way it flows anywhere — that is what bidirectional + means — and [expect] at the end is what catches the cases that ignore it, + so the refusal is the checker's own "expected f32, found string" and not a + second sentence written here that would drift from it. *) +(* Several of them against one frame, which is what the inspector's write verb + needs and what it must not build by hand. Two expressions checked + separately each number their slots from zero, so splicing them into one + thunk would have the second one's [let] reading and writing the first + one's storage — a frame that is two frames wearing one frame's clothes. + Sharing the [ctx] is the whole of the fix, and it is a fix because there is + exactly one allocator of slot indices in this compiler and it is this + record's counter. + + The expressions are otherwise independent: nothing binds a name for the + next one, because the list is a list of values being stored and not a + sequence. *) +let expressions env (es : (Types.t option * Ast.expr) list) : + Tast.expr list * Types.t array * string option array = let ctx = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "" } in - let t = check ctx e in - (t, Array.of_list (List.rev ctx.slot_tys), + (* Folded rather than mapped, because [List.map]'s order is unspecified and + every one of these calls has a side effect on [ctx] — the slot counter it + shares. An order nobody chose is one that can differ between builds, and + two frames laid out differently for the same edit is the kind of thing + that is found by somebody else, much later. *) + let ts = + List.rev + (List.fold_left + (fun acc (want, (e : Ast.expr)) -> + expect e.Ast.loc ~want (check ctx ?want e) :: acc) + [] es) + in + (ts, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names)) +let expression env ?want (e : Ast.expr) : + Tast.expr * Types.t array * string option array = + match expressions env [ (want, e) ] with + | [ t ], tys, names -> (t, tys, names) + | _ -> assert false + (* ── --no-gc ──────────────────────────────────────────────────────────── The flag that says this program is to be compiled with no collector in it, diff --git a/lib/dev.ml b/lib/dev.ml index 34baa6e..3904488 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -166,6 +166,30 @@ let deliver t path = String.trim (request t path) the *question*, not the code. *) let deliver_stopped_only t path = deliver t ("stopped-only " ^ path) +(* And the same again for a module that may only run from *one particular* + break. See the agent's [at_stop] note for why a write needs the stronger + promise: "stopped at all" lets a resume and a re-stop through, and a store + that goes through the shadow stack would then land in the same slot index + of a different stack. *) +let deliver_at_stop t ~gen path = + deliver t (Printf.sprintf "at-stop %d %s" gen path) + +(* Which stop the program is at: a number that is never reused, and 0 when it + is not stopped at all. + + [state] cannot stand in for this. Two stops at the same [(error (Boom …))] + are both [Stopped "Boom"], and "is this still the stop I rendered under" is + exactly the question they cannot tell apart — which is the question a write + has to have an answer to before it stores anything. + + [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 = + match request t "stop" with + | exception Unix.Unix_error _ -> None + | text -> int_of_string_opt (String.trim text) + (* 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. @@ -1348,17 +1372,33 @@ let backtrace_op t = that storage has existed since the process started. Neither carries a permission that can go stale between the asking and the running, because neither was given one. Tagging them stopped-only would refuse work that is - sound, which is the other way to lose an answer. *) -let run_render_thunk ?(stopped_only = false) t ~tag ~(c : Session.change) - : (string, string) result = + sound, which is the other way to lose an answer. + + ── [at_stop], the third setting, and the only one a write may use ──── + + A write through [flan/dev-slot] is the case the paragraph above declares + safe and is not. What makes a *read* of a frame slot safe against a resume + is that [snap_top] is then empty and the render produces nothing; what makes + a write unsafe is that a resume followed by a second stop refills it, and + the store lands in the same slot index of a stack the reader never saw. + [stopped_only] is blind to that — the program is stopped, which is all it + asks. So a write names the generation instead, and the agent compares it + against the stop actually in force at the moment it claims the job. + + The wait below is shared: both settings are watched through the same + refusal counter, because the agent drops both the same way and the sentence + it hands back is the one that says which. *) +let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag + ~(c : Session.change) : (string, string) result = let before = match result t with Some (g, _) -> g | None -> 0L in (* Read *before* the build, not before the wait: the resume this is watching for can land while llc is still running, and the job it kills is this one. [None] when the program cannot say, in which case nothing below compares against it — a missing count is no evidence either way. *) - let refused_before = if stopped_only then refusals t else None in + let watched = stopped_only || at_stop <> None in + let refused_before = if watched then refusals t else None in let resumed () = - match (refused_before, if stopped_only then refusals t else None) with + match (refused_before, if watched then refusals t else None) with | Some (before, _), Some (now, why) when now > before -> Some why | _ -> None in @@ -1367,7 +1407,11 @@ let run_render_thunk ?(stopped_only = false) t ~tag ~(c : Session.change) match build_module c ~debug:t.session.Session.debug ~out with | exception Failure m -> Error m | _ -> - (match (if stopped_only then deliver_stopped_only t out else deliver t out) with + (match + (match at_stop with + | Some gen -> deliver_at_stop t ~gen out + | None -> if stopped_only then deliver_stopped_only t out else deliver t out) + with | exception Unix.Unix_error (e, _, _) -> Error ("cannot reach the program: " ^ Unix.error_message e) | "ok" -> @@ -1645,7 +1689,126 @@ let inspect t ~frame ~slot ~path = here, because there is no second line to separate it from. *) ok [ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; - ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ])) + ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v; + (* Which stop this was read at, so that a write built from + what is on the screen can name it and be refused if the + program has been round the loop since. Nothing about the + read needs it; it is put here because *here* is the only + moment at which it is true of what the reader is looking + at, and an editor that asked for it separately would be + asking a second time about a different instant. *) + ":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ])) + + +(* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the + inspector's other direction, and [docs/BUILT.md]'s "Writing one of them + back" is the argument for having it at all. + + The addressing is [inspect]'s, to the letter: same frame, same slot index, + same path steps, same [stopped_frame] fingerprint. A write that addressed + values its own way would be free to land somewhere the render above it + never showed, which is precisely the stale-slot answer both verbs exist to + refuse. [:edits] is a list of (path-from-here, expression) pairs, so one + field set from a line of the buffer and a whole edited value committed at + once are the same request with a different number of entries. + + ── The two stops, and why a write needs both to be the same ───────── + + [:at-stop] is the generation the editor last *read* at. It is compared + twice, and the two comparisons catch different things. + + Here, before anything is built: the program has been round its loop and + stopped again since the buffer was drawn, so what is on the screen + describes storage that has been through a frame of the game. Nothing is + wrong with the request except that its author has not seen what they are + about to overwrite. It is refused, with the fact, and looking again is the + whole of the fix. + + And in the agent, on the game thread, at the moment the module is claimed: + everything between this check and that one takes time — a third of a second + of llc, a delivery, a wait — and a game that breaks every frame closes that + window without trying. That check is the one that makes this sound; this + one is the one that makes it *legible*, because a refusal that arrives + before the build arrives in a tenth of the time and names the buffer rather + than the module. + + A write with no [:at-stop] is taken. The stop is still named to the agent — + this end reads it and hands it over — so the window is closed either way; + what is skipped is only the "you are looking at an older stop" check, which + a caller that never rendered anything has no answer for. *) +let set_slot t ~frame ~slot ~path ~edits ~expect_stop = + match stopped_frame t ~frame ~what:"a local" with + | Error m -> error m + | Ok (name, fn) -> + (match stop_gen t with + | None -> + error + "cannot ask the program which stop it is at, and a write that cannot \ + name its stop is one the program has no way to refuse if it has \ + moved on" + | Some 0 -> + (* [stopped_frame] passed and this says running, so the program resumed + in between. Said as the race it is rather than repeated as the + running refusal, which would read as a check that had been made and + had not. *) + error + "the program resumed while this was being asked; there is no frame to \ + store into any more" + | Some gen -> + (match expect_stop with + | Some want when want <> gen -> + error + (Printf.sprintf + "this was written against stop %d and the program is at stop %d \ + now: it ran on and stopped again, so what is on the screen is \ + not what would be overwritten. Look again and re-do the edit" + want gen) + | _ -> + (match bound_slots t ~frame with + | Error m -> + error ("the program refused to say which slots are bound: " ^ m) + | Ok bound -> + if not (List.mem slot bound) then + (* The listing's refusal, and the same one [inspect] gives: an + unbound slot's entry is null, and storing through it would + fault on the game thread of a program that is already + stopped. A write faulting there is worse than a read doing + it — the program is not coming back from either, but this + one was asked to change something. *) + error + (Printf.sprintf + "slot %d of %s was not bound yet at the point the program \ + stopped; there is nothing at that address to store to" + slot name) + else + (* The rollback [eval_expr] takes and for its reason: checking + the stored expressions can instantiate a generic, the copies + land in the session before this module has been built or + taken, and a copy the session holds and no module defines is + a null cell. *) + let held = Session.held t.session in + let refused msg = Session.restore t.session held; error msg in + (match + Session.write_slot t.session ~frame ~fn ~slot ~path ~edits + with + | exception Loc.Error { Loc.dmsg = why; _ } -> refused why + | Error why -> refused why + | Ok (c, label, ty) -> + (match run_render_thunk ~at_stop:gen t ~tag:"s" ~c with + | Error m -> refused m + | Ok v -> + (* The value is what the *program* holds now, rendered by + the same thunk that did the storing — not an echo of + what was asked for. A buffer redrawn from this shows + the program's truth, which is the only reason it is + worth redrawing. *) + ok + [ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; + ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v; + ":wrote " ^ string_of_int (List.length edits); + ":at-stop " + ^ string_of_int + (Option.value ~default:0 (stop_gen t)) ]))))) (* ── The allocation registry, read from this end ───────────────────── *) @@ -2890,15 +3053,20 @@ let handle t req = option's payload. Anything else is refused by name rather than skipped — a path with a step silently dropped out of it would render a *different* value and say nothing. *) - | Some "inspect" -> + | Some (("inspect" | "set") as verb) -> (match Wire.int_field req "slot" with - | None -> error "inspect needs :slot, the index the locals listing gave" + | None -> + error (verb ^ " needs :slot, the index the locals listing gave") | Some slot -> let frame = match Wire.int_field req "frame" with Some n -> n | None -> 0 in - let steps = - match Wire.field req "path" with + (* Shared with [set], which addresses the same way down to the step — + one reader and not two, because a write that read its path by a + second set of rules could reach a value the render above it never + showed, which is the whole thing both verbs are built to refuse. *) + let path_of what (f : Form.t option) = + match f with | Some { Form.v = Form.List l; _ } -> List.fold_left (fun acc (e : Form.t) -> @@ -2919,12 +3087,59 @@ let handle t req = in that language special-case the empty path, and [nil] is not a step under any other reading. *) | Some { Form.v = Form.Sym "nil"; _ } -> Ok [] - | Some _ -> Error "inspect's :path is a list" + | Some _ -> Error (what ^ " is a list") | None -> Ok [] in - (match steps with + (match path_of (verb ^ "'s :path") (Wire.field req "path") with | Error m -> error m - | Ok path -> inspect t ~frame ~slot ~path)) + | Ok path -> + if verb = "inspect" then inspect t ~frame ~slot ~path + else + (* [:edits] is a list of [(:path (...) :code "...")], each path + relative to [:path] above. A list even for one edit, because + the buffer commit and the single field set are the same + request and a shorthand for the second would be a second shape + to keep in step with the first. *) + let edits = + match Wire.field req "edits" with + | None -> + Error + "set needs :edits, a list of (:path (...) :code \"...\") — \ + what to store and where, relative to :path" + | Some { Form.v = Form.List l; _ } -> + List.fold_left + (fun acc (e : Form.t) -> + match acc with + | Error _ -> acc + | Ok got -> + (match e.Form.v with + | Form.List _ -> + (match Wire.string_field e "code" with + | None -> + Error + "every :edits entry needs :code, the expression \ + whose value is to be stored" + | Some code -> + (match + path_of "an :edits entry's :path" + (Wire.field e "path") + with + | Error m -> Error m + | Ok steps -> Ok ((steps, code) :: got))) + | _ -> + Error + "every :edits entry is a list: (:path (...) :code \ + \"...\")")) + (Ok []) l + |> Result.map List.rev + | Some { Form.v = Form.Sym "nil"; _ } -> Ok [] + | Some _ -> Error "set's :edits is a list" + in + (match edits with + | Error m -> error m + | Ok edits -> + set_slot t ~frame ~slot ~path ~edits + ~expect_stop:(Wire.int_field req "at-stop")))) (* No :frame, and that is the point: the section is the stack's, not a frame's. See [globals_op]. *) | Some "globals" -> globals_op t diff --git a/lib/session.ml b/lib/session.ml index 230158c..04a2146 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1186,6 +1186,288 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path name ^ path_text path, Types.to_string v.Tast.ty))) +(* ── Writing one of them back ──────────────────────────────────────── *) + +(* The inspector's other direction. SLY sets a value from the inspector and + the reason it is worth having here is the same one the read half has: a + game keeps its state in a struct somewhere, and the loop between "that + field is wrong" and "is it this value that fixes it" is the loop the whole + dev story is about. Changing it in the source and reloading answers a + different question — it answers what the *next* run does. + + Everything about the addressing is the read half's, deliberately and not + for economy: the same root, the same [step_into], the same refusals for a + field a type does not have. A write that addressed values its own way would + be free to land somewhere the render above it never showed, which is the + whole class of bug [render_slot] exists to have closed. + + What is new is two things. The walk has to end at a *place* and not at a + value, and the value being stored is an expression somebody typed, so it + goes through the checker against the type the walk ended at. Both of those + refuse, and both refuse with a sentence rather than by doing something + smaller than was asked. *) + +(* The walk's last expression, as somewhere to store. + + [step_into] builds exactly four shapes and three of them are places. That + is not a coincidence to be relied on quietly, so the fourth is named here + rather than left to fall through to a backend: [emit]'s [place] would + [failwith] on it and [x86]'s would not, and two backends disagreeing about + what is writable is worse than either answer. + + Refused with the reason, not the layout. "A data type has no place form" is + a fact about this compiler; "the tag is what says which case the bytes are" + is the fact about the program, and it is the one that says why writing the + field alone would be wrong even if the offset were right. *) +let place_of (v : Tast.expr) : (Tast.place, string) result = + match v.Tast.e with + | Tast.Deref p -> Ok (Tast.Pderef p) + | Tast.Prim (Tast.At, target :: idx) when idx <> [] -> + Ok (Tast.Pindex (target, idx)) + (* [Ssome] builds this too, and it is the one [Field] that is not writable: + an option is a tag and a payload, and storing the payload on its own + leaves a [None] holding a value — a value nothing will ever read, because + every reader asks the tag first. Set the option itself. *) + | Tast.Field (target, _) when (match target.Tast.ty with + | Types.Option _ -> true | _ -> false) -> + Error + "an option's payload is not a place on its own: the tag is what says \ + whether there is one, and storing past it would leave a None holding a \ + value nothing will ever look at. Set the option itself" + | Tast.Field (target, i) -> Ok (Tast.Pfield (target, i)) + | Tast.CaseField (_, case, _) -> + Error + (Printf.sprintf + "%s is a field of a data type's case, and which case the bytes are in \ + is what the tag says — so there is no address to store to that does \ + not also have to settle the tag. Set the whole value instead" + case) + | _ -> + Error + (Printf.sprintf "%s is not somewhere a value can be stored" + (Types.to_string v.Tast.ty)) + +(* And the types that are places but must not be written through the editor. + + A [Ptr] is the one that matters. Every other refusal here is about a shape; + this one is about where the number would come from. A pointer value typed + into a prompt is an address this end made up, and the registry's whole + argument is that an address is only worth anything with a blessing beside + it. Storing one would hand the program a pointer nothing ever blessed, to + be dereferenced at a moment nobody chose. The read half refuses to *follow* + a pointer for the same reason it is refused here. *) +let writable_type (ty : Types.t) : (unit, string) result = + match ty with + | Types.Ptr _ -> + Error + (Printf.sprintf + "%s is a pointer, and an address typed in here is one this end made \ + up: nothing blessed it, and the program would dereference it at a \ + moment nobody chose. The inspector does not follow pointers either" + (Types.to_string ty)) + | _ -> Ok () + +(* Stores into slot [slot] of frame [frame], one store per [edits] entry, + after walking [path]. + + A list and not one store, because the buffer this exists for hands back a + whole value with several fields changed in it. N modules would be N builds + of a third of a second each and N trips past the agent's gate — so a + five-field edit would feel broken, and, worse, would be five separate + moments for a resume to land between. One module is one job: either every + store in it happened at this stop or none of them did. + + Each edit's steps are relative to [path], which is what the buffer is + showing. A single field set from a line of the inspector is one edit with + one step; a whole value committed is one edit per changed leaf, with the + steps that reach it. + + The thunk stores and then *renders*, between the same [dev-begin] and + [dev-end] the read half uses, and what comes back is therefore not the + editor's idea of what it asked for: it is what is actually there + afterwards, read out of the program's own storage by the printer that drew + the buffer in the first place. + + [retains] is left at its default on purpose. A module that stores a string + literal leaves the program pointing into that module's image, and the + default is what keeps the mapping alive for it; claiming otherwise here to + save a page would be [(set msg "tuned")] left pointing at unmapped memory, + which [emit.ml] spells out where it writes [flan_reload_transient]. + + The caller has established the frame, as it has for [render_slot]. *) +let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path + ~(edits : (step list * string) list) + : (change * string * string, string) result = + let loc = fn.Tast.floc in + let nslots_of_fn = Array.length fn.Tast.slots in + if slot < 0 || slot >= nslots_of_fn then + Error + (Printf.sprintf "there is no slot %d in %s; it has %d" slot fn.Tast.name + nslots_of_fn) + else if edits = [] then + (* Not a no-op quietly performed. A commit that found nothing to write is + a fact worth saying, and a module built to store nothing would cost a + third of a second to say it. *) + Error "there is nothing to store: nothing in this was changed" + else + let sname = + if slot < Array.length fn.Tast.snames then fn.Tast.snames.(slot) else None + in + match sname with + | None -> + Error + (Printf.sprintf + "slot %d of %s is one the compiler made up; no name was written for \ + it, and it is not something the listing offers" + slot fn.Tast.name) + | Some name -> + let where = name ^ path_text path in + let idx n = + { Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; + loc } + in + let ty = fn.Tast.slots.(slot) in + let address = + { Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx slot ]); + ty = Types.Ptr (Types.Int Types.U8); loc } + in + let typed = + { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]); + ty = Types.Ptr ty; loc } + in + let root = { Tast.e = Tast.Deref typed; ty; loc } in + let rec walk v = function + | [] -> Ok v + | s :: rest -> + (match step_into t v s with + | Error why -> Error why + | Ok v' -> walk v' rest) + in + (match walk root path with + | Error why -> Error (where ^ ": " ^ why) + | Ok shown -> + (* Two passes over the edits, and the split is the point. This one + settles every *place* and refuses the whole commit if any of them + is not one, before a single expression has been read — so a buffer + with one impossible field in it stores nothing rather than storing + the fields that happened to sort first. The module's + all-or-nothing property would be an empty promise if this end had + already half-decided. *) + let rec places acc = function + | [] -> Ok (List.rev acc) + | (steps, code) :: rest -> + let at = where ^ path_text steps in + (match walk shown steps with + | Error why -> Error (at ^ ": " ^ why) + | Ok target -> + (match writable_type target.Tast.ty with + | Error why -> Error (at ^ ": " ^ why) + | Ok () -> + (match place_of target with + | Error why -> Error (at ^ ": " ^ why) + | Ok dest -> + places ((at, dest, target.Tast.ty, code) :: acc) rest))) + in + (match places [] edits with + | Error why -> Error why + | Ok targets -> + (* And this one reads and checks the values. Every expression is + checked against one [ctx] — [Check.expressions], not one + [Check.expression] each — because two expressions checked apart + both number their slots from zero, and splicing them into one + thunk would have the second one's [let] reading and writing the + first one's storage. *) + let mark = Check.instance_mark t.env in + let wanted = + List.map + (fun (at, _, tty, code) -> + let form = + match Reader.read_all ~file:origin code with + | [ f ] -> f + | [] -> fail loc "nothing to store into %s" at + | _ :: f :: _ -> fail f.Form.loc "one value at a time" + in + (* Expanded with the session's imported macros in front of + it, for the reason [eval_expr] gives: the prompt sends + one expression with no import in sight, and the session + is the only thing holding what the imports brought in. *) + (Some tty, Parse.with_imported t.macros (fun () -> Parse.expr form))) + targets + in + (* Checked *against the place's type*, which is the whole reason + [Check.expression] grew a [want]. Without it, [7] into an [f32] + field arrives as an [i32] and is refused for a mismatch the + reader never wrote; with it, it arrives as an [f32], and what + stays refused is what really does not fit — in the checker's + own words, which is the only place that sentence should ever be + written down. *) + let values, base, bnames = Check.expressions t.env wanted in + let fresh = Check.instances_since t.env mark in + let stores = + List.map2 + (fun (_, dest, _, _) value -> + { Tast.e = Tast.Set (dest, value); ty = Types.Unit; loc }) + targets values + in + let extra = ref [] and nslots = ref (Array.length base) in + let c = + { Render.structs = t.program.Tast.structs; + datas = t.program.Tast.datas; + unions = t.program.Tast.unions; + enums = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; + emit = dev_emitter; + ptrs = Some dev_pointers; + alloc = (fun ty -> + let i = !nslots in + incr nslots; + extra := ty :: !extra; + i) } + in + (match Render.render c 0 shown with + | exception Loc.Error { Loc.dmsg = why; _ } -> + Error (where ^ ": " ^ why) + | parts -> + let nullary n = + { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } + in + t.thunks <- t.thunks + 1; + let tname = Printf.sprintf "set/%d" t.thunks in + let thunk : Tast.fn = + { Tast.name = tname; params = []; ret = Types.Unit; + body = + stores + @ (nullary "flan/dev-begin" :: parts) + @ [ nullary "flan/dev-end" ]; + fdefers = []; fparent = None; floc = loc; + slots = Array.append base (Array.of_list (List.rev !extra)); + (* The stored expressions' own [let]s keep their names; the + slots [render] added behind them are the walk's own + scratch and have none to keep. *) + snames = + Array.append bnames + (Array.make (List.length !extra) None) } + in + let program = + { t.program with + Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ]; + externs = t.program.Tast.externs @ externs } + in + let ir = + redefinition t ~call:tname program + ~fns: + (List.map (fun (f : Tast.fn) -> f.Tast.name) fresh + @ [ tname ]) + in + (* The instances the values forced stay, the thunk does not — + [eval_expr] says why, and the caller takes the same [held] + around this that it takes around one. *) + t.program <- + { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + Ok + ({ ir; x86 = t.x86; names = []; fns = []; installs = true }, + where, Types.to_string shown.Tast.ty)))) + (* ── The globals a stopped stack reaches ───────────────────────────── *) (* The other half of what a break loop can show, and in this language arguably diff --git a/test/test_dev.ml b/test/test_dev.ml index a9fccd1..905a51a 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -1867,6 +1867,241 @@ let () = end end; + (* ── Writing one of them back ─────────────────────────────────── *) + + (* The inspector's other direction. Its own daemon over the same program, + because the block above finishes by redefining [outer] under its own + frame on purpose — which is exactly the state in which nothing may be + written, so it is no state to write from. + + What is checked here is the three claims the verb makes. The store + lands where the render said it would, and the value that comes back is + read out of the program afterwards rather than echoed. The expression + is checked against the *place's* type, so a literal arrives at the + width the place has and a value that does not fit is refused in the + checker's own words. And a write that cannot name the stop it was + addressed to is refused rather than aimed at whatever stack happens to + be there. *) + let wsock = tmp "set.sock" and wout = tmp "set.out" in + (try Sys.remove wsock with Sys_error _ -> ()); + let wfd = Unix.openfile wout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let wpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-inspect.flan"; "-s"; wsock; "--llvm" |] + Unix.stdin wfd Unix.stderr + in + Unix.close wfd; + if not (listening ~pid:wpid wsock) then begin + fail "the set daemon %s" !listen_why; + (try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect wsock in + let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let message r = Option.value ~default:(status r) (Wire.string_field r "message") in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then + fail "the set program never stopped" + else begin + let slot_of r name = + match Wire.field r "locals" with + | Some { Form.v = Form.List l; _ } -> + List.fold_left + (fun acc (e : Form.t) -> + match acc with + | Some _ -> acc + | None -> + (match e.Form.v with + | Form.List + [ { Form.v = Form.Str n; _ }; _; _; + { Form.v = Form.Int i; _ } ] + when String.equal n name -> + Some (Int64.to_int i) + | _ -> None)) + None l + | _ -> None + in + let listing = ask "(:op \"locals\" :frame 1)" in + if status listing <> "ok" then + fail "locals of the outer frame: %s" (message listing) + else begin + let slot name = + match slot_of listing name with + | Some s -> s + | None -> + fail "the locals listing gave no slot index for %s" name; + -1 + in + let set ?(path = "()") name edits = + ask + (Printf.sprintf "(:op \"set\" :frame 1 :slot %d :path %s :edits %s)" + (slot name) path edits) + in + let inspect ?(path = "()") name = + ask + (Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)" + (slot name) path) + in + (* One field, addressed the way a line of the buffer addresses it: + the path reaches the field and the edit stores at it. The reply's + value is the field read back, and the inspection after it is the + independent one — the same thunk that stored could in principle + have rendered the value it was handed rather than the storage. *) + let r = set ~path:"(\"x\")" "mark" "((:code \"3.5\"))" in + if status r <> "ok" then fail "setting mark.x: %s" (message r) + else if value r <> "3.5" then + fail "setting mark.x answered %s, not 3.5" (value r); + let r = inspect ~path:"(\"x\")" "mark" in + if value r <> "3.5" then + fail "mark.x reads back as %s after the write, not 3.5" (value r); + + (* And the literal arrives at the *place's* width. Without the + expectation flowing into the checker this is the i32 three and + "expected f32, found i32"; with it, it is the f32 three, which is + the whole of what [Check.expression]'s [want] buys. *) + let r = set ~path:"(\"x\")" "mark" "((:code \"3\"))" in + if status r <> "ok" then + fail "an integer literal into an f32 field: %s" (message r) + else if value r <> "3" then + fail "the integer three into an f32 field read back as %s" (value r); + + (* Several fields at once, which is the buffer commit: one module, + one job, one render of what is there afterwards. *) + let r = + set "mark" "((:path (\"x\") :code \"9.25\") (:path (\"y\") :code \"8.5\"))" + in + if status r <> "ok" then fail "setting both fields of mark: %s" (message r) + else if value r <> "(Point {.x 9.25 .y 8.5})" then + fail "the pair of writes answered %s" (value r); + if Wire.int_field r "wrote" <> Some 2 then + fail "a two-edit commit did not report writing two"; + + (* The whole value, not a field of it. *) + let r = set "mark" "((:code \"(Point {.x 0.5 .y 0.25})\"))" in + if status r <> "ok" then fail "setting mark whole: %s" (message r) + else if value r <> "(Point {.x 0.5 .y 0.25})" then + fail "setting mark whole answered %s" (value r); + + (* An element, through the same [at] the render walks. The value is + an expression and not a literal, because the point of sending + Flan rather than a number is that it is evaluated in the + program. *) + let r = set "xs" "((:path (1) :code \"(+ 20 5)\"))" in + if status r <> "ok" then fail "setting xs[1]: %s" (message r) + else if value r <> "[ 10 25 30]" then + fail "setting xs[1] answered %s" (value r); + + (* A value that does not fit is refused in the checker's own words, + and nothing is stored. *) + let r = set ~path:"(\"x\")" "mark" "((:code \"\\\"hello\\\"\"))" in + if status r <> "error" then + fail "a string stored into an f32 field was accepted" + else if not (contains_sub (message r) "expected f32") then + fail "the type refusal does not name the type: %s" (message r); + let r = inspect "mark" in + if value r <> "(Point {.x 0.5 .y 0.25})" then + fail "the refused write changed something: %s" (value r); + + (* Two refusals about where, not about what. A data type's field has + no address that does not also settle the tag, and an option's + payload has none that does not settle whether there is one. Both + are readable — the block above reads them — which is the point: + what can be shown and what can be stored to are different sets, + and each refusal says which it is. *) + let r = set ~path:"(\"Shape.Rect.w\")" "s" "((:code \"11\"))" in + if status r <> "error" then + fail "a data type's case field was written to" + else if not (contains_sub (message r) "tag") then + fail "the data type refusal does not say why: %s" (message r); + let r = set ~path:"(some)" "box" "((:code \"(Point {.x 1.0 .y 1.0})\"))" in + if status r <> "error" then + fail "an option's payload was written to on its own" + else if not (contains_sub (message r) "None") then + fail "the option refusal does not say why: %s" (message r); + + (* An edit whose path is impossible refuses the whole commit, so the + good edit beside it does not land either. All-or-nothing is what + makes one module per commit worth anything. *) + let r = + set "mark" "((:path (\"x\") :code \"77.0\") (:path (\"z\") :code \"1.0\"))" + in + if status r <> "error" then fail "a commit with a bad field was taken"; + let r = inspect ~path:"(\"x\")" "mark" in + if value r <> "0.5" then + fail "half of a refused commit landed anyway: %s" (value r); + + (* And a write addressed to a stop the program is no longer at is + refused before anything is built. The number is one the program + cannot be at — generations start at one and count up — so this is + the mismatch and not a program that happens to have moved. *) + let r = + ask + (Printf.sprintf + "(:op \"set\" :frame 1 :slot %d :path () :edits ((:code \"(Point {.x 2.0 .y 2.0})\")) :at-stop 999999)" + (slot "mark")) + in + if status r <> "error" then + fail "a write against a stop the program is not at was taken" + else if not (contains_sub (message r) "Look again") then + fail "the stale-stop refusal does not say what to do: %s" (message r); + + (* The stop the reads have been carrying all along is the one the + writes have been landing at, which is what makes the editor able + to hold it between the two. *) + let r = inspect "mark" in + (match Wire.int_field r "at-stop" with + | Some g when g > 0 -> + let r = + ask + (Printf.sprintf + "(:op \"set\" :frame 1 :slot %d :path (\"y\") :edits ((:code \"4.5\")) :at-stop %d)" + (slot "mark") g) + in + if status r <> "ok" then + fail "a write naming the stop it read at: %s" (message r) + else if value r <> "4.5" then + fail "the write naming its stop answered %s" (value r) + | _ -> fail "an inspection did not say which stop it read at") + end; + (* An unbound slot has nothing to store to, and says so rather than + faulting on the game thread of a program that is already stopped. *) + let r = ask "(:op \"set\" :frame 0 :slot 0 :path () :edits ((:code \"1\")))" in + if status r <> "error" then + fail "a frame with no slots was written to" + end; + (* And a running program has no frame to store into. The same refusal + the read half gives, through the same check, which is the point of + it being the same check. *) + let r = ask "(:op \"restart\" :name \"carry-on\")" in + if status r <> "ok" then + fail "resuming the set program: %s" + (Option.value ~default:"" (Wire.string_field r "message")); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "the set program never resumed" + else begin + let r = ask "(:op \"set\" :frame 1 :slot 0 :path () :edits ((:code \"1\")))" in + if status r <> "error" then + fail "a running program was written to" + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] wpid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] wpid) with Unix.Unix_error _ -> ()) + end + end; + (* ── A pointer the registry knows about ───────────────────────── *) (* The inspector's pointer arm, and the address root beside it. diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 01a00f5..e376ad1 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -176,12 +176,41 @@ int flan_dev_reg_overflowed(void); * [handle] is set only for a module that declared itself transient — one that * ran a thunk and left nothing behind. Everything else is kept mapped forever: * a cell holds an address inside a module's text, and unloading it would leave - * every call site pointing at unmapped memory. */ + * every call site pointing at unmapped memory. + * + * ── [at_stop], and why [stopped_only] is not enough for a *write* ────── + * + * [stopped_only] asks "is the program stopped", and for a read that is the + * whole question: the worst a render can do against the wrong stop is print + * something that was true of a different frame, and it is printed into a + * buffer nobody stores anywhere. + * + * A write is not that. A module that *stores* into frame N slot I reaches its + * target through [flan_agent_frame_slot], which reads whatever snapshot is on + * top at the moment the store runs. Resume and stop again inside the build + * window — ~300ms of llc, and a game loop that breaks every frame closes that + * window without trying — and [depth] is above zero again, the job is + * accepted, and the store lands in frame N of a *different* stack. Not a + * fault: a plausible shape, in the wrong place, silently. + * + * So a write names the stop it was addressed against. [snap_push] mints a + * generation that is monotone and never reused, precisely so that "resumed + * and stopped again" is distinguishable from "still the same stop" — the + * restart machinery already leans on it for the same reason. [at_stop] is + * that number, asked for by the daemon through [stop] and handed back on the + * request, and checked here, on the game thread, at the moment the job is + * claimed. Zero means the job does not care, which is every read. + * + * It sits beside [stopped_only] rather than subsuming it because they are two + * different questions and one of them has no answer to give: a render rooted + * at a raw address wants "stopped at all" and has no stop to name, since the + * registry that blessed the address is not a stack. */ typedef struct { install_fn install; call_fn call; void *handle; int stopped_only; + int32_t at_stop; } job; /* Said once, in one place, and shipped to the daemon over [refusals] rather @@ -193,6 +222,24 @@ static const char *RESUMED = "the program resumed while this inspection was being built — stop it again " "and re-ask"; +/* The other way a job's stop can stop being the job's stop, and it needs its + * own sentence because the fix is a different one. Above, the program is + * running and the reader has to stop it. Here it *is* stopped — at a stop + * that came after the one the request named — so stopping it again would do + * nothing, and what is wanted is to look at what is there now. A write built + * against a render of the old stop would otherwise land in storage the reader + * never saw. */ +static const char *RESTOPPED = + "the program was resumed and stopped again while this was being built, so it " + "is no longer at the stop this was addressed to — look again and re-ask"; + +/* Which of the two the last drop was. One counter and two sentences rather + * than two counters, because the daemon's question is "did a drop happen + * between these two reads" and that is a count; the text is only what it says + * afterwards. Last writer wins, which is the residual [refused_while_running] + * already documents below for two inspections in flight at once. */ +static const char *_Atomic refused_why = NULL; + /* How many stopped-only jobs have been dropped, ever. A count and not a flag: * the daemon reads it before it delivers and again while it waits, and what it * wants to know is whether one happened *in between*, which a flag somebody @@ -734,10 +781,25 @@ int32_t flan_agent_poll(void) { * nothing was installed, and [n] is what a caller polls to find out that * something was. */ if (j.stopped_only && atomic_load(&depth) <= 0) { + atomic_store(&refused_why, RESUMED); atomic_fetch_add(&refused_while_running, 1); if (j.handle != NULL) { dlclose(j.handle); } continue; } + /* And the same gate for a job that named a stop. Read from [snap_top] and + * not from [snap_gen], which is the counter and not the stop: after a + * resume [snap_gen] still holds the generation of the break that ended, + * so comparing against it would accept a job whose stop is over. The + * snapshot on top is the stop that is in force. */ + if (j.at_stop != 0) { + snapshot *s = snap_top(); + if (s == NULL || s->gen != j.at_stop) { + atomic_store(&refused_why, s == NULL ? RESUMED : RESTOPPED); + atomic_fetch_add(&refused_while_running, 1); + if (j.handle != NULL) { dlclose(j.handle); } + continue; + } + } if (j.install != NULL) { j.install(); n++; } /* After the install, so a thunk sees the bodies its own module published. * @@ -1199,10 +1261,28 @@ static void handle_line(char *line, sink *o) { int k = snprintf(hdr, sizeof hdr, "%llu\n", (unsigned long long)atomic_load(&refused_while_running)); if (k > 0) emit(o, hdr, (size_t)k); - reply(o, RESUMED); + const char *why = atomic_load(&refused_why); + reply(o, why != NULL ? why : RESUMED); reply(o, "\n"); return; } + /* Which stop the program is at, as a number that is never reused and never + * zero — zero being "it is not stopped". [status] cannot answer this: two + * stops at the same [(error (Boom …))] are both "stopped Boom", and telling + * them apart is the whole question a write has to ask before it stores into + * a frame somebody rendered a moment ago. + * + * Its own verb rather than a field on [status] or [backtrace], because both + * 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. */ + 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); + if (k > 0) emit(o, hdr, (size_t)k); + return; + } if (strcmp(line, "result") == 0) { uint64_t gen = 0, len = 0; uint64_t cap = flan_dev_result_cap(); @@ -1404,6 +1484,23 @@ static void handle_line(char *line, sink *o) { stopped_only = 1; line += 13; } + /* [at-stop N ] travels the same way and for the same reason, and it goes + * after [stopped-only ] so that a module which is both spells it + * "stopped-only at-stop 7 /path". Nothing sends both today — naming a stop + * already implies one — but the two prefixes answer different questions and + * a parser that made them exclusive would have to be revisited the first + * time something wants the pair. The number is parsed here rather than + * trusted: a path beginning "at-stop " with no number after it is a path, + * and treating it as a malformed prefix would lose the module. */ + int32_t at_stop = 0; + if (strncmp(line, "at-stop ", 8) == 0) { + char *end = NULL; + long n = strtol(line + 8, &end, 10); + if (end != line + 8 && *end == ' ' && n > 0 && n <= 0x7fffffff) { + at_stop = (int32_t)n; + line = end + 1; + } + } /* Before the dlopen, not after it: a module there is no room to queue is * one there is no point relocating, and refusing here means no handle is * taken for it at all. Only one producer runs at a time, so room seen now is @@ -1455,7 +1552,7 @@ 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 })) + .stopped_only = stopped_only, .at_stop = at_stop })) fprintf(stderr, "flan: reload queue full after it was checked\n"); return; }