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