Which frame the inspector answered from, asserted rather than reasoned about
The `inspect' verb had no coverage. The discriminating case is not a path step, it is the frame: dev-inspect.flan gives `mark' to a global holding 99 and to a local of the OUTER frame holding a Point, so evaluating the name and rooting at the frame answer differently and not even with the same type. One `eval-expr' and one `inspect' of that name is the bug and the fix in a pair. The slot index comes off the locals listing's fourth element rather than being written as a literal, which exercises the field the editor depends on and keeps the test from passing for the wrong reason if slot allocation shifts. The rest is what a path can and cannot do: a struct field, an array element, an option's payload and a union case's field — the last two having offsets but no accessor form in the language — and four refusals, each checked for naming the step and saying why. A `:path' of `nil' is read as the slot itself, because Emacs has no other spelling for an empty list. Two claims about the frame, since `stopped_frame' being shared is an assertion about code rather than about behaviour until something proves it: the frame whose body was redefined under it is refused, and so is the whole stack once the program resumes.
This commit is contained in:
parent
4d29e52dbe
commit
404c810958
53
test/programs/dev-inspect.flan
Normal file
53
test/programs/dev-inspect.flan
Normal file
@ -0,0 +1,53 @@
|
|||||||
|
;;;; A stopped stack whose OUTER frame holds a local the evaluator cannot see.
|
||||||
|
;;;;
|
||||||
|
;;;; dev-locals.flan is about what one frame holds; this one is about which
|
||||||
|
;;;; frame the answer came from. The whole of the bug the `inspect' verb
|
||||||
|
;;;; exists for is that an expression is evaluated where the evaluator stands,
|
||||||
|
;;;; so a local's *name* reaches the right storage only when the frame is the
|
||||||
|
;;;; innermost one. `mark' below is a global AND a local of the outer frame,
|
||||||
|
;;;; holding different things of different types: evaluating the name answers
|
||||||
|
;;;; the global, and rooting at the frame and slot answers the frame.
|
||||||
|
;;;;
|
||||||
|
;;;; The other locals are the shapes a path step has to walk and that an
|
||||||
|
;;;; expression cannot reach at all: an option's payload, which has no
|
||||||
|
;;;; accessor form in the language, and a union case's field, whose offset
|
||||||
|
;;;; depends on which case the value is in.
|
||||||
|
(import agent "vendor:agent")
|
||||||
|
|
||||||
|
(defstruct Point [x f32 y f32])
|
||||||
|
(defstruct Boom [why i32])
|
||||||
|
|
||||||
|
(defunion Shape
|
||||||
|
[Empty
|
||||||
|
(Dot [x f64 y f64])
|
||||||
|
(Rect [w i32 h i32])])
|
||||||
|
|
||||||
|
;; The discriminator. `outer' binds a local of this name to something else, so
|
||||||
|
;; every claim about which frame answered is visible in the value itself.
|
||||||
|
(defvar mark i64)
|
||||||
|
|
||||||
|
;; The innermost frame, and it is deliberately dull: it holds nothing worth
|
||||||
|
;; inspecting, so that the frame worth inspecting is not the one an expression
|
||||||
|
;; would have found by luck.
|
||||||
|
(defn deeper [] i64
|
||||||
|
(restart-case
|
||||||
|
(do (error (Boom {.why 7})) 1)
|
||||||
|
(carry-on [] 5)))
|
||||||
|
|
||||||
|
(defn outer [] i64
|
||||||
|
(let [mark (Point {.x 1.5 .y 2.5})
|
||||||
|
xs [10 20 30]
|
||||||
|
box (Some (Point {.x 4.5 .y 5.5}))
|
||||||
|
s (Shape.Rect {.w 3 .h 6})]
|
||||||
|
(deeper)))
|
||||||
|
|
||||||
|
(defvar ticks i64)
|
||||||
|
|
||||||
|
(defn main [] i32
|
||||||
|
(set mark 99)
|
||||||
|
(agent/start "/tmp/flan-dev-inspect-fallback.sock")
|
||||||
|
(print (outer)) (println "")
|
||||||
|
(dotimes [i 4000]
|
||||||
|
(agent/wait 5)
|
||||||
|
(set ticks (+ ticks 1)))
|
||||||
|
0)
|
||||||
209
test/test_dev.ml
209
test/test_dev.ml
@ -884,6 +884,215 @@ let () =
|
|||||||
end
|
end
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
(* ── Which frame the inspector answered from ───────────────────── *)
|
||||||
|
|
||||||
|
(* The locals listing was already frame-accurate; the inspector was not.
|
||||||
|
`i' in the break buffer sent the local's *name* to be evaluated, and an
|
||||||
|
expression is evaluated where the evaluator stands — the right frame
|
||||||
|
only when the frame is the innermost one.
|
||||||
|
|
||||||
|
dev-inspect.flan is built so that failing to root at the frame is
|
||||||
|
visible in the value rather than only in the reasoning: `mark' is a
|
||||||
|
global holding 99 and a local of the *outer* frame holding a Point, and
|
||||||
|
the two are not even the same type. So the discriminating pair below is
|
||||||
|
one evaluation and one inspection of the same name.
|
||||||
|
|
||||||
|
It also carries the two shapes an expression cannot reach at all: an
|
||||||
|
option's payload, which no accessor form in the language names, and a
|
||||||
|
union case's field, whose offset depends on which case the value is
|
||||||
|
in. *)
|
||||||
|
let isock = tmp "inspect.sock" and iout = tmp "inspect.out" in
|
||||||
|
(try Sys.remove isock with Sys_error _ -> ());
|
||||||
|
let ifd = Unix.openfile iout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||||
|
let ipid =
|
||||||
|
Unix.create_process flan
|
||||||
|
[| flan; "dev"; "programs/dev-inspect.flan"; "-s"; isock |]
|
||||||
|
Unix.stdin ifd Unix.stderr
|
||||||
|
in
|
||||||
|
Unix.close ifd;
|
||||||
|
if not (await (fun () -> Sys.file_exists isock)) then begin
|
||||||
|
fail "the inspect daemon never listened";
|
||||||
|
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||||
|
end
|
||||||
|
else begin
|
||||||
|
let c = connect isock in
|
||||||
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
||||||
|
let stopped r =
|
||||||
|
match Wire.field r "stopped" with
|
||||||
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||||
|
| _ -> false
|
||||||
|
in
|
||||||
|
let contains hay needle =
|
||||||
|
let n = String.length needle in
|
||||||
|
let rec go i =
|
||||||
|
i + n <= String.length hay
|
||||||
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
||||||
|
in
|
||||||
|
go 0
|
||||||
|
in
|
||||||
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
||||||
|
fail "the inspect program never stopped"
|
||||||
|
else begin
|
||||||
|
(* The slot travels by index and the index comes off the listing,
|
||||||
|
which is the fourth element of each entry. Reading it here rather
|
||||||
|
than writing 0 exercises the field the editor depends on, and keeps
|
||||||
|
this test from passing for the wrong reason if slot allocation ever
|
||||||
|
shifts. *)
|
||||||
|
let slot_of r name =
|
||||||
|
match Wire.field r "locals" with
|
||||||
|
| Some { Form.v = Form.List l; _ } ->
|
||||||
|
List.fold_left
|
||||||
|
(fun acc (e : Form.t) ->
|
||||||
|
match acc with
|
||||||
|
| Some _ -> acc
|
||||||
|
| None ->
|
||||||
|
(match e.Form.v with
|
||||||
|
| Form.List
|
||||||
|
[ { Form.v = Form.Str n; _ }; _; _;
|
||||||
|
{ Form.v = Form.Int i; _ } ]
|
||||||
|
when String.equal n name ->
|
||||||
|
Some (Int64.to_int i)
|
||||||
|
| _ -> None))
|
||||||
|
None l
|
||||||
|
| _ -> None
|
||||||
|
in
|
||||||
|
let listing = ask "(:op \"locals\" :frame 1)" in
|
||||||
|
if status listing <> "ok" then
|
||||||
|
fail "locals of the outer frame: %s"
|
||||||
|
(Option.value ~default:(status listing) (Wire.string_field listing "message"))
|
||||||
|
else begin
|
||||||
|
let inspect ?(path = "()") slot =
|
||||||
|
ask
|
||||||
|
(Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)" slot
|
||||||
|
path)
|
||||||
|
in
|
||||||
|
let value r = Option.value ~default:"" (Wire.string_field r "value") in
|
||||||
|
let want name path ty v =
|
||||||
|
match slot_of listing name with
|
||||||
|
| None ->
|
||||||
|
fail "the locals listing gave no slot index for %s, so the \
|
||||||
|
inspector has nothing to root at" name
|
||||||
|
| Some slot ->
|
||||||
|
let r = inspect ~path slot in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "inspect %s%s: %s" name path
|
||||||
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
||||||
|
else begin
|
||||||
|
if value r <> v then
|
||||||
|
fail "inspect %s%s rendered %s, not %s" name path (value r) v;
|
||||||
|
if Option.value ~default:"" (Wire.string_field r "type") <> ty then
|
||||||
|
fail "inspect %s%s says its type is %s, not %s" name path
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "type")) ty
|
||||||
|
end
|
||||||
|
in
|
||||||
|
(* The pair the whole verb exists for. `mark' evaluated as an
|
||||||
|
expression is the global, because that is where the evaluator
|
||||||
|
stands; `mark' rooted at frame 1's slot is the frame's own
|
||||||
|
storage. Both answers are correct answers to different
|
||||||
|
questions, and the break buffer was asking the wrong one. *)
|
||||||
|
let r = ask "(:op \"eval-expr\" :code \"mark\" :file \"<t>\")" in
|
||||||
|
if status r <> "ok" || value r <> "99" then
|
||||||
|
fail "the global `mark' did not evaluate to 99: %s" (value r);
|
||||||
|
want "mark" "()" "Point" "(Point {.x 1.5 .y 2.5})";
|
||||||
|
(* A path step, which is an address plus an offset with that field's
|
||||||
|
type — the arithmetic the listing already does. *)
|
||||||
|
want "mark" "(\"x\")" "f32" "1.5";
|
||||||
|
want "xs" "(1)" "i32" "20";
|
||||||
|
(* And the two an expression cannot write at all. *)
|
||||||
|
want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})";
|
||||||
|
want "box" "(some \"x\")" "f32" "4.5";
|
||||||
|
want "s" "(\"Shape.Rect.w\")" "i32" "3";
|
||||||
|
(* Emacs prints an empty list as `nil' and has no other spelling for
|
||||||
|
one, so a client in that language cannot send `()'. *)
|
||||||
|
(match slot_of listing "mark" with
|
||||||
|
| None -> ()
|
||||||
|
| Some slot ->
|
||||||
|
let r = inspect ~path:"nil" slot in
|
||||||
|
if status r <> "ok" || value r <> "(Point {.x 1.5 .y 2.5})" then
|
||||||
|
fail "a :path of nil was not read as the slot itself: %s"
|
||||||
|
(Option.value ~default:(status r) (Wire.string_field r "message")));
|
||||||
|
(* Every step that does not fit the type in hand is refused by name
|
||||||
|
with its reason. A path with a step quietly dropped out of it
|
||||||
|
would render a *different* value and say nothing, which is the
|
||||||
|
failure this whole buffer is built to avoid. *)
|
||||||
|
List.iter
|
||||||
|
(fun (name, path, needle) ->
|
||||||
|
match slot_of listing name with
|
||||||
|
| None -> ()
|
||||||
|
| Some slot ->
|
||||||
|
let r = inspect ~path slot in
|
||||||
|
let m = Option.value ~default:"" (Wire.string_field r "message") in
|
||||||
|
if status r <> "error" then
|
||||||
|
fail "inspect %s%s answered instead of refusing: %s" name path
|
||||||
|
(value r)
|
||||||
|
else if
|
||||||
|
(* The refusal names the step and says why. *)
|
||||||
|
not
|
||||||
|
(contains m needle
|
||||||
|
&& contains m name)
|
||||||
|
then fail "inspect %s%s refused without saying why: %s" name path m)
|
||||||
|
[ ("mark", "(\"nope\")", "no field called nope");
|
||||||
|
("mark", "(some)", "not an option");
|
||||||
|
("xs", "(9)", "past the end");
|
||||||
|
(* A union field without its case: the payload's offset depends
|
||||||
|
on the case, so guessing one that two cases share would read
|
||||||
|
one case's layout over another's payload. *)
|
||||||
|
("s", "(\"w\")", "name the case") ]
|
||||||
|
end;
|
||||||
|
(* The innermost frame records no slots at all, and that is refused
|
||||||
|
with the reason rather than answered with something. *)
|
||||||
|
let r = ask "(:op \"inspect\" :frame 0 :slot 0 :path ())" in
|
||||||
|
if status r <> "error" then
|
||||||
|
fail "a frame with no slots answered the inspector anyway";
|
||||||
|
(* And the frame checks are the listing's, by construction: both go
|
||||||
|
through `stopped_frame'. An inspector with its own copy 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. This
|
||||||
|
body renames every local and keeps the count and the types, which
|
||||||
|
only the slot fingerprint can see. *)
|
||||||
|
let r =
|
||||||
|
ask
|
||||||
|
"(:op \"eval\" :code \"(defn outer [] i64 (let [tag (Point {.x 9.0 .y 9.0}) ys [1 2 3] maybe (Some (Point {.x 0.0 .y 0.0})) sh (Shape.Rect {.w 1 .h 1})] (deeper)))\" :file \"/tmp/buf.flan\")"
|
||||||
|
in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "installing a renamed body while stopped: %s"
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||||
|
else begin
|
||||||
|
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
||||||
|
if status r <> "error" then
|
||||||
|
fail
|
||||||
|
"the inspector read a frame whose body was redefined under it: %s"
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||||
|
end
|
||||||
|
end;
|
||||||
|
(* And a running program has no frame to root at. The inspector says so
|
||||||
|
rather than falling back to evaluating the name somewhere else, which
|
||||||
|
is the behaviour it replaced. *)
|
||||||
|
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "resuming the inspect program: %s"
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||||
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
||||||
|
fail "the inspect program never resumed"
|
||||||
|
else begin
|
||||||
|
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
||||||
|
if status r <> "error" then
|
||||||
|
fail "a running program answered the inspector"
|
||||||
|
end;
|
||||||
|
ignore (ask "(:op \"close\")");
|
||||||
|
Unix.close c;
|
||||||
|
if not
|
||||||
|
(await ~ms:5000 (fun () ->
|
||||||
|
match Unix.waitpid [ Unix.WNOHANG ] ipid with
|
||||||
|
| 0, _ -> false
|
||||||
|
| _ -> true
|
||||||
|
| exception Unix.Unix_error _ -> true))
|
||||||
|
then begin
|
||||||
|
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||||
|
(try ignore (Unix.waitpid [] ipid) with Unix.Unix_error _ -> ())
|
||||||
|
end
|
||||||
|
end;
|
||||||
|
|
||||||
(* ── The globals a stopped stack reaches ───────────────────────── *)
|
(* ── The globals a stopped stack reaches ───────────────────────── *)
|
||||||
|
|
||||||
(* The other half of what a break loop can show. Locals are one frame's;
|
(* The other half of what a break loop can show. Locals are one frame's;
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user