JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The inspector gets an address root, and the daemon a verb for it

Browse Source 
`i' in the break buffer sent a local's *name* to be evaluated, and an
expression is evaluated where the evaluator stands. On the innermost frame
that is the right frame; on any other it may resolve to a global, to another
binding of the same name, or to nothing, with the listing above it showing the
frame's own storage and nothing saying the two disagree.

The shadow stack is what makes the second rooting mode cheap: a frame's
address and every slot's type are both here, so a step into a field is an
address plus an offset with that field's type — the arithmetic
`Render.render' already does for the listing. `Session.render_slot' is
`render_locals' with a path applied to the root and one line out.

The slot travels by *index*, because a name is not unique: two `v's is two
slots and both are in the listing, and a refused slot is not, so the position
in the list is not an identifier either. So `locals' now puts the index on
each line.

The frame checks are `locals'' by construction — `stopped_frame' is one
function now, and an inspector with its own copy would be free to read a frame
whose body was redefined since it was entered. The build-and-read tail is one
function too, for the reason this file already records about the fingerprint.

And `layout' said union values were milestone 6, which they have not been
since today.
This commit is contained in:
Joseph Ferano 2026-09-12 17:15:57 +07:00
parent 4ea089839c
commit 122e17bd06
2 changed files with 561 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

469
lib/dev.ml
View File

@ -628,7 +628,17 @@ let layout t ~ty =
List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname ty)
t.session.Session.program.Tast.unions
then
error (ty ^ " is a union, not a struct; union values are milestone 6")
(* Unions have landed, so "milestone 6" was stale — but what replaces it
is not a layout. This op's reply is a flat [:fields] list, and a union
is a tag and one payload per case: there is no one field list to
answer with, and flattening the cases into one would describe storage
no value ever has. So it says which kind of type this is, and where
the question it was probably asked for *is* answered — the renderer
walks a union now, so a union value prints in a frame's locals and at
`C-x C-e' with its case and that case's fields. *)
error
(ty
^ " is a union, not a struct; a union is a tag and one payload per case, so it has no single field list for this op to answer with. Its value renders with its case and fields in a frame's locals and at C-x C-e")
else
let suffix = "/" ^ ty in
let candidates =
@ -724,6 +734,115 @@ 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.
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.
[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. *)
let run_render_thunk t ~tag ~(c : Session.change) : (string, string) result =
let before = match result t with Some (g, _) -> g | None -> 0L in
t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "%s%d.so" tag t.n) in
match
Build.shared
~opts:{ Build.default with Build.dev = true;
Build.debug = t.session.Session.debug }
~ir:c.Session.ir ~out ()
with
| exception Failure m -> Error m
| _ ->
(match deliver t out with
| exception Unix.Unix_error (e, _, _) ->
Error ("cannot reach the program: " ^ Unix.error_message e)
| "ok" ->
let rec wait ms =
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ when ms <= 0 -> None
| _ ->
ignore (Unix.select [] [] [] 0.005);
if alive t then wait (ms - 5) else None
in
(match wait 5000 with
| Some v -> Ok v
| None ->
Error
"the program did not reach a frame boundary; is it calling \
(agent/poll)?")
| reply -> Error ("the program refused the module: " ^ reply))
(* 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
[locals] rather than repeating four conditions is the point: an inspector
that sidestepped the fingerprint would read stale slots out of a frame the
listing above it is already refusing.
[what] goes into the wording — "read slot names from" is not the sentence
[inspect] wants — and nothing else differs. *)
let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
if not (alive t) then Error "the program exited; restart flan dev"
else
match state t with
| Running ->
Error
(Printf.sprintf
"the program is running; %s is read from a stopped frame, and \
nothing in a frame that is still executing holds still"
what)
| Unreachable m -> Error ("cannot ask the program where it is: " ^ m)
| Stopped _ ->
(match backtrace t with
| Error m -> Error ("the program refused to say where it is: " ^ m)
| Ok (frames, _) ->
(match List.nth_opt frames frame with
| None ->
Error
(Printf.sprintf "there is no frame %d; the backtrace has %d" frame
(List.length frames))
| Some (name, _, mine, nslots, sig_, _rsig) ->
if not mine then
Error
(name
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
else
match find_fn t name with
| None ->
Error
(name
^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from")
| Some fn ->
(* The two body checks come first, including for a frame
with no slots. "every slot in it is one the compiler made
up" is a claim about the body this session holds, and a
zero-slot frame whose body has since been replaced by one
with slots is a frame that claim is false about. *)
if nslots <> Array.length fn.Tast.slots then
Error
(Printf.sprintf
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
name nslots name (Array.length fn.Tast.slots))
else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching.
A redefinition that renames a local, or changes its type
to one of the same shape, keeps the count — and then
every name here would be the new body's read against the
old body's storage, which is the "visible rather than
correct" answer this project refuses to give. Said by
name, because a frame that is missing and a frame that
cannot be trusted are different facts. *)
Error
(Printf.sprintf
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
name name)
else Ok (name, fn)))
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
The half of a break loop that the author actually wanted, and the reason
@ -758,122 +877,109 @@ let backtrace_op t =
30-bit hash — but only between two differing bodies of the function whose
qualified name already matched, since [find_fn] gates the comparison. *)
let locals t ~frame =
if not (alive t) then error "the program exited; restart flan dev"
else
match state t with
| Running ->
error
"the program is running; locals are read from a stopped frame, and \
nothing in a frame that is still executing holds still"
| Unreachable m -> error ("cannot ask the program for its locals: " ^ m)
| Stopped _ ->
(match backtrace t with
| Error m -> error ("the program refused to say where it is: " ^ m)
| Ok (frames, _) ->
(match List.nth_opt frames frame with
| None ->
error
(Printf.sprintf "there is no frame %d; the backtrace has %d" frame
(List.length frames))
| Some (name, _, mine, nslots, sig_, _rsig) ->
if not mine then
error
(name
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
else
match find_fn t name with
| None ->
error
(name
^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from")
| Some fn ->
(* The two body checks come first, including for a frame
with no slots. "every slot in it is one the compiler made
up" is a claim about the body this session holds, and a
zero-slot frame whose body has since been replaced by one
with slots is a frame that claim is false about. *)
if nslots <> Array.length fn.Tast.slots then
error
(Printf.sprintf
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
name nslots name (Array.length fn.Tast.slots))
else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching.
A redefinition that renames a local, or changes its type
to one of the same shape, keeps the count — and then
every name here would be the new body's read against the
old body's storage, which is the "visible rather than
correct" answer this project refuses to give. Said by
name, because a frame that is missing and a frame that
cannot be trusted are different facts. *)
error
(Printf.sprintf
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
name name)
else if nslots = 0 then
ok
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
":note "
^ Wire.quote
"that frame records no slots; every slot in it is one the compiler made up" ]
else
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
let before = match result t with Some (g, _) -> g | None -> 0L in
t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "l%d.so" t.n) in
(match Build.shared
~opts:{ Build.default with Build.dev = true;
Build.debug = t.session.Session.debug }
~ir:c.Session.ir ~out () with
| _ ->
(match deliver t out with
| "ok" ->
let rec wait ms =
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ when ms <= 0 -> None
| _ ->
ignore (Unix.select [] [] [] 0.005);
if alive t then wait (ms - 5) else None
in
(match wait 5000 with
| Some v ->
(* One line per slot, name and type and value,
tab separated — safe because every string the
renderer emits is escaped. *)
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 ])
| _ -> None)
(String.split_on_char '\n' v)
in
ok
[ ":frame " ^ Wire.quote name;
":locals " ^ Wire.list entries;
":refused "
^ Wire.list
(List.map
(fun (n, why) ->
Wire.list
[ Wire.quote n; Wire.quote why ])
refused) ]
| None ->
error
"the program did not reach a frame boundary; is \
it calling (agent/poll)?")
| reply -> error ("the program refused the module: " ^ reply)
| exception Unix.Unix_error (e, _, _) ->
error ("cannot reach the program: " ^ Unix.error_message e))
| exception Failure m -> error m)))
match stopped_frame t ~frame ~what:"locals" with
| Error m -> error m
| Ok (name, fn) ->
if Array.length fn.Tast.slots = 0 then
ok
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
":note "
^ Wire.quote
"that frame records no slots; every slot in it is one the compiler made up" ]
else
(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
| 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
[ ":frame " ^ Wire.quote name;
":locals " ^ Wire.list entries;
":refused "
^ Wire.list
(List.map
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
refused) ]))
(* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second
rooting mode, and the answer to the hole [DISCUSS.md] item 1 named.
[i] in the break buffer used to send a local's *name* to be evaluated as an
expression. On the innermost frame that happens to be right; on any other
it is evaluated wherever the evaluator stands, so it may resolve to a
global, to a different binding of the same name, or to nothing — with the
listing right above it showing the frame's own storage and nothing saying
the two disagree.
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.
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
frame whose body was redefined since it was entered, which is exactly the
stale-slot answer the listing refuses.
The slot is named by *index* and not by name, because a name is not unique:
[check.ml]'s [fresh_slot] only ever allocates, so (let [v 22] …) inside
(let [v 11] …) is two slots both called [v], and both are in the listing.
The index travels out with each line of [locals] for exactly this.
[:path] is a list the reader parses: a string is a field, an integer is an
element, and the symbol [some] is an option's payload. Empty means the slot
itself. *)
let inspect t ~frame ~slot ~path =
match stopped_frame t ~frame ~what:"a local" with
| Error m -> error m
| Ok (name, fn) ->
(match bound_slots t ~frame with
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
| Ok bound ->
if not (List.mem slot bound) then
(* The 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. *)
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
| Error why -> error why
| Ok (c, label, ty) ->
(match run_render_thunk t ~tag:"i" ~c with
| Error m -> error m
| Ok v ->
(* One value and nothing else, so the whole of what came back is
it — minus the trailing newline the renderer does not write
here, because there is no second line to separate it from. *)
ok
[ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ]))
(* [(:op "globals")] — the globals the stopped stack reaches, in one section.
@ -1063,66 +1169,39 @@ let globals_op t =
nothing here that is not already in the locals" ]
else begin
let c, refused = Session.render_globals t.session ~globals:ordered in
let before = match result t with Some (g, _) -> g | None -> 0L in
t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "g%d.so" t.n) in
match Build.shared
~opts:{ Build.default with Build.dev = true;
Build.debug = t.session.Session.debug }
~ir:c.Session.ir ~out () with
| _ ->
(match deliver t out with
| "ok" ->
let rec wait ms =
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ when ms <= 0 -> None
| _ ->
ignore (Unix.select [] [] [] 0.005);
if alive t then wait (ms - 5) else None
in
(match wait 5000 with
| Some 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
List.iter
(fun (g : Tast.global) ->
Hashtbl.replace by_name g.Tast.gname (where g))
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
[ ":globals " ^ Wire.list entries;
":refused "
^ Wire.list
(List.map
(fun (n, why) ->
Wire.list [ Wire.quote n; Wire.quote why ])
refused);
skipped_field ]
| None ->
error
"the program did not reach a frame boundary; is it calling \
(agent/poll)?")
| reply -> error ("the program refused the module: " ^ reply)
| exception Unix.Unix_error (e, _, _) ->
error ("cannot reach the program: " ^ Unix.error_message e))
| exception Failure m -> error m
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
List.iter
(fun (g : Tast.global) ->
Hashtbl.replace by_name g.Tast.gname (where g))
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
[ ":globals " ^ Wire.list entries;
":refused "
^ Wire.list
(List.map
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
refused);
skipped_field ]
end)
(* A choice is validated by the *program*, on its listener thread, against a
@ -1516,6 +1595,42 @@ let handle t req =
| Some "backtrace" -> backtrace_op t
| Some "locals" ->
locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0)
(* The path is read by the language's own reader, so it arrives as a form
and is matched here rather than parsed out of a string: a string element
is a field, an integer is an element, and the symbol [some] is an
option's payload. Anything else is refused by name rather than skipped —
a path with a step silently dropped out of it would render a *different*
value and say nothing. *)
| Some "inspect" ->
(match Wire.int_field req "slot" with
| None -> error "inspect needs :slot, the index the locals listing gave"
| Some slot ->
let frame =
match Wire.int_field req "frame" with Some n -> n | None -> 0
in
let steps =
match Wire.field req "path" with
| Some { Form.v = Form.List l; _ } ->
List.fold_left
(fun acc (e : Form.t) ->
match acc with
| Error _ -> acc
| Ok got ->
(match e.Form.v with
| Form.Str f -> Ok (Session.Sfield f :: got)
| Form.Int i -> Ok (Session.Sindex (Int64.to_int i) :: got)
| Form.Sym "some" -> Ok (Session.Ssome :: got)
| _ ->
Error
"a :path step is a string for a field, an integer for an element, or `some' for an option's payload"))
(Ok []) l
|> Result.map List.rev
| Some _ -> Error "inspect's :path is a list"
| None -> Ok []
in
(match steps with
| Error m -> error m
| Ok path -> inspect t ~frame ~slot ~path))
(* No :frame, and that is the point: the section is the stack's, not a
frame's. See [globals_op]. *)
| Some "globals" -> globals_op t

270
lib/session.ml
View File

@ -496,8 +496,15 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
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 "\n" ])
((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts)
@ [ lit ("\t" ^ string_of_int i ^ "\n") ])
| exception Loc.Error (_, 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
@ -554,6 +561,267 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
ignore origin;
({ ir; names = []; fns = []; installs = true }, 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.
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.
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
index past the end of a fixed array, an option's payload on something that
is not an option. A pointer is still never followed — that is the
renderer's rule and not this mode's. *)
(* A step, as the editor sends it. [Sfield] on a union carries the case as
well, because a union's payload is at an offset that depends on which case
it is, and the renderer is what told the editor which case this value
currently holds. Guessing the case from a field name that two cases share
would read one case's layout over another's payload. *)
type step = Sfield of string | Sindex of int | Ssome
let step_text = function
| Sfield f -> "." ^ f
| Sindex i -> Printf.sprintf "[%d]" i
| Ssome -> ".some"
let path_text path = String.concat "" (List.map step_text path)
let step_into t (v : Tast.expr) (s : step) : (Tast.expr, string) result =
let loc = v.Tast.loc in
let ty = v.Tast.ty in
let no why = Error why in
match s with
| Ssome ->
(match ty with
| Types.Option pay -> Ok { Tast.e = Tast.Field (v, 1); ty = pay; loc }
| _ ->
no
(Printf.sprintf "%s is not an option, so it has no payload to go into"
(Types.to_string ty)))
| Sindex i ->
(match ty with
| Types.Array (n, el) ->
if i < 0 || Int64.compare (Int64.of_int i) n >= 0 then
no
(Printf.sprintf "%d is past the end of %s, which has %Ld elements" i
(Types.to_string ty) n)
else
Ok
{ Tast.e =
Tast.Prim
(Tast.At,
[ v;
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
ty = Types.Int Types.I32; loc } ]);
ty = el; loc }
| Types.Slice el ->
(* A slice's length is not in its type, so this is the one step whose
range cannot be settled here. It is checked in the program, like
every other index in a dev build. *)
if i < 0 then no (Printf.sprintf "%d is not an index" i)
else
Ok
{ Tast.e =
Tast.Prim
(Tast.At,
[ v;
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
ty = Types.Int Types.I32; loc } ]);
ty = el; loc }
| _ ->
no
(Printf.sprintf "%s is not an array or a slice, so it has no element %d"
(Types.to_string ty) i))
| Sfield spec ->
(match ty with
| Types.Named n
when List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname n)
t.program.Tast.unions ->
let u =
List.find (fun (u : Tast.union) -> String.equal u.Tast.uname n)
t.program.Tast.unions
in
(* The editor spells this `Union.case.field', which is the head the
renderer wrote — `(Union.case {.field …})' — with the field appended.
A bare `case.field' is taken too, since that is the same fact said
shorter. *)
(match String.rindex_opt spec '.' with
| None ->
no
(Printf.sprintf
"%s is a union: a field of it has to name the case that holds \
it, because the payload's offset depends on which case the \
value is in"
n)
| Some k ->
let case = String.sub spec 0 k
and fname = String.sub spec (k + 1) (String.length spec - k - 1) in
let case =
let pre = n ^ "." in
let lp = String.length pre in
if String.length case > lp && String.equal (String.sub case 0 lp) pre
then String.sub case lp (String.length case - lp)
else case
in
(match
List.find_opt
(fun (vr : Tast.variant) -> String.equal vr.Tast.vname case)
u.Tast.cases
with
| None ->
no (Printf.sprintf "%s has no case called %s" n case)
| Some vr ->
let rec idx i = function
| [] -> None
| (f : Tast.field) :: rest ->
if String.equal f.Tast.fname fname then Some (i, f.Tast.fty)
else idx (i + 1) rest
in
(match idx 0 vr.Tast.vfields with
| None ->
no
(Printf.sprintf "%s.%s has no field called %s" n case fname)
| Some (i, fty) ->
Ok
{ Tast.e = Tast.CaseField (v, vr.Tast.vname, i); ty = fty; loc })))
| Types.Named n ->
(match
List.find_opt
(fun (s : Tast.structure) -> String.equal s.Tast.sname n)
t.program.Tast.structs
with
| None ->
no
(Printf.sprintf
"%s is a type this session has no layout for, so there is no \
field to step to"
n)
| Some st ->
let rec idx i = function
| [] -> None
| (f : Tast.field) :: rest ->
if String.equal f.Tast.fname spec then Some (i, f.Tast.fty)
else idx (i + 1) rest
in
(match idx 0 st.Tast.fields with
| None ->
no (Printf.sprintf "%s has no field called %s" n spec)
| Some (i, fty) -> Ok { Tast.e = Tast.Field (v, i); ty = fty; loc }))
| _ ->
no
(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.
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 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 =
if slot < Array.length fn.Tast.snames then fn.Tast.snames.(slot) else None
in
match sname with
| None ->
Error
(Printf.sprintf
"slot %d of %s is one the compiler made up; no name was written for \
it, and it is not something the listing offers"
slot fn.Tast.name)
| Some name ->
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
emit = dev_emitter;
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.Int Types.U8); loc }
in
let typed =
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]);
ty = Types.Ptr ty; loc }
in
let root = { Tast.e = Tast.Deref typed; ty; loc } in
let rec walk v = function
| [] -> Ok v
| s :: rest ->
(match step_into t v s with
| Error why -> Error why
| Ok v' -> walk v' rest)
in
(match walk root path with
| Error why -> Error (name ^ path_text path ^ ": " ^ why)
| Ok v ->
(match Render.render c 0 v with
| exception Loc.Error (_, why) -> Error (name ^ path_text path ^ ": " ^ why)
| parts ->
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 = []; 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 =
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t)
~call:tname program ~fns:[ tname ]
in
ignore origin;
Ok
({ ir; names = []; fns = []; installs = true },
name ^ path_text path,
Types.to_string v.Tast.ty)))
(* ── The globals a stopped stack reaches ───────────────────────────── *)
(* The other half of what a break loop can show, and in this language arguably