437 lines
18 KiB
OCaml
437 lines
18 KiB
OCaml
(** 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; enested = 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 "()"
|
|
(* As the runtime spells a dyn char, which [Form.byte_repr] mirrors. *)
|
|
| Types.Char -> put b (Form.byte_repr (Int32.to_int (i32 c addr) land 0x1fffff))
|
|
(* The prelude's String is a (Vec u8), whose header starts with the same
|
|
pointer and length a str is. *)
|
|
| Types.String | Types.Slice (_, Types.Int Types.U8) | Types.Named "String" ->
|
|
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
|
|
if i > 0 then 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
|
|
if i > 0 then 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 }
|