JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_dev.ml
Joseph Ferano f2be0a62dd A pause is waited for by name, and a build is not a socket 
Two follow-ups to the marking commit.

`Dev.eval_expr`'s new wait matched `Stopped _`, which fires on the first
iteration when the program is already parked on something else — the
break loop allows evaluating, so that is reachable — and answers for a
thunk that has not run yet, on a reply whose own `:condition` names the
other condition. It now waits for `Stopped "Pause"`, which the agent
reports under a nested break because `condition_name` is overwritten on
the way in and restored on the way out. `dev-pause.flan` grows a
`Missing` and a `boom` so the test can park the program on something
else first and tell the two apart.

And the flake NEXT.md had as "seen once and unexplained": `the daemon
never listened` is not a race, it is an llc-and-link of the whole
program before `flan dev` binds — ~600ms idle, measured at 6.6s and 6.8s
with the rest of the suite beside it, against a 5s and 8s await. All
three test binaries now wait a minute; the watchdog is what bounds the
run. Two consecutive full runs green.
2026-09-13 13:07:25 +07:00

2384 lines
114 KiB
OCaml
Raw Blame History

(* [flan dev]: the daemon an editor talks to (NEXT.md, the dev loop).
What it adds over [flan reload] is that the session persists between
evaluations and that the daemon owns the build, so its idea of the running
process is not a guess. Both are tested here by sending a sequence: a name
the program was never built with, then a second evaluation that uses it. If
the session were rebuilt per request the second one would not even check. *)
open Flan
(* The watchdog first: a hang is the one failure mode that reports
nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:900 "test_dev"
let failures = ref 0
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
let scratch = Filename.get_temp_dir_name ()
let tmp n = Filename.concat scratch ("flan-devtest-" ^ n)
let rec await ?(ms = 5000) f =
if f () then true
else if ms <= 0 then false
else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
(* Waiting for a daemon to listen is not waiting for a socket: [flan dev]
compiles the whole program first, and only then binds. The build is llc and
a link, which is ~600ms on an idle machine and has been measured at 6.8s
with this suite's other binaries running beside it under dune's own
parallelism — so the 5s default turned a busy machine into "the daemon never
listened", a message that reads like a bug in the daemon and is not one.
A minute is not a guess about how slow the build can get; it is long enough
that a failure here means the daemon is not coming, which is the only thing
this check is trying to find out. The watchdog is the thing that bounds the
run, and it is armed at 900s for exactly this reason. *)
let listening path = await ~ms:60000 (fun () -> Sys.file_exists path)
let rec connect ?(ms = 5000) path =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
match Unix.connect s (Unix.ADDR_UNIX path) with
| () -> s
| exception Unix.Unix_error (_, _, _) when ms > 0 ->
Unix.close s;
ignore (Unix.select [] [] [] 0.005);
connect ~ms:(ms - 5) path
(* The program's own output arrives on the replies, not on a file: the daemon
reads its stdout through a pipe so an editor can see it. Every reply is
drained into here, which is also what an editor does. *)
let output = Buffer.create 256
let request fd sexp =
let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string output t
| None -> ());
r
let status r =
match Wire.string_field r "status" with Some s -> s | None -> "<none>"
let contains_sub 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
let () =
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
| 0 ->
let sock = tmp "dev.sock" in
let out = tmp "prog.out" in
(try Sys.remove sock with Sys_error _ -> ());
let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
(* The daemon is run as a subprocess rather than in-process because that is
how an editor meets it, and because it launches and owns a program of
its own. Its child's stdout is what we read the result off. *)
let flan = "../bin/main.exe" in
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock |]
Unix.stdin fd Unix.stderr
in
Unix.close fd;
if not (listening sock) then
fail "the daemon never listened"
else begin
(* The daemon owns the program's lifetime and kills it on [close], so
every step waits for the program to have got there. "ok" from an eval
means the module was queued, not that it has been installed. *)
let c = connect sock in
(* One process, which is the whole claim of the merge and the one thing
a reply cannot show. [flan dev] builds a binary that is the compiled
program *and* holds the compiler, and execs it — so the pid this test
launched as [flan] is the program, and there is no child to find. The
path pins it further: the build directory is named for the pid that
made it, so finding it under /proc/<pid>/exe says the process that
built the program is the process now running it.
Linux only, by /proc. Elsewhere it is skipped rather than faked: what
is being checked is the process table, and there is no portable way to
ask. *)
if Sys.file_exists (Printf.sprintf "/proc/%d/exe" pid) then begin
let want =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" pid))
"program"
in
match Unix.readlink (Printf.sprintf "/proc/%d/exe" pid) with
| link when link = want -> ()
| link ->
fail "flan dev is still two processes: %s is running %s, not %s"
(string_of_int pid) link want
| exception Unix.Unix_error _ -> ()
end;
(* And that the compiler is not talking to the program over a socket any
more. In one process a delivery is a call into the agent's own verb
table, so the *path* it used to connect on is now needed by nothing —
removing it is therefore the decisive test, and the only one available
from out here: a reply cannot say which way it came.
Unlinking a bound unix socket does not disturb the listener; it makes
new connects fail with ENOENT. So if every evaluation below still
installs, nothing connected. The agent's own socket stays bound for
[--two-process] and for a person at a raw socket, which is why it is
still created at all.
The path is the same one [start_merged] computes, and the /proc check
above has already established that this pid is the program. *)
let agent_sock =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" pid))
"agent.sock"
in
(* A completed reply is what makes the check above deterministic, so
[describe] is asked here rather than below. Connecting proves nothing:
the listener is bound by [merged_setup], and the program's main thread
— which is what calls [agent/start] — only runs after that returns, so
a connect lands in the backlog. [merged_serve] waits for the agent
socket before it accepts at all, so a reply having arrived means it has
already seen the path bound. Asking after the unlink instead would be
the same race from the other side: unlinking before [merged_serve]
looks makes it wait out its full timeout and warn. *)
let r = request c "(:op \"describe\")" in
if status r <> "ok" then fail "describe: %s" (status r);
if not (Sys.file_exists agent_sock) then
fail "the merged program never bound %s" agent_sock
else (try Unix.unlink agent_sock with Unix.Unix_error _ -> ());
(* The daemon owns the program's lifetime and kills it on [close], so
every step waits for the program to have got there. "ok" from an eval
means the module was queued, not that it has been installed. Output
only rides along with a reply, so asking is how it is collected, and
[describe] is the cheapest question there is. *)
let lines () =
List.length (String.split_on_char '\n' (Buffer.contents output)) - 1
in
let settle n =
await (fun () ->
ignore (request c "(:op \"describe\")");
lines () >= n)
in
(* [defs] is its own op rather than more fields on [describe], because
[describe] is what an editor polls to drain the program's output. It
carries what eldoc, completion and find-definition each need: a kind,
a signature, and where the name is written where that is knowable.
An empty location is the honest answer for a global — Tast.global has
no Loc — and an editor is expected to refuse rather than guess. *)
let r = request c "(:op \"defs\")" in
if status r <> "ok" then fail "defs: %s" (status r);
(match Wire.field r "defs" with
| Some { Form.v = Form.List entries; _ } ->
let find name =
List.find_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ }
:: { Form.v = Form.Str kind; _ }
:: { Form.v = Form.Str sign; _ }
:: { Form.v = Form.Str loc; _ } :: [])
when String.equal n name -> Some (kind, sign, loc)
| _ -> None)
entries
in
(match find "step" with
| Some ("fn", "step [] i64", loc) when String.length loc > 0 ->
(* Absolute, because an editor is not in this process's working
directory and cannot resolve a relative one. *)
if loc.[0] <> '/' then fail "a fn's location is relative: %s" loc
| Some (k, s, l) -> fail "step is described as (%s, %s, %s)" k s l
| None -> fail "defs did not mention step");
(match find "ticks" with
| Some ("var", "ticks i64", "") -> ()
| Some (k, s, l) -> fail "ticks is described as (%s, %s, %s)" k s l
| None -> fail "defs did not mention ticks");
(match find "agent/wait-raw" with
| Some ("extern", _, _) -> ()
| Some (k, _, _) -> fail "an extern is described as %s" k
| None -> fail "defs did not mention an imported extern")
| _ -> fail "defs did not answer with a list");
(* [layout]: a struct's fields and their types, out of [Tast.structs],
with no running program involved at all. *)
let strings_of f =
match f with
| Some { Form.v = Form.List xs; _ } ->
List.filter_map
(fun (x : Form.t) ->
match x.Form.v with Form.Str s -> Some s | _ -> None)
xs
| _ -> []
in
let fields r =
match Wire.field r "fields" with
| Some { Form.v = Form.List fs; _ } ->
List.filter_map
(fun (f : Form.t) ->
match f.Form.v with
| Form.List
[ { Form.v = Form.Str n; _ }; { Form.v = Form.Str t; _ } ] ->
Some (n ^ " " ^ t)
| _ -> None)
fs
| _ -> []
in
let r = request c "(:op \"layout\" :type \"Missing\")" in
if status r <> "ok" then
fail "layout Missing: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
if Wire.string_field r "type" <> Some "Missing" then
fail "layout answered a different type than it was asked for";
if fields r <> [ "id i32" ] then
fail "Missing's fields: %s" (String.concat ", " (fields r))
end;
(* The prelude's structs are in [Tast.structs] because [Check.program]
prepends the prelude, and they are answered for the same reason the
REPL's renderer resolves against the same list: an editor that could
see a type printed and not ask about it would be the two disagreeing.
[Rune] also pins the spelling — the types read exactly as [defs]
spells a signature, because both go through [Types.to_string]. *)
let r = request c "(:op \"layout\" :type \"Split\")" in
if fields r <> [ "rest [u8]"; "sep u8"; "more bool" ] then
fail "Split's fields: %s" (String.concat ", " (fields r));
let r = request c "(:op \"layout\" :type \"Nonesuch\")" in
if status r <> "error" then fail "a type that does not exist got a layout";
(* A name that plainly exists and is not a struct is refused by *kind*.
Both of these are types the checker knows and this op cannot
describe, and "no struct is named X" would read as "X does not
exist". *)
let refusal r =
Option.value ~default:(status r) (Wire.string_field r "message")
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
let r =
request c
"(:op \"eval\" :code \"(defenum Colour [red 0 green 1])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "a new enum: %s" (refusal r)
else begin
let r = request c "(:op \"layout\" :type \"Colour\")" in
if status r <> "error" then fail "an enum answered a struct layout"
else if not (contains (refusal r) "is an enum") then
fail "an enum is refused as: %s" (refusal r)
end;
let r =
request c
"(:op \"eval\" :code \"(defunion Shape [(Circle [r f32])])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "a new union: %s" (refusal r)
else begin
let r = request c "(:op \"layout\" :type \"Shape\")" in
if status r <> "error" then fail "a union answered a struct layout"
else if not (contains (refusal r) "is a union") then
fail "a union is refused as: %s" (refusal r)
end;
(* The identity rule, and the case NEXT.md named: a second [Blob] typed
into a package is [agent/Blob], the qualified name resolves, and the
bare one is refused with the names it could have meant rather than
resolved to either. The daemon derives the package from the path, so
the file this is sent with is the one the import qualified. *)
let agent_file =
let p = "../vendor/agent/agent.flan" in
try Unix.realpath p with Unix.Unix_error _ -> p
in
let r =
request c
(Printf.sprintf
"(:op \"eval\" :code \"(defstruct Blob [id i32])\" :file %s)"
(Wire.quote agent_file))
in
if status r <> "ok" then
fail "a struct typed into a package: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let r = request c "(:op \"layout\" :type \"agent/Blob\")" in
if status r <> "ok" || fields r <> [ "id i32" ] then
fail "a qualified name did not resolve: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r = request c "(:op \"layout\" :type \"Blob\")" in
if status r <> "error" then
fail "a bare package-qualified name was resolved rather than refused"
else if strings_of (Wire.field r "candidates") <> [ "agent/Blob" ] then
fail "the refusal did not name what it could have meant: %s"
(String.concat ", " (strings_of (Wire.field r "candidates")))
end;
(* A form that does not check comes back as an error with a location,
and must not disturb the session. *)
let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in
if status r <> "error" then fail "a bad form was accepted";
(match Wire.string_field r "loc" with
| Some l when String.length l > 0 -> ()
| _ -> fail "an error carried no location");
(* A name the program was never built with, then a second evaluation
that uses it. The second one only checks at all because the session
kept the first. *)
let r =
request c
"(:op \"eval\" :code \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "adding a var: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* Wait for the program to have installed it before sending the next.
Both queued at once is a legitimate thing for the agent to do — one
poll installs everything pending — but then only the last is observed
and the sequencing is not what was tested. *)
if not (settle 2) then fail "the first reload was never installed";
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "reusing a var added earlier: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* A change the running process cannot be told, refused with the reason
rather than delivered. *)
let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in
if status r <> "error"
|| not
(match Wire.string_field r "message" with
| Some m -> String.length m > 0
| None -> false)
then fail "retyping a global was not refused";
if not (settle 3) then fail "the second reload was never installed";
(* A restart-case in a body the process was never built with. The frame
it offers is an alloca in the newly loaded module's text, the call it
guards goes through the host's cell, and the transfer starts in a
handler and crosses [probe], which the host was compiled with. None of
those three meet anywhere else in the tests. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "a redefinition with a restart-case: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (settle 4) then fail "the third reload was never installed";
(* Expression evaluation, which is a different primitive: no name to
install a body into, so a thunk runs at a frame boundary and the value
comes back rendered. The program has stopped reaching frame boundaries
by now, so this only checks that the types that have no printer say so
rather than guessing — the live path is test_repl. *)
let r = request c "(:op \"eval-expr\" :code \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in
if status r <> "error" then fail "a declaration was accepted as an expression";
ignore (request c "(:op \"close\")");
Unix.close c;
(* Closing the connection ends the program, and its transcript is the
proof: 1 before any reload, 5 from a body over a var that did not
exist when it started, 105 from a second body reading the same one,
and 777 from a restart clause in a third — reached by a transfer that
started in a handler and crossed a function the host was built with. *)
ignore (Unix.waitpid [] pid);
let text = Buffer.contents output in
let wanted = "1\n5\n105\n777\n" in
if text <> wanted then
fail "program transcript\n got: %S\n wanted: %S" text wanted
end;
(* ── The break loop, from the editor's side ────────────────────── *)
(* A second daemon, over a program that stops on its first frame. The
claims are that an editor can find out it stopped without having been
told, that everything an editor does still works while it is stopped —
C-x C-e most of all, since the break loop *is* the poll loop — and that
a choice comes back refused or accepted, never "probably".
Its own daemon, its own program and its own output buffer: the block
above ends by checking a transcript, and sharing either with this would
make that check about two programs at once. *)
let bsock = tmp "break.sock" and bout = tmp "break.out" in
(try Sys.remove bsock with Sys_error _ -> ());
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let bpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-break.flan"; "-s"; bsock |]
Unix.stdin bfd Unix.stderr
in
Unix.close bfd;
if not (listening bsock) then begin
fail "the break daemon never listened";
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let boutput = Buffer.create 256 in
let c = connect bsock in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string boutput t
| None -> ());
r
in
(* [:stopped] is on every reply, whatever was asked. An editor that had
to ask would find out only when it happened to wonder, and a program
stops at moments nobody is wondering about. *)
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let condition r =
match Wire.string_field r "condition" with Some c -> c | None -> ""
in
let last = ref (ask "(:op \"describe\")") in
if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last))
then fail "a stopped program never said so on a reply it was already sending"
else begin
if condition !last <> "Missing" then
fail "the condition is reported as %S, wanted %S" (condition !last)
"Missing";
(* The identity claim, round-tripped: the string [break] reports is the
qualified struct name [Emit] put into [flan_error] and the agent
held in [condition_name], so handing it straight back as [:type]
has to resolve. This is the conditions buffer's whole path — it has
the condition's name and nothing else, and asks for the fields with
it. A layout that only answered a name typed by hand would leave
that path guessing. *)
let r =
ask
(Printf.sprintf "(:op \"layout\" :type %s)"
(Wire.quote (condition !last)))
in
if status r <> "ok" then
fail "the condition's own name did not resolve to a layout: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else
(match Wire.field r "fields" with
| Some { Form.v = Form.List [ { Form.v = Form.List
[ { Form.v = Form.Str "id"; _ }; { Form.v = Form.Str "i32"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "the stopped program's condition has the wrong layout");
(* What is on offer, innermost first. [break] carries the names and
nothing else — the state is the annotation's business, so there is
one place in the daemon that decides it. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break: %s" (status r);
(match Wire.field r "restarts" with
| Some { Form.v = Form.List names; _ } ->
let names =
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str s -> Some s | _ -> None)
names
in
if names <> [ "retry"; "use-placeholder" ] then
fail "restarts on offer: %s" (String.concat ", " names)
| _ -> fail "break did not list the restarts");
(* Where it is, which is the other half of what a stopped program can
be asked. The shadow stack is dev-only and the daemon owns the
build, so a frame per Flan call is there to be walked; the names
come off the frames themselves rather than out of any DWARF, which
is what makes this work in the break loop rather than in lldb.
Innermost first, [main] last, and both marked as the program's:
nothing is being evaluated here, so nothing is the evaluation's. *)
let frames r =
match Wire.field r "frames" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ }
:: { Form.v = Form.Str loc; _ }
:: { Form.v = Form.Str origin; _ } :: _) ->
Some (n, loc, origin)
| _ -> None)
l
| _ -> []
in
let r = ask "(:op \"backtrace\")" in
if status r <> "ok" then
fail "backtrace: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
match frames r with
| [ ("fetch", floc, "program"); ("main", _, "program") ] ->
(* Absolute and pointing into the program's own source, for the
same reason [defs] is: an editor is not in this process's
working directory. It comes off the frame, not off this end's
session, so a redefined body reports where the *installed* one
is written. *)
if String.length floc = 0 || floc.[0] <> '/' then
fail "a frame's location is not absolute: %s" floc
| fs ->
fail "backtrace of a stopped program: %s"
(String.concat ", "
(List.map (fun (n, _, o) -> n ^ "/" ^ o) fs))
end;
(* The payoff. The break loop is the poll loop, so an expression
evaluated here is a module the listener queues and the *stopped*
thread runs — which is the only reason C-x C-e works at the one
moment anybody wants it to. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "23" then
fail "C-x C-e while stopped: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And installing, which the break loop deliberately allows: there is
no frame in progress, so the rule about swapping a body that is on
the stack does not apply. This is the fix-it-and-retry loop. *)
let r =
ask
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 100)) ticks)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing while stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* -- A break inside a thunk, and the frames it cannot reach ---- *)
(* Evaluating here runs a thunk through [flan_reload_call], which holds
its own transfer channel and drops it on return. So a restart below
that C frame — the two this program was already stopped on — has
nowhere for a transfer to land: it would unwind to the thunk, stop,
and the program would carry on as though nothing had been chosen.
It used to be accepted and announced and silently not taken, which
is the worst of the three things that could happen.
Now the list says so and the choice is refused with the reason. *)
let r =
ask "(:op \"eval-expr\" :code \"(i64 (fetch 9))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped inside a break answered anyway";
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break inside a thunk: %s" (status r);
(* Four now: the thunk's own [fetch] frame over the one below it. *)
let names =
match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str x -> Some x | _ -> None)
l
| _ -> []
in
if names <> [ "retry"; "use-placeholder"; "retry"; "use-placeholder" ]
then fail "restarts at a break inside a thunk: %s"
(String.concat ", " names);
let unreachable =
match Wire.field r "unreachable" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with
| Form.Int i -> Some (Int64.to_int i)
| _ -> None)
l
| _ -> []
in
if unreachable <> [ 2; 3 ] then
fail "positions below the thunk: %s"
(String.concat ", " (List.map string_of_int unreachable));
(* And the backtrace says the same thing the restart list does, in its
own words: the two frames on top belong to the evaluation, the two
below them to the program. A backtrace that did not draw that line
would answer "where is my program" with [eval/1], which is true and
not the question. *)
(match frames (ask "(:op \"backtrace\")") with
| [ ("fetch", _, "eval"); (thunk, _, "eval"); ("fetch", _, "program");
("main", _, "program") ]
when String.length thunk > 5 && String.sub thunk 0 5 = "eval/" -> ()
| fs ->
fail "backtrace at a break inside a thunk: %s"
(String.concat ", "
(List.map (fun (n, _, o) -> n ^ "/" ^ o) fs)));
(* Refused, and refused *here* — not accepted and dropped. *)
let r = ask "(:op \"restart-at\" :index 2 :name \"retry\")" in
if status r <> "error" then
fail "a restart below the thunk boundary was accepted";
(* The ones above it still work, so this refuses a case rather than
disabling the feature. *)
let r = ask "(:op \"restart-at\" :index 0 :name \"retry\")" in
if status r <> "ok" then
fail "a restart inside the thunk was refused: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* And the program is back on the *outer* break, which is the one it
was on before any of this — the inner resume must not have been
read as the outer one resuming. *)
if not
(await (fun () ->
let r = ask "(:op \"break\")" in
status r = "ok"
&& (match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } -> List.length l = 2
| _ -> false)))
then fail "the outer break did not come back after the inner one";
(* A name nothing offers is refused against the live stack, on the
program's listener thread, before the reply. *)
let r = ask "(:op \"restart\" :name \"nonesuch\")" in
if status r <> "error" then fail "a restart nobody offers was accepted";
let r = ask "(:op \"restart\" :name \"retry\")" in
if status r <> "ok" then
fail "choosing a restart: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* [retry] returns 7 and [use-placeholder] returns -1, so the number in
the transcript is the proof that this choice and not the other one
was taken. *)
let printed () =
ignore (ask "(:op \"describe\")");
List.exists (String.equal "7")
(String.split_on_char '\n' (Buffer.contents boutput))
in
if not (await printed) then fail "the chosen restart never resumed";
(* Running again, and now every break verb is refused by name. There is
no restart stack to walk from a running program, and answering an
empty list would read as "no restarts are active". *)
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program still reads as stopped after resuming"
else begin
let r = ask "(:op \"restart\" :name \"retry\")" in
if status r <> "error" then
fail "a restart was accepted by a running program";
let r = ask "(:op \"abort\")" in
if status r <> "error" then
fail "an abort was accepted by a running program";
(* Refused for the same reason, and it is not a missing feature: the
frame chain is the game thread's and it is pushed and popped on
every call, so a walk from this end would have the shape of a
backtrace and the contents of a race. *)
let r = ask "(:op \"backtrace\")" in
if status r <> "error" then
fail "a running program answered with a backtrace";
(* ...and an ordinary evaluation works again on the far side of it. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "2" then
fail "an expression after the break: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* An expression that stops *itself*. The thunk runs on the game
thread from inside a poll, and the break loop it lands in polls
again from inside that very call — so the agent's poll has to be
re-entrant. One that cached its indices and wrote them back at the
end would rewind over everything the nested poll consumed and run
this same thunk again, which is not a stumble but an unbounded
recursion of breaks.
The evaluation cannot answer from in there and says so, with the
reason, rather than waiting forever or claiming a value. *)
let r =
ask
"(:op \"eval-expr\" :code \"(i64 (fetch 2))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped the program answered anyway";
if not (stopped r) then
fail "an expression that stopped the program did not report it";
let r = ask "(:op \"restart\" :name \"use-placeholder\")" in
if status r <> "ok" then
fail "resuming an expression that stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the stopped expression never resumed"
else
let r =
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
in
(* Still there, and evaluating once per evaluation: a thunk run
twice by a rewound queue would have broken a second time. *)
if Wire.string_field r "value" <> Some "4" then
fail "an expression after a break inside a thunk: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
end
end;
(* ...and the other way out. Every check above is of an abort being
*refused*; the accepted path is the one that must not be left as code
that has never run, because it is the one that ends a program. Break
it once more — the daemon's own program calls [step] every time round
its loop, so a body that errors stops it — and take the exit. *)
(match
ask
"(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (error (Missing {.id 9})) 0) (use-placeholder [] -1)))\" :file \"/tmp/buf.flan\")"
with
| r when status r <> "ok" ->
fail "installing a body that errors: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
| _ ->
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the program never stopped on the body that errors"
else begin
(* The claim this test exists for, and the one thing about a shadow
stack that is easy to get wrong: **the pop happens on the
transfer path too**. Five breaks have been taken and resumed by
now, every one of them by a condition transfer that unwound past
the frame that erred. A pop written only on the normal return
path would have left one dead frame behind each time, and this
backtrace would be [step, main] with a pile of stale [fetch]es
under it. It is two frames or the feature is a liar. *)
(match
List.map (fun (n, _, o) -> (n, o))
(match Wire.field (ask "(:op \"backtrace\")") "frames" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ }
:: { Form.v = Form.Str loc; _ }
:: { Form.v = Form.Str o; _ } :: _) ->
Some (n, loc, o)
| _ -> None)
l
| _ -> [])
with
| [ ("step", "program"); ("main", "program") ] -> ()
| fs ->
fail "frames left on the shadow stack by five handled errors: %s"
(String.concat ", " (List.map (fun (n, o) -> n ^ "/" ^ o) fs)));
let r = ask "(:op \"abort\")" in
if status r <> "ok" then
fail "abort was refused by a stopped program: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
end);
Unix.close c;
(* No [close] op: an abort ends the program, and the daemon owns the
program's lifetime, so it comes down on its own. A daemon still
running here would be one waiting on a socket nobody will use. *)
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] bpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
fail "the daemon outlived the program it aborted";
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ())
end
end;
(* ── A break over a bad index ──────────────────────────────────── *)
(* The block above stops on an [error] the program wrote. This one stops on
one nobody wrote: an out-of-bounds index, which until now printed its
location and called exit(134) — taking the compiler and the session with
it, since [flan dev] is one process.
Three claims, and the third is the point. The condition arrives named
[BoundsError] and its name resolves to a layout, so the conditions
buffer can show the numbers without anything special-casing it. The
restart on offer is the *program's* own [continue] — nothing is
established at the failing index, deliberately, because nothing a
handler could do would make index 9 valid for a length-4 array. And
taking it resumes: the transcript says 1, which is what [continue]'s
clause set, and the program goes on polling on the far side.
Its own daemon and its own program, for the reason every block here has
one: these claims are about one frame of one program. *)
let xsock = tmp "break-bounds.sock" and xout = tmp "break-bounds.out" in
(try Sys.remove xsock with Sys_error _ -> ());
let xfd =
Unix.openfile xout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let xpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-break-bounds.flan"; "-s"; xsock |]
Unix.stdin xfd Unix.stderr
in
Unix.close xfd;
if not (listening xsock) then begin
fail "the bad-index daemon never listened";
(try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let xoutput = Buffer.create 256 in
let c = connect xsock in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string xoutput t
| None -> ());
r
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let last = ref (ask "(:op \"describe\")") in
if not
(await (fun () -> last := ask "(:op \"describe\")"; stopped !last))
then fail "a bad index never stopped the program"
else begin
let cname =
match Wire.string_field !last "condition" with Some c -> c | None -> ""
in
if cname <> "BoundsError" then
fail "a bad index is reported as %S, wanted %S" cname "BoundsError";
(* The same round trip the block above makes: the name the break
reports is handed straight back as [:type], because that is the
conditions buffer's whole path. Three i64s — low, high and length —
with low and high the same index for an [at] and the two ends of a
range for a [slice], which is why there is one condition type and
not two. *)
let r =
ask (Printf.sprintf "(:op \"layout\" :type %s)" (Wire.quote cname))
in
if status r <> "ok" then
fail "BoundsError did not resolve to a layout: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else
(match Wire.field r "fields" with
| Some { Form.v = Form.List fs; _ } ->
let names =
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List ({ Form.v = Form.Str n; _ } :: _) -> Some n
| _ -> None)
fs
in
if names <> [ "low"; "high"; "length" ] then
fail "BoundsError's fields: %s" (String.concat ", " names)
| _ -> fail "BoundsError's layout has no fields");
(* Only the program's own restart is on offer. Nothing is pushed at the
failing index, so a list with anything else on it would mean a site
restart had been established after all. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break over a bad index: %s" (status r);
(match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
let names =
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str x -> Some x | _ -> None)
l
in
if names <> [ "continue" ] then
fail "restarts at a bad index: %s" (String.concat ", " names)
| _ -> fail "break over a bad index listed no restarts");
(* And the payoff: taking it resumes, which is the difference between a
stop you can recover from and a dead session. *)
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continuing past a bad index: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
let printed () =
ignore (ask "(:op \"describe\")");
List.exists (String.equal "1")
(String.split_on_char '\n' (Buffer.contents xoutput))
in
if not (await printed) then
fail "the program never resumed past a bad index";
(* Ordinary work on the far side of it, which is the whole claim: the
session outlived the index. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "4" then
fail "an expression after a bad index: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
end;
ignore (ask "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] xpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] xpid) with Unix.Unix_error _ -> ())
end
end;
(* ── The locals of a stopped frame ─────────────────────────────── *)
(* A third daemon, over a program that stops with something worth looking
at. This is the half of the shadow stack the backtrace was built for:
the frame chain gives the addresses, [Tast.fn] gives the types and the
names, and a thunk compiled here renders those types at those addresses
inside the stopped program. Nothing is copied out — a Flan value has no
header, so bytes read from another process would be bytes with no
meaning.
Its own daemon and its own program, for the same reason the break block
has: the claims are about one frame of one program. *)
let lsock = tmp "locals.sock" and lout = tmp "locals.out" in
(try Sys.remove lsock with Sys_error _ -> ());
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let lpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-locals.flan"; "-s"; lsock |]
Unix.stdin lfd Unix.stderr
in
Unix.close lfd;
if not (listening lsock) then begin
fail "the locals daemon never listened";
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect lsock 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
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the locals program never stopped"
else begin
let pairs r key =
match Wire.field r key with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List ({ Form.v = Form.Str a; _ }
:: { Form.v = Form.Str b; _ } :: rest) ->
Some (a, b,
match rest with
| { Form.v = Form.Str c; _ } :: _ -> c
| _ -> "")
| _ -> None)
l
| _ -> []
in
let r = ask "(:op \"locals\" :frame 0)" in
if status r <> "ok" then
fail "locals: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
(* One of each shape the structural printer has an arm for, rendered
in the program and read back as text. The values are the ones
[look] was called with, which is the claim: this is the frame's
own storage and not a guess from the source. *)
let got =
List.map (fun (n, ty, v) -> (n, ty, v)) (pairs r "locals")
in
let want =
[ ("n", "i64", "3");
("label", "string", "\"hello\"");
(* The *renderer's* output, not source — and it is a dot now.
[render.ml] and [emacs/flan-inspect.el] are the two ends of
one wire format, and they moved together, which is what the
note here used to say was still owed. *)
("p", "Point", "(Point {.x 1.5 .y 2.5})");
("xs", "[3 i32]", "[ 10 20 30]");
("flag", "bool", "true") ]
in
if got <> want then
fail "locals of the stopped frame: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
(* And the one that must not be rendered. [after] is bound inside
the restart-case *past* the error, so its slot is storage nothing
has written: the frame records a null for it, and a thunk that
printed it would dereference that null on the game thread of a
program that is already stopped. Refused by name, with the
reason, rather than left off the list — a local that is missing
and a local that could not be read are different facts. *)
match List.filter (fun (n, _, _) -> n = "after") (pairs r "refused") with
| [ (_, why, _) ] when why <> "" -> ()
| _ ->
fail "a slot bound after the error was not refused by name: %s"
(String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
end;
(* A frame whose every slot the compiler invented is not an error and
is not an empty answer either: it says which it is. *)
let r = ask "(:op \"locals\" :frame 1)" in
if status r <> "ok" then fail "locals of main: %s" (status r);
(* Out of range is refused with the depth, so a client can tell a bad
index from a frame with nothing in it. *)
let r = ask "(:op \"locals\" :frame 9)" in
if status r <> "error" then fail "a frame index past the end answered";
(* The inverse, first, because it is the cheap half of the same
claim: a redefinition that really does change the slots must be
refused too, and that one a count comparison can see. This body
drops [flag] and keeps the signature, so the frame on the stack has
one slot more than the body this session now holds. *)
let r =
ask
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [p (Point {.x 1.5 .y 2.5}) xs [10 20 30]] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing a body with fewer slots while stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let r = ask "(:op \"locals\" :frame 0)" in
if status r <> "error" then
fail "the frame of a body whose slots changed answered anyway"
end;
(* And the case that makes this a fingerprint rather than a slot
count. Installing while stopped is deliberately allowed — it is the
fix-it-and-retry loop — so the body on the stack and the body the
session holds can be two different bodies of one function. This one
renames every local and keeps the count and the types, which a
count comparison cannot see: without the hash, [q] would be shown
holding [p]'s value and nothing would say so. *)
let r =
ask
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0)] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :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 \"locals\" :frame 0)" in
if status r <> "error" then
fail "the frame of a superseded body answered with the new body's names";
(* And the other half of that claim, which is the one a fingerprint
that never matched would fail: redefining [look] says nothing
about [main], and its frame must still answer. A refusal that
fires for every frame would pass the test above and make the
whole verb useless. *)
let r = ask "(:op \"locals\" :frame 1)" in
if status r <> "ok" then
fail "redefining one function refused an untouched frame: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
end
end;
(* Running again, and then the locals verb is refused: a frame that is
still executing does not hold still long enough to be read. *)
let r = ask "(:op \"restart\" :name \"carry-on\")" in
if status r <> "ok" then
fail "resuming the locals program: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the locals program never resumed"
else begin
let r = ask "(:op \"locals\" :frame 0)" in
if status r <> "error" then
fail "a running program answered with its locals"
end;
ignore (ask "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] lpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
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 (listening 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 other half of what a break loop can show. Locals are one frame's;
these are the program's, and the question is which of them to show:
all of a program's globals would bury the one that matters under the
prelude's PRNG state, and per-frame nesting would imply an ownership a
global does not have and repeat the name once per frame that reads it.
So: one section, the union of what every frame on the stack references,
each entry saying which frames touch it, ordered by the innermost one
that does. [dev-globals.flan] is built so that all three of those
claims fail visibly if any of them is dropped. *)
let gsock = tmp "globals.sock" and gout = tmp "globals.out" in
(try Sys.remove gsock with Sys_error _ -> ());
let gfd = Unix.openfile gout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let gpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-globals.flan"; "-s"; gsock |]
Unix.stdin gfd Unix.stderr
in
Unix.close gfd;
if not (listening gsock) then begin
fail "the globals daemon never listened";
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect gsock 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
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the globals program never stopped"
else begin
(* (name type value (frame ...)) — four fields, the fourth a list of
numbers, which is what makes the annotation readable against the
stack section's own numbering. *)
let rows r =
match Wire.field r "globals" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List [ { Form.v = Form.Str n; _ };
{ Form.v = Form.Str ty; _ };
{ Form.v = Form.Str v; _ };
{ Form.v = Form.List fs; _ } ] ->
Some
(n, ty, v,
List.filter_map
(fun (f : Form.t) ->
match f.Form.v with
| Form.Int i -> Some (Int64.to_int i)
| _ -> None)
fs)
| _ -> None)
l
| _ -> []
in
let r = ask "(:op \"globals\")" in
if status r <> "ok" then
fail "globals: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
let want =
(* [grid] before [pressure] because that is the order they are
declared in and both are touched by frame 0; [label] last
because the innermost frame that touches it is 1, even though
it is declared before either. Ordering by proximity to the
error is what puts the likely culprit on top of a deep stack,
and declaring [label] first is how this notices that the sort
happened at all.
[grid]'s two writes are the two frames: [main] set element 1
before calling, [inner] set element 0 after. The value is read
out of the program's own storage, so both are in it. *)
[ ("grid", "[4 i32]", "[ 7 5 0 0]", [ 0; 1 ]);
("pressure", "i64", "12", [ 0 ]);
("label", "string", "\"running\"", [ 1 ]) ]
in
let got = rows r in
if got <> want then
fail "the globals of the stopped stack: %s"
(String.concat ", "
(List.map
(fun (n, ty, v, fs) ->
Printf.sprintf "%s %s = %s (%s)" n ty v
(String.concat " " (List.map string_of_int fs)))
got));
(* And the one that must not be there. [untouched] is a global of
this program that no frame on this stack reads, and a section
that listed it would be the "all the globals" answer this op
exists instead of. The prelude's own globals are the same claim
at scale: [rand-state] is in the session too. *)
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
fail "a global no frame on the stack references was listed anyway";
if List.exists (fun (n, _, _, _) -> n = "rand-state") got then
fail "the prelude's globals were listed; the section is not scoped \
to the stack"
end;
(* A frame whose body has been redefined since it was entered cannot
be attributed: what this session holds is a different body's
reference set. It is named in [:skipped] rather than dropped,
because "the union is incomplete and here is why" and "these are
all of them" are different answers.
The redefinition binds a local, deliberately, because that is what
the detector can see. [Emit.slot_fingerprint] hashes a body's
*slots*, so a new body with the same slots and different global
references is not caught — the hole is stated in BUILT.md, and a
test that asserted otherwise would be asserting a mechanism that is
not there. *)
let r =
ask
"(:op \"eval\" :code \"(defn inner [] i64 (let [z (i64 1)] (set untouched z)) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing a new body while stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let r = ask "(:op \"globals\")" in
if status r <> "ok" then
fail "globals after a redefinition: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let skipped =
match Wire.field r "skipped" with
| Some { Form.v = Form.List l; _ } -> List.length l
| _ -> 0
in
if skipped = 0 then
fail "the frame of a superseded body was attributed anyway";
(* [main] is untouched by that redefinition and must still
contribute: a refusal that fired for every frame would pass the
check above and make the whole verb useless. *)
let got = rows r in
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
fail "redefining one function dropped an untouched frame's globals";
(* And the new body's references must not have leaked in under the
old frame. [untouched] is what the installed body reads and the
frame on the stack does not. *)
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
fail "a superseded frame contributed the *new* body's references"
end;
(* And the case the slot fingerprint cannot see, which is the one this
section needs its own fingerprint for. This body binds exactly the
locals the frame on the stack binds — none, and the same
temporaries, because every expression in it has the same shape —
and names [untouched] where the frame's body names [pressure]. The
slot check passes; only [Reach.ref_fingerprint] can tell that what
this session now holds refers to different program state.
Refused by name and for that reason, like everything else in the
break loop. What would happen without it is not an error message:
it is [untouched] appearing in the union marked as touched by frame
0, and [pressure] missing from it, both of which read as facts
about the stopped program and are not. *)
let r =
ask
"(:op \"eval\" :code \"(defn inner [] i64 (set untouched 12) (set (at grid 0) 7) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing a body with the same slots and other globals: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let r = ask "(:op \"globals\")" in
if status r <> "ok" then
fail "globals after a reference-set change: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let whys =
match Wire.field r "skipped" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List [ _; { Form.v = Form.Str w; _ } ] -> Some w
| _ -> None)
l
| _ -> []
in
let mentions 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
(List.exists
(fun w -> mentions w "names different globals")
whys)
then
fail
"a frame whose body now names different globals was attributed \
anyway (skipped: %s)"
(String.concat " | " whys);
let got = rows r in
(* The new body's globals must not have leaked in under the old
frame, and the frame that did not change must still contribute:
a refusal that swallowed the whole stack would satisfy the check
above and say nothing. *)
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
fail "the new body's globals were attributed to the old frame";
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
fail "refusing one frame dropped an untouched frame's globals"
end
end;
(* Nothing handled the condition, so there is no restart to resume by
and [abort] is the only way out. The daemon owns the program's
lifetime, so it comes down on its own. *)
ignore (ask "(:op \"abort\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] gpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
end
end;
(* ── Disassembly ───────────────────────────────────────────────── *)
(* A third daemon, over a program that keeps running, because the two
claims here are about *which* module owns a name and what the answer is
allowed to say it means — and both change the moment a body is
delivered. Its own session rather than a reuse of the first: the first
one's program has been reloaded four times and abandoned by the time it
gets here, and a generation counter tested against a session someone
else drove says nothing. *)
let dsock = tmp "disasm.sock" and dout = tmp "disasm.out" in
(try Sys.remove dsock with Sys_error _ -> ());
let dfd = Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let dpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; dsock |]
Unix.stdin dfd Unix.stderr
in
Unix.close dfd;
if not (listening dsock) then begin
fail "the disassembly daemon never listened";
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let generation r =
match Wire.field r "generation" with
| Some { Form.v = Form.Int n; _ } -> Some (Int64.to_int n)
| _ -> None
in
let text r = Option.value ~default:"" (Wire.string_field r "text") in
let basis r = Option.value ~default:"" (Wire.string_field r "basis") in
let has hay needle =
let n = String.length needle and h = String.length hay in
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
n > 0 && go 0
in
let have_objdump =
Sys.command "command -v objdump > /dev/null 2>&1" = 0
in
(* Nothing has been delivered, so the cell still holds the body the
process was launched with. This is the one case where "what is
installed now" is knowable, and the reply has to say so rather than
hedging like the others. *)
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
if status r <> "ok" then
fail "the IR of a name the program was built with: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
if generation r <> Some 0 then
fail "an untouched name is not generation 0";
if not (has (text r) "define") || not (has (text r) "flan.step") then
fail "the IR of step is not a define of it: %S" (text r);
(* One function, not the module: dev-repl.flan defines [main] too, and
a slice that ran past its own closing brace would carry it. *)
if has (text r) "flan.main" then
fail "the IR of step carried another function with it";
if not (has (basis r) "host executable") then
fail "an untouched name does not say it is the host's: %S" (basis r)
end;
(* Delivering one moves the ownership, and with it everything the reply
derives from it: the generation, the object, the location the body was
typed at, and what the answer is now allowed to claim. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 7)) ticks)\" :file \"/tmp/disasm.flan\")"
in
if status r <> "ok" then
fail "installing a body to disassemble: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
if status r <> "ok" then
fail "the IR of a redefined name: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
if generation r <> Some 1 then
fail "a redefined name is not generation 1: %s"
(match generation r with Some n -> string_of_int n | None -> "none");
(* The body that was just sent, not the one the program was built
with — the two differ only in the constant. *)
if not (has (text r) "7") then
fail "the IR shown is not the body that was delivered: %S" (text r);
if Wire.string_field r "loc" <> Some "/tmp/disasm.flan:1:7" then
fail "the location is not where the new body was typed: %s"
(Option.value ~default:"" (Wire.string_field r "loc"));
match Wire.string_field r "object" with
| Some o when Filename.check_suffix o ".ll" -> ()
| o ->
fail "the IR did not come from a .ll: %s" (Option.value ~default:"" o)
end;
(* The honesty rule, and the whole reason this op is not allowed to say
"installed": the daemon delivered a module and the agent queued it,
which is not the same as the game thread having stored it into a
cell — and there is no verb that would let the daemon find out. *)
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
if has (basis r) "host executable" then
fail "a delivered body still claims to be the host's";
if not (has (basis r) "cannot read the cell back")
&& not (has (basis r) "not installed yet")
&& not (has (basis r) "cannot be said")
then fail "a delivered body claims more than delivery: %S" (basis r)
end;
if not have_objdump then
print_endline "dev: disassembly skipped (no objdump on PATH)"
else begin
let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in
if status r <> "ok" then
fail "the machine code of a redefined name: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
(* Offsets from the function's own start, SBCL's way: an address into
a .so is the one number on the line a reader cannot use. The first
instruction is therefore at 0000 whatever the object's layout. *)
if not (has (text r) " 0000 ") then
fail "the listing is not rebased to the function's start: %S" (text r);
if not (has (text r) "ret") then
fail "the listing has no instructions in it: %S" (text r);
(* Not faked. There are no line tables in this build, so the reply
says that rather than printing a listing with no source in it. *)
if not (has (Option.value ~default:"" (Wire.string_field r "note"))
"line tables")
then fail "the listing does not say why there is no source in it";
match Wire.string_field r "object" with
| Some o when Filename.check_suffix o ".so" -> ()
| o -> fail "the code did not come from a .so: %s"
(Option.value ~default:"" o)
end;
(* The other presentation borrow, and the one that needs a body with
somewhere to jump to: a branch inside the function reads as [L0]
rather than as an address into an object nobody will open. *)
let r =
request c
"(:op \"eval\" :code \"(defn wind [n i32] i32 (let [acc 0] (dotimes [i n] (set acc (+ acc i))) acc))\" :file \"/tmp/disasm.flan\")"
in
if status r <> "ok" then
fail "installing a body with a loop in it: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else
let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in
if status r <> "ok" then
fail "the machine code of a loop: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else if not (has (text r) "L0:") then
fail "a branch target is not labelled: %S" (text r)
else if has (text r) "<flan.wind+" then
fail "a branch still names the function it is inside: %S" (text r)
end;
(* Refused by name, each for its own reason: [ok] would have to mean
"probably" otherwise. *)
let refused what req wanted =
let r = request c req in
if status r <> "error" then fail "%s was not refused" what
else
match Wire.string_field r "message" with
| Some m when has m wanted -> ()
| m ->
fail "%s was refused for the wrong reason: %s" what
(Option.value ~default:"" m)
in
refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")"
"not a function";
refused "a name nothing defines"
"(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")"
"no function named";
refused "a form that is neither ir nor asm"
"(:op \"disassemble\" :name \"step\" :form \"pdf\")"
"\"ir\" or";
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
"needs :name";
(* A stopped program has not thereby failed to install. The commonest way
to stop is to install a body and have it error, so the one thing the
basis must not say here is "not installed yet" — it would be asserting
non-installation in exactly the case where the body is running. *)
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (error (Missing {.id 3})))\" :file \"/tmp/disasm.flan\")"
in
if status r <> "ok" then
fail "installing a body that errors: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else if
not (await (fun () -> stopped (request c "(:op \"describe\")")))
then fail "the program never stopped on the body that errors"
else begin
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
if status r <> "ok" then
fail "disassembling while the program is stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
if not (has (basis r) "stopped on Missing") then
fail "a stopped program is not mentioned in the basis: %S" (basis r);
if has (basis r) "not installed" then
fail "a stopped program is said not to have installed: %S" (basis r)
end
end;
ignore (request c "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] dpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ];
(* ── A location that survives an evaluation that did not land ───── *)
(* [Session.eval] replaces the checked program the moment a form checks,
which is before the build and before delivery. So there is a window in
which the session holds a body the running process has never seen, and a
disassembly that took its source location from the session would point
into the buffer of code that never landed — while showing the host's
code and saying, correctly, that nothing had been delivered. One reply
contradicting itself in two fields.
A daemon whose [llc] is [false] reproduces it exactly and cheaply: the
host is built by clang and runs, every redefinition checks and then
fails to build, and nothing is ever delivered. *)
let ssock = tmp "stale.sock" and sout = tmp "stale.out" in
(try Sys.remove ssock with Sys_error _ -> ());
let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let env =
Array.append (Unix.environment ()) [| "FLAN_LLC=false" |]
in
let spid =
Unix.create_process_env flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |]
env Unix.stdin sfd Unix.stderr
in
Unix.close sfd;
if not (listening ssock) then begin
fail "the daemon with no working llc never listened";
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect ssock in
let has hay needle =
let n = String.length needle and h = String.length hay in
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
n > 0 && go 0
in
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")"
in
if status r <> "error" then
fail "an evaluation that cannot be built was reported as installed";
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
if status r <> "ok" then
fail "disassembling after a build that failed: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
let loc = Option.value ~default:"" (Wire.string_field r "loc") in
if has loc "never-landed" then
fail "the location is a buffer whose code was never delivered: %s" loc;
if not (has loc "dev-repl.flan") then
fail "the location is not the source the process was built from: %s" loc
end;
ignore (request c "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] spid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ];
(* --debug, and the half the IR cannot show.
[test_session.ml] asserts that a debug session *emits* the metadata,
which is the unpassed-argument defect itself. It cannot see the other
half: [Build.shared] is what turns the flag into [-g] and [-O0] on the
module, and a daemon that dropped [Build.debug] from its opts would
still emit perfect IR and then compile it away — [llvm.dbg.declare]
describes an alloca and mem2reg deletes the alloca. So this goes to the
.so the daemon actually wrote and asks the object, not the text.
The line table is the needle because it is what a breakpoint in a .flan
buffer resolves against, and it names the file the form was typed in
rather than any file on disk. *)
if Sys.command "command -v llvm-dwarfdump > /dev/null 2>&1" = 0 then begin
let gsock = tmp "dbg.sock" and gout = tmp "dbg.out" in
(try Sys.remove gsock with Sys_error _ -> ());
let gfd =
Unix.openfile gout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let gpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; gsock; "--debug" |]
Unix.stdin gfd Unix.stderr
in
Unix.close gfd;
if not (listening gsock) then begin
fail "the --debug daemon never listened";
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect gsock in
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (let [n (i64 3)] (set ticks (+ ticks n)) ticks))\" :file \"/tmp/dbg.flan\")"
in
if status r <> "ok" then
fail "a --debug daemon refused an ordinary redefinition: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
(* The daemon builds into /tmp/flan-dev-<pid>, one module per eval,
and never reuses a name — dlopen caches by path. The first is
m1.so. *)
let so =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" gpid))
"m1.so"
in
if not (Sys.file_exists so) then
fail "the --debug daemon left no module at %s" so
else begin
let dump = tmp "dbg.dwarf" in
let code =
Sys.command
(Printf.sprintf "llvm-dwarfdump --debug-line %s > %s 2>&1"
(Filename.quote so) (Filename.quote dump))
in
let text =
if code <> 0 then ""
else In_channel.with_open_bin dump In_channel.input_all
in
(try Sys.remove dump with Sys_error _ -> ());
let has hay needle =
let n = String.length needle and h = String.length hay in
let rec go i =
i + n <= h && (String.sub hay i n = needle || go (i + 1))
in
n > 0 && go 0
in
if not (has text "dbg.flan") then
fail
"a --debug daemon's module carries no line table for the form's \
file, so a line breakpoint would stay pending across C-c C-c"
end
end;
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]
end;
(* ── The watch table ───────────────────────────────────────────── *)
(* The claim being tested is the one that makes the watch buffer possible
at all: values reach the editor *without anything being compiled*.
Every other listing here — locals, globals, inspect — is a thunk built
from the types, sent over and run at a frame boundary, which is fine at
the rate a person presses a key and ruinous at the rate a HUD refreshes.
This op compiles nothing. The program pushes into a table from inside
its own loop and the daemon reads memory.
Four things in order: nothing is written while nobody is watching; a
value appears once the table is armed; the *rendering* is per type, so
an f64 and a string do not come back looking like the i64 beside them;
and disarming stops it again. The first and the last are the ones that
make watching free when a watch buffer is closed, which is the whole
reason arming is a message rather than something inferred. *)
let wsock = tmp "watch.sock" and wout = tmp "watch.out" in
(try Sys.remove wsock with Sys_error _ -> ());
let wfd =
Unix.openfile wout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let wpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-watch.flan"; "-s"; wsock |]
Unix.stdin wfd Unix.stderr
in
Unix.close wfd;
if not (listening wsock) then
fail "the watch daemon never listened"
else begin
let wc = connect wsock in
let ask q = Wire.parse (Wire.send wc q; Wire.recv wc) in
let table () =
match Wire.field (ask "(:op \"watch\")") "watch" with
| Some { Form.v = Form.List rows; _ } ->
List.filter_map
(fun (r : Form.t) ->
match r.Form.v with
| Form.List [ { Form.v = Form.Str n; _ };
{ Form.v = Form.Str v; _ } ] -> Some (n, v)
| _ -> None)
rows
| _ -> []
in
(* Nothing yet, and this is not "the program has not got there" — the
loop has been running since before the socket existed. The table is
empty because a watch call with nobody watching writes nothing, which
is what "it costs nothing when nobody is looking" means. *)
if table () <> [] then
fail "the watch table had values before anything armed it";
if status (ask "(:op \"watch-enable\" :on t)") <> "ok" then
fail "watch-enable was refused";
(* Waiting on the *program*, not on the daemon. Arming is immediate; a
value appearing means the game thread has been round its loop since,
which is the hand-off this whole design turns on. *)
if not (await (fun () -> List.mem_assoc "ticks" (table ()))) then
fail "no value ever reached the watch table"
else begin
let t = table () in
(* Per type, because the table stores rendered text and nothing at run
time could say what a Flan value is. An i64 with a decimal point in
it, or a string without its quotes, would mean one renderer had been
used for all three. *)
(match List.assoc_opt "ticks" t with
| Some v when int_of_string_opt v <> None -> ()
| Some v -> fail "watch rendered an i64 as %s" v
| None -> fail "watch lost the i64");
(match List.assoc_opt "half" t with
| Some v when float_of_string_opt v <> None -> ()
| Some v -> fail "watch rendered an f64 as %s" v
| None -> fail "watch lost the f64");
(match List.assoc_opt "label" t with
| Some "\"sand\"" -> ()
| Some v -> fail "watch rendered a string as %s, unquoted" v
| None -> fail "watch lost the string");
(* The accumulator, which is the other half of the watch and the
half a scalar row cannot stand in for. [loop-cells] samples "cell"
eight times per step at 0, 3, ... 21, so the row has to show a
*range* and a count far above the number of steps. A slot that kept
only the last sample would say 21 and nothing else, and a slot that
counted steps rather than samples would say a number near "ticks".
See flan_dev.c, "A number sampled thousands of times a frame". *)
let stat row key =
let parts = String.split_on_char ' ' row in
List.find_map
(fun p ->
let k = key ^ "=" in
let n = String.length k in
if String.length p > n && String.sub p 0 n = k then
float_of_string_opt (String.sub p n (String.length p - n))
else None)
parts
in
(match List.assoc_opt "cell" t with
| None -> fail "the accumulator never reached the watch table"
| Some row ->
(match stat row "n", stat row "min", stat row "max" with
| Some n, Some lo, Some hi ->
(* More samples than there were steps: the loop is being counted
per iteration, which is the whole reason this is not a scalar
watch. *)
if n < 8.0 then fail "the accumulator counted %g samples" n;
(* And a range, which is what one sample can never show. *)
if not (lo < hi) then
fail "the accumulator kept no range: min=%g max=%g" lo hi
| _ -> fail "the accumulator rendered as %s" row));
(* And the window is the editor's to close. [:reset t] starts a new
one, so the count drops to what the program has done since —
which is what makes min and max track the present instead of
reaching the session's extremes and going dead. A read *without*
it must not reset, or anything that polls would cut the window
short under the editor that owns it. *)
let cell_n () =
match List.assoc_opt "cell" (table ()) with
| Some row -> stat row "n"
| None -> None
in
(* Let it run up first. One step writes eight samples, so two reads
back to back leave no room under the count for a reset to show in —
the assertion needs a window with something in it. Polling to get
there is itself the other half of the claim: every one of these
reads is a plain [watch], and a plain [watch] must not reset, or
the count could never climb at all. *)
if not (await (fun () ->
match cell_n () with Some n -> n > 32.0 | None -> false))
then fail "the accumulator never ran up; a plain read must not reset"
else begin
let high = match cell_n () with Some n -> n | None -> 0.0 in
ignore (ask "(:op \"watch\" :reset t)");
(* Waited for, not read once. A reset moves one counter and clears no
slot — the slot notices on its *next sample*, which is the game
thread's next time round the loop. That is the design and not a
delay to work around: the reader never writes the table, so the
game thread stays its only writer. The cost is that the new window
begins when the program next runs, which for a frame loop is the
only moment it could sensibly begin anyway. *)
if not (await (fun () ->
match cell_n () with Some n -> n < high | None -> false))
then fail "the window never reopened after a reset; it stayed at %g"
high
end;
(* It keeps moving. A table that filled once and froze would pass
everything above and be useless — the counter has to be the
program's, not a snapshot the daemon took when it armed. *)
let first = List.assoc "ticks" t in
if not (await (fun () ->
match List.assoc_opt "ticks" (table ()) with
| Some v -> v <> first
| None -> false))
then fail "the watch table stopped moving";
(* And off again. The value already in a slot stays — nothing clears
it — but the program stops writing, so it stops changing. *)
if status (ask "(:op \"watch-enable\" :on nil)") <> "ok" then
fail "watch-enable :on nil was refused";
let frozen = List.assoc_opt "ticks" (table ()) in
ignore (Unix.select [] [] [] 0.2);
if List.assoc_opt "ticks" (table ()) <> frozen then
fail "the program kept writing the watch table after it was disarmed"
end;
ignore (ask "(:op \"close\")");
Unix.close wc
end;
(try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] wpid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ wsock; wout ];
(* ── Marking a form with (pause), from the editor's side ───────── *)
(* DISCUSS.md §9: C-u before an evaluation marks a form so the program
stops when it runs. The mark travels as a *position* beside the code
rather than spliced into it — splicing text would move every line and
column after the insertion, and the error overlays, the break loop's
frame locations and DWARF all read those.
Two claims, and the second is the one worth the daemon:
a marked form stops the program where it was marked, on the prelude's
own Pause with its own [continue] restart — nothing in the compiler
knows about breakpoints;
and it *sticks*, until the same form is evaluated plainly. That is
§9's settled behaviour, and the half that is easy to leave untested:
one stop proves the splice, not the storage.
Its own daemon over its own program, for the reason every block here
has one. [dev-pause.flan] starts running and keeps running: a program
already stopped would prove nothing about what stopped it. *)
let psock = tmp "pause.sock" and pout = tmp "pause.out" in
(try Sys.remove psock with Sys_error _ -> ());
let pfd =
Unix.openfile pout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let ppid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; psock |]
Unix.stdin pfd Unix.stderr
in
Unix.close pfd;
if not (listening psock) then begin
fail "the pause daemon never listened";
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let poutput = Buffer.create 256 in
let c = connect psock in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string poutput t
| None -> ());
r
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
(* One line, so the position is line 1 and a column, and the column is
derived from the text rather than counted by hand: a miscount would
come back as "nothing to pause at", which reads like a broken feature
rather than a broken test. *)
let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in
let target = "(+ ticks 1)" in
let col =
let n = String.length target in
let rec find i =
if i + n > String.length body then 0
else if String.equal (String.sub body i n) target then i + 1
else find (i + 1)
in
find 0
in
if col = 0 then fail "the pause test cannot find its own target";
(* Running when it arrives, which is what makes the stop below mean
something. *)
if stopped (ask "(:op \"describe\")") then
fail "the pause program was already stopped before anything marked it";
let marked =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\" :pause (1 %d))"
(Wire.quote body) col)
in
if status marked <> "ok" then
fail "marking a sub-expression: %s"
(Option.value ~default:"" (Wire.string_field marked "message"))
else begin
(* Echoed back, so an editor draws its overlay off a mark the session
actually applied and can never claim one that was refused. *)
if Wire.string_field marked "pause" <> Some (Printf.sprintf "1:%d" col)
then
fail "an accepted mark did not echo its position: %s"
(Option.value ~default:"<none>" (Wire.string_field marked "pause"));
let last = ref marked in
if not
(await (fun () ->
last := ask "(:op \"describe\")";
stopped !last))
then fail "a marked form never stopped the program"
else begin
(* The prelude's own condition. Nothing in the compiler knows what a
breakpoint is: [(pause)] is [error] under a [restart-case], so the
break loop this lands in is the one an unhandled condition already
builds. *)
(match Wire.string_field !last "condition" with
| Some "Pause" -> ()
| c ->
fail "a marked form stopped on %S, wanted %S"
(Option.value ~default:"<none>" c) "Pause");
let r = ask "(:op \"break\")" in
let names =
match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str x -> Some x | _ -> None)
l
| _ -> []
in
if not (List.exists (String.equal "continue") names) then
fail "a break at (pause) offers %s, wanted continue among them"
(String.concat ", " names);
(* The second claim, and the one this block exists for. A plain
re-evaluation of the same form replaces the stored declaration
with an unmarked one — that single statement is the whole of
"it sticks until evaluated plainly", and nothing else holds the
mark. Sent while stopped, which the break loop allows: there is
no frame in progress for [step]. *)
let r =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")"
(Wire.quote body))
in
if status r <> "ok" then
fail "re-evaluating a marked form plainly: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if Wire.field r "pause" <> None then
fail "a plain evaluation echoed a pause position";
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continue at a breakpoint: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")"))))
then fail "the program never resumed from its breakpoint"
else begin
(* And then it has to *stay* running. A single sample proves
nothing: the frame that resumed is still in the old marked body,
past the [(pause)] call, so the first look is running whether
or not the mark was cleared. The program calls [step] every 5ms,
so half a second of polling is a hundred calls through the body
just installed — and if the mark were still there, one of them
would stop. *)
let deadline = Unix.gettimeofday () +. 0.5 in
let rec run_on () =
if Unix.gettimeofday () > deadline then ()
else if stopped (ask "(:op \"describe\")") then
fail "the mark was still there after a plain re-evaluation"
else begin
ignore (Unix.select [] [] [] 0.01);
run_on ()
end
in
run_on ()
end
end
end;
(* C-u C-x C-e: the same feature for §9's "last expression" target, and
a flag rather than a position because the expression sent is the
whole of it. The reply it must *not* give is the timeout, which is
what a thunk parked in the break loop looks like from the daemon's
side and what this path used to answer. *)
let r =
ask
"(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\" :pause t)"
in
if status r <> "ok" then
fail "C-u C-x C-e was reported as a failure: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if Wire.string_field r "value" <> None then
fail "an expression that stopped at (pause) answered with a value";
if not (stopped r) then
fail "an expression that stopped at (pause) did not say so";
if Wire.string_field r "condition" <> Some "Pause" then
fail "C-u C-x C-e stopped on %s, wanted Pause"
(Option.value ~default:"<none>" (Wire.string_field r "condition"));
(* It does not stick, and cannot: a thunk is built and thrown away, so
taking [continue] leaves nothing marked behind it. *)
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continue at an expression's breakpoint: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program never resumed from an expression's breakpoint"
else begin
let r =
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "4" then
fail "an ordinary expression after a paused one: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
end;
(* And the same key on a program that is *already* stopped, which the
break loop allows. The wait has to be looking for a [Pause] and not
for "stopped at all": the outer break is already there when the
request arrives, so anything less specific would answer for a thunk
that has not run yet — and answer it on a reply whose own
[:condition] names the other condition. *)
let r =
ask "(:op \"eval-expr\" :code \"(i64 (boom))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that erred inside a thunk answered anyway";
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the program never stopped on the expression that errs"
else begin
let r =
ask
"(:op \"eval-expr\" :code \"(+ 5 5)\" :file \"/tmp/buf.flan\" :pause t)"
in
if Wire.string_field r "condition" <> Some "Pause" then
fail
"C-u C-x C-e on an already-stopped program answered for %s, not Pause"
(Option.value ~default:"<none>" (Wire.string_field r "condition"));
if Wire.string_field r "value" <> None then
fail "C-u C-x C-e under an outer break answered with a value";
(* Innermost first, so this is the thunk's own [continue] and not
anything the outer break offers. *)
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continue at a breakpoint under an outer break: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* Back on the outer break, which was never resumed, and out of it the
ordinary way. *)
if not
(await (fun () ->
Wire.string_field (ask "(:op \"describe\")") "condition"
= Some "Missing"))
then fail "the outer break did not come back after the inner pause";
let r = ask "(:op \"restart\" :name \"carry-on\")" in
if status r <> "ok" then
fail "resuming the outer break: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program never resumed from the outer break"
end;
ignore (ask "(:op \"close\")");
Unix.close c
end;
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ psock; pout ];
(* ── The escape hatch, which still has to work ─────────────────── *)
(* [--two-process] is the old shape: a compiler process that builds the
program, launches it as a child and talks to it over the agent socket.
It exists for a machine that cannot build the compiler object — no
ocamlfind, no flan.cmxa beside the binary — and it is what every
behaviour above was originally written against, so it is worth one
round trip rather than none. The same three questions, briefly: it
answers, it installs, and the program's output comes back. *)
let tsock = tmp "twoproc.sock" and tout = tmp "twoproc.out" in
(try Sys.remove tsock with Sys_error _ -> ());
let tfd =
Unix.openfile tout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let tpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; tsock; "--two-process" |]
Unix.stdin tfd Unix.stderr
in
Unix.close tfd;
if not (listening tsock) then
fail "--two-process never listened"
else begin
let tc = connect tsock in
let seen = Buffer.create 64 in
let ask q =
let r = Wire.parse (Wire.send tc q; Wire.recv tc) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string seen t
| None -> ());
r
in
if status (ask "(:op \"describe\")") <> "ok" then
fail "--two-process: describe was refused";
(* Two processes is the claim here, and it is the opposite one: the pid
launched is the compiler, and the program is a child of it. *)
if Sys.file_exists (Printf.sprintf "/proc/%d/exe" tpid) then begin
match Unix.readlink (Printf.sprintf "/proc/%d/exe" tpid) with
| link when Filename.basename link = "program" ->
fail "--two-process became the program"
| _ | exception Unix.Unix_error _ -> ()
end;
let r =
ask
"(:op \"eval\" :code \"(defn step [] i64 42)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "--two-process: an eval was refused";
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "42"))
then fail "--two-process: the reload was never installed";
ignore (ask "(:op \"close\")");
Unix.close tc
end;
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] tpid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ tsock; tout ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
if !failures = 0 then print_endline "dev: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;
exit 1
end
| _ -> print_endline "dev: skipped (no clang or llc on PATH)"
Reference in New Issue View Git Blame Copy Permalink