The inspector reads a stopped program's memory through the compiled layouts, so locals, inspect, at, condition and globals build no module, and the inspector reads a generic instance's type arguments.
This commit is contained in:
parent
0f9160f3bc
commit
ae23787c04
13
TODO.org
13
TODO.org
@ -1685,10 +1685,15 @@ Settled for conditions and for structs, because =Load= qualifies every declarati
|
||||
at import. Still open for locals, where the debug information gives a bare name and
|
||||
nothing qualifies it.
|
||||
|
||||
** 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]
|
||||
|
||||
@ -2057,7 +2057,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
|
||||
@ -2614,6 +2614,40 @@ 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 and `flan_dyn_emit_to` renders it. 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.
|
||||
@ -6147,16 +6181,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,
|
||||
|
||||
@ -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
|
||||
;; <ptr> 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")
|
||||
|
||||
@ -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))
|
||||
|
||||
574
lib/dev.ml
574
lib/dev.ml
@ -2165,72 +2165,35 @@ 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 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 watched = 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
|
||||
@ -2245,7 +2208,7 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag
|
||||
(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)
|
||||
| None -> deliver t out)
|
||||
with
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
Error (unreachable t e)
|
||||
@ -2324,6 +2287,91 @@ 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
|
||||
"<ptr", as the thunk's [reg-emit] wrote it. *)
|
||||
| Ok l when starts l "dead" -> Inspect.Dead (after l "dead")
|
||||
| _ -> Inspect.Unknown);
|
||||
dyn =
|
||||
(fun w ->
|
||||
match agent_line t (Printf.sprintf "dyn %Lu" w) with
|
||||
| Ok l when starts l "ok " -> unhex (after l "ok ")
|
||||
| Ok l | Error l -> raise (Inspect.Unreadable ("a dyn value: " ^ l))) }
|
||||
|
||||
let reader t =
|
||||
Inspect.make ~program:t.session.Session.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
|
||||
Error
|
||||
"the program moved on while it was being read, 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
|
||||
@ -2412,13 +2460,11 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
|
||||
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
|
||||
@ -2451,27 +2497,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;
|
||||
@ -2487,16 +2552,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
|
||||
@ -2533,36 +2595,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;
|
||||
@ -2577,7 +2643,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
|
||||
@ -2593,9 +2659,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
|
||||
@ -2619,37 +2685,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
|
||||
@ -2659,7 +2737,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
|
||||
@ -2866,90 +2944,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.
|
||||
@ -2995,21 +2989,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 ->
|
||||
@ -3074,21 +3067,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.
|
||||
|
||||
@ -3221,23 +3212,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 \
|
||||
@ -3364,32 +3350,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 "
|
||||
@ -4262,7 +4254,7 @@ let watch_enable t ~on =
|
||||
|
||||
(* [NAME <tab> 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
|
||||
|
||||
432
lib/inspect.ml
Normal file
432
lib/inspect.ml
Normal file
@ -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 head from
|
||||
[Render.head]. *)
|
||||
|
||||
(* 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 "<allocator>"
|
||||
| Types.Vec _ -> put b "<vec>"
|
||||
| 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 (Render.head 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 "<ptr "; walk c b (depth + 1) p t; put b ">"
|
||||
| Dead why -> put b "<ptr"; put b why; put b ">"
|
||||
| Unknown -> put b "<ptr>"
|
||||
|
||||
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 }
|
||||
@ -97,6 +97,12 @@ let max_span = 8
|
||||
|
||||
let fail = Loc.fail
|
||||
|
||||
(* How a struct's rendering opens, and what a data case is called in one.
|
||||
Named here because lib/inspect.ml writes the same text by reading memory
|
||||
instead of emitting calls, and the two must spell a value alike. *)
|
||||
let head n = "(" ^ n ^ " {"
|
||||
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 =
|
||||
@ -256,7 +262,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
|
||||
@ -274,7 +280,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis
|
||||
@ render c (depth + 1) fv)
|
||||
shown)
|
||||
in
|
||||
do_ ((lit ("(" ^ full ^ " {") :: parts)
|
||||
do_ ((lit (head full) :: parts)
|
||||
@ (if List.length v.Tast.vfields > max_span then [ lit " ..." ]
|
||||
else [])
|
||||
@ [ lit "})" ])
|
||||
@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis
|
||||
@ render c (depth + 1) v)
|
||||
shown)
|
||||
in
|
||||
[ do_ ((lit ("(" ^ n ^ " {") :: parts)
|
||||
[ do_ ((lit (head n) :: parts)
|
||||
@ (if List.length fields > max_span then [ lit " ..." ] else [])
|
||||
@ [ lit "})" ]) ])
|
||||
(* A fixed array's length is in its type, so it unrolls — capped, because
|
||||
|
||||
431
lib/session.ml
431
lib/session.ml
@ -1352,19 +1352,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]. *)
|
||||
@ -1512,235 +1506,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 = "<locals>") 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;
|
||||
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;
|
||||
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
|
||||
@ -1888,25 +1671,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 = "<inspect>") 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
|
||||
@ -1914,34 +1695,6 @@ let render_slot ?(origin = "<inspect>") 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;
|
||||
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 ->
|
||||
@ -1949,65 +1702,9 @@ let render_slot ?(origin = "<inspect>") 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 ──────────────────────────────────────── *)
|
||||
|
||||
@ -2022,7 +1719,7 @@ let render_slot ?(origin = "<inspect>") 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
|
||||
@ -2117,7 +1814,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 = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
||||
~(edits : (step list * string) list)
|
||||
: (change * string * string, string) result =
|
||||
@ -2415,92 +2112,6 @@ let arm_restart ?(origin = "<restart>") 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 = "<globals>") 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;
|
||||
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
|
||||
|
||||
@ -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
|
||||
@ -1671,26 +1680,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
|
||||
@ -1778,17 +1800,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
|
||||
|
||||
@ -735,6 +735,11 @@ void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); }
|
||||
void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); }
|
||||
void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); }
|
||||
|
||||
/* And into whatever sink the caller hands over — the agent's, when the
|
||||
* daemon's inspector reads a dyn word out of a stopped program's memory and
|
||||
* wants its rendering as a reply rather than in the result buffer. */
|
||||
void flan_dyn_emit_to(dyn_sink w, flan_dyn v) { render(w, v, 0, 1); }
|
||||
|
||||
/* And into a condition's message, which flan_rt.c's sink bounds. */
|
||||
void flan_msg_emit(const uint8_t *p, int64_t n);
|
||||
void flan_dyn_emit_msg(flan_dyn v) { render(flan_msg_emit, v, 0, 1); }
|
||||
|
||||
109
test/programs/dev-parity.flan
Normal file
109
test/programs/dev-parity.flan
Normal file
@ -0,0 +1,109 @@
|
||||
;;;; 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])
|
||||
|
||||
(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)
|
||||
|
||||
;; 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)
|
||||
(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})
|
||||
(print (inner)) (println ""))
|
||||
(dotimes [i 4000]
|
||||
(agent/wait 5))
|
||||
0)
|
||||
100
test/test_dev.ml
100
test/test_dev.ml
@ -6247,6 +6247,106 @@ 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 <> 27 then
|
||||
fail "%s parity: %d globals came back, not 27: %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" ];
|
||||
|
||||
(* ── What a half-finished assignment looks like from the break ────── *)
|
||||
|
||||
(* A condition signalled from inside the value being assigned stops the
|
||||
|
||||
191
vendor/agent/flan_agent.c
vendored
191
vendor/agent/flan_agent.c
vendored
@ -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 <dlfcn.h>
|
||||
#include <errno.h>
|
||||
#include <stdlib.h>
|
||||
@ -52,6 +56,7 @@
|
||||
#include <time.h>
|
||||
#include <unistd.h>
|
||||
#if defined(__linux__)
|
||||
#include <sys/uio.h>
|
||||
#include <sys/prctl.h>
|
||||
#endif
|
||||
|
||||
@ -115,6 +120,18 @@ 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 a sink of the caller's. 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_to(void (*w)(const uint8_t *, int64_t), uint64_t v)
|
||||
__attribute__((weak));
|
||||
void flan_free_temp(void);
|
||||
void *flan_temp_scratch_begin(void);
|
||||
void flan_temp_scratch_end(void *prev);
|
||||
@ -680,12 +697,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;
|
||||
@ -1479,6 +1495,19 @@ static void reply_unarmed(sink *o, snapshot *s, int32_t i) {
|
||||
|
||||
static pthread_mutex_t request_lock = PTHREAD_MUTEX_INITIALIZER;
|
||||
|
||||
/* Where [dyn]'s rendering collects. Static, because [request_lock] makes
|
||||
* that verb one caller at a time, and the renderer's sink is a bare function
|
||||
* with nowhere to carry a pointer. Longer than any rendering the daemon keeps:
|
||||
* it cuts every value at the result buffer's size. */
|
||||
static char dyn_text[8192];
|
||||
static size_t dyn_text_len;
|
||||
static void dyn_text_put(const uint8_t *p, int64_t n) {
|
||||
size_t k = n < 0 ? 0 : (size_t)n;
|
||||
if (k > sizeof dyn_text - dyn_text_len) k = sizeof dyn_text - dyn_text_len;
|
||||
memcpy(dyn_text + dyn_text_len, p, k);
|
||||
dyn_text_len += k;
|
||||
}
|
||||
|
||||
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
|
||||
@ -1837,7 +1866,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
|
||||
@ -1910,6 +1939,154 @@ 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" — the rendering of one dyn value, as hex. The walk that takes
|
||||
* a dyn apart is the runtime's, so the daemon hands it the word. */
|
||||
if (strncmp(line, "dyn ", 4) == 0) {
|
||||
char *end = NULL;
|
||||
unsigned long long w = strtoull(line + 4, &end, 0);
|
||||
static const char hex[] = "0123456789abcdef";
|
||||
if (end == line + 4) { reply(o, "err dyn wants a word\n"); return; }
|
||||
if (flan_dyn_emit_to == NULL) {
|
||||
reply(o, "err this program has no dyn runtime linked\n");
|
||||
return;
|
||||
}
|
||||
dyn_text_len = 0;
|
||||
flan_dyn_emit_to(dyn_text_put, (uint64_t)w);
|
||||
reply(o, "ok ");
|
||||
for (size_t k = 0; k < dyn_text_len; k++) {
|
||||
unsigned char c = (unsigned char)dyn_text[k];
|
||||
char two[2] = { hex[c >> 4], hex[c & 15] };
|
||||
emit(o, two, 2);
|
||||
}
|
||||
reply(o, "\n");
|
||||
return;
|
||||
}
|
||||
if (strcmp(line, "result") == 0) {
|
||||
uint64_t gen = 0, len = 0;
|
||||
uint64_t cap = flan_dev_result_cap();
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user