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; }