diff --git a/TODO.org b/TODO.org index 45079c80..79b345c7 100644 --- a/TODO.org +++ b/TODO.org @@ -1378,13 +1378,9 @@ poll would, and test/agent_hooks.c uses it to choose at an outer break and then nest a break on top before the outer one looks. The inner break turns past the choice and resumes only on its own. Rules out a sleep-timed socket test for this. -** TODO A choice made at an outer break is lost to a nested one -=chosen_index=, =chosen_gen= and =chosen_ready= are one slot. A choice validated -against an outer break and met by a nested one survives the nested break's -turns, but the nested break can only resume on a choice of its own, which -overwrites it — so the outer break stays stopped after the listener answered ok -for it. test/agent_hooks.c's =stale= mode pins this as it is. A slot per -snapshot is the likely fix. +** DONE A choice made at an outer break survives a nested one +CLOSED: [2026-09-25] +A nested break keeps the choice pending for the break below it and puts it back when it is left, so the outer break takes it without being asked again; and a restart is taken only after every job queued before it was accepted has run. Rules out a scripted fix-then-retry running the old body. ** DONE SNAP_MAX and SNAP_NAMES are read rather than tested CLOSED: [2026-09-25] @@ -1642,10 +1638,15 @@ a defcustom. The agent keeps the condition pointer beside its name and a verb hands it back, so the editor can render the condition's own fields rather than only its class. -** NEXT The render-thunk-per-inspection design -Decided 2026-09-25: the inspector reads a value through the type layouts the compiler records, with no compile per inspection, which lets it hold a value. -An inspection still compiles a thunk per request. A redesign rather than a -deletion, and its own lane: it is what unblocks the inspector retaining a value. +** DONE Reading a value compiles nothing +CLOSED: [2026-09-25] +=locals=, =inspect=, =at=, =condition= and =globals= read memory through the agent and walk it in lib/inspect.ml; only writes still build a module. Rules out a render thunk per read, and a reply spelling a value differently from =C-x C-e= (test_dev's parity block). docs/BUILT.md, "Reading a value compiles nothing". + +** TODO The inspector holds a value +Reading needs no module now, so an address and a type are enough to keep a value on the daemon's side between requests, the way CIDER keeps a JVM object. Nothing holds one yet: the Emacs stack is still a stack of expressions. + +** TODO A frame that prints is skipped from the globals section +A frame whose body calls =print= comes back in =:skipped= as "running a body that has been redefined since" though nothing was redefined: its global-reference fingerprint differs between the build and the daemon. test/programs/dev-parity.flan stores each global to itself instead of printing it for this reason. ** DONE The watch table stays pushed CLOSED: [2026-09-25] diff --git a/docs/BUILT.md b/docs/BUILT.md index 5a8a18b8..2167994a 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -2060,7 +2060,7 @@ The fixed caps go with it: the snapshot is taken **on the game thread**, so it c What the merge *does* unlock here is one thing and it is the next item: `flan_agent_frame_slot` already hands back the address of a slot, and in one process the compiler could read the value at that address instead of compiling a render thunk to print it. That is the render-thunk-per-inspection redesign — a different mechanism rather than a deletion, and -what makes "the inspector can retain a value" reachable. It is deliberately not done here. +what makes "the inspector can retain a value" reachable. It was done later; see "Reading a value compiles nothing". **So of the three things the merge was expected to make deletable, one was.** The socket was transport and is gone; the result cap and the snapshot are both concurrency, and they were only ever mistaken for transport because the socket was @@ -2617,6 +2617,44 @@ escaping — was built and timed as the obvious alternative and is worse on both calling function's own stack is already hot, and an indexed store into a megabyte of BSS is not. It also has a fixed depth, which a chain of stack records does not. +### Reading a value compiles nothing + +`locals`, `inspect`, `at`, `condition` and `globals` used to each build a render thunk — `Render.render` over the +value's address, compiled, loaded, run on the stopped thread, read back — a third of a second of `llc` per question. +They now read the stopped program's memory from the daemon and walk it in OCaml (`lib/inspect.ml`), through the same +`Emit.lay` offsets both backends lay values out by. The sections below still describe *what* each verb answers; where +they say a thunk renders it, `Inspect` now does. + +**What the program is asked** is six agent verbs, all refused unless stopped: `slot F I`, `cond-at` and `global SYM` +for where a root is; `peek ADDR LEN` for bytes; `ptr ADDR` for the registry's live/dead/unknown and the epitaph +(`flan_dev_reg_epitaph`, which `flan_dev_reg_emit` now writes through, so the sentence has one author); and `dyn WORD`, +because a dyn value's tag is the runtime's to read. `dyn` queues a job the break loop runs on the program's thread, since the +dyn printer follows pointers: a trap or fault there is the reader's, so `break_loop_at` writes the value as +`#` and unwinds through the evaluation escape without pushing a break, and the fault report says the +inspector's read touched the address. A restart is taken once every job queued before it was accepted has run, and a job +that needs the stop is refused after one is. They go through `Dev.request`, +so the two-process daemon answers them over the socket and the merged one by a call. `peek` reads through +`process_vm_readv` on its own process, so an unmapped address is a refusal and not a fault that takes the program — +and in one process, the daemon — down with it. + +**The text is `Render.render`'s, byte for byte**, because the editor parses it back and because the same value must not +read differently at `C-x C-e` and in the break buffer. That walk still exists — `println` and an evaluated value are +rendered at compile time — so this is two walks over the same arms. What can be shared is: which types are refused is +decided by running `Render.render` over the type ([Inspect.refusal]), and a struct's head is `Render.head`. What +cannot, the arms themselves, is pinned by `test_dev`'s parity block, which asks both renderers about a global of every +shape on both backends. The output cap is now per value (4096, `...` as the runtime writes it) rather than per module; +a locals listing used to share one 4096-byte buffer between every slot and drop the ones past the cut. + +**A path ends at an address.** `Session.step_into` still decides which steps a type admits and how each is refused; +`Inspect.place` works out where the resulting expression lives. Two checks the compiled thunk made in the program are +made there instead: a slice index against the slice's length, and a data case against the value's tag. + +**Held to one stop.** The daemon serves one request at a time, so nothing it is asked can resume the program in the +middle of a read; `Dev.one_stop` compares the stop generation before and after anyway, and refuses on a difference. + +Writes still compile: `set` and a restart's arguments store an expression somebody typed, so they need a module, and +their read-back after the store is the thunk renderer's. + ### Locals of a stopped frame The half the shadow stack was built for. `(:op "locals" :frame N)` answers what a stopped frame's named locals hold. @@ -6151,16 +6189,14 @@ the name quoted and never defaulted to bytes. ### The address root renders a pointer, not a pointee -`(:op "at" :addr N)` — `M-x flan-inspect-address` — builds a `(Ptr T)` at the address and renders **that**. Rendering -the `T` directly would read the storage whatever the registry said, which is the hex dump this project is trying not -to be. Rendering the pointer puts the walk through `render.ml`'s pointer arm, which is the arm that asks first, so an -address root and a slot root reach the same two answers by the same code and permission is asked in exactly one place -in the compiler. +`(:op "at" :addr N)` — `M-x flan-inspect-address` — renders a `(Ptr T)` holding the address, not the `T` at it. +Rendering the `T` directly would read the storage whatever the registry said, which is the hex dump this project is +trying not to be. Rendering the pointer puts the walk through the pointer arm, which is the arm that asks first, so an +address root and a slot root reach the same two answers by the same code. -The one piece the thunk cannot do for itself is the address: **Flan has no integer-to-pointer cast**, deliberately, so -`flan_dev_reg_addr` is an extern beside `flan_agent_frame_slot` and for the same reason — the compiler knows the type -and something outside the language supplies the address. `flan_dev_reg_number` is the other direction, for a *program* -that has to say an address out loud; the language still has no operator for either. +The reader does the same with no thunk: `Inspect.render_ptr` enters the walk at the pointer arm, so the registry is +asked (`ptr ADDR`) before a byte of the pointee is read. `flan_dev_reg_number` is the other direction, for a *program* +that has to say an address out loud; the language still has no operator for it, deliberately. Three refusals, each by name: an address the registry never saw **with no `:type` given** (a stack local, a global, a pointer from C — the first two are answered by name already); an address the block's element size does not divide, diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index 72cc68a4..451fd977 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -31,9 +31,11 @@ ;; That is available to it because a JVM value can be retained: the middleware ;; keeps a reference and the collector leaves it alone. ;; -;; Nothing here can do that. A Flan value has no header, the thunk that -;; rendered it is `dlclose'd the moment it returns, and there is no heap to -;; retain anything in. So the stack is a stack of **expressions**, on this +;; Nothing here does that yet. A Flan value has no header and there is no +;; heap to retain anything in; the daemon reads a stopped program's memory +;; through the layouts it compiled (lib/inspect.ml), which is what would let +;; it hold an address and a type, but it holds nothing between requests +;; today. So the stack is a stack of **expressions**, on this ;; side, and going into a field means sending a *different expression* — ;; `(.pos b)' where the last one was `b'. Two consequences, one good and one ;; that has to be said out loud: @@ -129,6 +131,8 @@ reply without a daemon behind them, and so that this file names ;; ;; (Name {.f V .f V}) a struct, with ` ...' before the `}' if the walk hit ;; its span bound of 8 fields +;; (Name A {.f V}) an instance of a generic struct, its type arguments +;; kept on the head (:text) and the name alone as :type ;; [ V V V] an array or a slice, ` ...' likewise ;; (some V) / none an option ;; a pointer, never followed @@ -202,7 +206,7 @@ reply without a daemon behind them, and so that this file names (let ((j (1+ i))) (let ((start j)) (while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\))))) (setq j (1+ j))) - (let ((head (substring s start j))) + (let* ((head (substring s start j)) (name head)) (cond ;; (some V). There is no accessor form in Flan that reaches an ;; option's payload — the compiler gets at it as field 1 and nothing @@ -215,8 +219,27 @@ reply without a daemon behind them, and so that this file names :children (list (cons "some" (car r)))) (if (and (< k (length s)) (eq (aref s k) ?\))) (1+ k) k)))) (t - ;; `(Name {' then `.field VALUE' pairs, then `})'. - (setq j (flan-inspect--skip-space s j)) + ;; `(Name {' then `.field VALUE' pairs, then `})'. A generic + ;; struct's instance carries its type arguments between the name + ;; and the brace — `(Pair i32 {…})', `(Box (Option u8) {…})' — and + ;; they are read here as balanced text, since they are a type's + ;; spelling and not values. They stay on the head, so that + ;; `flan-inspect--literal' writes back what was read. + (let ((args nil)) + (setq j (flan-inspect--skip-space s j)) + (while (and (< j (length s)) (not (memq (aref s j) '(?\{ ?\))))) + (let ((start j) (depth 0)) + (while (and (< j (length s)) + (or (> depth 0) + (not (memq (aref s j) '(?\s ?\{ ?\)))))) + (pcase (aref s j) + ((or ?\( ?\[) (setq depth (1+ depth))) + ((or ?\) ?\]) (setq depth (1- depth)))) + (setq j (1+ j))) + (push (substring s start j) args)) + (setq j (flan-inspect--skip-space s j))) + (when args + (setq head (mapconcat #'identity (cons head (nreverse args)) " ")))) (when (and (< j (length s)) (eq (aref s j) ?\{)) (setq j (1+ j))) (let ((kids nil) (more nil) (done nil)) (while (not done) @@ -252,7 +275,7 @@ reply without a daemon behind them, and so that this file names (push (cons "?" (car r)) kids)))))) (setq j (flan-inspect--skip-space s j)) (when (and (< j (length s)) (eq (aref s j) ?\))) (setq j (1+ j))) - (cons (list :kind 'struct :text head :type head + (cons (list :kind 'struct :text head :type name :truncated more :children (nreverse kids)) j)))))))) @@ -512,7 +535,7 @@ stated honestly — every Flan integer is rendered through i64." (defun flan-inspect--summary (node) "One line for NODE, as it appears beside its label." (pcase (plist-get node :kind) - ('struct (format "(%s …%s)" (plist-get node :type) + ('struct (format "(%s …%s)" (plist-get node :text) (let ((n (length (plist-get node :children)))) (format " %d field%s" n (if (= n 1) "" "s"))))) ('seq (plist-get node :text)) @@ -536,7 +559,7 @@ value is stored, when the reply said." (if declared (format "%s\n" declared) (pcase (plist-get node :kind) - ('struct (format "a %s\n" (plist-get node :type))) + ('struct (format "a %s\n" (plist-get node :text))) ('seq (format "%s\n" (plist-get node :text))) ('option "an option\n") ('ptr "a pointer — never followed\n") diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index c158bdbb..d6f21f0d 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -74,6 +74,24 @@ (equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children)) '(0 1 2)))) +;; A generic struct's instance, its type arguments between the name and the +;; brace, compound ones included. Written back as it was read. +(let* ((src "(Pair (Option u8) [3 i32] {.a (some 1) .b [ 1 2 3]})") + (n (flan-inspect-parse src))) + (test-flan--check "a generic instance is a struct" + (eq (plist-get n :kind) 'struct)) + (test-flan--check "its type arguments are not read as fields" + (equal (mapcar #'car (plist-get n :children)) '("a" "b"))) + (test-flan--check "its name is the type, its head keeps the arguments" + (and (equal (plist-get n :type) "Pair") + (equal (plist-get n :text) "Pair (Option u8) [3 i32]"))) + (test-flan--check "and it is written back with them" + (equal (flan-inspect-parse (flan-inspect--literal n)) n))) +(test-flan--check "the older spelling of an instance still reads" + (equal (mapcar #'car (plist-get (flan-inspect-parse "(Pair-i32 {.a 1})") + :children)) + '("a"))) + ;; [ 0 42 0] — Types.Slice and Types.Array both write this. (let ((n (flan-inspect-parse "[ 0 42 0]"))) (test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq)) diff --git a/lib/dev.ml b/lib/dev.ml index 8c0b8967..0ee5f343 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -2281,88 +2281,62 @@ let backtrace_op t = Printf.sprintf ":more %d" more ] | Error m -> error ("the program refused to say where it is: " ^ m)) -(* Build a render thunk, hand it to the program, and read back what it wrote. +(* Build a thunk that changes something in the stopped program, hand it over, + and read back what it wrote. - The same five steps for every verb that renders something inside the - stopped program — [locals], [globals] and [inspect] — and they are here - once rather than three times because the note this file already carries - about the fingerprint applies to plumbing too: four of five hand-offs - present looks exactly like one hand-off dropping a step, and that is a bug - nobody sees until the one path that lost it is the one being used. + Only writes come here now — [set] storing into a frame, and a restart's + arguments stored before it is taken. Reading a value compiles nothing: see + [Inspect] and the verbs that use it below. A write still needs a module, + because the value being stored is an expression somebody typed. [tag] only names the [.so] on disk, which is what someone reads when they go looking at [t.dir] to find out which verb produced what. - ── [stopped_only], and why only one of the three wants it ──────────── + ── [at_stop] ───────────────────────────────────────────────────────── Everything between the gate and the thunk takes time the gate does not - cover. The verb checks that the program is stopped, the agent checks it - again, and then a module is *built* — a third of a second of llc and a - linker — and delivered, and waited on for up to five seconds. A [restart] - arriving anywhere in there resumes the game thread, and the thunk runs at - the next frame boundary instead of from the break. The wait below does not - even notice: it keeps waiting while liveness is [Live], and a resumed - program is the liveliest thing there is. - - What that costs depends entirely on what the thunk holds. - - [inspect] by *address* holds a number. [Dev.render_addr] bakes the address - into the module as an integer literal, because the registry's blessing — - "something live is there, and it is a [Foo]" — was given at build time by a - table that the running program is exactly the thing that changes. Run that - thunk after a resume and it dereferences an address whose blessing expired, - possibly into storage the program has since freed. So it is delivered - stopped-only, and the agent drops it rather than running it. - - [locals], [inspect] by *slot* and [globals] hold no address at all, and that - is the line. A local is reached through [flan/dev-slot], which is - [flan_agent_frame_slot], which asks [snap_top] for the frame *when the thunk - runs* — and [snap_top] is empty once the break that pushed it has been - resumed past. A global is reached by name: [Emit.redefinition] leaves it - [external], the dynamic linker binds it to the program's own storage, and - that storage has existed since the process started. Neither carries a - permission that can go stale between the asking and the running, because - neither was given one. Tagging them stopped-only would refuse work that is - sound, which is the other way to lose an answer. - - ── [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 + cover: a module is *built* — a third of a second of llc and a linker — and + delivered, and waited on for up to five seconds. A [restart] arriving in + there resumes the game thread, and a second stop refills the snapshot, so a + store through [flan/dev-slot] would land in the same slot index of a stack + the reader never saw. So a write names the generation it was built against, + and the agent compares it against the stop actually in force at the moment + it claims the job, and drops it otherwise. *) +let rec run_render_thunk ?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 watched = stopped_only || at_stop <> None in - let refused_before = if watched then refusals t else None in - let resumed () = - match (refused_before, if watched then refusals t else None) with - | Some (before, _), Some (now, why) when now > before -> Some why - | _ -> None - in + (* The counters are 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. *) + let mark = job_mark ?at_stop t in t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "%s%d.so" tag t.n) in match build_module c ~debug:t.session.Session.debug ~out with | exception Failure m -> Error m | _ -> - (match - (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 + await_job mark t (fun () -> + match at_stop with + | Some gen -> deliver_at_stop t ~gen out + | None -> deliver t out) + +(* What a wait compares against: the result generation, and the agent's + count of dropped jobs when the job names a stop. [None] where the program + cannot say, in which case nothing compares against it — a missing count is + no evidence either way. *) +and job_mark ?at_stop t = + let before = match result t with Some (g, _) -> g | None -> 0L in + let refused_before = if at_stop <> None then refusals t else None in + (before, refused_before, stop_gen t) + +(* Hand a job to the program with [send], and wait for the value it writes + into the result buffer. Shared by a compiled thunk and by the [dyn] verb, + which renders a dyn value on the program's own thread. *) +and await_job (before, refused_before, gen) t send : (string, string) result = + let resumed () = + match (refused_before, if refused_before <> None then refusals t else None) with + | Some (before, _), Some (now, why) when now > before -> Some why + | _ -> None + in + (match send () with | exception Unix.Unix_error (e, _, _) -> Error (unreachable t e) | "ok" -> @@ -2386,6 +2360,15 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag | _ -> match resumed () with | Some why -> Error why + | None when (match (gen, stop_gen t) with + | Some g, Some g' -> g' > g + | _ -> false) -> + (* The job itself stopped the program — a trap in the value it + was rendering — and the break it pushed is holding the thread. + Said now rather than after the five seconds. *) + Error + "the program stopped again while producing the value, and the \ + break buffer is holding it: take a restart there, or abort" | None -> (* Two sentences for the same silence, because there are two causes and each names a different thing to go and look at. @@ -2440,6 +2423,110 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag wait 5000 | reply -> Error ("the program refused the module: " ^ reply)) +(* ── Reading a stopped program's memory ────────────────────────────── *) + +(* [locals], [inspect], [at], [condition] and [globals] read values here, on + the daemon's side, through [Inspect] — the layouts this session compiled + and the bytes the agent hands back — rather than building a render thunk + for the program to run. See lib/inspect.ml for why that is possible and + what stays shared with the thunk renderer. + + Through [request], so the same verbs answer in one process, where the agent + is a call, and in the two-process daemon, where it is the socket. *) + +let chomp s = + let n = String.length s in + if n > 0 && s.[n - 1] = '\n' then String.sub s 0 (n - 1) else s + +let unhex s = + String.init (String.length s / 2) (fun i -> + Char.chr (int_of_string ("0x" ^ String.sub s (2 * i) 2))) + +let starts s pre = + String.length s >= String.length pre + && String.sub s 0 (String.length pre) = pre + +let after s pre = String.sub s (String.length pre) (String.length s - String.length pre) + +(* One line back from the agent, with a refusal as [Error] and its sentence + kept. *) +let agent_line t line : (string, string) result = + match request t line with + | exception Unix.Unix_error (e, _, _) -> Error (unreachable t e) + | text -> + let l = chomp (List.hd (String.split_on_char '\n' (text ^ "\n"))) in + if starts l "err " then Error (after l "err ") else Ok l + +let agent_mem t : Inspect.mem = + { Inspect.read = + (fun a n -> + match agent_line t (Printf.sprintf "peek %d %d" a n) with + | Ok l when starts l "ok " -> unhex (after l "ok ") + | Ok l | Error l -> + raise + (Inspect.Unreadable + (Printf.sprintf "the %d bytes at 0x%x could not be read (%s)" n a l))); + ptr = + (fun a -> + match agent_line t (Printf.sprintf "ptr %d" a) with + | Ok "live" -> Inspect.Live + (* The epitaph keeps its leading space: it is written straight after + " Inspect.Dead (after l "dead") + | _ -> Inspect.Unknown); + (* Rendered by the program, on its own thread, as an evaluation is: the + dyn printer follows pointers and can trap or fault, and there that is + caught and the value reads [#], rather than a daemon + that never answers again. See the agent's [dyn] verb. *) + dyn = + (fun w -> + let mark = job_mark ~at_stop:1 t in + match + await_job mark t (fun () -> + String.trim (request t (Printf.sprintf "dyn %Lu" w))) + with + | Ok v -> v + | Error m -> raise (Inspect.Unreadable ("a dyn value: " ^ m))) } + +let reader t = + let p = t.session.Session.program in + (* With the struct copies an evaluated expression named first, which the + session keeps outside its program until a module lays them out. *) + let program = + { p with Tast.structs = + p.Tast.structs @ Check.fresh_copies t.session.Session.env p.Tast.structs } + in + Inspect.make ~program + ~enums:(Hashtbl.fold (fun k v acc -> (k, v) :: acc) + t.session.Session.env.Check.enums []) + ~mem:(agent_mem t) + +(* "ok ADDR" from one of the agent's root verbs. *) +let agent_addr t line : (int, string) result = + match agent_line t line with + | Error m -> Error m + | Ok l when starts l "ok " -> + (match int_of_string_opt (after l "ok ") with + | Some a -> Ok a + | None -> Error ("the program answered " ^ l)) + | Ok l -> Error ("the program answered " ^ l) + +(* A read that spans several requests, held to one stop. The daemon serves one + request at a time, so nothing it is asked can resume the program mid-read; + this is the check that says so rather than the argument. *) +let one_stop t f = + let before = stop_gen t in + let r = f () in + if stop_gen t = before then r + else + match r with + | Error _ -> r + | Ok _ -> + Error + "the program stopped somewhere else while it was being read — a value \ + it was asked to render may have trapped, and the break buffer is \ + holding that stop — so what was read may mix two stops; ask again" + (* The frame checks, which every verb that reads a *frame* has to make and must make the same way. [inspect] exists precisely because the listing is frame-accurate and the inspector was not, so it sharing this function with @@ -2562,13 +2649,11 @@ let eval_expr ?frame ?at_stop t ~code ~origin ~pause = the shadow stack was built rather than more DWARF: DWARF would have put these in lldb, and the point is to need lldb less often. - Nothing is copied out of the program. A Flan value has no header, so bytes - read from another process would be bytes with no meaning; what this end has - is the *type* — [Tast.fn.slots], from the build it owns — and the name - beside it in [snames]. So it compiles a thunk that renders those types at - those addresses, in the program, on the stopped thread, and reads the text - back the way [C-x C-e] does. The only thing that comes from the running - program is where the frame is. + A Flan value has no header, so bytes read out of the program mean nothing + on their own; what this end has is the *type* — [Tast.fn.slots], from the + build it owns — and the name beside it in [snames]. So it asks the agent + where each slot is and reads the value there through [Inspect], which walks + the bytes by the layouts this session compiled. Nothing is built. Three refusals, each by name and with its reason rather than by omission: a slot the compiler invented and nobody named; a slot whose binding had not @@ -2601,27 +2686,46 @@ let locals t ~frame = (match bound_slots t ~frame with | Error m -> error ("the program refused to say which slots are bound: " ^ m) | Ok bound -> - let c, refused = Session.render_locals t.session ~frame ~fn ~bound in - (match run_render_thunk t ~tag:"l" ~c with + let c = reader t in + let names = Session.shown_names fn in + (* Each entry is name, type, value and slot index. The index is last + and it is what [i] in the break buffer hands back to [inspect]: + two slots can share a name, so the name is not an identifier and + the position in this list is not one either, since a refused slot + is not in it. A slot the compiler made up is hidden, not refused; + see [Session.shown_names]. *) + let read () = + let entries = ref [] and refused = ref [] in + Array.iteri + (fun i ty -> + match names.(i) with + | None -> () + | Some n when not (List.mem i bound) -> + refused := (n, "not bound yet where the program stopped") :: !refused + | Some n -> + let v = + match agent_addr t (Printf.sprintf "slot %d %d" frame i) with + | Error m -> Error m + | Ok addr -> Inspect.render c ~addr ty + in + (match v with + | Ok v -> + entries := + Wire.list + [ Wire.quote n; Wire.quote (Types.to_string ty); + Wire.quote v; string_of_int i ] + :: !entries + (* A type the structural printer has no arm for, or storage + that could not be read. Named, with the reason, rather + than left out: a local that is missing and a local that + could not be printed are different facts. *) + | Error why -> refused := (n, why) :: !refused)) + fn.Tast.slots; + Ok (List.rev !entries, List.rev !refused) + in + (match one_stop t read with | Error m -> error m - | Ok v -> - (* One line per slot — name, type, value, slot index — tab - separated, and safe because every string the renderer emits is - escaped. The index is last and it is what [i] in the break - buffer hands back to [inspect]: two slots can share a name, so - the name is not an identifier and the position in this list is - not one either, since a refused slot is not in it. *) - let entries = - List.filter_map - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value; slot ] -> - Some - (Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value; slot ]) - | _ -> None) - (String.split_on_char '\n' v) - in + | Ok (entries, refused) -> ok [ ":frame " ^ Wire.quote name; ":locals " ^ Wire.list entries; @@ -2637,16 +2741,13 @@ let locals t ~frame = involved; this is the other half. The break loop stashed the pointer it was handed in the agent's snapshot, and this end knows the type at that address — it compiled it, and [status] reports its qualified name. So it - is [locals] pointed at the condition: a thunk renders each field through - [flan/dev-cond], on the stopped thread, and the text comes back the same - way. + is [locals] pointed at the condition: the agent says where the condition + is and [Inspect] reads each field at its offset. - Delivered at-stop, and that is the correctness of it rather than a nicety. - The thunk reads whatever pointer the snapshot on top holds when it runs; a - program that resumed and stopped again holds a *different* condition, and - rendering the old stop's type over the new stop's pointer would be a - misread with a plausible shape. Naming the stop makes the agent drop the - thunk instead. + Held to one stop, and that is the correctness of it rather than a nicety: + a program that resumed and stopped again holds a *different* condition, + and reading the old stop's type over the new stop's pointer would be a + misread with a plausible shape. Refused, by name, for a stop that has no value to read: a trap like [NullAllocator] is a name with no struct behind it, and a trap with no @@ -2683,36 +2784,40 @@ let condition_op t = match stop_gen t with | None | Some 0 -> error "cannot pin the stop this condition belongs to; ask again" - | Some gen -> - let c, refused = Session.render_condition t.session ~st in - (match run_render_thunk ~at_stop:gen t ~tag:"c" ~c with + | Some _ -> + let c = reader t in + let read () = + match agent_addr t "cond-at" with + | Error m -> Error m + | Ok base -> + let _, _, offs = + Emit.lay_fields c.Inspect.md + (List.map (fun (f : Tast.field) -> f.Tast.fty) st.Tast.fields) + in + let entries = ref [] and refused = ref [] in + List.iter2 + (fun (f : Tast.field) off -> + match Inspect.render c ~addr:(base + off) f.Tast.fty with + | Ok v -> + entries := + Wire.list + [ Wire.quote f.Tast.fname; + Wire.quote (Types.to_string f.Tast.fty); + Wire.quote v ] + :: !entries + (* A field the structural printer has no arm for, named + with the reason, so the buffer shows the field and + says why its value is not beside it. *) + | Error why -> refused := (f.Tast.fname, why) :: !refused) + st.Tast.fields offs; + Ok (List.rev !entries, List.rev !refused) + in + (* Held to one stop: the type was chosen against the stop [status] + answered for, and a program that resumed and stopped again + holds a different condition behind the same verb. *) + (match one_stop t read with | Error m -> error m - | Ok v -> - (* One line per field — name, type, value, tab separated, and - safe because every string the renderer emits is escaped. - - A line that is not three parts is *not* dropped. Nothing - should produce one, which is exactly why it must be visible - if anything ever does: a field silently in neither list - would read as a condition that has fewer fields than it - has. It joins the refusals, with what came back. *) - let entries = ref [] and strays = ref [] in - List.iter - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value ] -> - entries := - Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value ] - :: !entries - | _ -> - if String.trim line <> "" then - strays := - (line, "the renderer wrote a line this end could not \ - read as a field") - :: !strays) - (String.split_on_char '\n' v); - let entries = List.rev !entries in + | Ok (entries, refused) -> ok [ ":type " ^ Wire.quote cname; ":fields " ^ Wire.list entries; @@ -2727,7 +2832,7 @@ let condition_op t = (List.map (fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ]) - (refused @ List.rev !strays)) ]) + refused) ]) (* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second rooting mode. [docs/BUILT.md]'s "Two ways to root a walk" says what each root @@ -2743,9 +2848,9 @@ let condition_op t = This roots the walk where the listing roots it: a frame and a slot index, which is the address the shadow stack knows, plus the type [Tast.fn.slots] knows. A step into a field is then an address plus an offset with that - field's type, which is arithmetic [Render.render] already does — see - [Session.render_slot], which is [render_locals] with a path applied to the - root and one line out instead of one per slot. + field's type — see [Session.slot_path], which builds the path, and + [Inspect.place], which works out where it ends. The value there is read + the way [locals] reads a slot. The frame checks are [locals]'s, by construction: both go through [stopped_frame]. An inspector that made its own would be free to read a @@ -2769,37 +2874,49 @@ let inspect t ~frame ~slot ~path = | Ok bound -> if not (List.mem slot bound) then (* The same refusal the listing gives, and for the same reason: an - unbound slot's entry is null, and a thunk that rendered it would - fault on the game thread of a program that is already stopped. *) + unbound slot's entry is null, and there is nothing there to read. *) error (Printf.sprintf "slot %d of %s was not bound yet at the point the program \ stopped; there is nothing at that address to read" slot name) else - match Session.render_slot t.session ~frame ~fn ~slot ~path with + let c = reader t in + let read () = + match agent_addr t (Printf.sprintf "slot %d %d" frame slot) with + | Error m -> Error m + | Ok base -> + (match + Session.slot_path t.session ~fn ~slot ~path + ~root:(Inspect.root ~addr:base) + with + | Error why -> Error why + | Ok (v, label) -> + (match Inspect.place c v with + | Error why -> Error (label ^ ": " ^ why) + | Ok addr -> + (match Inspect.render c ~addr v.Tast.ty with + | Error why -> Error (label ^ ": " ^ why) + | Ok value -> + (* Where the value is stored, when the path ends at a + place in the stopped frame: a data case's field is + not one — [set] refuses to store to it, because the + tag decides which case the bytes are — so it has no + address to offer. *) + let addr = + if Emit.addr_is_place v then Some addr else None + in + Ok (label, Types.to_string v.Tast.ty, value, addr)))) + in + match one_stop t read with | Error why -> error why - | Ok (c, label, ty) -> - (match run_render_thunk t ~tag:"i" ~c with - | Error m -> error m - | Ok out -> - (* The address the value is stored at, on a line of its own, and - then the value. See [Session.render_slot]. *) - let addr, v = - match String.index_opt out '\n' with - | Some i -> - ( Int64.of_string_opt (String.sub out 0 i), - String.sub out (i + 1) (String.length out - i - 1) ) - | None -> (None, out) - in + | Ok (label, ty, v, addr) -> ok ([ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ] @ (match addr with - (* Unsigned, as an address is: a user-space pointer is - positive as an i64 today, and printing it as the - unsigned number keeps that true if it ever is not. *) - | Some a -> [ Printf.sprintf ":addr %Lu" a ] + (* Unsigned, as an address is. *) + | Some a -> [ Printf.sprintf ":addr %Lu" (Int64.of_int a) ] | None -> []) @ [ (* Which stop this was read at, so that a write built from @@ -2809,7 +2926,7 @@ let inspect t ~frame ~slot ~path = 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)) ]))) + ":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ])) (* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the @@ -3016,90 +3133,6 @@ let type_of_spelling t spelling : (Types.t, string) result = | ty -> Ok ty | exception Loc.Error { Loc.dmsg = why; _ } -> refuse why) -(* The extern that hands a number back as a pointer. - - The one piece an address-rooted thunk cannot work out for itself, and it is - the same arrangement [flan/dev-slot] has for a frame's slot: Flan has no - integer-to-pointer cast, deliberately, and the inspector is not a Flan - program. Everything after this is ordinary — a pointer-to-pointer cast and - a render, which is what [Session.render_slot] already does at a slot's - address. *) -let addr_extern : Tast.extern = - { Tast.ename = "flan/dev-addr"; esym = "flan_dev_reg_addr"; - eparams = [ Types.Int Types.I64 ]; - eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); eloc = Loc.unknown } - -(* Renders the value [(Ptr ty)] holding [addr], in the program. - - **A pointer and not the pointee, and that is the design.** Rendering the - [ty] at that address directly would read the storage whatever the registry - said, which is the hex dump this project does not want to be. Rendering a - [(Ptr ty)] puts the walk through [render.ml]'s pointer arm, which is the - arm that asks first: live, and the pointee is rendered one level deeper; - dead, and the epitaph says what died there instead. So an address root and - a slot root reach the same two answers by the same path, and the permission - question is asked in exactly one place in the compiler. - - Built here rather than in [session.ml] because it is the inspector's - rooting mode and not the session's: a session renders what a *program* - holds — a frame's slot, a global — and an address handed in from outside is - neither of those. *) -let render_addr (s : Session.t) ~addr ~(ty : Types.t) - : (Session.change, string) result = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = s.Session.program.Tast.structs; - datas = s.Session.program.Tast.datas; - unions = s.Session.program.Tast.unions; - enums = - Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.Session.env.Check.enums []; - emit = Session.dev_emitter; - ptrs = Some Session.dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let pty = Types.Ptr (Types.Mut, ty) in - let root = - { Tast.e = - Tast.Prim - (Tast.Cast pty, - [ { Tast.e = - Tast.Call - ("flan/dev-addr", - [ { Tast.e = Tast.Int (Int64.of_int addr, Types.I64); - ty = Types.Int Types.I64; loc } ]); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } ]); - ty = pty; loc } - in - match Render.render c 0 root with - | exception Loc.Error { Loc.dmsg = why; _ } -> Error why - | parts -> - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - s.Session.thunks <- s.Session.thunks + 1; - let name = Printf.sprintf "at/%d" s.Session.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: what is being shown - is storage this thunk reaches by address. *) - snames = Array.make (List.length !extra) None } - in - let program = - { s.Session.program with - Tast.fns = s.Session.program.Tast.fns @ [ thunk ]; - externs = s.Session.program.Tast.externs @ Session.externs @ [ addr_extern ] } - in - (* Through the session's own chooser, so that this thunk is compiled by - whichever backend built the process it is about to be loaded into. *) - let ir = Session.redefinition s ~call:name program ~fns:[ name ] in - Ok { Session.ir; x86 = s.Session.x86; names = []; fns = []; installs = true; stale = [] } - (* [(:op "at" :addr N :type "Enemy")] — point at any heap address. The inspector's third rooting mode, and the one that needs no frame. @@ -3145,21 +3178,20 @@ let inspect_addr t ~addr ~want_type = else match liveness t with | Gone -> error gone - (* The registry outlives the run, so the entry is still there — and that is - the trap. Rendering what is at the address means building a thunk and - having the program run it, and a parked program runs nothing; the answer - would be a five-second wait. *) + (* The registry outlives the run, so the entry is still there — but the + agent reads memory only for a stopped program, which is the moment + nothing is writing it, and a parked one has not stopped on anything. *) | Parked when not (parked_break t) -> parked "whether an address is still live is read from a stopped program, and \ a parked one has not stopped on anything" - (* The thunk this builds is delivered stopped-only, and a park with a - stopped thunk in it satisfies that check exactly as a running program's - break does: the agent asks its own [depth], which the break loop raised, - and knows nothing about runs. So this needs no special case beyond being - allowed through — and it wants one, because the registry outlived the - run and an address out of a leak report from the last run is a thing - somebody has in their hand precisely while the program is parked. *) + (* A park with a stopped thunk in it satisfies the agent's gate exactly as + a running program's break does: the agent asks its own [depth], which + the break loop raised, and knows nothing about runs. So this needs no + special case beyond being allowed through — and it wants one, because + the registry outlived the run and an address out of a leak report from + the last run is a thing somebody has in their hand precisely while the + program is parked. *) | Live | Parked -> match state t with | Running -> @@ -3224,21 +3256,19 @@ let inspect_addr t ~addr ~want_type = let live = match entry with Some e when e.rlive -> "t" | _ -> "nil" in - (match render_addr t.session ~addr ~ty with + (* As a [(Ptr ty)] holding the address, so the registry is asked + before a byte is read: live, and the pointee is shown; dead, + and what died there. See [Inspect.render_ptr]. The agent's + verbs are stopped-only, which is what holds the gate above. *) + let c = reader t in + (match one_stop t (fun () -> Inspect.render_ptr c ~addr ty) with | Error m -> error m - | exception Failure m -> error m - | Ok c -> - (* Stopped-only, and the only one of the three that is. The - gate above was read three round trips and a build ago; - this is what holds it. See [run_render_thunk]. *) - (match run_render_thunk ~stopped_only:true t ~tag:"a" ~c with - | Error m -> error m - | Ok v -> - ok - ([ Printf.sprintf ":addr %d" addr; - ":type " ^ Wire.quote (Types.to_string (Types.Ptr (Types.Mut, ty))); - ":value " ^ Wire.quote v; ":live " ^ live ] - @ told @ where)))))) + | Ok v -> + ok + ([ Printf.sprintf ":addr %d" addr; + ":type " ^ Wire.quote (Types.to_string (Types.Ptr (Types.Mut, ty))); + ":value " ^ Wire.quote v; ":live " ^ live ] + @ told @ where))))) (* [reg types] and [reg leaks] — the table grouped by type spelling. @@ -3371,23 +3401,18 @@ let reg_listing t ~verb ~note = membership in the union and the frame numbers beside an entry, is now a named refusal like every other. - Nothing is copied out of the program here either, and the mechanism is one - step simpler than [locals]: a global is reached by name rather than by - address, because [Emit.redefinition] writes a global the host already has as - [external] and the dynamic linker binds the thunk to the program's own - storage. So there is no [bound_slots] round trip and no not-yet-bound case — - a global's storage exists from the moment the process started. *) + The mechanism is one step simpler than [locals]: a global is found by its + symbol rather than through a frame, so there is no [bound_slots] round trip + and no not-yet-bound case — a global's storage exists from the moment the + process started. [Inspect] reads it there. *) let globals_op t = match liveness t with | Gone -> error gone - (* Refused for the mechanism and not for the policy, which is worth saying - because the storage really is readable: a global's memory exists from the - moment the process started and is exactly as the finished run left it, - which is the whole of what makes a re-run worth having. What does not - exist while parked is the renderer. A globals section is a thunk built - here, delivered, and run by the program at a frame boundary, the same as - [locals] and [inspect]; the stack that decides which globals to show went - with the run as well. *) + (* Refused because the section is the globals a stopped *stack* reaches, + and a parked program's stack went with the run. The storage itself is + readable — it is exactly as the finished run left it — and the agent's + reads are gated on a break rather than on a park only because a break is + the moment that is promised to hold still. *) | Parked when not (parked_break t) -> parked "a globals section is the globals a stopped stack reaches, and a parked \ @@ -3514,32 +3539,38 @@ let globals_op t = "no frame on this stack references a global; there is \ nothing here that is not already in the locals" ] else begin - let c, refused = Session.render_globals t.session ~globals:ordered in - match run_render_thunk t ~tag:"g" ~c with - | Error m -> error m - | Ok v -> - (* One line per global, name and type and value, tab separated — - safe because every string the renderer emits is escaped. The - frames are added back here, from the table above, because the - thunk knows nothing about the stack it was chosen for. *) - let by_name = Hashtbl.create 32 in + (* A global is found by its symbol: the executable's own, for one + the program was built with, or flan_dev.c's table for one it + introduced since — the two places a redefinition module finds + one. *) + let c = reader t in + let read () = + let entries = ref [] and refused = ref [] in List.iter (fun (g : Tast.global) -> - Hashtbl.replace by_name g.Tast.gname (where g)) + let v = + match agent_addr t ("global " ^ Mangle.sym g.Tast.gname) with + | Error m -> Error m + | Ok addr -> Inspect.render c ~addr g.Tast.gty + in + match v with + | Ok v -> + entries := + Wire.list + [ Wire.quote g.Tast.gname; + Wire.quote (Types.to_string g.Tast.gty); + Wire.quote v; where g ] + :: !entries + (* Named with its reason rather than left out: a global that + is missing and a global that could not be printed are + different facts. *) + | Error why -> refused := (g.Tast.gname, why) :: !refused) ordered; - let entries = - List.filter_map - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value ] -> - Some - (Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value; - (try Hashtbl.find by_name n - with Not_found -> Wire.list []) ]) - | _ -> None) - (String.split_on_char '\n' v) - in + Ok (List.rev !entries, List.rev !refused) + in + match one_stop t read with + | Error m -> error m + | Ok (entries, refused) -> ok [ ":globals " ^ Wire.list entries; ":refused " @@ -4459,7 +4490,7 @@ let watch_enable t ~on = (* [NAME VALUE] per line, after a header of [COUNT DROPPED]. - Tab is safe as the separator for [render_locals]'s reason: every string that + Tab is safe as the separator because every string that reaches a value goes through an emitter that escapes tab and newline, so neither can appear inside one. [OVERFLOW] is carried rather than dropped — a name that found no slot is a value that never appears, and a buffer that diff --git a/lib/inspect.ml b/lib/inspect.ml new file mode 100644 index 00000000..07cce1b7 --- /dev/null +++ b/lib/inspect.ml @@ -0,0 +1,432 @@ +(** The inspector's reader: a value rendered by reading a stopped program's + memory through the type layouts the compiler computed, with nothing + compiled. + + What it replaces is a thunk per inspection. A Flan value carries no header, + so only the compiler knows what the bytes at an address are, and the first + answer to that was to compile the knowledge into a module — [Render.render] + over the address, built, loaded, run on the stopped thread, read back. That + costs a build per question, and it means nothing on this side can *hold* a + value: the thunk is gone once it has printed. The layouts were never the + program's to know, though. [Emit.lay] is where both backends get every + offset and size, and the daemon owns the build, so it can read the bytes + itself and walk them — the only facts it needs from the program are where a + root is, what bytes are at an address, and the two things only the runtime + can answer: whether a pointer may be followed, and what a dyn word is. + Those are [mem] below, and the agent's [peek], [ptr] and [dyn] verbs. + + The text is [Render.render]'s, byte for byte, because the editor parses it + back (emacs/flan-inspect.el) and because a locals listing and an + inspection of the same slot must not read differently. That walk still + exists — [println] and an evaluated expression's value are rendered at + compile time — so this is a second walk over the same arms, and each arm + below names its twin's decisions rather than making its own. What cannot + drift is shared outright: which types are refused comes from running + [Render.render] itself over the type ([refusal]), and a struct's name from + [Render.head], which spells a generic instance [Pair i32]. *) + +(* What the reader needs from the stopped program. [read] raises + [Unreadable] rather than returning garbage for an address that is not + mapped, which is the agent reading through process_vm_readv. *) +type ptr_state = Live | Dead of string | Unknown + +exception Unreadable of string + +type mem = { + read : int -> int -> string; (* address, length *) + ptr : int -> ptr_state; + dyn : int64 -> string; +} + +type ctx = { + md : Emit.m; + structs : Tast.structure list; + datas : Tast.data list; + unions : Tast.structure list; + enums : (string * (string * int64) list) list; + mem : mem; + (* Bytes already read, by aligned chunk. A struct's fields are neighbours, + and asking the agent once per scalar would be a round trip per leaf over + a socket in the two-process daemon. Sound for one walk because the + program is stopped for all of it. *) + cache : (int, string) Hashtbl.t; +} + +let make ~(program : Tast.program) ~enums ~mem = + { md = X86.layout_ctx ~checks:false ~dev:true program; + structs = program.Tast.structs; datas = program.Tast.datas; + unions = program.Tast.unions; enums; mem; cache = Hashtbl.create 16 } + +let chunk = 256 + +let read c addr len = + if len <= 0 then "" + else + let base = addr - (addr mod chunk) in + if addr + len <= base + chunk then begin + (* A chunk that crosses into an unmapped page fails as a whole, where the + bytes asked for alone may be fine: fall back to exactly those. *) + match Hashtbl.find_opt c.cache base with + | Some s -> String.sub s (addr - base) len + | None -> + (match c.mem.read base chunk with + | s -> Hashtbl.replace c.cache base s; String.sub s (addr - base) len + | exception Unreadable _ -> c.mem.read addr len) + end + else c.mem.read addr len + +let u8 c a = Char.code (read c a 1).[0] +let i8 c a = String.get_int8 (read c a 1) 0 +let i16 c a = String.get_int16_le (read c a 2) 0 +let u16 c a = String.get_uint16_le (read c a 2) 0 +let i32 c a = String.get_int32_le (read c a 4) 0 +let i64 c a = String.get_int64_le (read c a 8) 0 +let ptr c a = Int64.to_int (i64 c a) + +(* An integer of kind [k], widened to i64 the way the thunk's [Cast] widens + it: sign extension for a signed kind, zero extension otherwise. *) +let int c a (k : Types.ikind) : int64 = + match k with + | Types.I8 -> Int64.of_int (i8 c a) + | Types.U8 -> Int64.of_int (u8 c a) + | Types.I16 -> Int64.of_int (i16 c a) + | Types.U16 -> Int64.of_int (u16 c a) + | Types.I32 -> Int64.of_int32 (i32 c a) + | Types.U32 -> Int64.logand (Int64.of_int32 (i32 c a)) 0xFFFFFFFFL + | Types.I64 | Types.U64 -> i64 c a + +(* ── The text, as the runtime spells it ───────────────────────────────── *) + +(* The result buffer's size, and what a value that overran it becomes: cut + so that "..." still fits, then "..." (runtime/flan_dev.c, [RESULT_MAX] + and [truncate_value]). One cap per value, where the thunk had one per + module — a locals listing used to share 4096 bytes between every slot, + and the slots after the cut fell out of the reply without a word. *) +let cap = 4096 + +exception Full + +let put b s = + let room = cap - Buffer.length b in + if String.length s > room then begin + Buffer.add_string b (String.sub s 0 (max 0 room)); + raise Full + end + else Buffer.add_string b s + +(* runtime/flan_rt.c's [flan_f64_format]: an unsigned NaN, and C's %g, which + OCaml's Printf hands to the same printf. *) +let f64 x = if Float.is_nan x then "nan" else Printf.sprintf "%g" x + +(* runtime/flan_rt.c's [flan_escape_char], framed in quotes as + [flan_dev_emit_str] frames it. *) +let quoted s = + let b = Buffer.create (String.length s + 2) in + Buffer.add_char b '"'; + String.iter + (fun ch -> + match ch with + | '"' -> Buffer.add_string b "\\\"" + | '\\' -> Buffer.add_string b "\\\\" + | '\n' -> Buffer.add_string b "\\n" + | '\t' -> Buffer.add_string b "\\t" + | '\r' -> Buffer.add_string b "\\r" + | c when Char.code c < 0x20 -> Buffer.add_string b (Printf.sprintf "\\x%02x" (Char.code c)) + | c -> Buffer.add_char b c) + s; + Buffer.add_char b '"'; + Buffer.contents b + +(* runtime/flan_dev.c's [flan_dev_emit_u8_char]: the byte's spelling as + lib/reader.ml's [read_byte] takes it back, or nothing. *) +let u8_char x = + match x with + | 32 -> " (\\space)" + | 9 -> " (\\tab)" + | 10 -> " (\\newline)" + | 13 -> " (\\return)" + | 0 -> " (\\nul)" + | _ when x < 33 || x > 126 -> "" + | _ -> + (match Char.chr x with + | '(' | ')' | '[' | ']' | '{' | '}' | '"' | ';' | '`' | '~' | ',' -> "" + | ch -> Printf.sprintf " (\\%c)" ch) + +(* ── Which types are refused ──────────────────────────────────────────── *) + +(* The refusal [Render.render] would give for a value of [ty], or [None]. + Asked of the walk itself, over a placeholder it never evaluates, so the + rule — which arms exist, and that a field past the span cap or a level past + the depth cap is never looked at — has one statement. *) +let refusal c (ty : Types.t) : string option = + let loc = Loc.unknown in + let unit_ = { Tast.e = Tast.Unit; ty = Types.Unit; loc } in + let emit _ = unit_ in + let rc = + { Render.structs = c.structs; datas = c.datas; unions = c.unions; + enums = c.enums; + emit = { Render.ebytes = emit; estr = emit; ei64 = emit; eu64 = emit; + ef64 = emit; edyn = emit }; + ptrs = Some { Render.live = (fun _ -> { unit_ with ty = Types.Bool }); + bytechar = emit; epitaph = emit }; + alloc = (fun _ -> 0) } + in + match Render.render rc 0 { Tast.e = Tast.Local 0; ty; loc } with + | _ -> None + | exception Loc.Error { Loc.dmsg; _ } -> Some dmsg + +(* ── The walk ─────────────────────────────────────────────────────────── *) + +let find_struct c n = + List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) c.structs + +let find_data c n = + List.find_opt (fun (u : Tast.data) -> String.equal u.Tast.dname n) c.datas + +let size c ty = fst (Emit.lay c.md ty) + +let offsets c tys = let _, _, offs = Emit.lay_fields c.md tys in offs + +(* Where a data value's payload starts: the second member of [Emit.lay]'s + { i32 tag, [k x iA] }. *) +let payload_off c (u : Tast.data) = + let psize, palign = Emit.payload_lay c.md u in + if psize = 0 then 4 + else + List.nth + (offsets c + [ Types.Int Types.I32; + Types.Array (Int64.of_int (psize / palign), + Types.Int (Emit.int_kind (palign * 8))) ]) + 1 + +let case_offsets c (v : Tast.variant) = + offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) v.Tast.vfields) + +let option_off c t = List.nth (offsets c [ Types.Int Types.I8; t ]) 1 + +(* [Render.render]'s arms, in its order and with its text. *) +let rec walk c b depth addr (ty : Types.t) = + if depth > Render.max_depth then put b "..." + else + match ty with + | Types.Int Types.U64 -> put b (Printf.sprintf "%Lu" (i64 c addr)) + | Types.Int Types.U8 -> + let x = u8 c addr in + put b (string_of_int x); + put b (u8_char x) + | Types.Int k -> put b (Int64.to_string (int c addr k)) + | Types.Float Types.F32 -> put b (f64 (Int32.float_of_bits (i32 c addr))) + | Types.Float Types.F64 -> put b (f64 (Int64.float_of_bits (i64 c addr))) + (* An [i1] in memory is a byte, and a load keeps its low bit. *) + | Types.Bool -> put b (if u8 c addr land 1 <> 0 then "true" else "false") + | Types.Unit -> put b "()" + | Types.String | Types.Slice (_, Types.Int Types.U8) -> + let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in + (* Enough bytes to overrun the cap once quoted, and no more: a string of + a million bytes is shown as its first few thousand either way. *) + let n = max 0 (min n cap) in + put b (quoted (if n = 0 then "" else read c p n)) + (* The members are checked last-declared first, as the thunk's chain of + comparisons is nested, so a value two members share reads as the later. *) + | Types.Enum n -> + let members = try List.assoc n c.enums with Not_found -> [] in + let v = Int64.of_int32 (i32 c addr) in + (match List.find_opt (fun (_, m) -> Int64.equal m v) (List.rev members) with + | Some (name, _) -> put b (":" ^ name) + | None -> put b (Int64.to_string v)) + | Types.Ptr (_, t) -> pointer c b depth (ptr c addr) t + | Types.Alloc -> put b "" + | Types.Vec _ -> put b "" + | Types.Fn _ -> put b ("<" ^ Types.to_string ty ^ ">") + | Types.Option t -> + if i8 c addr <> 0 then begin + put b "(some "; + walk c b (depth + 1) (addr + option_off c t) t; + put b ")" + end + else put b "none" + | Types.Named n when find_data c n <> None -> + let u = Option.get (find_data c n) in + let tag = Int32.to_int (i32 c addr) in + (match List.nth_opt u.Tast.cases tag with + | Some v when tag >= 0 -> + let full = Render.case_name n v.Tast.vname in + if v.Tast.vfields = [] then put b full + else begin + let base = addr + payload_off c u in + let offs = case_offsets c v in + put b ("(" ^ full ^ " {"); + List.iteri + (fun i ((f : Tast.field), off) -> + if i < Render.max_span then begin + if i > 0 then put b " "; + put b ("." ^ f.Tast.fname ^ " "); + walk c b (depth + 1) (base + off) f.Tast.fty + end) + (List.combine v.Tast.vfields offs); + if List.length v.Tast.vfields > Render.max_span then put b " ..."; + put b "})" + end + | _ -> put b (Printf.sprintf "<%s tag %d>" n tag)) + | Types.Named n + when List.exists (fun (u : Tast.structure) -> String.equal u.Tast.sname n) + c.unions -> + put b ("<" ^ n ^ " union>") + | Types.Named n -> + (match find_struct c n with + | None -> put b ("<" ^ n ^ ">") + | Some st -> + let fields = st.Tast.fields in + let offs = offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) fields) in + put b ("(" ^ Render.head n ^ " {"); + List.iteri + (fun i ((f : Tast.field), off) -> + if i < Render.max_span then begin + if i > 0 then put b " "; + put b ("." ^ f.Tast.fname ^ " "); + walk c b (depth + 1) (addr + off) f.Tast.fty + end) + (List.combine fields offs); + if List.length fields > Render.max_span then put b " ..."; + put b "})") + | Types.Array (n, t) -> + let n = Int64.to_int n in + let shown = min n Render.max_span and sz = size c t in + put b "["; + for i = 0 to shown - 1 do + put b " "; + walk c b (depth + 1) (addr + (i * sz)) t + done; + if n > shown then put b " ..."; + put b "]" + (* No span cap, as the thunk's loop has none: the value's cap is what + stops a long slice. *) + | Types.Slice (_, t) -> + let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in + let sz = size c t in + put b "["; + for i = 0 to n - 1 do + put b " "; + walk c b (depth + 1) (p + (i * sz)) t + done; + put b "]" + | Types.Dyn -> put b (c.mem.dyn (i64 c addr)) + (* [refusal] turned these away before the walk began. *) + | t -> put b ("<" ^ Types.to_string t ^ ">") + +(* A pointer holding [p]: followed one level deeper if the registry says it + is live, what died there if it is dead, and its bare shape if the registry + never saw it — a stack local, a global, a pointer from C, or null. *) +and pointer c b depth p t = + match c.mem.ptr p with + | Live -> put b "" + | Dead why -> put b "" + | Unknown -> put b "" + +let finish f ty c = + match refusal c ty with + | Some why -> Error why + | None -> + let b = Buffer.create 64 in + (match f b with + | () -> Ok (Buffer.contents b) + | exception Full -> + let s = Buffer.contents b in + Ok (String.sub s 0 (min (String.length s) (cap - 3)) ^ "...") + | exception Unreadable why -> Error why + | exception Failure why -> Error why) + +(* The value of type [ty] at [addr], as [Render.render] would have printed + it, or the refusal. A value that could not be read — an address the agent + found unmapped — is an error too, named, rather than a partial rendering. *) +let render c ~addr (ty : Types.t) : (string, string) result = + finish (fun b -> walk c b 0 addr ty) ty c + +(* A [(Ptr ty)] holding [addr], which is how an address somebody has in hand + is shown: through the pointer arm, so the registry is asked before a byte + of it is read and a dead block names what died instead. *) +let render_ptr c ~addr (ty : Types.t) : (string, string) result = + finish (fun b -> pointer c b 0 addr ty) (Types.Ptr (Types.Mut, ty)) c + +(* ── Where a path ends ────────────────────────────────────────────────── *) + +(* The address a [Session.step_into] path reaches, and its type. + + The steps are still [Session.step_into]'s: it is the one statement of which + steps a type admits and how each is refused, and the thunk's addressing was + built on it. What it produces is an expression over a [Deref] of the root; + this computes where that expression's value lives instead of compiling it. + Two checks the compiled thunk made in the program are made here: an index + into a slice against the slice's length, and a data type's case against its + tag — a field of the case the value is not in is a payload that is not + there. *) +let rec place c (e : Tast.expr) : (int, string) result = + let ( let* ) = Result.bind in + match e.Tast.e with + | Tast.Deref { Tast.e = Tast.Int (a, _); _ } -> Ok (Int64.to_int a) + | Tast.Field (target, i) -> + let* a = place c target in + (match target.Tast.ty with + | Types.Option t -> Ok (if i = 0 then a else a + option_off c t) + | Types.Named n -> + (match find_struct c n with + | Some st -> + Ok (a + List.nth (offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) + st.Tast.fields)) i) + | None -> Error (n ^ " has no layout here")) + | t -> Error ("no field in " ^ Types.to_string t)) + | Tast.CaseField (target, case, i) -> + let* a = place c target in + (match target.Tast.ty with + | Types.Named n -> + (match find_data c n with + | None -> Error (n ^ " has no layout here") + | Some u -> + let rec index k = function + | [] -> None + | (v : Tast.variant) :: rest -> + if String.equal v.Tast.vname case then Some (k, v) else index (k + 1) rest + in + (match index 0 u.Tast.cases with + | None -> Error (n ^ " has no case called " ^ case) + | Some (k, v) -> + let tag = Int32.to_int (i32 c a) in + if tag <> k then + Error + (Printf.sprintf + "the value is not a %s — its tag says %s — so that case's \ + fields are not in it" + (Render.case_name n case) + (match List.nth_opt u.Tast.cases tag with + | Some w when tag >= 0 -> Render.case_name n w.Tast.vname + | _ -> string_of_int tag)) + else Ok (a + payload_off c u + List.nth (case_offsets c v) i))) + | t -> Error ("no case field in " ^ Types.to_string t)) + | Tast.Prim (Tast.At, [ target; { Tast.e = Tast.Int (i, _); _ } ]) -> + let* a = place c target in + let i = Int64.to_int i in + (match target.Tast.ty with + | Types.Array (_, t) -> Ok (a + (i * size c t)) + | Types.Slice (_, t) -> + let n = Int64.to_int (i64 c (a + 8)) in + if i >= n then + Error + (Printf.sprintf "%d is past the end of a slice of %d elements" i n) + else Ok (ptr c a + (i * size c t)) + | t -> Error ("no element in " ^ Types.to_string t)) + | _ -> Error "not a place the inspector can find" + +let place c e = + match place c e with + | r -> r + | exception Unreadable why -> Error why + +(* The root [step_into] walks from: the value of type [ty] at [addr]. *) +let root ~addr (ty : Types.t) : Tast.expr = + let loc = Loc.unknown in + { Tast.e = + Tast.Deref + { Tast.e = Tast.Int (Int64.of_int addr, Types.I64); + ty = Types.Ptr (Types.Mut, ty); loc }; + ty; loc } diff --git a/lib/render.ml b/lib/render.ml index 5cf3f33f..365c6d26 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -97,6 +97,11 @@ let max_span = 8 let fail = Loc.fail +(* What a data case is called in a rendering. Named here, beside [head], + because lib/inspect.ml writes the same text by reading memory instead of + emitting calls, and the two must spell a value alike. *) +let case_name n v = n ^ "." ^ v + (* The refusal for a type the walk has no arm for, worded for the form that asked. [print]'s is the default. *) let print_refusal _loc t = @@ -262,7 +267,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis ty = Types.Int Types.I32; loc } ]); ty = Types.Bool; loc } in - let full = n ^ "." ^ v.Tast.vname in + let full = case_name n v.Tast.vname in let body = if v.Tast.vfields = [] then lit full else diff --git a/lib/session.ml b/lib/session.ml index 3a1e371e..8369e89a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1396,19 +1396,13 @@ let externs : Tast.extern list = one emit_u64 "flan_dev_emit_u64"; one emit_f64 "flan_dev_emit_f64"; (* The address of a slot in a *stopped* frame, resolved by the agent - against the snapshot that break took. It is the one piece a locals + against the snapshot that break took. It is the one piece a write thunk cannot work out for itself: the compiler knows every slot's type and name, and nothing but the running program knows where the frame - is. See [render_locals]. *) + is. See [write_slot]. *) { Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot"; eparams = [ Types.Int Types.I64; Types.Int Types.I64 ]; eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); eloc = Loc.unknown }; - (* The condition the stopped program is holding, same contract: the agent - resolves it against the snapshot on top when the thunk runs, and NULL - when there is none. See [render_condition]. *) - { Tast.ename = "flan/dev-cond"; esym = "flan_agent_condition"; - eparams = []; eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); - eloc = Loc.unknown }; (* A typed restart's parameter, by the restart's index in the snapshot on top and a byte offset into its buffer, and the flag that says the buffer was written. See [arm_restart]. *) @@ -1565,235 +1559,24 @@ let shown_names (fn : Tast.fn) : string option array = | Some d -> if count d > 1 then raw.(i) else Some d) stripped -(* The second half of what a break loop can show, and it is the same primitive - as [C-x C-e] pointed somewhere else. - - Nothing marshals and nothing is read across the process boundary. A Flan - value carries no header, so the daemon could not make sense of bytes it - copied out even if it had them; what it has instead is the *type*, from - [Tast.fn.slots], and a name for it, from [snames] beside it. So it compiles - a thunk that renders those types at those addresses, in the program, and - reads back the text — exactly what an evaluated expression does, except - that the root is an address rather than an expression. That address is the - only thing that comes from the running program. - - [bound] is which slots the program says have been reached. It is not an - optimisation: an unbound slot's entry is null, and a thunk that rendered - one would dereference null on the game thread of a program that is already - stopped. So the refusal happens here, before any code is emitted for it. - - What comes back is one line per slot — name, type, value, tab separated. - Tab and newline are safe separators because every string the renderer emits - goes through [flan_dev_emit_str], which escapes both. - - Each slot is rendered from its address rather than copied into the thunk - first. A copy would be one [alloca] the size of the slot — 40KB for sand's - grid — and the walk only ever shows eight elements of it. The cost is one - call to [flan/dev-slot] per leaf the walk reaches instead of one per slot, - which the depth and span caps already bound. *) -let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound - : change * (string * string) list = - let loc = fn.Tast.floc in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env 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 - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let refused = ref [] in - let refuse name why = refused := (name, why) :: !refused in - let one i ty name = - let idx n = - { Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc } - in - let address = - { Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx i ]); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ address ]); - ty = Types.Ptr (Types.Mut, ty); loc } - in - let v = { Tast.e = Tast.Deref typed; ty; loc } in - match Render.render c 0 v with - | parts -> - (* The slot *index* travels with the line, last, and it is what makes - [i] in the break buffer able to name this exact slot back to the - daemon. The name cannot: [check.ml]'s [fresh_slot] only ever - allocates, so (let [v 22] …) inside (let [v 11] …) is two slots both - called [v] and both listed here. Nor can the position in the list, - because a refused slot is not in it. See [render_slot]. *) - Some - ((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts) - @ [ lit ("\t" ^ string_of_int i ^ "\n") ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A type the structural printer has no arm for — a map, a function - value, a type variable. Named, with the reason, rather than left out - of the list: a local that is missing and a local that could not be - printed are different facts. *) - refuse name why; - None - in - let names = shown_names fn in - let body = - List.concat - ((List.filter_map - (fun i -> - let ty = fn.Tast.slots.(i) in - match names.(i) with - | None -> - (* A slot the compiler made up — hidden, not refused; see - [shown_names]. *) - None - | Some name when not (List.mem i bound) -> - refuse name - "not bound yet where the program stopped"; - None - | Some name -> one i ty name) - (List.init (Array.length fn.Tast.slots) (fun i -> i)))) - in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "locals/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: the locals being shown - are the *other* frame's, and this thunk reaches them by address. *) - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t ~call:name program ~fns:[ name ] - in - ignore origin; - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - -(* ── The fields of the condition a break is holding ────────────────── *) - -(* [render_locals] pointed at the condition instead of a frame. The break - loop stashes the pointer it was handed in the snapshot, the thunk reads it - back through [flan/dev-cond], and the type at that address is the struct - whose qualified name the agent reported as the condition — this end - compiled it, so the layout is its own to know. One line per field: - name, type, value, tab separated. - - The thunk carries no address of its own — [flan/dev-cond] resolves against - the snapshot on top when it runs — but the *type* it reads with was chosen - against a particular stop, so the caller delivers it at-stop: a program - that resumed and stopped again holds a different condition, and rendering - the old type over the new pointer is the misread the at-stop check - refuses. *) -let render_condition t ~(st : Tast.structure) : change * (string * string) list = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env 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 - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let refused = ref [] in - let cty = Types.Named st.Tast.sname in - let address = - { Tast.e = Tast.Call ("flan/dev-cond", []); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, cty)), [ address ]); - ty = Types.Ptr (Types.Mut, cty); loc } - in - let root = { Tast.e = Tast.Deref typed; ty = cty; loc } in - let one i (f : Tast.field) = - let v = { Tast.e = Tast.Field (root, i); ty = f.Tast.fty; loc } in - match Render.render c 0 v with - | parts -> - Some - ((lit (f.Tast.fname ^ "\t" ^ Types.to_string f.Tast.fty ^ "\t") :: parts) - @ [ lit "\n" ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A field the structural printer has no arm for. Named with the - reason, so the buffer shows the field and says why its value is - not beside it. *) - refused := (f.Tast.fname, why) :: !refused; - None - in - let body = - List.concat - (List.filter_map Fun.id (List.mapi (fun i f -> one i f) st.Tast.fields)) - in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "condition/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = redefinition t ~call:name program ~fns:[ name ] in - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - (* ── One slot of a stopped frame, walked ───────────────────────────── *) (* The inspector's second rooting mode, and the whole of what it needed. - The inspector navigates by rewriting *expressions* — `(.pos b)' where the - last one was `b' — because a Flan value has no header and the thunk that - rendered it is [dlclose]d as soon as it returns, so nothing can be held on - this side the way CIDER holds a JVM object. The cost of that is the bug it - had: a name sent back to be evaluated is evaluated wherever the evaluator - stands, which on any frame but the innermost may resolve to a global, to a - different binding, or to nothing, with the listing above it still showing - the frame's own storage. + The inspector used to navigate by rewriting *expressions* — `(.pos b)' + where the last one was `b' — and a name sent back to be evaluated is + evaluated wherever the evaluator stands, which on any frame but the + innermost may resolve to a global, to a different binding, or to nothing, + with the listing above it still showing the frame's own storage. Rooting at the slot's address alone does not fix it — an address is not an expression, so the first step has nothing to build from. What makes this work is that the step does not have to be an expression either. A frame's address comes from the shadow stack and every slot's type comes from [Tast.fn.slots], so a step into a field is an address plus an offset with - that field's type, which is *exactly* the arithmetic [Render.render] does - for the locals listing. So this is [render_locals] with a path applied to - the root before the walk, and not a second walk. + that field's type. [slot_path] builds that as an expression over the + slot's value and [Inspect.place] works out where it lives, so the steps + and their refusals are stated once, here. What the path cannot do is the honest half. Every step is refused by name with its reason rather than guessed at: a field the type does not have, an @@ -1941,25 +1724,23 @@ let step_into t (v : Tast.expr) (s : step) : (Tast.expr, string) result = (Printf.sprintf "%s has no fields, so there is no .%s in it" (Types.to_string ty) spec)) -(* Renders slot [slot] of frame [frame], after walking [path] into it. The - thunk is [render_locals]'s, minus the loop over every slot: one root, one - line, and the reply carries the type the path ended at so the editor can - say what it is looking at. +(* Where slot [slot] of [fn] ends up after walking [path] into it, as an + expression over [root] — the value at the slot's address — together with + the label the reply names it by. [Dev.inspect] reads the value there + through [Inspect]; nothing is compiled. The caller has already established that the frame is the body this session holds — the slot fingerprint — and that the slot is bound. This function does not re-derive either; it is handed the [fn] that check passed. *) -let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path - : (change * string * string, string) result = - let loc = fn.Tast.floc in +let slot_path t ~(fn : Tast.fn) ~slot ~path ~(root : Types.t -> Tast.expr) + : (Tast.expr * string, string) result = 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 - let sname = (shown_names fn).(slot) in - match sname with + match (shown_names fn).(slot) with | None -> Error (Printf.sprintf @@ -1967,34 +1748,6 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path show it and there is nothing here to inspect" slot fn.Tast.name) | Some name -> - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env 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 - 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.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ address ]); - ty = Types.Ptr (Types.Mut, ty); loc } - in - let root = { Tast.e = Tast.Deref typed; ty; loc } in let rec walk v = function | [] -> Ok v | s :: rest -> @@ -2002,65 +1755,9 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Error why -> Error why | Ok v' -> walk v' rest) in - (match walk root path with + (match walk (root fn.Tast.slots.(slot)) path with | Error why -> Error (name ^ path_text path ^ ": " ^ why) - | Ok v -> - (match Render.render c 0 v with - | exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why) - | parts -> - (* Where the value lives, first and on a line of its own, when [v] - is a place in the stopped frame: its address is then the - storage the listing is reading. A data case's field is not a - place — [AddrOf] on it would answer the address of a copy — so - it has no address line. The caller splits the line off at the - first newline; a rendering has none, because [Render] quotes a - string's. *) - let parts = - if not (Emit.addr_is_place v) then parts - else - let addr = - { Tast.e = - Tast.Prim - (Tast.Cast (Types.Int Types.I64), - [ { Tast.e = Tast.Prim (Tast.AddrOf, [ v ]); - ty = Types.Ptr (Types.Mut, v.Tast.ty); loc } ]); - ty = Types.Int Types.I64; loc } - in - let newline = - { Tast.e = - Tast.Prim - (Tast.Bytes, - [ { Tast.e = Tast.Str "\n"; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - dev_emitter.Render.ei64 addr :: dev_emitter.Render.ebytes newline - :: parts - in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - t.thunks <- t.thunks + 1; - let tname = Printf.sprintf "inspect/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name = tname; params = []; ret = Types.Unit; - body = - (nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t - ~call:tname program ~fns:[ tname ] - in - ignore origin; - Ok - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, - name ^ path_text path, - Types.to_string v.Tast.ty))) + | Ok v -> Ok (v, name ^ path_text path)) (* ── Writing one of them back ──────────────────────────────────────── *) @@ -2075,7 +1772,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path 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. + whole class of bug [slot_path] 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 @@ -2170,7 +1867,7 @@ let writable_type (ty : Types.t) : (unit, string) result = 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]. *) + The caller has established the frame, as it has for [slot_path]. *) let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path ~(edits : (step list * string) list) : (change * string * string, string) result = @@ -2479,92 +2176,6 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.map Types.to_string params) -(* ── The globals a stopped stack reaches ───────────────────────────── *) - -(* The other half of what a break loop can show, and in this language arguably - the more useful one: a game keeps most of its state in top-level [defonce]s, - and sand.flan holds its entire grid that way. - - Almost the same thunk as [render_locals] with a different root, and the - difference is the whole reason this is a second function rather than a - parameter. A local is reached by *address* — [flan/dev-slot] hands back - where the frame is, and only the stopped program knows that. A global is - reached by *name*: [Emit.redefinition] writes a global the host already has - as [external], so the loaded module binds to the program's own storage and - the dynamic linker does the work. Nothing has to be asked of the stopped - thread at all, which is also why there is no [bound] list here — a global's - storage exists from the moment the process started, so there is no - not-yet-bound case to refuse. - - [globals] is chosen by the caller and not here, because the choice is about - the *stack* and this function is about rendering. See [Dev.globals_op]. - - One line per global — name, type, value, tab separated — the same framing - [render_locals] uses, and safe for the same reason: every string the - renderer emits goes through [flan_dev_emit_str], which escapes both. *) -let render_globals ?(origin = "") t ~(globals : Tast.global list) - : change * (string * string) list = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env 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 - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let refused = ref [] in - let one (g : Tast.global) = - let v = { Tast.e = Tast.Global g.Tast.gname; ty = g.Tast.gty; loc } in - match Render.render c 0 v with - | parts -> - Some - ((lit (g.Tast.gname ^ "\t" ^ Types.to_string g.Tast.gty ^ "\t") :: parts) - @ [ lit "\n" ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A type the structural printer has no arm for. Named with its reason - rather than left out, for [render_locals]'s reason: a global that is - missing and a global that could not be printed are different facts, - and a list that showed neither would be the same lie twice. *) - refused := (g.Tast.gname, why) :: !refused; - None - in - let body = List.concat (List.filter_map one globals) in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "globals/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: what is being shown is - the program's storage, which this thunk reaches by name. *) - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t ~call:name program ~fns:[ name ] - in - ignore origin; - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - (* [pause] is [C-u C-x C-e] — §9's "last expression" target. It is a flag and not a position, because there is only one form here and it is the whole of what was sent: the expression *is* the target. It is also why nothing here diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index e096961d..45512a4e 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -116,6 +116,15 @@ void *flan_dev_global(const char *name, uint64_t size, const void *init) { return e->cell; } +/* A global's storage by its symbol, for the daemon's inspector, or NULL for a + * name this table never interned — a global the host was built with, which the + * agent finds by symbol instead. It never interns: a lookup that allocated + * would hand back zeroed storage the program has never seen. */ +void *flan_dev_global_find(const char *name) { + entry *e = find(name); + return e == NULL ? NULL : e->cell; +} + /* ── The value of an evaluated expression ──────────────────────────── */ /* C-x C-e compiles a thunk that renders one expression and emits it here, a @@ -1781,26 +1790,39 @@ int32_t flan_dev_reg_live(const void *p) { * Returns 1 if anything was written, so that a caller can tell "the registry * has never heard of this address" — a stack local, which is by design not in * here — from "this is dead", which is the sentence worth printing. */ +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap); int32_t flan_dev_reg_emit(const void *p) { static char desc[192]; + int32_t n = flan_dev_reg_epitaph(p, desc, (int64_t)sizeof desc); + if (n <= 0) return 0; + flan_dev_emit((const uint8_t *)desc, n); + return 1; +} + +/* The epitaph's text, into [buf], and its length — 0 for an address that is + * live or that the table never saw. [flan_dev_reg_emit] above is this aimed at + * the result buffer; the agent's [ptr] verb is this aimed at a reply, for the + * daemon's inspector, which reads a stopped program's memory itself rather + * than building a thunk to render it. One sentence, so the two cannot word a + * dead pointer differently. */ +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap) { uintptr_t a = (uintptr_t)p; flan_reg_entry *e = flan_reg_on ? flan_reg_find(a) : NULL; int64_t off; char where[64]; int n; - if (e == NULL || e->died == 0) return 0; + if (e == NULL || e->died == 0 || cap <= 1) return 0; off = (int64_t)(a - e->base); where[0] = '\0'; if (e->elem > 0 && off % e->elem == 0 && off / e->elem > 0) snprintf(where, sizeof where, "[%lld] of ", (long long)(off / e->elem)); else if (off != 0) snprintf(where, sizeof where, "+%lld into ", (long long)off); - n = snprintf(desc, sizeof desc, " dead: was %s%.*s, freed at step %lld", + n = snprintf(buf, (size_t)cap, " dead: was %s%.*s, freed at step %lld", where, (int)e->typelen, e->type, (long long)e->died); if (n < 0) return 0; - if (n > (int)sizeof desc - 1) n = (int)sizeof desc - 1; - flan_dev_emit((const uint8_t *)desc, n); - return 1; + if (n > (int)cap - 1) n = (int)cap - 1; + return n; } /* How many blocks the table holds — everything, or only the live ones. For a @@ -1888,17 +1910,8 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, return 1; } -/* An address, as a number, handed back as a pointer. The one thing an - * address-rooted render thunk cannot do for itself: Flan has no integer-to- - * pointer cast, deliberately — a program that could make a pointer out of - * arithmetic is a program the type system stops describing — and the - * inspector is not a program. It is the same arrangement [flan_agent_frame_ - * slot] already has for a frame's slot, and for the same reason: the compiler - * knows the type, and something outside the language supplies the address. */ -void *flan_dev_reg_addr(int64_t a) { return (void *)(uintptr_t)a; } - -/* And back the other way, which is the half a *program* needs rather than the - * inspector. The address root above takes a number, and the things that hand +/* An address as a number, which is the half a *program* needs rather than + * the inspector. The address root takes a number, and the things that hand * out addresses as numbers all live outside the language — gdb, valgrind, a C * library's callback, a printf("%p") in somebody's shim. A Flan program that * wants to say one out loud has no cast for it, deliberately: pointer @@ -2532,6 +2545,11 @@ static void crash_hex(uintptr_t x) { crash_puts(b + i, sizeof b - i); } +/* Non-NULL while the agent renders a value for the inspector, naming it. A + * fault then is the reader's, and the report says so instead of blaming the + * frame that happens to be on top — the program was stopped, not running. */ +const char *volatile flan_dev_crash_reading; + static void crash_handler(int sig, siginfo_t *si, void *uc) { /* Not the program's thread: this is the daemon's own fault to deal with, * and OCaml's handler is the one that knows how. See the header. */ @@ -2542,12 +2560,19 @@ static void crash_handler(int sig, siginfo_t *si, void *uc) { if (flan_crash_entered++) goto die; crash_puts("\nflan: ", 7); if (sig == SIGBUS) crash_puts("SIGBUS", 6); else crash_puts("SIGSEGV", 7); - { + if (flan_dev_crash_reading != NULL) { + static const char reading[] = " \xe2\x80\x94 reading "; + static const char tail[] = " for the inspector touched "; + crash_puts(reading, sizeof reading - 1); + crash_puts(flan_dev_crash_reading, strlen(flan_dev_crash_reading)); + crash_puts(tail, sizeof tail - 1); + } else { static const char touched[] = " \xe2\x80\x94 the program touched "; crash_puts(touched, sizeof touched - 1); } crash_hex((uintptr_t)si->si_addr); - if (flan_frame_head != NULL && flan_frame_head->info != NULL) { + if (flan_dev_crash_reading == NULL + && flan_frame_head != NULL && flan_frame_head->info != NULL) { const flan_fninfo *fi = flan_frame_head->info; crash_puts(" in ", 4); crash_puts(fi->name, (size_t)fi->namelen); diff --git a/test/agent_hooks.c b/test/agent_hooks.c index 455213e6..c1bc9799 100644 --- a/test/agent_hooks.c +++ b/test/agent_hooks.c @@ -23,6 +23,8 @@ #include #include #include +#include +#include void flan_rt_init(int32_t argc, char **argv); int32_t flan_agent_start(const uint8_t *path, int64_t len); @@ -132,10 +134,9 @@ static int snapnames(void) { * not addressed to it, for as many turns as it is left alone, and resumes * only on a choice made against its own list. * - * What happens after that is pinned as it is, not as it ought to be: the - * choice slot is one slot, so the inner choice overwrote the outer one, and - * the outer break has to be asked again. TODO.org, "A choice made at an outer - * break is lost to a nested one". */ + * The choice slot is one slot, so the inner choice overwrites the outer one; + * the inner break puts the outer one back when it is left, and the outer + * break takes it without being asked again. */ static int level, inner_turns, outer_turns, reasked; static void *outer_a, *outer_b, *inner; @@ -190,6 +191,60 @@ static int stale(void) { return 0; } +/* ── A restart accepted with a read queued behind it ──────────────── + * + * The inspector's [dyn] read is a job for the stopped thread, named for the + * stop. Requests take effect in the order they were sent: one queued before a + * restart is accepted runs in the stop, and then the restart is taken; one + * asked for after acceptance is refused at the door. */ +extern uint64_t flan_dynword(void *xfer) __asm__("flan.dynword"); +int32_t flan_agent_poll(void); +static int resuming_done; +static char r_queued[128], r_take[128], r_late[128]; +static pthread_t resumer; + +/* The listener's side of it, from another thread: the break loop is asleep + * between turns when these land, as a request from the editor would be. */ +static void *resume_from_outside(void *arg) { + const char *line = arg; + struct timespec pause = { 0, 500000 }; + nanosleep(&pause, NULL); + snprintf(r_queued, sizeof r_queued, "%s", ask(line)); + snprintf(r_take, sizeof r_take, "%s", ask("restart-at 0 retry")); + snprintf(r_late, sizeof r_late, "%s", ask(line)); + return NULL; +} + +static void resuming_hook(void) { + static char line[64]; + void *x = NULL; + if (resuming_done) return; + resuming_done = 1; + snprintf(line, sizeof line, "dyn %llu", + (unsigned long long)flan_dynword(&x)); + pthread_create(&resumer, NULL, resume_from_outside, line); +} + +static long refusal_count(void) { return strtol(ask("refusals"), NULL, 10); } + +static int resuming(void) { + void *xfer = NULL; + int32_t v; + long before; + flan_agent_break_poll_hook = resuming_hook; + v = flan_deep(0, &xfer); + flan_agent_break_poll_hook = NULL; + pthread_join(resumer, NULL); + printf("queued %stake %slate %s", r_queued, r_take, r_late); + printf("returned %d\n", v); + /* The read wrote the result buffer, whose generation starts at zero. */ + printf("read %s\n", strtol(ask("result"), NULL, 10) > 0 ? "ran" : "did not run"); + before = refusal_count(); + flan_agent_poll(); + printf("dropped %ld\n", refusal_count() - before); + return 0; +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 3) { @@ -204,6 +259,7 @@ int main(int argc, char **argv) { if (strcmp(argv[1], "snapmax") == 0) return snapmax(); if (strcmp(argv[1], "snapnames") == 0) return snapnames(); if (strcmp(argv[1], "stale") == 0) return stale(); + if (strcmp(argv[1], "resuming") == 0) return resuming(); fprintf(stderr, "unknown mode %s\n", argv[1]); return 2; } diff --git a/test/programs/agent-hooks.flan b/test/programs/agent-hooks.flan index 827b025e..fb8e4cf9 100644 --- a/test/programs/agent-hooks.flan +++ b/test/programs/agent-hooks.flan @@ -21,3 +21,7 @@ (restart-case (if (= n 0) (do (error (Deep {.n n})) 0) (wide (- n 1))) (retry-with-a-name-long-enough-that-twenty-of-them-fill-the-four-kilobytes-a-break-loop-keeps-for-the-names-of-its-restarts-and-the-twenty-first-does-not-fit-anywhere-in-the-buffer-at-all-xxx-and-so-on [] n))) + +;;; A dyn keyword, so the dyn runtime is linked and the agent's [dyn] verb has +;;; something to render. agent_hooks.c's "resuming" mode reads one. +(defn dynword [] dyn :k) diff --git a/test/programs/dev-dyn-trap.flan b/test/programs/dev-dyn-trap.flan new file mode 100644 index 00000000..3738ff21 --- /dev/null +++ b/test/programs/dev-dyn-trap.flan @@ -0,0 +1,34 @@ +;;;; Two dyn values the dyn printer cannot print. [dv] is a dyn view of a Vec +;;;; whose arena was freed, which traps DynRange when printed; the first +;;;; element of [s] is a word that reads as a boxed pointer to address 0x10, +;;;; which faults when printed as a dyn. The inspector hands each to the +;;;; program's own thread to render, which catches the trap: each reads as +;;;; #, no break is pushed, and the daemon keeps answering. +(import agent "vendor:agent") + +(defstruct Boom [why i32]) +(defonce tv (Vec i64)) +(defonce dv dyn) +(defonce n i32) + +(defn as-dyn [d dyn] dyn d) + +(defn inner [s [i64]] i64 + (set dv dv) (set n n) + (error (Boom {.why 3})) + (at s 0)) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-dyn-trap-fallback.sock") + (let [ar (arena-new 4096)] + (set tv (vec-new i64 ar)) + (push tv 7) + (set dv (as-dyn tv)) + (free-all ar)) + (set n 5) + (let [v (vec-new i64)] + (push v -1407374883553264) + (push v 5) + (print (inner (slice v))) (println "")) + (dotimes [i 4000] (agent/wait 5)) + 0) diff --git a/test/programs/dev-fix-retry.flan b/test/programs/dev-fix-retry.flan new file mode 100644 index 00000000..6d852130 --- /dev/null +++ b/test/programs/dev-fix-retry.flan @@ -0,0 +1,19 @@ +;;;; Fix and retry, from a script: [f] errors, a client loads a new [f] and +;;;; takes [retry] at once, and the retry must run the new body. The load is a +;;;; job in the agent's ring and the restart a choice; the break loop runs what +;;;; was queued before the choice was accepted, then takes it. +(import agent "vendor:agent") + +(defstruct Boom [why i32]) + +(defn f [] i32 (error (Boom {.why 3})) 1) + +(defn g [] i32 + (restart-case (f) + (retry [] (g)))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-fix-retry-fallback.sock") + (let [r (g)] (println "RESULT " r)) + (dotimes [i 4000] (agent/wait 5)) + 0) diff --git a/test/programs/dev-parity.flan b/test/programs/dev-parity.flan new file mode 100644 index 00000000..f91e2993 --- /dev/null +++ b/test/programs/dev-parity.flan @@ -0,0 +1,112 @@ +;;;; One global of every shape the inspector walks, for comparing two +;;;; renderings of each: the break loop's [globals], which reads the stopped +;;;; program's memory through lib/inspect.ml and compiles nothing, and an +;;;; evaluated expression naming the global, which is still rendered by a +;;;; compiled thunk through lib/render.ml. They must agree byte for byte — +;;;; the editor parses both back, and a value that read one way in the break +;;;; buffer and another at C-x C-e would be two answers to one question. +(import agent "vendor:agent") + +(defstruct Boom [why i32]) +(defstruct Point [x f32 y f32]) +(defstruct Wide [a i32 b i32 c i32 d i32 e i32 f i32 g i32 h i32 i i32 j i32]) +(defstruct In4 [v i32]) +(defstruct In3 [v In4]) +(defstruct In2 [v In3]) +(defstruct In1 [v In2]) +(defstruct In0 [v In1]) +(defstruct Enemy [hp i32 x i32]) +(defenum Colour [red 0 green 1 blue 2]) +(defdata Shape + [Empty + (Dot [x f64 y f64]) + (Rect [w i32 h i32])]) +(defunion W [p (Ptr i32) n u64]) +(defstruct Pair [a $t b $t]) + +(defonce small i8) +(defonce mid u16) +(defonce large u32) +(defonce huge u64) +(defonce neg i64) +(defonce ratio f32) +(defonce far f64) +(defonce odd f64) +(defonce yes bool) +(defonce byte u8) +(defonce text string) +(defonce colour Colour) +(defonce stray Colour) +(defonce some (Option Point)) +(defonce none (Option i32)) +(defonce wide Wide) +(defonce deep In0) +(defonce dot Shape) +(defonce empty Shape) +(defonce row [10 i32]) +(defonce words [u8]) +(defonce nums [i32]) +(defonce live (Ptr Enemy)) +(defonce dead (Ptr Enemy)) +(defonce nowhere (Ptr Enemy)) +(defonce un W) +(defonce anything dyn) +(defonce pair (Pair i32)) + +;; The innermost frame names every global above, so the break loop's section +;; holds all of them; then it stops. Each is stored back to itself rather than +;; printed: a frame that prints is refused attribution today (TODO.org, "A +;; frame that prints is skipped from the globals section"), and this is about +;; the values. +(defn inner [] i64 + (set small small) (set mid mid) (set large large) (set huge huge) + (set neg neg) (set ratio ratio) (set far far) (set odd odd) (set yes yes) + (set byte byte) (set text text) (set colour colour) (set stray stray) + (set some some) (set none none) (set wide wide) (set deep deep) + (set dot dot) (set empty empty) (set row row) (set words words) + (set nums nums) (set live live) (set dead dead) (set nowhere nowhere) + (set un un) (set anything anything) (set pair pair) + (error (Boom {.why 3})) + 0) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-parity-fallback.sock") + (let [v (vec-new Enemy) + w (vec-new Enemy) + bytes (vec-new u8) + ints (vec-new i32)] + (push v (Enemy {.hp 41 .x 2})) + (push w (Enemy {.hp 7 .x 9})) + (push bytes 104) (push bytes 105) (push bytes 10) + (push ints 4) (push ints -5) (push ints 6) + (set live (addr (at v 0))) + (set dead (addr (at w 0))) + (free w) + (set words (slice bytes)) + (set nums (slice ints)) + (set small -5) + (set mid 65535) + (set large 4000000000) + (set huge (u64 -1)) + (set neg -9000000000) + (set ratio 1.25) + (set far 3.5e20) + (set odd (/ 0.0 0.0)) + (set yes true) + (set byte 97) + (set text "a\"b\\c\nd\te") + (set colour :blue) + (set some (Some (Point {.x 1.5 .y -2.5}))) + (set wide (Wide {.a 1 .b 2 .c 3 .d 4 .e 5 .f 6 .g 7 .h 8 .i 9 .j 10})) + (set deep (In0 {.v (In1 {.v (In2 {.v (In3 {.v (In4 {.v 5})})})})})) + (set dot (Shape.Dot {.x 0.5 .y 2})) + (set empty Shape.Empty) + (set (at row 0) 11) + (set (at row 9) 99) + (set un (W {.n 12})) + (set anything {:s "kept" :n 1}) + (set pair (Pair 3 4)) + (print (inner)) (println "")) + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/test_agent.ml b/test/test_agent.ml index 93ba88e0..ecd63d4f 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -944,18 +944,30 @@ let () = (* A choice made against the outer break, then a break nested on top of it before the outer one looks. The inner break turns past it five times and resumes only on its own choice, into its own frame; index 1 read - without its generation would have sent it to outer-b. The last two lines - are the outer break needing to be asked again, because the choice slot - is one slot — TODO.org, "A choice made at an outer break is lost to a - nested one". *) + without its generation would have sent it to outer-b. The inner break + puts the outer choice back when it is left, so the outer break takes it + without being asked again. *) let code, out, err = hook_mode "stale" in let want = "outer choice ok\nstatus stopped Inner\ninner choice ok\ninner turns 5\n\ - inner resumed into inner\nouter re-asked 1\nouter resumed into outer-a\n" + inner resumed into inner\nouter re-asked 0\nouter resumed into outer-a\n" in if code <> 0 || out <> want then fail "a choice addressed to an outer break, met by a nested one\n got: %S (exit %d, err %S)\n wanted: %S" out code err want; + (* An inspector read queued, then a restart accepted, then a second read. + Requests take effect in the order they were sent: the first read runs + in the stop it was sent to, the restart is taken after it, and the + late read is refused at the door rather than run in the stop being + left. *) + let code, out, err = hook_mode "resuming" in + let want = + "queued ok\ntake ok\nlate err the program is resuming: a restart was taken\n\ + returned 0\nread ran\ndropped 0\n" + in + if code <> 0 || out <> want then + fail "a restart accepted with a read queued behind it\n got: %S (exit %d, err %S)\n wanted: %S" + out code err want; (try Sys.remove hexe with Sys_error _ -> ()); Test_support.report ~label:"agent" () diff --git a/test/test_dev.ml b/test/test_dev.ml index 6789224b..72a203bb 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6655,6 +6655,255 @@ let () = end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ isock; iout ]; + (* ── The inspector's reader against the compiled renderer ────────── *) + + (* The break loop reads a value out of the stopped program's memory + through lib/inspect.ml and compiles nothing; an evaluated expression is + still rendered by a compiled thunk through lib/render.ml. The two are + separate walks over the same arms, so this asks both about one global + of every shape and wants the same text — on both backends, because the + offsets the reader uses are [Emit.lay]'s and a backend that laid a + value out any other way would read differently here first. *) + List.iter + (fun backend -> + let psock = tmp ("parity" ^ backend ^ ".sock") + and pout = tmp ("parity" ^ backend ^ ".out") in + (try Sys.remove psock with Sys_error _ -> ()); + let pfd = + Unix.openfile pout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let ppid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-parity.flan"; "-s"; psock; backend |] + Unix.stdin pfd Unix.stderr + in + Unix.close pfd; + if not (listening ~pid:ppid psock) then begin + fail "the %s parity daemon %s" backend !listen_why; + (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect psock in + let said r = Option.value ~default:"" (Wire.string_field r "message") in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then + fail "the %s parity program never stopped" backend + else begin + let r = request c "(:op \"globals\")" in + let rows = + match Wire.field r "globals" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str n; _ } :: _ + :: { Form.v = Form.Str v; _ } :: _) -> + Some (n, v) + | _ -> None) + l + | _ -> [] + in + (* And nothing was built to answer it, which is the point: a + read used to be a module per request, named for its verb in + the session's directory. *) + let r2 = request c "(:op \"locals\" :frame 1)" in + let dir = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-dev-%d" ppid) + in + let built = + try + List.filter + (fun f -> + Filename.check_suffix f ".so" + && String.length f > 1 + && (f.[0] = 'g' || f.[0] = 'l') + && f.[1] >= '0' && f.[1] <= '9') + (Array.to_list (Sys.readdir dir)) + with Sys_error _ -> [] + in + if built <> [] then + fail "%s: reading globals and locals built %s" backend + (String.concat " " built); + if status r2 <> "ok" then fail "%s parity locals: %s" backend (said r2); + if status r <> "ok" then fail "%s parity globals: %s" backend (said r) + else if List.length rows <> 28 then + fail "%s parity: %d globals came back, not 28: %s" backend + (List.length rows) (String.concat " " (List.map fst rows)) + else + List.iter + (fun (n, v) -> + let e = + request c + (Printf.sprintf "(:op \"eval-expr\" :code %S)" n) + in + match Wire.string_field e "value" with + | Some ev when ev = v -> () + | got -> + fail "%s: %s reads %S in the break loop and %S evaluated" + backend n v (Option.value ~default:(said e) got)) + rows + end; + ignore (request c "(:op \"close\")"); + (try Unix.close c with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ psock; pout ]) + [ "--llvm"; "--x86" ]; + + (* ── Fix and retry, sent back to back ───────────────────────────── *) + + (* A client that loads a new body and takes [retry] in the next breath — + a script, or an editor command that does both — must get the new body. + The load is queued before the restart is accepted, so it runs first. + Both backends. *) + List.iter + (fun backend -> + let fsock = tmp ("fixretry" ^ backend ^ ".sock") + and fout = tmp ("fixretry" ^ backend ^ ".out") in + (try Sys.remove fsock with Sys_error _ -> ()); + let ffd = + Unix.openfile fout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let fpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-fix-retry.flan"; "-s"; fsock; backend |] + Unix.stdin ffd Unix.stderr + in + Unix.close ffd; + if not (listening ~pid:fpid fsock) then begin + fail "the %s fix-retry daemon %s" backend !listen_why; + (try Unix.kill fpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect fsock in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then + fail "the %s fix-retry program never stopped" backend + else begin + Buffer.clear output; + let r = request c "(:op \"eval\" :code \"(defn f [] i32 2)\")" in + if status r <> "ok" then fail "%s: loading the fix was refused" backend; + let r = request c "(:op \"restart\" :name \"retry\")" in + if status r <> "ok" then fail "%s: retry was refused" backend; + if not + (await (fun () -> + ignore (request c "(:op \"describe\")"); + contains_sub (Buffer.contents output) "RESULT ")) + then fail "%s: the retried program printed nothing" backend + else if not (contains_sub (Buffer.contents output) "RESULT 2") then + fail "%s: the retry ran the old body: %S" backend + (Buffer.contents output) + end; + ignore (request c "(:op \"close\")"); + (try Unix.close c with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] fpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ]) + [ "--llvm"; "--x86" ]; + + (* ── A dyn value that traps or faults while it is printed ─────────── *) + + (* The reader hands a dyn word to the program's own thread to render, + because the dyn printer follows pointers: a view of a freed arena + traps, and a scribbled word faults. Either is the reader's trouble and + not the program's, so it pushes no break: the value shows as the trap's + name, the rest of the section renders, and the stop on top is still + the program's own after any number of refreshes. A fault says it was + the inspector's read that touched the address, not the stopped frame. + Both backends. *) + List.iter + (fun backend -> + let dsock = tmp ("dyntrap" ^ backend ^ ".sock") + and dout = tmp ("dyntrap" ^ backend ^ ".out") in + (try Sys.remove dsock with Sys_error _ -> ()); + let dfd = + Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let dpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-dyn-trap.flan"; "-s"; dsock; backend |] + Unix.stdin dfd dfd + in + Unix.close dfd; + if not (listening ~pid:dpid dsock) then begin + fail "the %s dyn-trap daemon %s" backend !listen_why; + (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect dsock in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let still_boom what = + let r = request c "(:op \"describe\")" in + if Wire.string_field r "condition" <> Some "Boom" then + fail "%s: after %s the program is stopped on %s, not its own Boom" + backend what + (Option.value ~default:"nothing" (Wire.string_field r "condition")) + in + if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then + fail "the %s dyn-trap program never stopped" backend + else begin + let r = request c "(:op \"inspect\" :frame 0 :slot 0 :path (0))" in + (match Wire.field r "addr" with + | Some { Form.v = Form.Int a; _ } -> + let r = + request c + (Printf.sprintf "(:op \"at\" :addr %Ld :type \"dyn\")" a) + in + if Wire.string_field r "value" <> Some ">" + then + fail "%s: a dyn word pointing at 0x10 read as %s" backend + (Option.value ~default:(status r) (Wire.string_field r "value")); + still_boom "a dyn word that faults" + | _ -> fail "%s: inspecting the slice element gave no :addr" backend); + for i = 1 to 10 do + let r = request c "(:op \"globals\")" in + let rows = + match Wire.field r "globals" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str n; _ } :: _ + :: { Form.v = Form.Str v; _ } :: _) -> + Some (n, v) + | _ -> None) + l + | _ -> [] + in + if List.assoc_opt "dv" rows <> Some "#" + || List.assoc_opt "n" rows <> Some "5" + then + fail "%s: globals refresh %d with a trapping dyn: %s" backend i + (String.concat ", " (List.map (fun (n, v) -> n ^ "=" ^ v) rows)) + done; + still_boom "ten refreshes of a section holding a trapping dyn" + end; + ignore (request c "(:op \"close\")"); + (try Unix.close c with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ()); + let said = In_channel.with_open_bin dout In_channel.input_all in + if not (contains_sub said "reading a dyn value for the inspector touched") + || contains_sub said "the program touched" + then + fail "%s: the fault in the inspector's read was reported as: %s" + backend said + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ]) + [ "--llvm"; "--x86" ]; + (* ── What a half-finished assignment looks like from the break ────── *) (* A condition signalled from inside the value being assigned stops the diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index dda48ddb..e0b4c4f2 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -37,6 +37,10 @@ * with nc. */ +/* For process_vm_readv, the one call [peek] reads through. */ +#if defined(__linux__) && !defined(_GNU_SOURCE) +#define _GNU_SOURCE +#endif #include #include #include @@ -52,6 +56,7 @@ #include #include #if defined(__linux__) +#include #include #endif @@ -115,6 +120,19 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, int64_t *typelens, int64_t cap, int64_t *unread); int flan_dev_reg_enabled(void); int flan_dev_reg_overflowed(void); +/* The inspector's two questions about a pointer, asked here by the daemon + * rather than from inside a compiled thunk: whether it may be followed, and + * what died at it. And a global the program introduced after it started, + * which has storage in flan_dev.c's table and no symbol. */ +int32_t flan_dev_reg_live(const void *p); +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap); +void *flan_dev_global_find(const char *name); +/* A dyn word's rendering, into the result buffer. Weak: flan_dyn.c is linked + * only into a program that uses a dyn operation, and a program with no dyn + * value has nothing to ask it about. */ +void flan_dyn_emit_dev(uint64_t v) __attribute__((weak)); +void flan_dev_result_begin(void); +void flan_dev_result_end(void); void flan_free_temp(void); void *flan_temp_scratch_begin(void); void flan_temp_scratch_end(void *prev); @@ -447,6 +465,13 @@ static const uint8_t abandon_report[] = * frames jumped over do not run. NULL when no evaluation is in progress; * saved and restored around the call like [eval_boundary]. */ static sigjmp_buf *eval_escape; +/* Set while [dyn_job] renders a value for the inspector: a trap in there is + * the reader's, not the program's. See [break_loop_at]. Game thread only. */ +static int inspector_reading; +/* flan_dev.c's: what the fault report names when the fault is a read the + * inspector asked for, rather than the program's own. */ +extern const char *volatile flan_dev_crash_reading; +void flan_dev_emit(const uint8_t *bytes, int64_t len); /* Whether the game thread is inside an evaluated thunk's call, at any depth, * rather than in the program's own code. A break records it, and it is what @@ -564,6 +589,11 @@ static _Atomic int chosen_index; * take it; the inner loop simply does not claim what is not addressed to it. */ static _Atomic int chosen_gen; static _Atomic int chosen_ready; +/* The ring's head when the choice was accepted. Requests take effect in the + * order they were sent: every job queued before the restart runs in the stop + * it was sent to — a redefinition loaded and then [retry] is the fix-and-retry + * loop — and only then is the restart taken. */ +static _Atomic unsigned chosen_head; static _Atomic int aborting; /* -- The snapshot ---------------------------------------------------- */ @@ -702,12 +732,11 @@ void *flan_agent_frame_slot(int64_t frame, int64_t slot) { return flan_dev_frame_slot(s->fframe[frame], (int32_t)slot); } -/* The condition this break holds, for the render thunk the daemon builds to - * show its fields. Same contract as [flan_agent_frame_slot]: called on the - * stopped game thread, resolved against the snapshot on top *when the thunk - * runs*, NULL for a break that carries none — and the daemon delivers the - * thunk at-stop, so a resume between the asking and the running drops it - * rather than rendering one break's type over another break's pointer. */ +/* The condition this break holds, for the daemon's [cond-at] to show its + * fields: resolved against the snapshot on top, NULL for a break that carries + * none. The daemon checks the stop generation either side of its read, so a + * resume in between is refused rather than one break's type being read over + * another break's pointer. */ void *flan_agent_condition(void) { snapshot *s = snap_top(); return s == NULL ? NULL : s->cond; @@ -1058,9 +1087,43 @@ static _Noreturn void die_now(void) { * it is the same interleaving on every run. */ void (*flan_agent_break_poll_hook)(void); +static int32_t poll_upto(int bounded, unsigned limit); + +/* Put back a choice that was waiting for an outer break when a nested one + * started, unless it was this break's own. */ +static void restore_choice(int ready, int index, int gen, unsigned head_at, + int32_t mine) { + if (!ready || gen == mine) return; + atomic_store(&chosen_index, index); + atomic_store(&chosen_gen, gen); + atomic_store(&chosen_head, head_at); + atomic_store(&chosen_ready, 1); +} + static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, void *xfer, int resumable) { struct timespec step = { 0, 2000000 }; /* 2ms */ + /* A trap or fault inside the inspector's own read of a value — the dyn + * printer following a pointer that is no longer good. It is not the + * program's error and no break is pushed for it: the value is written as + * the trap's name, the evaluation escape unwinds the job exactly as an + * abandon would, and the stop the reader was looking at stays the one on + * top. A break here would leave the program one level deeper on every + * refresh of a section that holds the value. */ + if (inspector_reading && eval_escape != NULL) { + inspector_reading = 0; + flan_dev_crash_reading = NULL; + fprintf(stderr, "flan: reading a value for the inspector stopped on " + "%.*s; it is shown as #\n", + (int)namelen, (const char *)name, (int)namelen, (const char *)name); + fflush(stderr); + flan_dev_result_begin(); + flan_dev_emit((const uint8_t *)"#", 1); + flan_dev_result_end(); + siglongjmp(*eval_escape, 1); + } fflush(stdout); fprintf(stderr, "\nflan: unhandled %.*s — stopped, not dead.\n", (int)namelen, (const char *)name); @@ -1076,6 +1139,14 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, fflush(stderr); die_now(); } + /* A choice already accepted for a break below this one — this break was + * pushed by a job drained ahead of it. The slot is one slot, so it is kept + * here and put back when this break is left, and the outer break takes it + * then. */ + int outer_ready = atomic_load(&chosen_ready); + int outer_index = atomic_load(&chosen_index); + int outer_gen = atomic_load(&chosen_gen); + unsigned outer_head = atomic_load(&chosen_head); { snapshot *s = snap_top(); my_gen = s->gen; @@ -1147,9 +1218,18 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, fflush(stderr); die_now(); } + /* With a choice for this break waiting, the ring is drained only up to + * where it stood when the choice was accepted: what the client sent before + * the restart runs in this stop, in order, and then the restart is taken. + * A job that needs this stop and arrives after acceptance is refused at the + * listener; anything else queued after it runs at the next boundary. */ for (;;) { - flan_agent_poll(); - if (flan_agent_break_poll_hook != NULL) flan_agent_break_poll_hook(); + if (atomic_load(&chosen_ready) && atomic_load(&chosen_gen) == my_gen) + poll_upto(1, atomic_load(&chosen_head)); + else { + flan_agent_poll(); + if (flan_agent_break_poll_hook != NULL) flan_agent_break_poll_hook(); + } if (atomic_load(&aborting)) { fflush(stdout); fprintf(stderr, "flan: aborted at the break loop\n"); @@ -1183,6 +1263,7 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, atomic_store(&aborting, 0); snap_pop(); atomic_fetch_sub(&depth, 1); + restore_choice(outer_ready, outer_index, outer_gen, outer_head, my_gen); siglongjmp(*eval_escape, 1); } if (ok) { @@ -1212,6 +1293,7 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, * arriving in it is validated against a list nobody is looking at. */ snap_pop(); atomic_fetch_sub(&depth, 1); + restore_choice(outer_ready, outer_index, outer_gen, outer_head, my_gen); return; } /* The listener checks all of this before answering ok, so reaching here @@ -1253,7 +1335,13 @@ static void trap_stop(const uint8_t *name, int64_t namelen) { * consumed, and running a C-x C-e thunk a second time is the one thing the * whole dev loop is careful never to do. Still single-consumer: only the game * thread writes tail, nesting included. */ -int32_t flan_agent_poll(void) { +static int32_t poll_upto(int bounded, unsigned limit); +int32_t flan_agent_poll(void) { return poll_upto(0, 0); } + +/* [bounded]: stop at ring position [limit] — the head when a restart was + * accepted — rather than at the head now. Signed difference, because a + * nested break's own poll may already have taken the ring past it. */ +static int32_t poll_upto(int bounded, unsigned limit) { int32_t n = 0; /* A poll the game loop makes is a frame boundary, and a dev build wipes the * temp allocator there, as the program's own (free-temp) would. Not a poll @@ -1265,6 +1353,7 @@ int32_t flan_agent_poll(void) { unsigned t = atomic_load_explicit(&tail, memory_order_relaxed); unsigned h = atomic_load_explicit(&head, memory_order_acquire); if (t == h) return n; + if (bounded && (int)(limit - t) <= 0) return n; job j = queue[t % QUEUE]; atomic_store_explicit(&tail, t + 1, memory_order_relaxed); /* The gate the [job] comment argues for, asked at the only moment whose @@ -1507,6 +1596,19 @@ static void reply_unarmed(sink *o, snapshot *s, int32_t i) { static pthread_mutex_t request_lock = PTHREAD_MUTEX_INITIALIZER; +/* The word [dyn] hands the game thread. One slot, because the daemon waits + * for each rendering before asking for the next. */ +static uint64_t dyn_word; +static void dyn_job(void) { + flan_dev_result_begin(); + inspector_reading = 1; + flan_dev_crash_reading = "a dyn value"; + flan_dyn_emit_dev(dyn_word); + inspector_reading = 0; + flan_dev_crash_reading = NULL; + flan_dev_result_end(); +} + static void handle_line(char *line, sink *o) { /* The one verb that is not a module: read back the value of the last * expression evaluated, with the counter that says whether it is a new @@ -1772,6 +1874,7 @@ static void handle_line(char *line, sink *o) { if (unarmed(s, (int32_t)idx)) { reply_unarmed(o, s, (int32_t)idx); return; } atomic_store(&chosen_index, (int)idx); atomic_store(&chosen_gen, s->gen); + atomic_store(&chosen_head, atomic_load(&head)); /* Published last, so the game thread never reads an index that is about * to change, or one whose generation has not arrived yet. */ atomic_store(&chosen_ready, 1); @@ -1821,6 +1924,7 @@ static void handle_line(char *line, sink *o) { if (unarmed(s, at)) { reply_unarmed(o, s, at); return; } atomic_store(&chosen_index, at); atomic_store(&chosen_gen, s->gen); + atomic_store(&chosen_head, atomic_load(&head)); atomic_store(&chosen_ready, 1); /* The same two answers as [restart-at], because this verb is defined as * that one on the first index offering the name. Two verbs that resolve to @@ -1865,7 +1969,7 @@ static void handle_line(char *line, sink *o) { * a C identifier-ish string the program passed — and the value cannot * contain a raw tab or newline, because everything that reaches it goes * through an emitter that escapes both. So no framing is needed beyond - * this, which is the same bet render_locals makes on the same grounds. + * this, which is the same bet the locals reader makes on the same grounds. * * A header first: the count actually written, and how many names were * whether any name ever found no slot, so an overflow is reported rather @@ -1951,6 +2055,167 @@ static void handle_line(char *line, sink *o) { if (k > 0) emit(o, hdr, (size_t)k); return; } + /* ── Reading a stopped program's memory ───────────────────────────── + * + * The daemon's inspector reads values itself, through the type layouts it + * compiled, instead of building a thunk per inspection for the program to + * run. These verbs are everything it needs from this side: where a root is + * ([slot], [cond-at], [global]), the bytes at an address ([peek]), the + * registry's answer about a pointer ([ptr]), and a dyn word's rendering + * ([dyn]), which only the runtime can give because the tag is its to read. + * + * Stopped only, all of them. What makes reading another thread's memory + * sound is that the thread is not writing it, and a break is the moment + * that is promised. */ + if (strncmp(line, "slot ", 5) == 0 || strcmp(line, "cond-at") == 0 + || strncmp(line, "global ", 7) == 0 || strncmp(line, "peek ", 5) == 0 + || strncmp(line, "ptr ", 4) == 0 || strncmp(line, "dyn ", 4) == 0) { + if (!(atomic_load(&depth) > 0)) { + reply(o, "err not stopped: a running program's memory is being written " + "as it is read\n"); + return; + } + } + /* "slot F I" — the address of slot I of frame F, against the snapshot on + * top, which is what [flan_agent_frame_slot] answers a thunk. Null for a + * slot not yet bound, and that is refused rather than answered. */ + if (strncmp(line, "slot ", 5) == 0) { + char *end = NULL, *end2 = NULL; + long long f = strtoll(line + 5, &end, 10); + long long i = end != line + 5 ? strtoll(end, &end2, 10) : 0; + void *p; + char b[48]; + if (end == line + 5 || end2 == end) { + reply(o, "err slot wants a frame and a slot index\n"); + return; + } + p = flan_agent_frame_slot((int64_t)f, (int64_t)i); + if (p == NULL) { reply(o, "err no such slot, or it is not bound yet\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "cond-at" — where the condition this break holds is. [-] for none. */ + if (strcmp(line, "cond-at") == 0) { + void *p = flan_agent_condition(); + char b[48]; + if (p == NULL) { reply(o, "-\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "global SYM" — a global's storage, by its mangled symbol. A global the + * program introduced after it started lives in flan_dev.c's table and has + * no symbol; one it was built with is a symbol of the executable, which a + * redefinition module already binds to by name, so it is exported. */ + if (strncmp(line, "global ", 7) == 0) { + const char *name = line + 7; + void *p = flan_dev_global_find(name); + char b[48]; + if (p == NULL) { + void *self = dlopen(NULL, RTLD_LAZY); + if (self != NULL) p = dlsym(self, name); + } + if (p == NULL) { reply(o, "err no global by that symbol\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "peek ADDR LEN" — LEN bytes at ADDR, as hex. + * + * Through process_vm_readv on this process rather than a memcpy, so that an + * address that is not mapped is an [err] and not a fault: a slice whose + * storage has gone reads as garbage, and a fault here would take the + * program — and in one process, the daemon — down with it. */ + if (strncmp(line, "peek ", 5) == 0) { + char *end = NULL, *end2 = NULL; + unsigned long long a = strtoull(line + 5, &end, 0); + long long n = end != line + 5 ? strtoll(end, &end2, 10) : 0; + unsigned char *buf; + static const char hex[] = "0123456789abcdef"; + if (end == line + 5 || end2 == end || n < 0 || n > 65536) { + reply(o, "err peek wants an address and a length of at most 65536\n"); + return; + } + if (a == 0) { reply(o, "err unreadable\n"); return; } + buf = malloc(n > 0 ? (size_t)n : 1); + if (buf == NULL) { reply(o, "err out of memory\n"); return; } +#if defined(__linux__) + { + struct iovec local = { buf, (size_t)n }; + struct iovec remote = { (void *)(uintptr_t)a, (size_t)n }; + if (n > 0 + && process_vm_readv(getpid(), &local, 1, &remote, 1, 0) != (ssize_t)n) { + free(buf); + reply(o, "err unreadable\n"); + return; + } + } +#else + memcpy(buf, (const void *)(uintptr_t)a, (size_t)n); +#endif + reply(o, "ok "); + for (long long k = 0; k < n; k++) { + char two[2] = { hex[buf[k] >> 4], hex[buf[k] & 15] }; + emit(o, two, 2); + } + reply(o, "\n"); + free(buf); + return; + } + /* "ptr ADDR" — may this pointer be followed: [live], [dead] and what died + * there, or [none] for an address the registry never saw. The renderer's + * [reg-live] and [reg-emit], asked from here. */ + if (strncmp(line, "ptr ", 4) == 0) { + char *end = NULL; + unsigned long long a = strtoull(line + 4, &end, 0); + char desc[192]; + int32_t n; + const void *p = (const void *)(uintptr_t)a; + if (end == line + 4) { reply(o, "err ptr wants an address\n"); return; } + if (flan_dev_reg_live(p)) { reply(o, "live\n"); return; } + n = flan_dev_reg_epitaph(p, desc, (int64_t)sizeof desc); + if (n <= 0) { reply(o, "none\n"); return; } + reply(o, "dead"); + emit(o, desc, (size_t)n); + reply(o, "\n"); + return; + } + /* "dyn WORD" — render one dyn value into the result buffer, on the game + * thread, and answer [ok] for having queued it; the daemon reads the value + * back as it reads a thunk's. + * + * Not rendered here. The dyn printer follows the value's pointers and can + * trap — a view of a Vec whose arena was freed — or fault on a scribbled + * word, and on this thread either one is a break loop that holds + * [request_lock] for ever, or the daemon's own death. On the game thread it + * runs as an evaluation does, inside [flan_agent_poll]'s escape, and a trap + * there is caught by [break_loop_at] and written as the value's text + * without pushing a break. */ + if (strncmp(line, "dyn ", 4) == 0) { + char *end = NULL; + unsigned long long w = strtoull(line + 4, &end, 0); + snapshot *s = snap_top(); + job j = { 0 }; + if (end == line + 4) { reply(o, "err dyn wants a word\n"); return; } + if (flan_dyn_emit_dev == NULL) { + reply(o, "err this program has no dyn runtime linked\n"); + return; + } + if (s == NULL) { reply(o, "err no snapshot\n"); return; } + if (atomic_load(&chosen_ready)) { + reply(o, "err the program is resuming: a restart was taken\n"); + return; + } + if (!queue_room()) { reply(o, "err the install queue is full\n"); return; } + dyn_word = (uint64_t)w; + j.call = dyn_job; + j.stopped_only = 1; + j.at_stop = s->gen; + if (!publish(j)) { reply(o, "err the install queue is full\n"); return; } + reply(o, "ok\n"); + return; + } if (strcmp(line, "result") == 0) { uint64_t gen = 0, len = 0; uint64_t cap = flan_dev_result_cap(); @@ -2173,6 +2438,13 @@ static void handle_line(char *line, sink *o) { * 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 * room still there at [publish] below. */ + /* A job that needs the stop, arriving after a restart was accepted and + * before the break loop has taken it: the stop it was built for is being + * left, so it is refused here rather than run in a break that is ending. */ + if ((stopped_only || at_stop != 0) && atomic_load(&chosen_ready)) { + reply(o, "err the program is resuming: a restart was taken\n"); + return; + } if (!queue_room()) { reply(o, "err reload queue full; the program is not calling " "agent/poll\n");