diff --git a/lib/dev.ml b/lib/dev.ml index 5af554d..aac36ce 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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 diff --git a/lib/session.ml b/lib/session.ml index 52618e9..1d11dea 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -496,8 +496,15 @@ let render_locals ?(origin = "") 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 = "") 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 = "") 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