diff --git a/test/programs/dev-inspect.flan b/test/programs/dev-inspect.flan new file mode 100644 index 0000000..753a8aa --- /dev/null +++ b/test/programs/dev-inspect.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index afb6c0b..2dd8a3a 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -884,6 +884,215 @@ let () = 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 \"\")" 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 other half of what a break loop can show. Locals are one frame's;