JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_dev.ml
Joseph Ferano d6fc15474b The count is length, so len is a name a program can have 
The author: "I think I prefer length over len, because then I'll use len as
the variable name". One arm in check.ml, one row in the table beside it, and
every (len x) in lib, test, examples, vendor, spike, docs, web, emacs,
plan.org and NEXT.md rewritten.

Shadowing and builtin/ had already taken most of the sting out: a (defn len
...) was legal and won in its own file, and builtin/len reached past it. What
was left is that len was still a builtin — the defn earned a warning, and a
wrapper had to say builtin/ at every inner call. Now there is nothing under
the short name: len is an ordinary identifier in every position, which is
what (let [len (length xs)] ...) wants.

length takes over as shadowing's worked example rather than the feature
losing one. shadow-builtin.flan, builtin-qualified.flan, pkgs/shadowed and the
builtin/ rows in test_flan move to it and go on testing shadowing.

A call to a len nothing defines is answered where an unknown function is,
after every table and after the shadowing guard, so a program with its own len
never reaches it. The sentence is said rather than guessed at — len and length
are three edits apart and the did-you-mean's net is one — and the call is
written back out through spell_arg, as-slice's spelling lifted out of it and
now shared, so what is printed compiles.

sand.flan:33 still calls the old name and is the author's to change; until it
does, test_acceptance and test_session abort there. Both were run green
against a copy with that one line changed. FIX.org says so.
2026-09-21 11:58:56 +07:00

6790 lines
339 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(* [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"
(* SIGPIPE ignored, and for the watchdog's own reason: a binary killed by a
signal prints no line saying why and leaves every case after it unrun. The
daemons here are ended on purpose — an [abort] at a break or a trap exits
the process, because in a merged [flan dev] the daemon *is* the program —
so a [Wire.send] into a socket whose peer has just gone is a shape this
file reaches by design. Ignored, it comes back as EPIPE out of
[Unix.write], which a case can name; unignored, it is the test binary that
dies. [flan dev] ignores it for the same reason — see [Dev.ignore_sigpipe],
whose note is about the other end of these same sockets. *)
let () =
try Sys.set_signal Sys.sigpipe Sys.Signal_ignore
with Invalid_argument _ -> ()
(* The counter, the scratch paths, the poll and the daemon wait are all in
test_support.ml, which is where [listening]'s long note about telling a
still-building daemon from a dead one now lives too. The watchdog armed
just above is what bounds this particular run. *)
let failures = Test_support.failures
let fail fmt = Test_support.fail fmt
let tmp n = Test_support.tmp "flan-devtest-" n
let await = Test_support.await
let listen_why = Test_support.listen_why
let listening = Test_support.listening
(* ── Three states, without a program to be in them ──────────────────── *)
(* [Dev.liveness] reads a C symbol that only a merged [flan dev] binary has, so
in this one it always answers [Absent] and the interesting arm is out of
reach. [Dev.liveness_of] is the decision on its own, which is why it was
split out: the end-to-end case below proves a real program parks and runs
again, and this proves the three-way itself — including the two-process arm,
which nothing else here can reach at all, and the [Absent] fallback every
test in this directory is running under. *)
let () =
let case name got want =
if got <> want then fail "liveness: %s" name
in
(* A child: the kernel's answer, and never [Parked] — a program in its own
process that finishes is gone, and there is no thread here to wake. *)
case "a living child is live"
(Dev.liveness_of ~child_alive:(Some true) ~finished:false
~program:Program.Absent)
Dev.Live;
case "a reaped child is gone, whatever this process's own state says"
(Dev.liveness_of ~child_alive:(Some false) ~finished:false
~program:Program.Parked)
Dev.Gone;
(* Merged: the program is this process, and the C says which. *)
case "a merged program between frames is live"
(Dev.liveness_of ~child_alive:None ~finished:false
~program:Program.Running)
Dev.Live;
case "a merged program that finished is parked, not gone"
(Dev.liveness_of ~child_alive:None ~finished:false ~program:Program.Parked)
Dev.Parked;
(* And the fallback, which is what a session in a binary with no program
thread of its own gets: the pipe's EOF, which is all there ever was
before the C could be asked. *)
case "with no program thread, EOF on the pipe is still the answer"
(Dev.liveness_of ~child_alive:None ~finished:true ~program:Program.Absent)
Dev.Gone;
case "and no EOF means there is still something there"
(Dev.liveness_of ~child_alive:None ~finished:false ~program:Program.Absent)
Dev.Live
(* ── When an absent editor counts as a dead one ─────────────────────── *)
(* Split out of [accept_loop] for the same reason as the three-way above: the
loop needs a session and a bound socket, so reaching the decision otherwise
costs a compile. The end-to-end case at the bottom of this file proves a
daemon really does exit; these are the four ways it must not. *)
let () =
let case name got want = if got <> want then fail "orphaned: %s" name in
case "a daemon no client has ever reached is not an orphan, however long"
(Dev.orphaned ~grace:1. ~served:false ~idle:10_000. Dev.Parked)
false;
case "a client that let go a moment ago is coming back"
(Dev.orphaned ~grace:60. ~served:true ~idle:1. Dev.Parked)
false;
case "a parked program whose client is long gone is an orphan"
(Dev.orphaned ~grace:60. ~served:true ~idle:61. Dev.Parked)
true;
(* The longer clock: a running program is a window somebody may be looking
at, so the same idle gap that ends a parked session does not end this
one. *)
case "a live program gets the longer grace"
(Dev.orphaned ~grace:60. ~served:true ~idle:61. Dev.Live)
false;
case "but not an unbounded one"
(Dev.orphaned ~grace:60. ~served:true ~idle:361. Dev.Live)
true;
case "a non-positive grace is off"
(Dev.orphaned ~grace:0. ~served:true ~idle:10_000. Dev.Parked)
false
let connect = Test_support.connect
(* 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 = Test_support.contains
(* ── The one verb whose reply races the process it ends ─────────────── *)
(* [abort] is answered twice over, and the two answers are not ordered. On the
program's own channel flan_agent.c's listener writes "ok" and then sets
[aborting]; the break loop's next pass prints "aborted at the break loop"
and calls [die_now], which is [_exit(134)] — from the program thread. The
reply to the editor is composed on the *serve* thread, out of [Dev.abort]'s
[ok], and in a merged [flan dev] both threads are in this one process. So
an abort that did exactly what was asked comes back either as
[:status "ok"] or as the socket closing under the read, depending on which
thread got there first.
Both are the same outcome, and neither is the assertion. What says the
abort worked is the [waitpid] wait every caller does underneath it: the
process ended. [aborted] therefore answers [None] for the end that arrived
as an exit, and its callers check a status only when there is one to check.
Written out because the bare [Wire.recv] this replaces lost that race often
enough to kill the binary outright — [Fatal error: exception
Flan.Wire.Closed], no FAIL line, and every case after it silently unrun,
which is the worst shape a flake can take here. Reproduced four runs out of
four at the null-allocator trap before this.
[Unix_error] is caught beside [Closed] because a peer that [_exit]s can
reset the connection rather than close it cleanly, and a reset leaves
[Unix.read] by its errno rather than as the EOF [Wire.recv] turns into
[Closed]. The same end, arriving under another name. *)
let aborted c =
match Wire.parse (Wire.send c "(:op \"abort\")"; Wire.recv c) with
| r -> Some r
| exception Wire.Closed -> None
| exception Unix.Unix_error _ -> None
(* ── Whose fault a full reload ring is ──────────────────────────────── *)
(* The agent refuses a module it has no room to queue with "the program is not
calling agent/poll", and for a running program that is the cause. For a
parked one it is the wrong cause said confidently: there is no game thread
left to poll with, the ring is full precisely *because* the program
finished, and [Dev.eval]'s own note promises exactly that a body redefined
while parked installs when the program is run again. Somebody sent
the sixty-fifth one, and the reply sent them to read a loop that is not
running.
Pinned on the decision rather than end to end. Filling the ring means
sixty-four modules through a real clang, which is minutes of [dune test] to
assert one sentence; what the daemon *does* with the agent's words is the
whole of the change, and it is a function of two arguments. The pass-through
is asserted too: a running program's refusal must still arrive in the
agent's own words, because for it they are true. *)
let () =
let full = "err reload queue full; the program is not calling agent/poll" in
let parked = Dev.refusal ~parked:true full in
if contains_sub parked "not calling agent/poll" then
fail "a parked program's queue-full refusal still blames its poll: %S"
parked;
if not (contains_sub parked "flan-rerun") then
fail "a parked program's queue-full refusal names no way out: %S" parked;
let live = Dev.refusal ~parked:false full in
if not (contains_sub live "not calling agent/poll") then
fail "a running program's queue-full refusal lost the agent's reason: %S"
live;
(* Only that one reply is rewritten. Every other refusal a parked program
can give — a bad ABI, a module with no installer — is the agent's to
explain and is quoted as it stands. *)
let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in
if not (contains_sub other "flan.abi.x86") then
fail "a parked program's other refusals were rewritten too: %S" other
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
(* [--llvm] on this daemon and on the four below it, and it is about what
they test rather than about a preference. Everything they ask for -- a
backtrace, the locals of a stopped frame, the globals a stopped stack
reaches -- is read off the dev shadow stack, and [lib/x86.ml] pushes no
frames onto it. x86 is what [flan dev] takes unasked now, so a flagless
daemon here would answer every one of those with the sentence [Dev.ask]
rewrites: a true statement about the backend and no test of the verb.
The default itself is checked further down, on a daemon that does not
need frames. *)
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock; "--llvm" |]
Unix.stdin fd Unix.stderr
in
Unix.close fd;
if not (listening ~pid sock) then
fail "the daemon %s" !listen_why
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.
A fifth string carries a line of prose, and the compiler's builtins
ride the same op under a kind of their own: [arena-new] is a name an
editor is asked about and no program's symbol table holds, so without
them here C-c C-v answers "the running program defines no arena-new"
about a name that is perfectly good. *)
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; _ }
:: { Form.v = Form.Str doc; _ } :: [])
when String.equal n name -> Some (kind, sign, loc, doc)
| _ -> 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");
(* The builtin the author hit. It is here with a signature, a line of
prose and no location — and the empty location has to be read
against the kind, because a global's empty one means the Tast
dropped it while this one means there was never a file. *)
(match find "arena-new" with
| Some ("builtin", sign, "", doc) ->
if sign = "" then fail "arena-new has no signature";
if doc = "" then fail "arena-new has no description"
| Some (k, _, l, _) ->
fail "arena-new is described as a %s at %S" k l
| None -> fail "defs did not mention arena-new");
(* And a name in value position, which is [var]'s half of the same
table: it is a builtin too, and reads as one. *)
(match find "context/allocator" with
| Some ("builtin", _, "", doc) when doc <> "" -> ()
| Some (k, _, _, _) -> fail "context/allocator is described as a %s" k
| None -> fail "defs did not mention context/allocator");
(* A program's own names come first, so a completion table built out
of this order does not bury them under the compiler's. *)
let kind_of (e : Form.t) =
match e.Form.v with
| Form.List (_ :: { Form.v = Form.Str k; _ } :: _) -> k
| _ -> ""
in
let rec no_program_after_builtin seen = function
| [] -> ()
| e :: rest ->
let k = kind_of e in
if seen && k <> "builtin" then
fail "a %s entry comes after a builtin in defs" k;
no_program_after_builtin (seen || k = "builtin") rest
in
no_program_after_builtin false entries
| _ -> 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 \"(defdata Shape [(Circle [r f32])])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "a new data type: %s" (refusal r)
else begin
let r = request c "(:op \"layout\" :type \"Shape\")" in
if status r <> "error" then fail "a data type answered a struct layout"
else if not (contains (refusal r) "is a data type") then
fail "a data type 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 \"(defonce 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 \"(defonce 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";
(* ── The program, run again ──────────────────────────────────── *)
(* [main] has returned by now — dev-loop.flan prints four times and
stops — and that used to be the end of everything: the process stayed
up only to keep the compiler's socket answering, with the program
itself unreachable for the rest of the session. The complaint it came
from was a window: you close one, main returns, and the only way to
get another is to tear down the build, the session and every global
with it. Common Lisp and Clojure do not have that problem, because the
image outlives main and you simply call it again.
So the main thread parks instead of exiting, and this is the proof
that it can be sent round [main] a second time. *)
let parked () =
match Wire.field (request c "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await parked) then
fail "the program never parked after main returned";
(* The refusals a parked program gives. Not "the program exited", which
is what every guard in the daemon used to say and is wrong about the
commonest case there is: the process is there, its globals are there,
and what the reader needs is the name of the verb that starts it. *)
let r = request c "(:op \"backtrace\")" in
let refused = Option.value ~default:(status r) (Wire.string_field r "message") in
if status r <> "error" then fail "a parked program answered a backtrace"
else if not (contains_sub refused "parked" && contains_sub refused "flan-rerun")
then fail "a parked backtrace is refused as: %s" refused;
(* ── C-x C-e against the park ─────────────────────────────────── *)
(* The complaint: somebody typed [(+ 1 1)] at the top of a buffer and was
told that an expression is evaluated at a frame boundary and a parked
program reaches none. True, and about the wrong thing — [(+ 1 1)]
needs nothing from the program at all. What it needed was somewhere to
run, and the park is one: the thread is asleep on a condition
variable, no frame is executing and no global is being written, which
is exactly what a frame boundary offers. So the park drains the
agent's ring when it is woken for it, and this is the proof. *)
let r = request c "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/buf.flan\")" in
if Wire.string_field r "value" <> Some "2" then
fail "C-x C-e against a parked program: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* On this very reply and not on a later [describe]: a thunk is not a
run, so the state the editor reads beside the value has to still be
the parked one. Reading it afterwards would not tell the two apart
from a program that went live and parked again. *)
(match Wire.field r "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "an expression against the park reported the program live");
(* And the half that needs the process rather than only the compiler.
[extra] is a global this session introduced and the first run left at
105 — the third reload's [step] does not touch it — so this is the
finished run's storage, read by a thunk the finished run's thread ran.
Nothing is reset between runs and nothing is reset for an evaluation
either. *)
let r = request c "(:op \"eval-expr\" :code \"extra\" :file \"/tmp/buf.flan\")" in
if Wire.string_field r "value" <> Some "105" then
fail "a global the finished run left: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* What the thunk *printed*, which needs one more thing than the value
does. In the merged build fd 1 is a fully buffered pipe into the
daemon, and a run flushes at its own pace while the park flushes once
on the way in — neither covers a thunk that printed after both, so
without a flush beside the poll this line would sit in the FILE buffer
until the next park, which is to say until after the next run. The
value arriving and the output not is exactly the shape that would go
unnoticed, so it is asked for by name. *)
let before = Buffer.length output in
let r =
request c
"(:op \"eval-expr\" :code \"(do (println \\\"pk\\\") 9)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "9" then
fail "a printing expression against the park: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
if not (contains_sub (Buffer.sub output before (Buffer.length output - before)) "pk")
then fail "a parked thunk's output never reached the daemon";
(* ── And a thunk that stops, on a thread with no run under it ──── *)
(* Parked and stopped at once, which is a pair of states that could not
both hold until this. The thunk runs on the parked thread, so a
[(pause)] in it puts *that* thread in the break loop — and every op
that refused [Parked] outright would have refused the break with it,
including the restart that is the only way out. A first paused
expression against a parked program would have been the last thing
that session could do. *)
let r =
request c
"(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\" :pause t)"
in
if Wire.string_field r "condition" <> Some "Pause" then
fail "a paused expression against the park stopped on %s"
(Option.value ~default:(status r) (Wire.string_field r "condition"));
(* Both flags on one reply, which is the state the daemon had no way to
describe before: no run is in progress and the program is nevertheless
stopped on something. *)
(match Wire.field r "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "a thunk stopped in the park reported the program live");
(* The frames are the thunk's, and they are there to be walked — the
refusal above was about a park with nothing in it, not about the
state. *)
let r = request c "(:op \"backtrace\")" in
if status r <> "ok" then
fail "a backtrace of a thunk stopped in the park: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And the section that walks that stack, which is the one op here whose
answer is *empty* and has to arrive anyway. Every frame a paused thunk
has is an eval frame, so nothing is attributed and everything lands in
[:skipped] — but a render thunk is still built, delivered and run, and
"ok with nothing in it" is a different reply from the five-second
timeout that a job nobody polled would give. That is what this
distinguishes. *)
let r = request c "(:op \"globals\")" in
if status r <> "ok" then
fail "the globals of a thunk stopped in the park: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* The way out, and the reason the restart ops had to stop refusing the
state: nothing else resumes this, and a re-run asked for meanwhile
would be taken and then wait on the same resume. *)
let r = request c "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continue at a breakpoint inside the park: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () ->
match Wire.field (request c "(:op \"describe\")") "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> false
| _ -> true))
then fail "the thunk never resumed from its breakpoint in the park";
(* Still parked, and with nothing of the thunk left behind. A backtrace
is the cheap proof of the second: the chain the park cleared is still
cleared, so the thunk pushed frames and popped them, and the refusal
is the same one it gave before any of this ran. *)
let r = request c "(:op \"backtrace\")" in
let refused = Option.value ~default:(status r) (Wire.string_field r "message") in
if status r <> "error" then
fail "a parked program answered a backtrace after running a thunk"
else if not (contains_sub refused "parked") then
fail "a parked backtrace after a thunk is refused as: %s" refused;
if not (await parked) then
fail "the program did not stay parked across an evaluation";
(* [eval] is the one op a parked program took before this, because it
queues and waits for nothing: the module sits in the ring until the
parked thread next looks at it, which is when it is woken — to run an
expression, or to start the run below. Having to run the program
before being allowed to fix the thing you closed it over is the loop
this feature exists to remove. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 1)) extra)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "a redefinition while parked: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else
(match Wire.string_field r "note" with
| Some n when contains_sub n "parked" -> ()
(* Reworded when the park learned to run a thunk: a poll that runs one
installs everything queued ahead of it, so "when it is run again"
stopped being the whole truth and became an upper bound. *)
| _ ->
fail
"a delivery to a parked program still promised the next frame \
boundary");
let r = request c "(:op \"rerun\")" in
if status r <> "ok" then
fail "rerun: %s" (Option.value ~default:"" (Wire.string_field r "message"));
(* One line, and the whole claim is in which body printed it. It is the
body delivered while the program was parked — installed before the
re-run re-entered [main] rather than at the first [agent/wait] after
it — and its value is 106 rather than 1, because [extra] is a global
of a process that never died and the second run reads what the first
left in it. Nothing is zeroed between runs, deliberately: a clean
slate is one evaluation away, and cannot be had back once a re-run
has wiped something.
This used to be two lines, and the first of them was the defect:
[flan_merged_park] left on the re-run flag without draining its ring,
so the new run printed the *old* [step] and the queued body did not
land until the [agent/wait] after it. Everything a run does before
its first poll ran a body the person had already replaced, and a
redefined [main] — which is all of that run — would have had to be
asked for twice.
Six and not five, because [settle] counts every line the daemon has
handed over and the printing expression above contributed one that no
run printed. *)
if not (settle 6) then fail "the program did not run again";
(* And a re-run while it is running is refused rather than queued: two
mains in one process would be writing the same globals at once. *)
let r = request c "(:op \"rerun\")" in
let refused = Option.value ~default:(status r) (Wire.string_field r "message") in
if status r <> "error" then fail "a second main was started under the first"
else if not (contains_sub refused "already running") then
fail "a re-run while running is refused as: %s" refused;
(* 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 \"(defonce 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.
Then the same [main], run a second time in the same process: 106,
from the body delivered while it was parked. There is no second 777
in front of it any more, and that absence is the claim — the park
drains its ring on the way out, so the re-run starts with the body
the person last sent rather than with the one they replaced. 106 and
not 1 is the other half: the globals are the finished run's, the
process never died, so [extra] is where the first run left it.
And [pk] between the two, which is a line no run printed: it is the
thunk evaluated against the park, on the parked thread, flushed there
rather than waiting for a run to flush it. Its position in the
transcript is the claim — after everything the first run printed and
before anything the second did. *)
ignore (Unix.waitpid [] pid);
let text = Buffer.contents output in
let wanted = "1\n5\n105\n777\npk\n106\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; "--llvm" |]
Unix.stdin bfd Unix.stderr
in
Unix.close bfd;
if not (listening ~pid:bpid bsock) then begin
fail "the break daemon %s" !listen_why;
(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");
(* And the value behind the shape: [fetch 1] built the condition, so
[.id] holds 1, and the daemon's thunk reads it out of the stopped
frame's own storage — a user [error], not a trap, so the same path
serves both. *)
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "condition values at a user error: %s"
(Option.value ~default:(status r) (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"; _ };
{ Form.v = Form.Str "1"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "the condition's own field value did not render");
(* 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);
(* Five now: the thunk's own [fetch] frame, the boundary the agent
establishes around every evaluation, and the frame below it. The
boundary sits between the two groups by construction — it is pushed
after the floor is read and before the thunk runs — so its position
is also the line the floor draws. *)
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"; "abandon-evaluation"; "retry";
"use-placeholder" ]
then fail "restarts at a break inside a thunk: %s"
(String.concat ", " names);
(* And it is named by position, not by spelling. A program may
establish a restart called [abandon-evaluation] of its own; [:abandon]
is the agent's own frame, identified by address. *)
(match Wire.field r "abandon" with
| Some { Form.v = Form.Int 2L; _ } -> ()
| _ -> fail "the break inside a thunk did not say which restart abandons it");
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 <> [ 3; 4 ] 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 3 :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"));
(* The way out the floors used to leave missing, which is the report
this whole thing came from: a C-x C-e that signals must cost the
evaluation and not the session. The agent establishes a restart
at the thunk boundary, so every break reached from inside an
evaluation has one choice that is neither "resume this expression"
nor "kill the program".
Offered *beside* the thunk's own restarts rather than instead of
them: [fetch] establishes two, they are above the boundary and
takeable, and the boundary is last because it is the outermost
frame of the evaluation. *)
(let r =
ask
"(:op \"eval-expr\" :code \"(i64 (fetch 3))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped the program answered anyway";
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 names <> [ "retry"; "use-placeholder"; "abandon-evaluation" ]
then
fail "restarts at a break inside an evaluation: %s"
(String.concat ", " names);
(* Nothing on this list is below anything: the program itself was
running, so the evaluation is the whole stack above it. *)
(match Wire.field r "unreachable" with
| Some { Form.v = Form.List []; _ } -> ()
| _ ->
fail "a break inside an evaluation over a running program \
refused one of its own restarts");
(match Wire.field r "abandon" with
| Some { Form.v = Form.Int 2L; _ } -> ()
| _ ->
fail "the break did not say which restart abandons the \
evaluation");
(* And it says *why* nothing is refused, which is a different fact
from which entries are: this break has a transfer channel. *)
(match Wire.field r "trap" with
| Some { Form.v = Form.Sym "nil"; _ } -> ()
| _ -> fail "a signalled break reported itself as a trap");
(* -- Two evaluations, and two boundaries ------------------- *)
(* The claim the save-and-restore is for: a second evaluation run
from inside the first one's break gets a boundary of its own, and
abandoning it leaves the first one exactly as it was. Both are on
one list — the inner one above the floor and takeable, the outer
one below it with the frames it belongs to — which is also what
proves they are two frames and not one reused. *)
let r =
ask
"(:op \"eval-expr\" :code \"(i64 (fetch 4))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "a second evaluation stopped inside the first answered anyway";
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
names
<> [ "retry"; "use-placeholder"; "abandon-evaluation"; "retry";
"use-placeholder"; "abandon-evaluation" ]
then
fail "restarts at a break inside a nested evaluation: %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
(* The outer evaluation's own restarts, its boundary included: from
in here they are below a C frame that holds its own channel, so a
transfer to any of them lands nowhere. The inner boundary is the
only way out of the inner evaluation, which is the point. *)
if unreachable <> [ 3; 4; 5 ] then
fail "positions below the inner evaluation: %s"
(String.concat ", " (List.map string_of_int unreachable));
(match Wire.field r "abandon" with
| Some { Form.v = Form.Int 2L; _ } -> ()
| _ ->
fail "a nested evaluation did not name its own boundary as the \
one that abandons it");
let r =
ask "(:op \"restart-at\" :index 2 :name \"abandon-evaluation\")"
in
if status r <> "ok" then
fail "the inner boundary was refused: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* And the outer evaluation is back, with its three restarts and its
own boundary still on offer — an inner abandon must not have been
read as the outer one. *)
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 = 3
| _ -> false)
&& (match Wire.field r "abandon" with
| Some { Form.v = Form.Int 2L; _ } -> true
| _ -> false)))
then
fail "the outer evaluation did not come back intact after the \
inner one was abandoned";
(* Taken by index with the name as the receipt, which is what an
editor sends: the position is the identity and the name is what
makes a stale position wrong out loud. *)
let r =
ask "(:op \"restart-at\" :index 2 :name \"abandon-evaluation\")"
in
if status r <> "ok" then
fail "the boundary restart was refused: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* And the note says what taking it did, because "resumes at its
next pass of the break loop" would be false in both halves —
nothing is resumed and there is no value coming. *)
(match Wire.string_field r "note" with
| Some n
when contains_sub n "the evaluation is abandoned"
&& contains_sub n "is still changed" -> ()
| n ->
fail "abandoning reported itself as %S" (Option.value ~default:"" n));
(* The whole claim, in one line: the program is running again. *)
if not (await (fun () -> not (stopped (ask "(:op \"describe\")"))))
then
fail "the program did not carry on after its evaluation was \
abandoned";
let r =
ask "(:op \"eval-expr\" :code \"(+ 3 4)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "7" then
fail "an expression after an abandoned one: %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;
(* ── ArithError, and the layout nobody can see both halves of ────
The other condition the runtime builds by hand. [flan_arith_cond]
is {i32 op; i64 lhs, rhs} in flan_rt.c and [(defstruct ArithError
[op i32 lhs i64 rhs i64])] in the prelude, and neither end can see
the other — the same hand-kept agreement [flan_name_id] has with
[Check.type_id]. It used to be read only by a handler that pulled
out one field; the break loop's render now walks all three, padding
included, so a drifted layout shows the op sitting in [lhs].
Driven from the editor rather than from main: [divide] holds a
restart-case, so the break has somewhere to go afterwards and the
daemon carries on. This is also the LLVM half of the site check —
an arith trap publishes its loc the same way a bounds trap does,
and the bad-index block below is x86. *)
(let r =
ask
"(:op \"eval-expr\" :code \"(divide (i64 1) (i64 0))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "a division by zero answered instead of stopping"
else if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "a division by zero never stopped the program"
else begin
(match Wire.string_field (ask "(:op \"describe\")") "condition" with
| Some "ArithError" -> ()
| c ->
fail "a division by zero is reported as %S"
(Option.value ~default:"" c));
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "ArithError's fields: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
let fields =
match Wire.field r "fields" 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; _ } ] -> Some (n, ty, v)
| _ -> None)
l
| _ -> []
in
(* op 0 is FLAN_ARITH_DIV_ZERO; lhs is the dividend and rhs the
divisor, which is the pair the unhandled message prints. Each
read at its own offset, so an i32 followed by two i64s is the
layout both ends have to agree on. *)
if
fields
<> [ ("op", "i32", "0"); ("lhs", "i64", "1"); ("rhs", "i64", "0") ]
then
fail "ArithError's rendered fields: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) fields))
end;
(* The site, on LLVM: an arith trap publishes its loc around the
hook exactly as a bounds trap does. *)
(match Wire.string_field (ask "(:op \"break\")") "site" with
| Some site when contains_sub site "dev-break.flan:" -> ()
| Some site -> fail "the arith site points at %s" site
| None -> fail "a division by zero carries no :site");
let r = ask "(:op \"restart\" :name \"use-zero\")" in
if status r <> "ok" then
fail "resuming past a division by zero: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program never resumed past a division by zero"
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)));
(* [aborted] and not [ask]: the reply races the exit it asked for,
and a session that went before it could answer is the abort
having worked. The wait on [bpid] below is the claim. *)
(match aborted c with
| None -> ()
| Some r ->
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
(* [--x86] spelled out rather than taken from the default. It *is*
the default for [flan dev] (bin/main.ml), so this block has always
been the x86 side of the break loop — but the condition render,
the trap site and the nested-site check all live here, and which
backend they run under is the whole point of them. A default that
moves must not silently take this coverage with it; the LLVM side
of the same three is the break block above. *)
[| flan; "dev"; "programs/dev-break-bounds.flan"; "-s"; xsock; "--x86" |]
Unix.stdin xfd Unix.stderr
in
Unix.close xfd;
if not (listening ~pid:xpid xsock) then begin
fail "the bad-index daemon %s" !listen_why;
(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");
(* The values, not just the shape. The break loop stashed the pointer
it was handed, the daemon knows the type — it compiled it — and a
thunk it builds renders the fields in the stopped program. This is
what turns "BoundsError" into "9 is past the end of a length-4
array" in the buffer, with nothing special-casing BoundsError. *)
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "condition values: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
let fields =
match Wire.field r "fields" 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; _ } ] -> Some (n, ty, v)
| _ -> None)
l
| _ -> []
in
if
fields
<> [ ("low", "i64", "9"); ("high", "i64", "9");
("length", "i64", "4") ]
then
fail "the condition's fields: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) fields))
end;
(* Where the *expression* is. The frame lines say where each call was;
the trap's own loc is the only record of the indexing itself, and
[break] carries it with the line's text so a buffer can point at
the column Elm-style. *)
(let r = ask "(:op \"break\")" in
match Wire.string_field r "site" with
| None -> fail "break over a bad index carries no :site"
| Some site ->
let has hay needle =
let n = String.length hay and m = String.length needle in
let rec go i = i + m <= n && (String.sub hay i m = needle || go (i + 1)) in
m = 0 || go 0
in
if not (has site "dev-break-bounds.flan:") then
fail "the site does not point into the program: %s" site;
(match Wire.string_field r "source" with
| Some line when has line "(at grid i)" -> ()
| Some line -> fail "the site's source line reads %S" line
| None -> fail "break carries a :site but no :source line"));
(* 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 no way to abandon an evaluation, because there is no evaluation
to abandon: this program stopped on its own frame. Offering one here
would promise to unwind something nobody asked for. *)
(match Wire.field r "abandon" with
| Some { Form.v = Form.Sym "nil"; _ } -> ()
| _ ->
fail "a break the program took on its own offered to abandon an \
evaluation");
(* A break nested inside this one must not inherit the trap's site.
The fix-it-and-retry flow evaluates code *at* the bounds stop; if
that code raises its own error, its break has no trap behind it,
and a caret pointing at the outer stop's indexing under the inner
condition's name would be a plausible-looking lie. The site is
consumed by the snapshot that owns it. *)
let r =
ask
"(:op \"eval-expr\" :code \"(restart-case (do (error (BoundsError {.low 1 .high 2 .length 3})) (i64 0)) (back [] (i64 1)))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped inside the bounds break answered anyway";
(let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break inside the bounds break: %s" (status r)
else
match Wire.string_field r "site" with
| None -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site);
let r = ask "(:op \"restart\" :name \"back\")" in
if status r <> "ok" then
fail "resuming the inner break: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* Back on the outer break, whose own snapshot still holds its site. *)
if not
(await (fun () ->
let r = ask "(:op \"break\")" in
status r = "ok" && Wire.string_field r "site" <> None))
then fail "the outer bounds break lost its site after the inner one";
(* 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"));
(* The report, reproduced on x86 and then answered.
The program is running its loop. An expression evaluated into it
indexes past the end, and nothing above the boundary establishes a
restart — a bad index establishes none, and the [continue] the
program's own frame offers is below the boundary, where a transfer
has nowhere to land. That list used to be empty of anything
takeable, which left abort as the only live choice, and abort ends
the process: a mistyped index cost the session.
The index is computed from a global so the compiler cannot decide
it at build time — a constant one is a compile error, which is the
right answer to a different question. *)
let r =
ask
"(:op \"eval-expr\" :code \"(at grid (i32 (+ ticks 100)))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an out-of-bounds expression answered instead of stopping";
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 names <> [ "abandon-evaluation" ] then
fail "restarts at a bad index inside an evaluation: %s"
(String.concat ", " names);
(match Wire.field r "abandon" with
| Some { Form.v = Form.Int 0L; _ } -> ()
| _ ->
fail "the only restart on offer did not say it abandons the \
evaluation");
let r =
ask "(:op \"restart-at\" :index 0 :name \"abandon-evaluation\")"
in
if status r <> "ok" then
fail "abandoning an evaluation on x86: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the x86 program did not carry on after its evaluation was \
abandoned";
(* Still the same program, with the globals it had: abandoning drops
the expression, it does not restart anything. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 5 5)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "10" then
fail "an expression after an abandoned one on x86: %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;
(* ── A break over a trap with no way back ─────────────── *)
(* The block above stops on a bad index and *resumes*: the signal walks the
handlers, reaches the break loop, and the program's own [continue]
carries it out. Six refusals in the runtime cannot be reached that way.
[flan_restart_fail], [flan_restart_args_fail], [flan_restart_unarmed],
[flan_transfer_fail], [flan_null_alloc_fail] and [flan_free_all_fail]
are called by emitted code that then falls off the end, with no transfer
channel anywhere in the call — so there is nothing for a chosen restart
to land in, and every one of them called [_exit(134)]. In a merged
[flan dev] that is one process, and the session went with the program.
Two of the six are driven here, and the pair is chosen so that the
refusal has something to refuse: [dev-trap-free-all.flan] traps inside a
live [restart-case], so [continue] is on the stack, is listed, and is
still not takeable; [dev-trap-null-alloc.flan] traps with an empty
restart stack, which is the other shape the break loop has to print.
What is asserted is the difference the change is about. The program is
*stopped* and not gone — [describe] answers, and answers [:stopped] — an
expression still evaluates while it stands there, which is the proof the
daemon is alive and serving, and a resume is refused *with a reason*
rather than by the process having exited before anyone could ask. The
standalone half of the same claim is test_acceptance.ml's
free-all-refused, which still exits 134: nothing installs the hook in a
program that did not import the agent. *)
let trap_park ?(refault = false) ?(trapping = "") what prog cond restarts =
let tsock = tmp (prog ^ ".sock") and tout = tmp (prog ^ ".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/" ^ prog; "-s"; tsock |]
Unix.stdin tfd Unix.stderr
in
Unix.close tfd;
if not (listening ~pid:tpid tsock) then begin
fail "the %s trap daemon %s" what !listen_why;
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect tsock 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
(* Seeded with a reply nobody sent rather than with a first [ask]: the
poll below overwrites it on its first pass, and the ask it replaces
was a second bare [Wire.recv] exposed to the same closing socket. *)
let last = ref (Wire.parse "()") in
(* The poll, and what a session that vanishes under it means. These
traps park because [flan_trap_hook] is installed; with no hook
[rt_trap] falls through to [rt_die], the program [_exit]s 134 and
takes the merged daemon with it — so a socket closing here is the
trap having ended the program instead of stopping it, which is the
failure named below and not something to wait out. There is no
retry: the daemon was answering a moment ago, [listening] saw to
that, so this is never a session still coming up. *)
let ended = ref false in
let poll () =
match ask "(:op \"describe\")" with
| r -> last := r; stopped r
| exception Wire.Closed -> ended := true; true
| exception Unix.Unix_error _ -> ended := true; true
in
if (not (await poll)) || !ended then
fail "the %s trap never stopped the program, it ended it" what
else begin
(* Which trap, by name. There is no [defstruct] behind these — they
are traps and not conditions, and [layout] will say it cannot
place the name, which flan-cnr.el already draws as a reason. The
name is here to say where the program is standing. *)
let got =
match Wire.string_field !last "condition" with
| Some c -> c
| None -> ""
in
if got <> cond then
fail "the %s trap is reported as %S, wanted %S" what got cond;
(* What is on offer, which at a trap is a list nobody can take. It
is still *listed*: "why can I not have that one" is a fair
question, and an empty list would make a live restart-case look
like it had been unwound. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break at the %s trap: %s" what (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 <> restarts then
fail "restarts at the %s trap: %s" what
(String.concat ", " names)
| _ -> fail "break at the %s trap listed no restarts field" what);
(* And every one of them named as untakeable. This is the half the
editor reads: the terminal listing says so in words, and a
[:unreachable] that disagreed with it would be the two ends
describing different programs — a restart shown as choosable,
chosen, and then refused. *)
(match Wire.field r "unreachable" with
| Some { Form.v = Form.List l; _ } ->
let idx =
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Int i -> Some (Int64.to_int i) | _ -> None)
l
in
if idx <> List.mapi (fun i _ -> i) restarts then
fail "unreachable restarts at the %s trap: %s" what
(String.concat ", " (List.map string_of_int idx))
| _ ->
if restarts <> [] then
fail "break at the %s trap named no unreachable restarts" what);
(* Why they are refused, and it has to be answerable with *no*
restarts on the list at all — which is the shape the null
allocator has, and the reason this is a fact about the break
rather than a flag on an entry. An editor captions the rows from
it, and "below this evaluation" in front of somebody looking at a
trap sends them hunting for an evaluation that is not there. *)
(match Wire.field r "trap" with
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "the %s trap did not say the break was taken by one" what);
(* And the refusal, where there is a name to refuse. Answered [err]
with the reason rather than [ok] and then dropped, which is the
shape that would tell an editor the program had resumed when it
had not. *)
List.iter
(fun name ->
let r =
ask (Printf.sprintf "(:op \"restart\" :name %s)"
(Wire.quote name))
in
if status r = "ok" then
fail "the %s trap accepted a restart it cannot take" what)
restarts;
(* The session, still a session. This is the whole point: the daemon
is answering, the compiler is in this process, and the program is
standing still in front of it. *)
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 while parked at the %s trap: %s" what
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And the fault taken *while already parked*, which is the first
bug this whole section fixed, relocated one level in. A handler
installed without SA_NODEFER leaves its own signal blocked for
the life of the park — and the park never returns — so a second
hardware SIGSEGV is not delivered to it at all: the kernel
forces the default action and the process dies on the spot with
no message. Fault, park, evaluate something at the break loop
that faults, daemon gone, exactly the way the author's session
went. Measured before the flag was added: the evaluation below
got no reply and the next request found a dead socket.
What is asserted is only the part that matters — that the
daemon is still there afterwards. The faulting evaluation's own
reply is an error either way (the thunk never reaches a frame
boundary) and is not worth pinning a sentence of. *)
if refault then begin
let faulting =
"(:op \"eval-expr\" :code \
\"(let [v (bytes-view \\\"refault\\\")] (set (at v 0) 90) 1)\" \
:file \"/tmp/buf.flan\")"
in
(match ask faulting with _ -> () | exception _ -> ());
let r =
try
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
with _ -> Wire.parse "(:status \"gone\")"
in
if Wire.string_field r "value" <> Some "4" then
fail
"a second fault at the %s break killed the daemon — the park \
is only as good as SA_NODEFER: %s"
what (status r)
end;
(* The one case where "just ignore that whole call" cannot hold, and
it is the same reason every other refusal at a trap has: an
evaluation that *traps* stops with no transfer channel anywhere in
the call, so there is nothing for the boundary restart to unwind
through either. It is listed — it is a live frame, and hiding it
would make the one break where it does not work the one break that
never mentions it — and it is listed as untakeable, with
[:abandon] saying there is no position to offer. Fix the
expression and evaluate it again; that is the whole of the way
out. *)
if trapping <> "" then begin
let r =
ask
(Printf.sprintf "(:op \"eval-expr\" :code %s :file \"/tmp/buf.flan\")"
(Wire.quote trapping))
in
if status r <> "error" then
fail "an expression that trapped at the %s break answered anyway"
what;
let r = ask "(:op \"break\")" in
(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 <> [ "abandon-evaluation" ] then
fail "restarts at a trap inside an evaluation: %s"
(String.concat ", " names)
| _ -> fail "break at a trap inside an evaluation listed nothing");
(match Wire.field r "unreachable" with
| Some { Form.v = Form.List [ { Form.v = Form.Int 0L; _ } ]; _ } -> ()
| _ ->
fail "the boundary restart was offered at a trap, where nothing \
can be taken");
(match Wire.field r "abandon" with
| Some { Form.v = Form.Sym "nil"; _ } -> ()
| _ ->
fail "a trap inside an evaluation named a position that abandons \
it");
(* And the reason those positions are refused, which is the half an
editor puts in front of somebody. [:abandon] being nil cannot
carry it: a break the program took on its own has a nil there
too, and captioning a segfault "below this evaluation" sends the
reader looking for an evaluation that is not there. *)
(match Wire.field r "trap" with
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ ->
fail "a break at a trap did not say it was taken by one")
end;
(* Torn down by [abort], not by [close]: a trap parks for good, so
there is no resume to wait for and nothing to gain by waiting.
Through [aborted], because this is the site where the race it
describes was actually losing: the trap's break loop calls
[die_now] from the program thread while the serve thread is still
writing the reply, and a closed socket here says the program
ended, which is what the abort asked for. The [waitpid] below is
what asserts it. *)
(match aborted c with
| None -> ()
| Some r ->
if status r <> "ok" then
fail "abort at the %s trap: %s" what
(Option.value ~default:"" (Wire.string_field r "message")))
end;
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] tpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
fail "the daemon outlived the %s trap it aborted" what;
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] tpid) with Unix.Unix_error _ -> ())
end
end
in
trap_park "free-all" "dev-trap-free-all.flan" "NoFreeAll" [ "continue" ];
trap_park ~trapping:"(do (free-all nowhere) 0)" "null allocator"
"dev-trap-null-alloc.flan" "NullAllocator" [];
(* And the one that used to be a silent death rather than an exit code:
SIGSEGV. The author's dogfooding session sorted (bytes "INSERTIONSORT")
in place — the old aliasing bytes — and the session vanished without a
word. The dev build's crash handler (flan_dev_crash_enable) enters the
same trap hook the six no-channel refusals use, so everything trap_park
asserts for them holds here too: stopped and describable, an eval still
answered, a resume refused. The program writes through bytes-view,
which is the surviving spelling of that crash. *)
trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" [];
(* ── 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; "--llvm" |]
Unix.stdin lfd Unix.stderr
in
Unix.close lfd;
if not (listening ~pid:lpid lsock) then begin
fail "the locals daemon %s" !listen_why;
(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");
(* The byte's character half, in the three shapes it has. The
spelling is one [lib/reader.ml]'s [read_byte] accepts, so
what is shown could be typed back; 7 has neither a name nor
a single-character spelling, so it stays a number rather
than growing an invented escape. *)
("byte", "u8", "97 (\\a)");
("gap", "u8", "32 (\\space)");
("ctl", "u8", "7");
(* [hop] is [dotimes]'s index and it is listed; the loop's
hidden bound sits in the very next slot and is *not* — a
compiler temp is hidden, not refused, because [s6] is not a
variable anyone can find in the file. *)
("hop", "i32", "0");
(* The shadowing rebind keeps its raw spelling here because the
outer [label] is on the same list: strip the suffix from one
and the frame shows two rows called [label] with nothing to
tell them apart. *)
("label~2", "string", "\"inner\"") ]
in
if got <> want then
fail "locals of the stopped frame: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
(* No refusal mentions an invented name: the hidden bound must be
absent from both lists, not moved to the other one. *)
(match
List.filter
(fun (n, _, _) -> String.length n > 0 && n.[0] = 's')
(pairs r "refused")
with
| [] -> ()
| rs ->
fail "a compiler temp leaked into the refusals: %s"
(String.concat ", " (List.map (fun (n, _, _) -> n) rs)));
(* 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
(* Slot for slot with the body on the stack — three u8s included,
or the *count* would catch this and the fingerprint would go
untested. Every name differs and every type matches, which is
exactly what a count cannot see. *)
"(: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) ch (u8 98) sp (u8 33) cc (u8 8)] (dotimes [pip 0] (print \\\"\\\")) (let [tag \\\"x\\\"] (restart-case (do (error (Boom {.why 7})) (let [later (i64 99)] later)) (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
data type 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; "--llvm" |]
Unix.stdin ifd Unix.stderr
in
Unix.close ifd;
if not (listening ~pid:ipid isock) then begin
fail "the inspect daemon %s" !listen_why;
(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 data type 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;
(* ── Writing one of them back ─────────────────────────────────── *)
(* The inspector's other direction. Its own daemon over the same program,
because the block above finishes by redefining [outer] under its own
frame on purpose — which is exactly the state in which nothing may be
written, so it is no state to write from.
What is checked here is the three claims the verb makes. The store
lands where the render said it would, and the value that comes back is
read out of the program afterwards rather than echoed. The expression
is checked against the *place's* type, so a literal arrives at the
width the place has and a value that does not fit is refused in the
checker's own words. And a write that cannot name the stop it was
addressed to is refused rather than aimed at whatever stack happens to
be there. *)
let wsock = tmp "set.sock" and wout = tmp "set.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-inspect.flan"; "-s"; wsock; "--llvm" |]
Unix.stdin wfd Unix.stderr
in
Unix.close wfd;
if not (listening ~pid:wpid wsock) then begin
fail "the set daemon %s" !listen_why;
(try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect wsock 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 message r = Option.value ~default:(status r) (Wire.string_field r "message") in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the set program never stopped"
else begin
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" (message listing)
else begin
let slot name =
match slot_of listing name with
| Some s -> s
| None ->
fail "the locals listing gave no slot index for %s" name;
-1
in
let set ?(path = "()") name edits =
ask
(Printf.sprintf "(:op \"set\" :frame 1 :slot %d :path %s :edits %s)"
(slot name) path edits)
in
let inspect ?(path = "()") name =
ask
(Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)"
(slot name) path)
in
(* One field, addressed the way a line of the buffer addresses it:
the path reaches the field and the edit stores at it. The reply's
value is the field read back, and the inspection after it is the
independent one — the same thunk that stored could in principle
have rendered the value it was handed rather than the storage. *)
let r = set ~path:"(\"x\")" "mark" "((:code \"3.5\"))" in
if status r <> "ok" then fail "setting mark.x: %s" (message r)
else if value r <> "3.5" then
fail "setting mark.x answered %s, not 3.5" (value r);
let r = inspect ~path:"(\"x\")" "mark" in
if value r <> "3.5" then
fail "mark.x reads back as %s after the write, not 3.5" (value r);
(* And the literal arrives at the *place's* width. Without the
expectation flowing into the checker this is the i32 three and
"expected f32, found i32"; with it, it is the f32 three, which is
the whole of what [Check.expression]'s [want] buys. *)
let r = set ~path:"(\"x\")" "mark" "((:code \"3\"))" in
if status r <> "ok" then
fail "an integer literal into an f32 field: %s" (message r)
else if value r <> "3" then
fail "the integer three into an f32 field read back as %s" (value r);
(* Several fields at once, which is the buffer commit: one module,
one job, one render of what is there afterwards. *)
let r =
set "mark" "((:path (\"x\") :code \"9.25\") (:path (\"y\") :code \"8.5\"))"
in
if status r <> "ok" then fail "setting both fields of mark: %s" (message r)
else if value r <> "(Point {.x 9.25 .y 8.5})" then
fail "the pair of writes answered %s" (value r);
if Wire.int_field r "wrote" <> Some 2 then
fail "a two-edit commit did not report writing two";
(* The whole value, not a field of it. *)
let r = set "mark" "((:code \"(Point {.x 0.5 .y 0.25})\"))" in
if status r <> "ok" then fail "setting mark whole: %s" (message r)
else if value r <> "(Point {.x 0.5 .y 0.25})" then
fail "setting mark whole answered %s" (value r);
(* An element, through the same [at] the render walks. The value is
an expression and not a literal, because the point of sending
Flan rather than a number is that it is evaluated in the
program. *)
let r = set "xs" "((:path (1) :code \"(+ 20 5)\"))" in
if status r <> "ok" then fail "setting xs[1]: %s" (message r)
else if value r <> "[ 10 25 30]" then
fail "setting xs[1] answered %s" (value r);
(* A value that does not fit is refused in the checker's own words,
and nothing is stored. *)
let r = set ~path:"(\"x\")" "mark" "((:code \"\\\"hello\\\"\"))" in
if status r <> "error" then
fail "a string stored into an f32 field was accepted"
else if not (contains_sub (message r) "expected f32") then
fail "the type refusal does not name the type: %s" (message r);
let r = inspect "mark" in
if value r <> "(Point {.x 0.5 .y 0.25})" then
fail "the refused write changed something: %s" (value r);
(* Two refusals about where, not about what. A data type's field has
no address that does not also settle the tag, and an option's
payload has none that does not settle whether there is one. Both
are readable — the block above reads them — which is the point:
what can be shown and what can be stored to are different sets,
and each refusal says which it is. *)
let r = set ~path:"(\"Shape.Rect.w\")" "s" "((:code \"11\"))" in
if status r <> "error" then
fail "a data type's case field was written to"
else if not (contains_sub (message r) "tag") then
fail "the data type refusal does not say why: %s" (message r);
let r = set ~path:"(some)" "box" "((:code \"(Point {.x 1.0 .y 1.0})\"))" in
if status r <> "error" then
fail "an option's payload was written to on its own"
else if not (contains_sub (message r) "None") then
fail "the option refusal does not say why: %s" (message r);
(* An edit whose path is impossible refuses the whole commit, so the
good edit beside it does not land either. All-or-nothing is what
makes one module per commit worth anything. *)
let r =
set "mark" "((:path (\"x\") :code \"77.0\") (:path (\"z\") :code \"1.0\"))"
in
if status r <> "error" then fail "a commit with a bad field was taken";
let r = inspect ~path:"(\"x\")" "mark" in
if value r <> "0.5" then
fail "half of a refused commit landed anyway: %s" (value r);
(* And a write addressed to a stop the program is no longer at is
refused before anything is built. The number is one the program
cannot be at — generations start at one and count up — so this is
the mismatch and not a program that happens to have moved. *)
let r =
ask
(Printf.sprintf
"(:op \"set\" :frame 1 :slot %d :path () :edits ((:code \"(Point {.x 2.0 .y 2.0})\")) :at-stop 999999)"
(slot "mark"))
in
if status r <> "error" then
fail "a write against a stop the program is not at was taken"
else if not (contains_sub (message r) "Look again") then
fail "the stale-stop refusal does not say what to do: %s" (message r);
(* The stop the reads have been carrying all along is the one the
writes have been landing at, which is what makes the editor able
to hold it between the two. *)
let r = inspect "mark" in
(match Wire.int_field r "at-stop" with
| Some g when g > 0 ->
let r =
ask
(Printf.sprintf
"(:op \"set\" :frame 1 :slot %d :path (\"y\") :edits ((:code \"4.5\")) :at-stop %d)"
(slot "mark") g)
in
if status r <> "ok" then
fail "a write naming the stop it read at: %s" (message r)
else if value r <> "4.5" then
fail "the write naming its stop answered %s" (value r)
| _ -> fail "an inspection did not say which stop it read at")
end;
(* An unbound slot has nothing to store to, and says so rather than
faulting on the game thread of a program that is already stopped. *)
let r = ask "(:op \"set\" :frame 0 :slot 0 :path () :edits ((:code \"1\")))" in
if status r <> "error" then
fail "a frame with no slots was written to"
end;
(* And a running program has no frame to store into. The same refusal
the read half gives, through the same check, which is the point of
it being the same check. *)
let r = ask "(:op \"restart\" :name \"carry-on\")" in
if status r <> "ok" then
fail "resuming the set program: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the set program never resumed"
else begin
let r = ask "(:op \"set\" :frame 1 :slot 0 :path () :edits ((:code \"1\")))" in
if status r <> "error" then
fail "a running program was written to"
end;
ignore (ask "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] wpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] wpid) with Unix.Unix_error _ -> ())
end
end;
(* ── A pointer the registry knows about ───────────────────────── *)
(* The inspector's pointer arm, and the address root beside it.
[programs/dev-ptr.flan] carried the two lines a session answers with in
its own header and said, in the header, that they had been read off a
running session **by hand**. This is the case that makes that stop
being true. Nothing else drives it: [programs/registry.flan] asserts
the *table* from the acceptance side — live or not, in a dev build and
a release one — and says nothing about what an inspector renders.
The claim has two halves and they are what the registry bought. A
pointer into live Vec storage is *followed*, one level deeper, and its
pointee rendered by the same walk as anything else. A pointer into
storage that has been freed is not followed, and names what died there
instead. Both pointers have the same static type, so nothing but the
table can tell them apart — which is the whole argument of "permission,
not identification". *)
let psock = tmp "ptr.sock" and pout = tmp "ptr.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-ptr.flan"; "-s"; psock; "--llvm" |]
Unix.stdin pfd Unix.stderr
in
Unix.close pfd;
if not (listening ~pid:ppid psock) then begin
fail "the pointer daemon %s" !listen_why;
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect psock 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 value r = Option.value ~default:"" (Wire.string_field r "value") in
let message r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
let flag r key =
match Wire.field r key with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let starts s pre =
String.length s >= String.length pre
&& String.equal (String.sub s 0 (String.length pre)) pre
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 pointer program never stopped"
else begin
let entries r =
match Wire.field r "locals" 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; _ }; _ ] -> Some (n, ty, v)
| _ -> None)
l
| _ -> []
in
let listing = ask "(:op \"locals\" :frame 1)" in
if status listing <> "ok" then
fail "locals of the frame holding the two pointers: %s"
(message listing)
else begin
let got = entries listing in
let find n = List.find_opt (fun (m, _, _) -> String.equal m n) got in
(* The live half, asserted whole. A pointer with nobody to ask
renders [<ptr>]; this is what having somebody to ask buys. *)
(match find "live" with
| Some ("live", "(Ptr Enemy)", "<ptr (Enemy {.hp 41 .x 2})>") -> ()
| Some (_, ty, v) ->
fail "a live pointer into Vec storage rendered %s : %s" v ty
| None ->
fail "the frame holding the two pointers listed no `live': %s"
(String.concat ", " (List.map (fun (n, _, _) -> n) got)));
(* And the dead half, asserted *around* the step number and never on
it. The step is the registry's own event counter: it moves if
anything allocates or frees ahead of this program's two Vecs, and
the program's header says so. What is being claimed is that the
pointer was not followed and that what died is named. *)
(match find "dead" with
| None -> fail "the frame holding the two pointers listed no `dead'"
| Some (_, ty, v) ->
if ty <> "(Ptr Enemy)" then
fail "the dead pointer's type is %s, not (Ptr Enemy)" ty;
let pre = "<ptr dead: was Enemy, freed at step " in
if not (starts v pre && String.length v > String.length pre
&& v.[String.length v - 1] = '>')
then fail "a pointer into freed Vec storage rendered %s" v
else
let n =
String.sub v (String.length pre)
(String.length v - String.length pre - 1)
in
if int_of_string_opt n = None then
fail "the epitaph's step is %S, which is not a number" n;
(* No address in it, and that is deliberate rather than an
omission: an address is not stable across two runs, so
printing one would make this very assertion depend on where
the heap landed. *)
if contains v "0x" then
fail "the epitaph carried an address: %s" v)
end;
(* ── The address root ─────────────────────────────────────── *)
(* [(:op "at" :addr N)] is the rooting mode with no frame in it. The
two addresses are left in globals by the program, which is how a
person at a break loop reaches them too — a global is evaluable by
name while stopped and a local is not. *)
let addr name =
let r =
ask (Printf.sprintf "(:op \"eval-expr\" :code %S :file \"<t>\")" name)
in
if status r <> "ok" then None else int_of_string_opt (value r)
in
(match (addr "live-addr", addr "dead-addr") with
| Some live, Some dead when live > 0 && dead > 0 ->
(* The type is not given, so the answer for it is the registry's
own — the recorded *string*, resolved back to a type by the
session. That resolution is the whole of what item 3 needed and
it is what this line is really asserting: nothing but the table
said `Enemy' here. *)
let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" live) in
if status r <> "ok" then fail "pointing at a live address: %s" (message r)
else begin
if value r <> "<ptr (Enemy {.hp 41 .x 2})>" then
fail "the address root rendered %s at a live address" (value r);
if Option.value ~default:"" (Wire.string_field r "type")
<> "(Ptr Enemy)"
then
fail "the address root resolved the recorded name to %s"
(Option.value ~default:"" (Wire.string_field r "type"));
if not (flag r "live") then
fail "a live address came back not live";
if Option.value ~default:"" (Wire.string_field r "recorded")
<> "Enemy"
then fail "the reply did not carry what the table recorded"
end;
(* And the dead one, by the same route and with the same type,
which is the point: the static type cannot tell these apart. *)
let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" dead) in
if status r <> "ok" then fail "pointing at a dead address: %s" (message r)
else begin
if not (starts (value r) "<ptr dead: was Enemy, freed at step ")
then fail "the address root rendered %s at a dead address" (value r);
if flag r "live" then fail "a freed address came back live"
end;
(* A named :type wins over the recorded one and is not checked
against it — overriding is the point of being able to say it —
but the disagreement is never silent: [:recorded] is carried
whenever the table had a name. *)
let r =
ask (Printf.sprintf "(:op \"at\" :addr %d :type \"i32\")" live)
in
if status r <> "ok" then
fail "reading a live address as a named type: %s" (message r)
else begin
if value r <> "<ptr 41>" then
fail "a named :type did not win over the recorded one: %s"
(value r);
if Option.value ~default:"" (Wire.string_field r "recorded")
<> "Enemy"
then fail "an overridden read did not say what was recorded"
end;
(* An address inside an element rather than at one. Rendering the
element type there would show one element's tail as another's
head — a plausible-looking answer, which is the worst kind — so
it is refused with the offset, and a named :type reads it
anyway. *)
let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" (live + 1)) in
if status r <> "error" then
fail "an address inside an element answered anyway: %s" (value r)
else if not (contains (message r) "inside an element") then
fail "a misaligned address was refused without saying why: %s"
(message r);
let r =
ask (Printf.sprintf "(:op \"at\" :addr %d :type \"i32\")" (live + 4))
in
if status r <> "ok" then
fail "a named :type did not reach the second half of an element: %s"
(message r)
else if value r <> "<ptr 2>" then
fail "reading the second i32 of an Enemy gave %s" (value r)
| _ ->
fail "the program did not leave its two addresses in globals");
(* An address the registry has never seen is a fact and not a failure
— a stack local, a global, or a pointer from C — and with no
[:type] there is nothing to say what is there. Refused by name,
rather than answered with bytes. *)
let r = ask "(:op \"at\" :addr 12345)" in
if status r <> "error" then
fail "an address the registry never saw was rendered anyway: %s"
(value r)
else if not (contains (message r) "never seen") then
fail "an unknown address was refused without saying why: %s" (message r);
(* ── The breakdown, and what is still held ─────────────────── *)
(* Both are one walk over the table in [flan_dev.c] with the dead
left out of the second, and the difference between the two answers
is the assertion: this program freed one of its two Enemy blocks,
so the breakdown has both and the leak report has one. Counting
only the rows would pass with the walk stubbed out; counting the
difference cannot. *)
let enemy r =
match Wire.field r "types" with
| Some { Form.v = Form.List l; _ } ->
List.fold_left
(fun acc (e : Form.t) ->
match e.Form.v with
| Form.List
[ { Form.v = Form.Str "Enemy"; _ };
{ Form.v = Form.Int n; _ }; { Form.v = Form.Int b; _ } ] ->
Some (Int64.to_int n, Int64.to_int b)
| _ -> acc)
None l
| _ -> None
in
let all = ask "(:op \"allocations\")" in
let live = ask "(:op \"leaks\")" in
if status all <> "ok" then fail "the breakdown by type: %s" (message all)
else if status live <> "ok" then fail "the leak report: %s" (message live)
else begin
(match (enemy all, enemy live) with
| Some (2, _), Some (1, _) -> ()
| got, held ->
let say = function
| None -> "no row"
| Some (n, b) -> Printf.sprintf "%d blocks, %d bytes" n b
in
fail
"the table should hold two Enemy blocks with one of them freed; \
the breakdown says %s and the leak report says %s" (say got)
(say held));
(* Ordered biggest first, by bytes. A breakdown read in table order
is a list of everything and answers nothing; biggest-first is the
answer to "where did the memory go", which is the only reason
either verb exists. *)
let bytes r =
match Wire.field r "types" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List [ _; _; { Form.v = Form.Int b; _ } ] ->
Some (Int64.to_int b)
| _ -> None)
l
| _ -> []
in
let rec descending = function
| a :: (b :: _ as rest) -> a >= b && descending rest
| _ -> true
in
if not (descending (bytes all)) then
fail "the breakdown is not ordered biggest first";
(* And a leak report is a subset of the breakdown, always: nothing
can be live that was never recorded. *)
let sum r = List.fold_left ( + ) 0 (bytes r) in
if sum live > sum all then
fail "the leak report holds more bytes than the whole table does"
end
end;
(* And a running program is refused. There is no frame here to be
redefined under us — the registry is a table and not a stack — but
live-or-dead is exactly what a running program is changing, so an
answer read mid-frame is an answer about a moment that has gone. *)
let r = ask "(:op \"restart\" :name \"carry-on\")" in
if status r <> "ok" then
fail "resuming the pointer program: %s" (message r);
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the pointer program never resumed"
else begin
let r = ask "(:op \"at\" :addr 4096)" in
if status r <> "error" then
fail "a running program answered the address root"
end;
ignore (ask "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] ppid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ppid) 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; "--llvm" |]
Unix.stdin gfd Unix.stderr
in
Unix.close gfd;
if not (listening ~pid:gpid gsock) then begin
fail "the globals daemon %s" !listen_why;
(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 docs/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 (aborted c);
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; "--llvm" |]
Unix.stdin dfd Unix.stderr
in
Unix.close dfd;
if not (listening ~pid:dpid dsock) then begin
fail "the disassembly daemon %s" !listen_why;
(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 = contains_sub 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.
[--llvm] with it, and the two go together: [llc] is only in the loop at
all on that backend, so a session that defaulted to x86 would assemble
its modules with [as] and deliver them, and the window this reproduces
would never open. *)
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; "--llvm" |]
env Unix.stdin sfd Unix.stderr
in
Unix.close sfd;
if not (listening ~pid:spid ssock) then begin
fail "the daemon with no working llc %s" !listen_why;
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect ssock in
let has = contains_sub 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 ];
(* ── A program that prints more than the pipe holds ─────────────── *)
(* The one thing every other fixture in this file is too quiet to reach.
In a merged build the program's stdout is a 64K pipe back into the
daemon's own process, and the only reader is the select in
[Dev.accept_loop] — which is not running while [serve] is answering a
request. [programs/dev-chatty.flan] prints 4K a frame, so those 64K are
full within sixteen frames, which is far less than a module takes to
build. The game thread is then stopped inside [fwrite] and reaches no
frame boundary at all; the thunk this evaluation delivers has nowhere to
run.
What that used to produce was five seconds of polling and then "the
program did not reach a frame boundary; is it calling (agent/poll)?" —
about a program whose every frame calls it. A diagnostic that names the
wrong cause is worse than none, because it is believed.
Three claims, and the third is not decoration. The value comes back, so
the thunk ran. The reply is not the frame-boundary sentence, so the
timeout is not being reached by some other route. And the program's text
rides on the reply as [:output] — which is the claim that the drain went
through [Dev.drain] and not [Dev.take]: a wait that took the buffer and
threw it away would satisfy the first two and silently delete the output
the evaluation itself caused, which is the output anyone wants to see. *)
let csock = tmp "chatty.sock" and cout = tmp "chatty.out" in
(try Sys.remove csock with Sys_error _ -> ());
let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let cpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-chatty.flan"; "-s"; csock |]
Unix.stdin cfd Unix.stderr
in
Unix.close cfd;
if not (listening ~pid:cpid csock) then begin
fail "the chatty daemon %s" !listen_why;
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
(* And the default backend, on the first flagless daemon in this file
that does not need the shadow stack. No flag was given above, so what
it built through is what [flan dev] builds through when nobody says:
[start_merged] writes the host's listing beside the binary and names
it [host.s] or [host.ll] by the backend that produced it, so the
extension is the whole of the claim. Here rather than in a daemon of
its own because this one is already standing and the answer costs a
[stat] -- the opt-in half is checked the same way on the [--llvm]
daemon further down. *)
let chost ext =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" cpid))
("host." ^ ext)
in
if not (Sys.file_exists (chost "s")) then
fail "flan dev with no backend flag did not build through x86: %s is \
not there"
(chost "s");
if Sys.file_exists (chost "ll") then
fail "flan dev with no backend flag left LLVM IR at %s" (chost "ll");
let c = connect csock in
(* Long enough for the program to have run the sixteen frames that fill
the pipe before anything is asked of the daemon. It prints at 4K a
frame with a 1ms wait between them, so this is an order of magnitude
more than it needs — the point is only that the pipe is full when the
request lands, not how full. *)
ignore (Unix.select [] [] [] 0.3);
let started = Unix.gettimeofday () in
let r =
request c "(:op \"eval-expr\" :code \"(+ 20 22)\" :file \"/tmp/chatty.flan\")"
in
let took = Unix.gettimeofday () -. started in
let said = Option.value ~default:"" (Wire.string_field r "message") in
if status r <> "ok" then
fail "evaluating against a program that is printing: %s" said
else if Wire.string_field r "value" <> Some "42" then
fail "the value from a printing program is %s"
(Option.value ~default:"none" (Wire.string_field r "value"));
if contains_sub said "agent/poll" then
fail
"a printing program was diagnosed as one that is not polling, which \
is the defect and not the symptom";
(* The only job this number has is to sit under the daemon's own
five-second wait, so that "it answered" and "it gave up" cannot be
confused. It is not a measurement of how fast a module builds, and it
is deliberately not tightened into one: [listening] above records 6.8s
for a cold build under dune's parallelism, and a suite that goes red
on a loaded machine teaches whoever is running it to skim past red.
The two assertions that actually discriminate are the status and the
absence of the frame-boundary sentence; this one only rules out a
timeout that somehow reported success. *)
if took > 4.5 then
fail "evaluating against a printing program took %.1fs" took;
(* And the program's own text came back on the reply rather than being
drained into nothing. *)
(match Wire.string_field r "output" with
| Some o when contains_sub o "......" -> ()
| Some _ -> fail "the reply carried output, but not the program's"
| None ->
fail
"the evaluation drained the program's pipe and kept none of it, so \
the output it caused is gone");
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] cpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ csock; cout ];
(* ── An expression that signals, and the sentence it gets ───────── *)
(* The other way the wait used to name the wrong cause, and the one that
was reported from a real session: an expression evaluated from a buffer
signalled a [BoundsError], the thunk stopped in the break loop, and five
seconds later the daemon said "the program did not reach a frame
boundary; is it calling (agent/poll)?" — on a reply that said
[:stopped t :condition "BoundsError"] two fields along. The program had
reached the boundary, run the thunk, and stopped in it.
The chatty block above is the same failure from the other end: there the
sentence was wrong because the program could not get to a boundary, here
because it got there and the thunk never came back. Both now answer what
is true of them.
Three claims. The condition is named, and named from what the agent
reported rather than from anything guessed here — a [BoundsError] and
not an [error] the fixture raises, because the fixture raises none and
the expression is the whole of what stops. The frame-boundary sentence
is *not* said. And it is said at once: a thunk in the break loop
produces no value until someone answers the break, so waiting for one is
waiting for nothing, and the wait disappearing is the point of the
change rather than a side effect of it.
[--llvm], and the x86 half of the same claim is on the [dev-pause]
daemon further down, where an expression that errs inside a thunk is
already evaluated against the default backend. The diagnostic is
backend-independent — it is read off [status] and nothing else — so a
daemon each is what covers it without a third compile. *)
let sigsock = tmp "signal.sock" and sigout = tmp "signal.out" in
(try Sys.remove sigsock with Sys_error _ -> ());
let sigfd =
Unix.openfile sigout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let sigpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; sigsock; "--llvm" |]
Unix.stdin sigfd Unix.stderr
in
Unix.close sigfd;
if not (listening ~pid:sigpid sigsock) then begin
fail "the signalling-expression daemon %s" !listen_why;
(try Unix.kill sigpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect sigsock in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
(* A value first, so that "it answered fast" below is about this
expression and not about a daemon that was refusing everything. *)
let r =
request c "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/signal.flan\")"
in
if Wire.string_field r "value" <> Some "2" then
fail "the signalling-expression daemon did not evaluate a plain one: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* [(+ ticks 100)] rather than a literal 9: [ticks] is the fixture's own
counter and is never negative, so the index is out of a length-4 array
whatever the program has got to, and it is out of range at run time
rather than at check time. *)
let started = Unix.gettimeofday () in
let r =
request c
"(:op \"eval-expr\" :code \"(at [1 2 3 4] (i32 (+ ticks 100)))\" \
:file \"/tmp/signal.flan\")"
in
let took = Unix.gettimeofday () -. started in
let said = Option.value ~default:"" (Wire.string_field r "message") in
if status r <> "error" then
fail "an expression that signalled was reported as %s" (status r);
if not (contains_sub said "stopped on BoundsError") then
fail "an expression that signalled was reported as: %s" said;
if contains_sub said "agent/poll" then
fail
"a thunk stopped in the break loop was diagnosed as a program that \
is not polling, which is the defect and not the symptom";
(* Under the daemon's own five-second wait, and measured the way the
chatty block measures: the clock starts before the module is built, so
a compile on a loaded machine is inside this number and the bound is
not a measurement of anything. What it rules out is the one thing that
matters — the wait being spent before the answer. *)
if took > 4.5 then
fail "an expression that signalled took %.1fs to say so" took;
(* And the machine-readable half, which the editor reads rather than the
sentence: the break buffer opens off these two fields. *)
if not (stopped r) then
fail "an expression that signalled did not carry :stopped";
if Wire.string_field r "condition" <> Some "BoundsError" then
fail "an expression that signalled carried :condition %s"
(Option.value ~default:"<none>" (Wire.string_field r "condition"));
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] sigpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill sigpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] sigpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sigsock; sigout ];
(* --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 ~pid:gpid gsock) then begin
fail "the --debug daemon %s" !listen_why;
(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 = contains_sub 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 ~pid:wpid wsock) then
fail "the watch daemon %s" !listen_why
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 ───────── *)
(* docs/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 ~pid:ppid psock) then begin
fail "the pause daemon %s" !listen_why;
(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;
(* The other way a thunk reaches a [(pause)], and the one no flag asks
for: an ordinary [C-x C-e] over an expression that calls a body
somebody marked earlier. The mark is the one above, set on a
declaration rather than on the expression, and the expression knows
nothing about it.
Its own function, and one the program never calls. Marking [step]
would stop the *program* within 5ms — before the module is even built
— and the reply would then be right about a break that was nothing to
do with the thunk. The claim is about a stop the expression caused, so
the fixture has to leave only one way to reach it.
[ok] with the note, not the error the signalling case gets. A
breakpoint firing is the feature working; "the break loop is holding
it: take a restart, or abort" would be telling somebody to abort out
of the breakpoint they set on purpose. *)
let idle = "(defn idle [] i64 (+ 1 1))" in
let icol =
let n = String.length "(+ 1 1)" in
let rec find i =
if i + n > String.length idle then 0
else if String.equal (String.sub idle i n) "(+ 1 1)" then i + 1
else find (i + 1)
in
find 0
in
if icol = 0 then fail "the marked-body test cannot find its own target";
let r =
ask
(Printf.sprintf
"(:op \"eval\" :code %s :file \"/tmp/buf.flan\" :pause (1 %d))"
(Wire.quote idle) icol)
in
if status r <> "ok" then
fail "installing a marked body the program never calls: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
(* Nothing has stopped: the program does not call [idle], so the mark
sits there until the expression below reaches it. Without this the
assertions after it would pass off the program's own break. *)
ignore (Unix.select [] [] [] 0.05);
if stopped (ask "(:op \"describe\")") then
fail "marking a body the program never calls stopped it anyway";
let started = Unix.gettimeofday () in
let r =
ask "(:op \"eval-expr\" :code \"(idle)\" :file \"/tmp/buf.flan\")"
in
let took = Unix.gettimeofday () -. started in
if status r <> "ok" then
fail
"a plain expression that reached a marked (pause) 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 stopped at a marked (pause) answered with a value";
(match Wire.string_field r "note" with
| Some n when contains_sub n "(pause)" -> ()
| n ->
fail "an expression stopped at a marked (pause) noted: %s"
(Option.value ~default:"<none>" n));
if not (stopped r) then
fail "an expression stopped at a marked (pause) did not carry :stopped";
if Wire.string_field r "condition" <> Some "Pause" then
fail "an expression stopped at a marked (pause) carried :condition %s"
(Option.value ~default:"<none>" (Wire.string_field r "condition"));
(* And at once. Before the stop generation this fell past every test
the wait had and spent the whole five seconds, to end on the
frame-boundary sentence about a program that was polling fine. *)
if took > 4.5 then
fail "an expression that reached a marked (pause) took %.1fs" took;
(* Unwound before anything else runs, or every check below this would
be reading the thunk's break instead of its own. *)
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continue at a marked body'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 a marked body's breakpoint"
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 started = Unix.gettimeofday () in
let r =
ask "(:op \"eval-expr\" :code \"(i64 (boom))\" :file \"/tmp/buf.flan\")"
in
let took = Unix.gettimeofday () -. started in
if status r <> "error" then
fail "an expression that erred inside a thunk answered anyway";
(* And it says so rather than waiting the wait out. A thunk in the break
loop will not produce a value until someone answers the break, so the
five seconds buy nothing — they used to be spent and then reported as
a program that was not polling. 4.5 for the chatty block's reason and
not because that is how long this takes: the clock starts before the
module is built, so a loaded machine's compile is inside this number,
and the only claim being made is that the daemon's own five-second
wait was not spent. *)
if took > 4.5 then
fail "an expression that erred inside a thunk took %.1fs to say so" took;
(match Wire.string_field r "message" with
| Some m when contains_sub m "stopped on Missing" -> ()
| m ->
fail "an expression that erred inside a thunk was reported as: %s"
(Option.value ~default:"" m));
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";
(* And the pair that the condition's *name* cannot separate, which is
what the stop generation is here for. Stop the program on [Missing],
then evaluate an expression that stops on [Missing] as well: two
readings of [status] are the same four words, and "is this still the
break I came in on" has no answer in them. [snap_push] mints a
generation on every break entry including a nested one, so the
second stop is a *number* larger than the first and the thunk's
break is told apart from the one it was evaluated inside.
Both halves are asserted, because either alone would pass for the
wrong reason: the sentence, which a name-only test would get wrong
by saying nothing had stopped, and the clock, which is the whole
difference between recognising the stop and waiting the five seconds
out and then guessing at it. *)
let r =
ask "(:op \"eval-expr\" :code \"(i64 (boom))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stops the program was reported as %s"
(status r);
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the program never stopped ahead of the same-condition case"
else begin
let started = Unix.gettimeofday () in
let r =
ask
"(:op \"eval-expr\" :code \"(i64 (boom))\" :file \"/tmp/buf.flan\")"
in
let took = Unix.gettimeofday () -. started in
(match Wire.string_field r "message" with
| Some m when contains_sub m "stopped on Missing" -> ()
| m ->
fail
"a thunk that stopped on the condition its break was already \
on was reported as: %s"
(Option.value ~default:(status r) m));
if took > 4.5 then
fail
"the same-condition case took %.1fs, so it was found by waiting \
rather than by the stop generation"
took
end
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 ~pid:tpid tsock) then
fail "--two-process %s" !listen_why
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";
(* And the one verb this shape cannot have. Running [main] again means
waking a thread that parked inside this process, and here the program
is a child: when it finishes it is gone, and there is nothing to wake.
Refused by naming what this daemon is rather than with the message a
merged one gives, because "the program is already running" would send
somebody back to try again after it had exited — and [--x86] arrives
here too, since it refuses the merged daemon for the -rdynamic reason
given below. *)
let r = ask "(:op \"rerun\")" in
let why = Option.value ~default:(status r) (Wire.string_field r "message") in
if status r <> "error" then
fail "--two-process answered a rerun it cannot perform"
else if not (contains_sub why "two-process") then
fail "--two-process refuses a rerun as: %s" why;
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 ];
(* ── And the program must not outlive the daemon that owns it ──── *)
(* The case above ends with [close], which is a daemon going away the
polite way: [two_process]'s [Fun.protect ~finally] runs and kills its
child on the way out. This is the other way, and it is the one that
actually happens — a harness tearing down a daemon it has given up on,
a watchdog firing, somebody with [kill -9]. SIGKILL runs no finally
block, so what used to be left behind was the program: ppid 1, a loop
with nobody to talk to, an agent socket nothing will ever connect to.
Eight of those were sitting on the machine this was written on, the
oldest six days old, and one had been minted by this suite.
SIGKILL and not SIGTERM, and that is the difference between a test and a
test-shaped thing: SIGTERM lets the daemon tear down normally and kill
the child the way it always did, so the assertion below would be just as
green with the fix reverted.
[dev-watch.flan] for the same reason, and it is the subtler half. The
daemon's read end of the program's stdout pipe is no longer inherited by
the program (see [two_process]), so a program that *prints* now takes
SIGPIPE on its next line once the daemon is gone and dies of that. That
is a welcome second net and it is not the mechanism: it does nothing for
a program that is quiet, which is most of them between frames.
dev-watch never writes to stdout — it spins on [agent/wait] and pushes
into the watch table — so the only thing that can end it here is the one
being tested.
Its own daemon, because there is nothing left to ask a daemon after you
have killed it, and the source is one the suite has already built, so
the object cache answers and this costs a link. *)
let osock = tmp "orphan.sock" and oout = tmp "orphan.out" in
(try Sys.remove osock with Sys_error _ -> ());
let ofd =
Unix.openfile oout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let opid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-watch.flan"; "-s"; osock;
"--two-process" |]
Unix.stdin ofd ofd
in
Unix.close ofd;
(* Gone, or a zombie nobody has collected yet. Both mean the process
stopped, and which one is visible depends on how promptly whoever
adopted the orphan gets round to reaping it — asserting only on the
/proc entry disappearing would make this flaky for a reason that has
nothing to do with what it tests. The state is the character two past
the last ')' and not the third field of a split, because the comm field
is parenthesised and may contain spaces. *)
let stopped_running pid =
match open_in (Printf.sprintf "/proc/%d/stat" pid) with
| exception Sys_error _ -> true
| ic ->
let line = try input_line ic with End_of_file -> "" in
close_in ic;
(match String.rindex_opt line ')' with
| Some i when i + 2 < String.length line -> line.[i + 2] = 'Z'
| _ -> true)
in
if not (listening ~pid:opid osock) then begin
fail "the orphan-watch daemon %s" !listen_why;
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
(* One round trip first, so that what is killed below is a daemon that
was demonstrably serving and a program that was demonstrably up. A
daemon that had already fallen over would strand nothing, and the
assertion would pass by having nothing to prove. *)
let oc = connect osock in
if status (Wire.parse (Wire.send oc "(:op \"describe\")"; Wire.recv oc))
<> "ok"
then fail "the orphan-watch daemon would not describe itself";
(* The program is a grandchild of this process, so [waitpid] on it is
ECHILD and /proc is the only place to look. [children] is the kernel's
own answer to "whose parent is this", which beats scanning /proc and
matching on a name — and it is read *before* the kill, because after
it the relationship it answers about no longer exists. *)
let kids =
match open_in (Printf.sprintf "/proc/%d/task/%d/children" opid opid) with
| exception Sys_error _ -> []
| ic ->
let line = try input_line ic with End_of_file -> "" in
close_in ic;
List.filter_map int_of_string_opt (String.split_on_char ' ' line)
in
let program =
List.find_opt
(fun pid ->
match Unix.readlink (Printf.sprintf "/proc/%d/exe" pid) with
| link -> Filename.basename link = "program"
| exception Unix.Unix_error _ -> false)
kids
in
(try Unix.close oc with Unix.Unix_error _ -> ());
(match program with
| None ->
fail "the --two-process daemon had no program child to strand";
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ())
| Some child ->
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] opid) with Unix.Unix_error _ -> ());
if not (await ~ms:5000 (fun () -> stopped_running child)) then begin
fail
"the program outlived the daemon that owned it: %d was still \
running five seconds after the daemon was SIGKILLed"
child;
(try Unix.kill child Sys.sigkill with Unix.Unix_error _ -> ())
end)
end;
(try ignore (Unix.waitpid [ Unix.WNOHANG ] opid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ];
(* A program that never calls [agent/start], which is the one condition on
which the two shapes of [flan dev] deliberately disagree. [two_process]
kills its child and [failwith]s: the program is a separate process, the
daemon owns it, and a daemon with nothing to deliver to is useless.
[merged_serve] prints a warning and serves anyway, because the thing it
would have to kill is itself — an editor connected to it still deserves
[describe], [defs] and the program's output, and only a *delivery*
needs the agent.
That second policy was held up by nothing at all. Nothing in the suite
reached lib/dev.ml's warning branch, and the shape of the mistake it
guards against is a small one: copying the daemon's answer back into
the merged path is the obvious tidy-up, and it would turn every program
without an agent into a session that dies at startup, silently, because
no test would have noticed.
So what is asserted is the policy and not the sentence: the session
answers. The warning text is checked second, as the evidence that this
is the branch that produced it and not some other path that happened to
work.
WHEN it answers is asserted too, and that is the newer half. The wait
for the agent socket used to sit in front of [accept_loop], so this
[describe] could not arrive until the ten seconds had run out — the
block's cost, and every real session's first keystroke. The wait is a
deadline the session passes now ([Dev.agent_check]), so the reply comes
back immediately and the sentence is said later, by the accept loop,
once the deadline is behind it. The second half is what still costs ten
seconds here: a warning about a program that is never going to start an
agent cannot honestly be said before waiting for one.
[describe] and not a cheaper op on purpose: it is what
[emacs/flan.el] sends straight after [flan--open] (flan.el:646) and
what its poll sends after that, so this is the stall a person would
actually have felt. *)
let nsock = tmp "noagent.sock" and nlog = tmp "noagent.log" in
(try Sys.remove nsock with Sys_error _ -> ());
(* Its own stderr, unlike every other daemon here: the warning is the
evidence and it is written there. *)
let nfd =
Unix.openfile nlog [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
(* [--llvm] here, on a daemon that was going to stand up anyway: the
opt-in is the other half of the default checked at the top of this file,
and proving it costs the same [stat] on the same directory. It also
keeps one merged LLVM daemon in the suite now that a flagless one is an
x86 one -- this test is about a program with no [(agent/start ...)],
which is a claim about the daemon and not about a backend, so it is the
cheapest place for both. *)
let npid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-noagent.flan"; "-s"; nsock; "--llvm" |]
Unix.stdin nfd nfd
in
Unix.close nfd;
if not (listening ~pid:npid nsock) then
fail "the agentless daemon %s" !listen_why
else begin
let nhost ext =
Filename.concat
(Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" npid))
("host." ^ ext)
in
if not (Sys.file_exists (nhost "ll")) then
fail "flan dev --llvm did not build through LLVM: %s is not there"
(nhost "ll");
if Sys.file_exists (nhost "s") then
fail "flan dev --llvm left an x86 listing at %s" (nhost "s");
let nc = connect nsock in
(* The exception arm is not defensive: a session that adopted the
daemon's policy would exit here, and the connection would come back
ECONNRESET rather than with a status. Reported by name because an
uncaught [Unix_error] out of a test binary says nothing about which
test. *)
let nt0 = Unix.gettimeofday () in
(match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with
| r when status r = "ok" -> ()
| r ->
fail "a program without (agent/start ...) was not served: describe: %s"
(status r)
| exception e ->
fail
"a program without (agent/start ...) ended the session instead of \
drawing a warning: %s" (Printexc.to_string e));
let ndt = Unix.gettimeofday () -. nt0 in
(* Two seconds, against a stall that was ten and a reply that is a
fraction of one. The threshold is loose on purpose: what is being
held is "the session does not wait for the program's socket before
answering", and a number close to the real cost would fail on a
loaded machine for a reason that has nothing to do with the wait. *)
if ndt > 2. then
fail
"the first editor request waited %.1fs on a program without \
(agent/start ...); the accept loop is gated on the agent again"
ndt;
(* Dropped rather than closed with [(:op "close")], and the difference
is the rest of this row: [close] ends the session, the process
[_exit]s, and the deadline below would be waited out by nobody. A
dropped connection leaves the accept loop cycling, which is where
the sentence is said from. *)
(try Unix.close nc with Unix.Unix_error _ -> ())
end;
(* And the sentence, which arrives after the deadline rather than before
the loop. Awaited with the daemon still alive — the accept loop is what
says it, so killing first would be testing that a dead process does not
print. Generous against the ten-second deadline for the reason the
threshold above is loose. *)
let nlog_says () =
contains_sub
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "")
"does it call (agent/start ...)?"
in
ignore (await ~ms:30000 nlog_says);
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ());
if not (nlog_says ()) then
fail
"a program without (agent/start ...) drew no warning from flan dev:\n%s"
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "");
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ nsock; nlog ];
(* ── ...and what a delivery to one is told ────────────────────────
The row above is about the daemon's own stderr. This one is about the
reply an editor gets for a redefinition, and it is here because that
reply was never pinned and this lane changed which of two it is.
[install_note] has a sentence for a RUNNING program whose socket is not
bound — queued, installs at its next [(agent/poll)], not at all if there
is never one. It was true of exactly one thing: a merged session whose
program links the agent, so the ring is reachable in-process, but has
not got to its [(agent/start ...)] yet. The constructor closed that
window, so nothing reaches the sentence any more; the late-agent row
below asserts its absence, and FIX.org says the branch can be retired.
A program that does not link the agent at all never reached it either,
and this row is what says so rather than leaving it to be assumed. There
is no agent in this process to call and no socket to fall back to, so
the delivery is REFUSED — which is the honest answer and not the note:
"queued" would have promised a poll that has nothing to drain.
It needs the program to be running, which is why it is not folded into
the row above: dev-noagent.flan's main returns, so it parks within the
first moment and a delivery to it is answered by the parking path
instead. This fixture loops. *)
let gsock = tmp "noagent-running.sock" and glog = tmp "noagent-running.log" in
(try Sys.remove gsock with Sys_error _ -> ());
let gfd =
Unix.openfile glog [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let gpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-noagent-running.flan"; "-s"; gsock |]
Unix.stdin gfd gfd
in
Unix.close gfd;
if not (listening ~pid:gpid gsock) then begin
fail "the running agentless daemon %s" !listen_why;
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let gc = connect gsock in
let r =
request gc
"(:op \"eval\" :code \"(defn step [] i64 9)\" :file \
\"programs/dev-noagent-running.flan\")"
in
let msg = Option.value ~default:"" (Wire.string_field r "message") in
(* Refused, and the reason names the socket it could not reach rather
than the compiler: the module built, and what failed is the hand-off
to a program that has no agent in it. *)
if status r = "ok" then
fail
"a redefinition for a program with no agent in it was answered \
ok%s — nothing can install it"
(match Wire.string_field r "note" with
| Some n -> Printf.sprintf " (note: %S)" n
| None -> "")
else if not (contains_sub msg "cannot reach the program on ") then
fail "a delivery to a running agentless program was refused with: %S"
msg;
(* And the session is still there afterwards, which is the rest of the
claim: a refusal is a reply, not the end. *)
(match request gc "(:op \"describe\")" with
| r when status r = "ok" -> ()
| r ->
fail "the session did not survive an unreachable delivery: %s"
(status r)
| exception e ->
fail "the session ended on an unreachable delivery: %s"
(Printexc.to_string e));
(try
ignore (Wire.send gc "(:op \"close\")");
ignore (Wire.recv gc)
with _ -> ());
(try Unix.close gc with Unix.Unix_error _ -> ());
(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; glog ];
(* ── A build that fails is a refusal, not the end of the session ── *)
(* Evaluating runs a compiler, and a compiler can fail in ways the
frontend never does. Expansion is part of both C-c C-c and C-x C-e now,
and expanding means building a macro module and dlopening it — a whole
clang driver, which answers with an exit status and a [Failure], not
with a [Loc.Error]. The daemon used to catch only the latter, at each
op, so the former went past [serve] and took the session with it: the
program stays on screen, the daemon is gone, and the editor finds out
at its next request, on a closed socket. NEXT.md's rule — a form that
does not check leaves the session exactly as it was — is about every
way a form can be refused, not only the checker's.
The build is made to fail by taking the cache directory away from it,
which is the one lever that reaches the macro module and nothing else:
a redefinition module goes llc-then-ld into the daemon's own working
directory and does not touch the cache, so an ordinary evaluation is
unaffected while this is in force. It is also the failure *shape* that
matters here rather than its cause — the daemon cannot tell a linker
that cannot write its output from a macro body clang rejects, and the
claim is about what it does with either.
Its own daemon, its own program and its own cache: the cache has to
start empty for the first expansion to be a miss, and the program has to
outlive a sequence with several cold clang drivers in it, which is what
programs/dev-robust.flan is for. *)
let rsock = tmp "robust.sock" and rout = tmp "robust.out" in
(* This daemon gets a stderr of its own, which none of the others needs.
[Build.run] shells out with [Sys.command], so a clang driver's own words
go to whatever stderr it inherited — and the two failures below are
deliberate, so on a *passing* run the suite was printing
"cannot open output file ... Permission denied" and "linker command
failed" straight to the terminal. Four lines of what reads like a broken
toolchain, on every run, for years of handoffs. Noise that is always
there stops being read, and a real linker failure in this spot would
have been invisible behind it. So it goes to a file, and the file is
reprinted below only if a step in this block actually failed. *)
let rerr = tmp "robust.err" in
let rcache = tmp "robust.cache" in
(* Counted from here, not from zero: [failures] is the whole file's, and a
failure in an earlier block is not a reason to reprint this daemon's
expected complaints. *)
let rfailures = !failures in
let rec rm_rf path =
match Sys.is_directory path with
| true ->
Array.iter (fun f -> rm_rf (Filename.concat path f)) (Sys.readdir path);
(try Sys.rmdir path with Sys_error _ -> ())
| false -> (try Sys.remove path with Sys_error _ -> ())
| exception Sys_error _ -> ()
in
(* A run that failed half way through leaves it read-only, and a second
[dune test] has to start from the same place as the first. *)
(try Unix.chmod rcache 0o700 with Unix.Unix_error _ -> ());
rm_rf rcache;
(try Sys.remove rsock with Sys_error _ -> ());
Unix.mkdir rcache 0o700;
let renv =
Array.of_list
(List.filter
(fun kv ->
not (String.length kv >= 15 && String.sub kv 0 15 = "FLAN_CACHE_DIR="))
(Array.to_list (Unix.environment ()))
@ [ "FLAN_CACHE_DIR=" ^ rcache ])
in
let rfd = Unix.openfile rout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let refd = Unix.openfile rerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
(* Said out loud, because the alternative is a reader deciding for
themselves what a linker complaint in a test run means. Deliberately no
"error" or "FAIL" in the wording: the reader this line is for is
scanning for exactly those words. *)
print_endline
(Printf.sprintf
"dev: two builds below are made to fail on purpose — the robustness \
fixture holds its own cache directory (%s) read-only, so the linker \
cannot write its output there. The compiler's complaints go to a \
log and are reprinted only if a step actually goes wrong."
rcache);
let rpid =
Unix.create_process_env flan
[| flan; "dev"; "programs/dev-robust.flan"; "-s"; rsock |]
renv Unix.stdin rfd refd
in
Unix.close rfd;
Unix.close refd;
if not (listening ~pid:rpid rsock) then begin
fail "the robustness daemon %s" !listen_why;
(try Unix.kill rpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect rsock in
let ask sexp =
(* Its own buffer: the transcript checks above are about other
programs, and this one's output is nobody's evidence. *)
Wire.parse (Wire.send c sexp; Wire.recv c)
in
(* A reply that never arrived is the failure being denied, and it comes
back as an exception out of [Wire.recv] rather than as a status — so
every step here is prepared to say "the session died" by name instead
of ending the test binary on an unhandled [Wire.Closed]. *)
let ask_or what sexp =
match ask sexp with
| r -> Some r
| exception e ->
fail "%s ended the session: %s" what (Printexc.to_string e);
None
in
let message r =
match Wire.string_field r "message" with Some m -> m | None -> ""
in
(* What the session knows, as the editor can see it. Liveness is not the
property — a daemon that answers while having lost track of the
program is worse than one that died — so the failing steps below are
bracketed by this and it has to come back unchanged. *)
let knows () =
match ask_or "describe" "(:op \"describe\")" with
| Some r ->
(match Wire.field r "fns" with
| Some f -> Form.to_string f
| None -> "<no :fns>")
| None -> "<dead>"
in
(* An origin inside the programs directory, because an [import] is
resolved relative to the file the form came from and the package is
beside it. The file itself need not exist: it is an editor buffer. *)
let origin = Filename.concat (Sys.getcwd ()) "programs/buf.flan" in
(* The package's macros have to be in the session before C-x C-e can
reach an expansion at all — an evaluated import is how they get
there, which is [Session.eval]'s macro union. *)
(match
ask_or "the import"
(Printf.sprintf
"(:op \"eval\" :code \"(import mac \\\"pkgs/mac\\\")\" :file %s)"
(Wire.quote origin))
with
| Some r when status r = "ok" -> ()
| Some r -> fail "importing a macro package: %s %s" (status r) (message r)
| None -> ());
(* ── C-x C-e, the path that newly reaches the driver ───────────── *)
(* Taken after the import, which is a change that was *accepted*: the
baseline is what the session knows when the failing step begins. *)
let before = knows () in
(try Unix.chmod rcache 0o500 with Unix.Unix_error _ -> ());
(match
ask_or "an expression whose macro module will not build"
(Printf.sprintf
"(:op \"eval-expr\" :code \"(mac/quad 4)\" :file %s)"
(Wire.quote origin))
with
| Some r ->
if status r <> "error" then
fail "an expression whose macro module will not build answered %s"
(status r);
(* The compiler's own words, which is the whole of what an editor has
to go on. "internal error" would be a reply nobody can act on. *)
if not (contains_sub (message r) "(exit ") then
fail "the reply did not carry the compiler's message: %S"
(message r)
| None -> ());
if knows () <> before then
fail "a failed expression changed what the session knows:\n \
was: %s\n now: %s" before (knows ());
(try Unix.chmod rcache 0o700 with Unix.Unix_error _ -> ());
(* Usable afterwards, and usable *for the thing that just failed*: the
same expression, expanded by the module that would not build a moment
ago. A session that had kept a half-built anything would fail here. *)
(match
ask_or "the expression after a failed one"
(Printf.sprintf
"(:op \"eval-expr\" :code \"(mac/quad 4)\" :file %s)"
(Wire.quote origin))
with
| Some r when status r = "ok" ->
(match Wire.string_field r "value" with
| Some "16" -> ()
| Some v -> fail "(mac/quad 4) evaluated to %s, not 16" v
| None -> fail "the expression after a failed one produced no value")
| Some r ->
fail "the expression after a failed one: %s %s" (status r) (message r)
| None -> ());
(* ── C-c C-c, which is a different path and was as exposed ─────── *)
(* A [defmacro] in the form being evaluated, so this evaluation's macro
set is one the cache has never seen and the build is a miss again. It
is also the case NEXT.md describes literally: a macro whose module
does not build. *)
let macro_defn =
"(defmacro plusone [& args] `(+ ~(at args 0) 1)) \
(defn probe-one [] i64 (plusone 41))"
in
let before = knows () in
(try Unix.chmod rcache 0o500 with Unix.Unix_error _ -> ());
(match
ask_or "a defmacro whose module will not build"
(Printf.sprintf "(:op \"eval\" :code %s :file %s)"
(Wire.quote macro_defn) (Wire.quote origin))
with
| Some r ->
if status r <> "error" then
fail "a defmacro whose module will not build answered %s" (status r);
if not (contains_sub (message r) "(exit ") then
fail "the reply did not carry the compiler's message: %S"
(message r)
| None -> ());
(* Nothing of the refused form is in the session — not the macro, and
not the function that was declared beside it. *)
(match knows () with
| k when k <> before ->
fail "a failed redefinition changed what the session knows:\n \
was: %s\n now: %s" before k
| k -> if contains_sub k "probe-one" then
fail "a refused redefinition left probe-one in the session");
(try Unix.chmod rcache 0o700 with Unix.Unix_error _ -> ());
(match
ask_or "the redefinition after a failed one"
(Printf.sprintf "(:op \"eval\" :code %s :file %s)"
(Wire.quote macro_defn) (Wire.quote origin))
with
| Some r when status r = "ok" -> ()
| Some r ->
fail "the redefinition after a failed one: %s %s" (status r)
(message r)
| None -> ());
(* And the session knows it *now*, which is the half of "usable
afterwards" that a live socket does not show: the name is there, and
calling it runs the body the failed evaluation never installed. *)
if not (contains_sub (knows ()) "probe-one") then
fail "the redefinition after a failed one installed nothing";
(match
ask_or "a call to the function the recovered evaluation installed"
(Printf.sprintf "(:op \"eval-expr\" :code \"(probe-one)\" :file %s)"
(Wire.quote origin))
with
| Some r when status r = "ok" ->
(match Wire.string_field r "value" with
| Some "42" -> ()
| Some v -> fail "(probe-one) evaluated to %s, not 42" v
| None -> fail "(probe-one) produced no value")
| Some r -> fail "(probe-one): %s %s" (status r) (message r)
| None -> ());
(* ── A form that checks and then fails to land ─────────────────── *)
(* The two above fail inside the check — a macro module that will not
build is refused before [Session.eval] has committed anything, which
is the easy half. This is the other half, and it is the one that used
to end in a segfault: a form that checks, joins the session, and then
cannot be built or cannot be delivered. The editor reads an error and
the session goes on holding the declaration; the next module built for
that session lists the name in its install prologue, interns a cell
for it, stores nothing in it, and the first call through that cell
jumps the game thread to address 0.
Reached by taking the daemon's own working directory away from it,
which is where a redefinition module is written — a different lever
from the cache above, and deliberately so: the cache is the macro
module's and cannot fail a build that has no macro in it. The
directory is named after the daemon's pid, which is the one this test
started.
The last step is the crash. Pre-fix, [(probe-two)] compiled to a call
through a null cell and this file died with the program; the assertion
it now makes is that the daemon refuses by name instead. *)
let devdir =
Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" rpid)
in
let probe_two = "(defn probe-two [] i64 7)" in
let before = knows () in
(try Unix.chmod devdir 0o500 with Unix.Unix_error _ -> ());
(match
ask_or "a redefinition the daemon cannot write its module for"
(Printf.sprintf "(:op \"eval\" :code %s :file %s)"
(Wire.quote probe_two) (Wire.quote origin))
with
| Some r ->
if status r <> "error" then
fail "a redefinition whose module could not be written answered %s"
(status r)
| None -> ());
(try Unix.chmod devdir 0o700 with Unix.Unix_error _ -> ());
(match knows () with
| k when k <> before ->
fail "a redefinition that never landed changed what the session \
knows:\n was: %s\n now: %s" before k
| k ->
if contains_sub k "probe-two" then
fail "a redefinition that never landed left probe-two in the \
session");
(match
ask_or "an expression calling a redefinition that never landed"
(Printf.sprintf "(:op \"eval-expr\" :code \"(probe-two)\" :file %s)"
(Wire.quote origin))
with
| Some r ->
if status r <> "error" then
fail "an expression calling a body no module carries answered %s"
(status r);
if not (contains_sub (message r) "probe-two") then
fail "the refusal did not name the body that never landed: %S"
(message r)
| None -> ());
(* Usable afterwards, for the thing that just failed: the same form
again, and then the call that could not be made. *)
(match
ask_or "the redefinition after one that could not be written"
(Printf.sprintf "(:op \"eval\" :code %s :file %s)"
(Wire.quote probe_two) (Wire.quote origin))
with
| Some r when status r = "ok" -> ()
| Some r ->
fail "the redefinition after one that could not be written: %s %s"
(status r) (message r)
| None -> ());
(match
ask_or "a call to the body the recovered evaluation installed"
(Printf.sprintf "(:op \"eval-expr\" :code \"(probe-two)\" :file %s)"
(Wire.quote origin))
with
| Some r when status r = "ok" ->
(match Wire.string_field r "value" with
| Some "7" -> ()
| Some v -> fail "(probe-two) evaluated to %s, not 7" v
| None -> fail "(probe-two) produced no value")
| Some r -> fail "(probe-two): %s %s" (status r) (message r)
| None -> ());
(* ── An editor that leaves before its reply does ──────────────── *)
(* The failure this closes was a flake in test_emacs, and it read like
nothing it was: two break-loop checks failing, and then
"cannot reconnect: Connection refused" on a socket path that plainly
existed. A write into a socket whose reader has gone is SIGPIPE, and
SIGPIPE's default action is to kill the process — which in the merged
build is the program, the compiler and the listener at once, and
leaves the socket file behind for the next client to be refused on.
It is not a contrived shape: reconnecting tears the old connection
down, and a reply already on its way out lands in the gap.
[c] is closed first because the daemon serves one connection at a
time: a second one would sit in the backlog until this one ended, and
then there would be no reply in flight to lose. *)
(try Unix.close c with Unix.Unix_error _ -> ());
let hit_and_run () =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
(try
Unix.connect s (Unix.ADDR_UNIX rsock);
Wire.send s "(:op \"describe\")"
with Unix.Unix_error _ -> ());
(try Unix.close s with Unix.Unix_error _ -> ())
in
(* Several, because the first write into a freshly closed socket can
still land in a buffer nobody will read; the second is the one that
is refused. *)
for _ = 1 to 8 do hit_and_run (); ignore (Unix.select [] [] [] 0.02) done;
let c =
match Unix.waitpid [ Unix.WNOHANG ] rpid with
| 0, _ -> Some (connect rsock)
| _, st ->
(* Named rather than numbered, because [WSIGNALED] carries OCaml's
own signal numbering and "signal -8" would send the next reader
to the wrong page. SIGPIPE is the answer this check expects to
see when it fails. *)
fail "an editor that left before its reply did ended the daemon (%s)"
(match st with
| Unix.WEXITED n -> Printf.sprintf "exit %d" n
| Unix.WSIGNALED n when n = Sys.sigpipe -> "killed by SIGPIPE"
| Unix.WSIGNALED n -> Printf.sprintf "signal %d" n
| Unix.WSTOPPED n -> Printf.sprintf "stopped on %d" n);
None
| exception Unix.Unix_error _ -> Some (connect rsock)
in
(match c with
| None -> ()
| Some c ->
(match Wire.parse (Wire.send c "(:op \"describe\")"; Wire.recv c) with
| r ->
if not (contains_sub (Form.to_string (Option.get (Wire.field r "fns")))
"probe-one")
then fail "the session lost track of the program after a client left"
| exception e ->
fail "the session did not answer after a client left: %s"
(Printexc.to_string e));
(try
ignore (Wire.send c "(:op \"close\")");
ignore (Wire.recv c)
with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ()))
end;
(try Unix.kill rpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] rpid) with Unix.Unix_error _ -> ());
(try Unix.chmod rcache 0o700 with Unix.Unix_error _ -> ());
rm_rf rcache;
(* Its contents rather than its name: [rerr] is under dune's per-run
TMPDIR, which is gone by the time anyone reads the run. *)
if !failures > rfailures then begin
(* True on every path through the block, which the obvious wording is
not: a step that fails *before* either chmod window leaves no
deliberate failure in the log at all, and a header promising two of
them would be a wrong diagnosis — the thing NEXT.md says costs more
than no message. So it names the signature rather than a count. *)
print_endline
"dev: the robustness daemon's stderr follows. Any linker failure in \
it that names the read-only cache directory above is one of the \
deliberate ones; anything else is not.";
match open_in_bin rerr with
| ic ->
let n = in_channel_length ic in
print_string (really_input_string ic n);
flush stdout;
close_in ic
| exception Sys_error e -> Printf.printf " (unreadable: %s)\n" e
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ rsock; rout; rerr ];
(* The dev loop on the other backend, through the daemon rather than
through the library. [test_reload.ml] builds an --x86 host and --x86
modules by hand and loads them into a C host; this is the same thing
arriving the way a user meets it — one flag on [flan dev], and every
module the session emits compiled by the backend that built the process
they are loaded into. A C-c C-c that works in [test_reload.ml] and not
here is not a dev loop.
[--two-process] here and merged below, and both are kept: the merged
daemon is the shape a user gets by default and the one that was refused
on this backend until the macro module stopped being interposable, but
[--two-process] is the arm where the compiler is a separate LLVM binary
and the only thing crossing is a redefinition module. Those are two
different claims about the same flag and neither covers the other. *)
let xsock2 = tmp "x86.sock" and xout2 = tmp "x86.out" in
(try Sys.remove xsock2 with Sys_error _ -> ());
let xfd2 =
Unix.openfile xout2 [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let xpid2 =
Unix.create_process flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; xsock2; "--x86";
"--two-process" |]
Unix.stdin xfd2 Unix.stderr
in
Unix.close xfd2;
if not (listening ~pid:xpid2 xsock2) then begin
fail "the --x86 daemon %s" !listen_why;
(try Unix.kill xpid2 Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect xsock2 in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* C-c C-c on a name the host was built with: the case X86.redefinition
could already compile, now reached through the daemon. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 5)) ticks)\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 C-c C-c: %s" (said r);
(* C-x C-e: the transient thunk and the marker the agent unloads on,
which is a different emitter from the one above. *)
let r =
request c "(:op \"eval-expr\" :code \"(+ 2 3)\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 C-x C-e: %s" (said r)
else if value r <> "5" then fail "x86 C-x C-e answered %S" (value r);
(* A string literal in the thunk. The module keeps its mapping rather
than claiming to be transient — the value is copied out, but a module
holding a literal can never say nothing points into it. *)
let r =
request c
"(:op \"eval-expr\" :code \"\\\"hi\\\"\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 C-x C-e on a literal: %s" (said r)
else if value r <> "\"hi\"" then
fail "x86 C-x C-e on a literal answered %S" (value r);
(* A defonce the host has no storage for, with a value of its own, and a
defn the host has no cell for: both go through flan_dev.c's registry
into slots this backend fills at install time. The expression after
them reads one and calls the other, so the answer is what says the
lookups resolved rather than that the module merely loaded. *)
let r =
request c
"(:op \"eval\" :code \"(defonce fresh i64 41)\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 new defonce: %s" (said r);
let r =
request c
"(:op \"eval\" :code \"(defn twice [x i64] i64 (* x 2))\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 new defn: %s" (said r);
let r =
request c
"(:op \"eval-expr\" :code \"(twice fresh)\" :file \"/tmp/x86buf.flan\")"
in
if status r <> "ok" then fail "x86 new name round trip: %s" (said r)
else if value r <> "82" then
fail "x86 (twice fresh) answered %S, so the registry lookups did not resolve" (value r);
(* And a backtrace *through* a redefined body, which is the one frame a
module has to get right on its own: the descriptor a body points at
travels in the object that body was compiled into, so a module that
pushed no frame would leave a gap where the redefinition ran, and one
that pointed at the host's descriptor would report the location of the
body it replaced. The installed body's own file is what says which
happened. Last in this block deliberately — it stops the program. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (let [n (+ ticks 1)] (error (Missing {.id 3})) n))\" :file \"/tmp/x86redef.flan\")"
in
if status r <> "ok" then fail "x86 redefined-body backtrace, install: %s" (said r)
else if not (await (fun () ->
match Wire.field (request c "(:op \"describe\")") "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false))
then fail "the --x86 program never stopped in the redefined body"
else begin
let r = request c "(:op \"backtrace\")" in
let top =
match Wire.field r "frames" with
| Some { Form.v = Form.List ({ Form.v = Form.List
({ Form.v = Form.Str n; _ }
:: { Form.v = Form.Str loc; _ } :: _); _ }
:: _); _ } -> Some (n, loc)
| _ -> None
in
match top with
| Some ("step", loc) when contains_sub loc "x86redef.flan" -> ()
| Some (n, loc) -> fail "x86 backtrace through a redefined body: %s at %S" n loc
| None -> fail "x86 backtrace through a redefined body: %s" (said r)
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] xpid2) with Unix.Unix_error _ -> ())
end;
(* ── The inspector, on the other backend ──────────────────────────── *)
(* The break loop's four questions asked of an [--x86] host. They are the
ones that go through the shadow stack rather than through a module: the
frame chain gives the depth and the names, and the addresses in it are
what a render thunk reads the locals and the globals out of. Until
[X86.emit_fn] pushed a frame this daemon answered every one of them with
"this program was not built with --dev", which was false of it.
[programs/dev-locals.flan] and not a fixture of its own, deliberately:
the LLVM block above asks these same questions of that same program, so
the two sets of answers can be read against each other, and what is
being claimed is that they are the *same* answers rather than merely
plausible ones. A backend the break loop can tell apart is a backend the
break loop cannot be trusted on. *)
let isock = tmp "x86locals.sock" and iout = tmp "x86locals.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-locals.flan"; "-s"; isock; "--x86" |]
Unix.stdin ifd Unix.stderr
in
Unix.close ifd;
if not (listening ~pid:ipid isock) then begin
fail "the --x86 inspector daemon %s (%S)" !listen_why
(In_channel.with_open_bin iout In_channel.input_all);
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect isock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then
fail "the --x86 inspector program never stopped"
else begin
(* The backtrace first, because everything below names a frame by the
index this listing gives. Two frames and not one: [main] called
[look], so a chain with only the innermost on it would mean the push
happened and the previous head was not saved. *)
let r = request c "(:op \"backtrace\")" in
let frames =
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
(* The condition's own fields, rendered under this backend. The thunk
reads them through [flan_agent_condition] at offsets the *x86*
backend laid out, and x86 tracks LLVM's observable behaviour: the
break block above renders a condition on LLVM, so this renders one
here, and the two must read alike. [look] signals (Boom {.why 7}),
so the number is the one the source wrote. *)
(let r = request c "(:op \"condition\")" in
if status r <> "ok" then fail "x86 condition: %s" (said r)
else
match Wire.field r "fields" with
| Some { Form.v = Form.List
[ { Form.v = Form.List
[ { Form.v = Form.Str "why"; _ };
{ Form.v = Form.Str "i32"; _ };
{ Form.v = Form.Str "7"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "x86 condition did not render (Boom {.why 7})");
(* And a user [error] carries no site — there is no trapping
expression behind it — which is the same answer LLVM gives. Said
rather than left untested: the site is absent here for a reason,
not because this backend cannot produce one. *)
(match Wire.string_field (request c "(:op \"break\")") "site" with
| None -> ()
| Some site -> fail "an x86 user error carried a site: %s" site);
if status r <> "ok" then fail "x86 backtrace: %s" (said r)
else
(match frames with
| [ ("look", l0, "program"); ("main", _, "program") ] ->
(* The location travels in the frame's own descriptor, so a wrong
one is a descriptor built from the wrong function rather than a
cosmetic slip. *)
if not (contains_sub l0 "dev-locals.flan:14") then
fail "x86 backtrace put look at %S" l0
| _ ->
fail "x86 backtrace: %s"
(String.concat ", "
(List.map (fun (n, _, o) -> n ^ "/" ^ o) frames)));
let triples 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
(* The locals of the stopped frame, and this is the claim the slot
table exists for: the values are the ones [look] was called with and
bound to, read at the addresses the frame recorded, under this
backend's own frame layout. A wrong address renders whatever those
bytes happen to be, so matching the LLVM listing exactly is the
check and a shape-only assertion would not be. *)
let r = request c "(:op \"locals\" :frame 0)" in
if status r <> "ok" then fail "x86 locals: %s" (said r)
else begin
let want =
[ ("n", "i64", "3");
("label", "string", "\"hello\"");
("p", "Point", "(Point {.x 1.5 .y 2.5})");
("xs", "[3 i32]", "[ 10 20 30]");
("flag", "bool", "true");
(* And the byte's character half under this backend too: the
spelling table is the dev runtime's, but the slot the byte
is read from is x86's. *)
("byte", "u8", "97 (\\a)");
("gap", "u8", "32 (\\space)");
("ctl", "u8", "7");
(* Same two rows the LLVM listing pins: the loop index shown,
the loop's hidden bound hidden, the shadowing rebind kept
raw because the outer [label] is on the same list. *)
("hop", "i32", "0");
("label~2", "string", "\"inner\"") ]
in
let got = triples r "locals" in
if got <> want then
fail "x86 locals of the stopped frame: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
(* [after] is bound past the error, so nothing wrote its entry and it
is still the null the push stored. That null is the whole of how
"not bound yet" is told from "bound" on this side too — there is no
liveness analysis behind it — so a frame whose table were left
uninitialised would render this one from stack litter. *)
match List.filter (fun (n, _, _) -> n = "after") (triples r "refused") with
| [ (_, why, _) ] when why <> "" -> ()
| _ ->
fail "x86: a slot bound after the error was not refused by name: %s"
(String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused")))
end;
(* One slot by index, which is the inspector's own root rather than
[locals]' listing, and an aggregate for it: an x86 frame passes every
aggregate by pointer, so a struct is where a recorded address could
most easily be the caller's copy instead of this frame's. *)
let r = request c "(:op \"inspect\" :frame 0 :slot 2)" in
if status r <> "ok" then fail "x86 inspect: %s" (said r)
else if Wire.string_field r "value" <> Some "(Point {.x 1.5 .y 2.5})" then
fail "x86 inspect of slot 2 answered %S"
(Option.value ~default:"" (Wire.string_field r "value"));
(* And a byte by the same root: the inspector is the other place a
person is reading rather than the program printing, so it shows
the character half exactly as the listing does. Slot 5 is [byte]. *)
(let r = request c "(:op \"inspect\" :frame 0 :slot 5)" in
if status r <> "ok" then fail "x86 inspect of a byte: %s" (said r)
else if Wire.string_field r "value" <> Some "97 (\\a)" then
fail "x86 inspect of a byte answered %S"
(Option.value ~default:"" (Wire.string_field r "value")));
(* And the write half of the same root, for the reason this whole block
exists: the two backends must answer the same. A store is where they
could most easily not — the place forms the walk ends at are lowered
by each backend's own [place], and the two disagree about an Option,
which is why what may be written is settled in [session.ml] above
both of them rather than in either. *)
let r =
request c
"(:op \"set\" :frame 0 :slot 2 :path (\"y\") :edits ((:code \"6.5\")))"
in
if status r <> "ok" then fail "x86 set: %s" (said r)
else if Wire.string_field r "value" <> Some "6.5" then
fail "x86 set of p.y answered %S"
(Option.value ~default:"" (Wire.string_field r "value"));
let r = request c "(:op \"inspect\" :frame 0 :slot 2)" in
if Wire.string_field r "value" <> Some "(Point {.x 1.5 .y 6.5})" then
fail "x86: the store did not land where the render says it did: %S"
(Option.value ~default:"" (Wire.string_field r "value"));
(* A refusal that comes from above both backends reads the same here
as it does there, which is the claim rather than the refusal. *)
let r =
request c
"(:op \"set\" :frame 0 :slot 2 :path (\"y\") :edits ((:code \"\\\"no\\\"\")))"
in
if status r <> "error" || not (contains_sub (said r) "expected f32") then
fail "x86: a value of the wrong type was not refused by the checker: %s"
(said r);
(* And the globals, which are not in the frame at all -- they are found
through the same descriptor's fingerprint, and a frame whose
[refsig] disagreed with what the daemon recomputes would refuse
every one of them while the locals above still read. That is the
failure an empty globals table in [X86.layout_ctx] produces, and it
is why this question is asked here and not left to the LLVM block. *)
let r = request c "(:op \"globals\")" in
if status r <> "ok" then fail "x86 globals: %s" (said r)
else
(match triples r "globals" with
| [ ("ticks", "i64", v) ] when v <> "" -> ()
| got ->
fail "x86 globals: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got)))
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ipid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ isock; iout ];
(* And the *merged* daemon on this backend, which used to be refused by
name and is the case the refusal was standing in for.
[programs/dev-macro.flan] and not the dev-repl above, and the choice is
the whole test: it calls a prelude [defmacro] at the top level, so
starting it means the compiler built a macro module and dlopened it into
*this* process -- which is an [--x86] [-rdynamic] host, and until
[Build.macro_module] hid that module's own Flan definitions the host's
bodies interposed them. The failure was a SIGSEGV inside
[flan.\[clamp\]] during the first expansion, before the program had run
a line, so a daemon that reaches a bound socket at all is most of the
deliverable.
The rest of it is one daemon carrying everything this combination has to
be able to do: C-x C-e, a C-c C-c whose body calls a macro *again* with
the program now running beside the compiler, and — because the fixture's
[main] returns after one delivery — the park and the [rerun] that the
merged build exists for. *)
let msock = tmp "x86merged.sock" and mout = tmp "x86merged.out" in
(try Sys.remove msock with Sys_error _ -> ());
let mfd =
Unix.openfile mout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let mpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-macro.flan"; "-s"; msock; "--x86" |]
Unix.stdin mfd Unix.stderr
in
Unix.close mfd;
if not (listening ~pid:mpid msock) then begin
fail "the merged --x86 daemon %s (%S)" !listen_why
(In_channel.with_open_bin mout In_channel.input_all);
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect msock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let parked () =
match Wire.field (request c "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
(* C-x C-e first, while the program is certainly still in its loop: an
expression is answered at a frame boundary and a parked program has
none. Retried rather than asked once, because the daemon binds its
socket in [merged_setup] and the program's own thread only starts
after that returns — so the first ask can arrive before there is an
agent to reach, which is a race with the startup and not a result. *)
let answered = ref "" in
let asked () =
let r =
request c
"(:op \"eval-expr\" :code \"(+ 2 3)\" :file \"programs/dev-macro.flan\")"
in
status r = "ok"
&& (answered := Option.value ~default:"" (Wire.string_field r "value");
true)
in
if not (await asked) then
fail "merged --x86 C-x C-e never reached a frame boundary"
else if !answered <> "5" then
fail "merged --x86 C-x C-e answered %S" !answered;
(* And a C-c C-c whose body is itself a macro call. This is the expansion
that matters most here: the macro module is already resident, the
program is running in the same process, and the caller landing in the
host's body instead of the module's is exactly the crash. *)
let r =
request c
"(:op \"eval\" :code \"(defn step [] i64 (unless false (set ticks (+ \
ticks 10))) ticks)\" :file \"programs/dev-macro.flan\")"
in
if status r <> "ok" then fail "merged --x86 C-c C-c: %s" (said r);
if not (await parked) then
fail "the merged --x86 program never parked after main returned";
(* And round [main] again in the same process, which is what the merged
build exists for. "ok" only says the op was accepted, so the check is
what the program prints: every reply drains its stdout into [output],
and [parity] -- the macro-using function -- is what it prints. So a
line appearing there after this mark is a second run having really
happened, with the expansion still good in it.
The second run parks like the first, which is what there is to wait
for; asking for the text immediately would be asking before the
thread had been let go. *)
let mark = Buffer.length output in
let r = request c "(:op \"rerun\")" in
if status r <> "ok" then fail "merged --x86 rerun: %s" (said r)
else begin
let printed () =
let s = Buffer.contents output in
let s = String.sub s mark (String.length s - mark) in
contains_sub s "even" || contains_sub s "odd"
in
(* [parked] first, and the order is not style: it is the call that asks
the daemon anything, and so the only thing that drains the program's
stdout into [output] at all. *)
if not (await ~ms:10000 (fun () -> parked () && printed ())) then
fail "merged --x86 rerun printed %S, so main did not run again"
(let s = Buffer.contents output in
String.sub s mark (String.length s - mark))
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] mpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ xsock2; xout2; msock; mout ];
(* ── The dyn globals a park holds ─────────────────────────────────── *)
(* The banner a finished run prints says the globals are as it left them,
and for a dyn global that was not true. The park cuts three stacks back
— the conditions, the frame chain, and the collector's roots — and the
third one was emptied outright. But the dyn globals' roots are on it
too: the emitted main pushes them once and nothing ever pops them,
which is the whole of what a global's extent means to the collector. So
the park unrooted every one of them, and the first evaluated thunk to
allocate past the heap's floor swept what they held. The read
afterwards answered [nil] — by luck of what the freed words decoded as,
which is to say it was a read of freed memory and could as easily have
been a crash.
Both backends, because the daemon's own default is [--x86] and the fix
is two emitters agreeing: the bracket around the global pushes is
emitted by [Emit.emit_main] and by [X86]'s, and a session on either one
has to come back with the string.
The cycle is run three times over. Once would pass on a fix that kept
the globals rooted for the first park only; a re-entered main pushing a
second copy of every global rather than re-rooting the same ones is the
other way to get this wrong, and it needs a second and third run to
show at all. *)
List.iter
(fun backend ->
let dsock = tmp ("dynglobal" ^ backend ^ ".sock")
and dout = tmp ("dynglobal" ^ backend ^ ".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-dyn-global.flan"; "-s"; dsock;
"--" ^ backend |]
Unix.stdin dfd Unix.stderr
in
Unix.close dfd;
if not (listening ~pid:dpid dsock) then begin
fail "the dyn-global daemon (--%s) %s" backend !listen_why;
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let said r = Option.value ~default:(status r) (Wire.string_field r "message") in
(* [(:op "memory")] — which lines of the program allocate, asked of
the daemon rather than of the running program. It is
[Check.memory_sites] over the session's last checked program, so
it needs no process on the far end and says the same thing here
as [flan check --warn-memory] says on the command line.
This fixture is the one that earns the check: its [(set config
{:s "kept" :n 1})] is two crossings into the collected heap on
one line — the map and the string inside it — at columns the
squiggle has to get right, and it has no native allocation
anywhere, which is the half a classifier that answered "gc" for
everything would also pass. Rows from the prelude ride along and
are ignored here; [flan.el] filters by the buffers it has open. *)
let mem_rows () =
let r = request c "(:op \"memory\")" in
if status r <> "ok" then begin
fail "--%s: memory: %s" backend (said r); []
end
else
match Wire.field r "sites" with
| Some { Form.v = Form.List rows; _ } ->
List.filter_map
(fun (row : Form.t) ->
match row.Form.v with
| Form.List
[ { Form.v = Form.Str loc; _ };
{ Form.v = Form.Str kind; _ };
{ Form.v = Form.Str msg; _ } ] ->
Some (loc, kind, msg)
| _ -> None)
rows
| _ -> fail "--%s: memory answered no :sites" backend; []
in
let rows = mem_rows () in
let ours =
List.filter
(fun (loc, _, _) ->
contains_sub loc "programs/dev-dyn-global.flan")
rows
in
let has loc kind needle =
List.exists
(fun (l, k, m) ->
contains_sub l loc && k = kind && contains_sub m needle)
ours
in
if not (has ":23:15" "memory/gc" "a dyn map is an object") then
fail "--%s: memory did not name the map literal at 23:15: %s"
backend
(String.concat "; "
(List.map (fun (l, k, _) -> l ^ " " ^ k) ours));
if not (has ":23:19" "memory/gc" "a string crossing into dyn") then
fail "--%s: memory did not name the string at 23:19" backend;
if List.exists (fun (_, k, _) -> k = "memory/native") ours then
fail
"--%s: memory called a line of dev-dyn-global.flan a native \
allocation, and the file has none"
backend;
let parked () =
match Wire.field (request c "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
(* What the expression answered, wherever it came back: a dyn value
is rendered into the reply's output rather than into [:value],
and which of the two carries it is not what is under test. *)
let answer r =
Option.value ~default:"" (Wire.string_field r "value")
^ Option.value ~default:"" (Wire.string_field r "output")
in
let read () =
answer
(request c
"(:op \"eval-expr\" :code \"(get config :s)\" \
:file \"programs/dev-dyn-global.flan\")")
in
(* A hundred thousand small maps: flan_dyn.c collects at a
one-megabyte floor, so this is several collections and not a
heap that merely grew. *)
let churn () =
request c
"(:op \"eval-expr\" :code \"(do (dotimes [i 100000] (let [m \
{:k i}] 0)) 1)\" :file \"programs/dev-dyn-global.flan\")"
in
if not (await ~ms:20000 parked) then
fail "the dyn-global program (--%s) never parked" backend
else begin
if not (contains_sub (read ()) "kept") then
fail "--%s: the global was not readable before any thunk ran: %S"
backend (read ());
for cycle = 1 to 3 do
let r = churn () in
if status r <> "ok" then
fail "--%s: the churning thunk (cycle %d): %s" backend cycle
(said r)
else if not (contains_sub (read ()) "kept") then
fail
"--%s: after a thunk that allocates (cycle %d) the parked \
program's dyn global reads %S"
backend cycle (read ());
(* And round main again, which re-enters the very code that
pushed those roots. *)
let r = request c "(:op \"rerun\")" in
if status r <> "ok" then
fail "--%s: rerun (cycle %d): %s" backend cycle (said r);
if not (await ~ms:20000 parked) then
fail "--%s: the program did not park again (cycle %d)" backend
cycle
done
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ dsock; dout ])
[ "llvm"; "x86" ];
(* ── What a re-run does to a global ───────────────────────────────── *)
(* The rule is the defining form's: a [defonce] is Common Lisp's, so its
initialiser runs only if the variable is not already initialised and its
value survives a re-run. A zeroed one always did — .bss is untouched by
a second entry into [main] — and a computed one did not, because the
startup function [main] calls ran again from the top and stored the
initial value back over what the last run had left.
[Emit.startup_plan] guards each computed initialiser with a flag of its
own; this is the claim that guard exists for.
On the default backend, which is x86 and merged, because that is what
the dev loop takes unasked and the guard is emitted by the two backends
from one shared body. Three re-runs and not one: a guard that ran the
initialiser every *other* time would pass a single re-run.
[programs/dev-rerun.flan] prints one line per case per run, and the
whole assertion is the fourth run's lines: [counter] computed and
incremented four times, [zeroed] uncomputed and incremented four times,
a computed dyn map whose contents were mutated four times, a dyn global
written the three-element way and incremented four times, a typed array
filled once by a computed (array-fill ...) and written four times, and a
[defconst] that no run can have changed. *)
let rsock = tmp "rerun.sock" and rout = tmp "rerun.out" in
(try Sys.remove rsock with Sys_error _ -> ());
let rfd =
Unix.openfile rout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let rpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-rerun.flan"; "-s"; rsock |]
Unix.stdin rfd Unix.stderr
in
Unix.close rfd;
if not (listening ~pid:rpid rsock) then begin
fail "the re-run daemon %s (%S)" !listen_why
(In_channel.with_open_bin rout In_channel.input_all);
(try Unix.kill rpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect rsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* [describe] is what drains the program's stdout into [output], so the
park is asked for rather than slept through and the lines are there
to read the moment it is parked. *)
let parked () =
match Wire.field (request c "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let printed s = contains_sub (Buffer.contents output) s in
if not (await ~ms:20000 parked) then
fail "the re-run fixture never parked (%S)"
(In_channel.with_open_bin rout In_channel.input_all);
if not (printed "counter 41") then
fail "the first run printed %S" (Buffer.contents output);
for _ = 1 to 3 do
let r = request c "(:op \"rerun\")" in
if status r <> "ok" then fail "rerun: %s" (said r);
if not (await ~ms:20000 parked) then
fail "a re-run never parked (%S)"
(In_channel.with_open_bin rout In_channel.input_all)
done;
let want =
[ (* A computed [defonce], which is the whole bug: 41 on the first run
and one more on each of the three after it. *)
"counter 44";
(* An uncomputed one, which survived before this and still does. *)
"zeroed 8";
(* A computed dyn global, mutated by every run: its value survives
and so does the mutation, which is the map still being the map the
first run built. *)
"runs 4";
(* The three-element spelling of a computed dyn global, which is the
explicit one with the keyword left out: it goes through the same
guard because it *is* the same declaration by the time anything
downstream sees it. *)
"tally 4";
(* A typed array with a computed initialiser — (array-fill ...),
which is an expression and so is lifted into the startup function
like any other computed one. 250 filled once and incremented four
times; a fill that re-ran would print 251 every run. *)
"grid 254";
(* And the element no run writes, which separates "the guard held"
from "the initialiser never ran": 250, not 0. *)
"grid-far 250";
(* And a [defconst], which no run can have changed. *)
"base 40";
(* A [def], CL's defparameter: the initialiser runs on every
re-run, unguarded, so where [tally] climbed to 4 this is 4 on
every one of the four runs — 3 repainted, then incremented. *)
"c 4";
(* The typed-array [def]: the fill repaints the same storage, so
the element every run increments reads 8 every run. *)
"hue 8";
(* A def initialiser that reads another global, re-read on each
re-run: [counter] is 43 when the fourth run's startup stores
this, and main increments it to 44 afterwards. A def that had
captured its first answer would print 40 on all four runs —
which is the claim the static ordering analysis cannot make. *)
"echo 43" ]
in
List.iter
(fun s ->
if not (printed s) then
fail "after three re-runs the program never printed %S: %S" s
(Buffer.contents output))
want;
(* The other half of each [def] claim: a run that ever saw the last
run's increment would have printed the next number, so its absence
is what says the repaint happened at all. *)
List.iter
(fun s ->
if printed s then
fail "a def survived a re-run it must not survive: %S in %S" s
(Buffer.contents output))
[ "c 5"; "hue 9" ];
(* Read back rather than only printed, because the two can differ: a
printed line is what the run computed, and this is what the global
holds now. *)
let r =
request c
"(:op \"eval-expr\" :code \"counter\" :file \"programs/dev-rerun.flan\")"
in
(match Wire.string_field r "value" with
| Some "44" -> ()
| v ->
fail "counter reads back as %S after three re-runs"
(Option.value ~default:(status r) v));
(* The headline: the author edits a [def]'s initialiser and C-c C-c's
it. The evaluation republishes the lifted [global/c] through its
cell — [Session]'s [def_inits] — and the *next re-run* runs the
edited initialiser: 9 repainted, then incremented, so 10. A
[defonce] beside it keeps its value through the same re-run, which
is the pair the two forms exist to be.
This is the re-run half of [def] and not the whole of it. The
evaluation also stores the new value straight away — see the
[dev-defstore.flan] block below, which is that half on a program
that is running — and a parked program takes that store when its
ring drains, which is at the top of this very re-run. Either way
the number below is the same one: 9 stored, 9 computed again by
the run's own startup, and 10 after main increments it. *)
let r =
request c
"(:op \"eval\" :code \"(def c 9)\" :file \"programs/dev-rerun.flan\")"
in
if status r <> "ok" then fail "re-evaluating (def c 9): %s" (said r);
let r = request c "(:op \"rerun\")" in
if status r <> "ok" then fail "the rerun after the edit: %s" (said r);
if not (await ~ms:20000 parked) then
fail "the re-run after the edit never parked (%S)"
(In_channel.with_open_bin rout In_channel.input_all);
if not (printed "c 10") then
fail "the edited initialiser never took: no %S in %S" "c 10"
(Buffer.contents output);
(* And the defonce beside it: a fifth run, still climbing — the edit
and the extra re-run must not have reset it. *)
if not (printed "counter 45") then
fail "the defonce beside the edited def lost its value: %S"
(Buffer.contents output);
(* Read back rather than only printed, [counter]'s reason. A dyn
renders through the program's printer — its reply carries the text
in [:output] and an empty [:value] — so the cast is what turns the
answer into a value the reply can hold. *)
(let r =
request c
"(:op \"eval-expr\" :code \"(i64 c)\" :file \"programs/dev-rerun.flan\")"
in
match Wire.string_field r "value" with
| Some "10" -> ()
| v ->
fail "c reads back as %S after the edit and re-run"
(Option.value ~default:(status r) v));
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] rpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ rsock; rout ];
(* ── Evaluating a [def] stores the value, now ────────────────────── *)
(* The author's report, and the whole of what [def] means: it is Common
Lisp's [defparameter], so evaluating one *assigns*. Editing a palette
in a running game and pressing C-c C-c has to change the colours on
the next frame — not on the next restart, which was the behaviour and
was the same complaint the form was built to answer, one step further
in.
Read back rather than printed, because the question is what the
storage holds now: [programs/dev-defstore.flan] prints nothing and
runs a bare wait loop, so every line below is the daemon asking the
*running* program what it has. No re-run happens anywhere in here.
Both backends. [flan dev] takes x86 unasked, so that is the first
pass; the second names [--llvm], and the two publish a lifted
initialiser through machinery each wrote for itself. *)
List.iter
(fun (tag, extra) ->
let dsock = tmp ("defstore-" ^ tag ^ ".sock")
and dout = tmp ("defstore-" ^ tag ^ ".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
(Array.append
[| flan; "dev"; "programs/dev-defstore.flan"; "-s"; dsock |]
extra)
Unix.stdin dfd Unix.stderr
in
Unix.close dfd;
if not (listening ~pid:dpid dsock) then begin
fail "the def-store daemon (%s) %s (%S)" tag !listen_why
(In_channel.with_open_bin dout In_channel.input_all);
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let said r =
Option.value ~default:"" (Wire.string_field r "message")
in
let file = " :file \"programs/dev-defstore.flan\")" in
let value code =
Wire.string_field
(request c
("(:op \"eval-expr\" :code " ^ Wire.quote code ^ file))
"value"
in
(* An evaluation is answered as soon as the module is queued, so
the read that follows is a second module behind it in the same
ring — which is an order and not a race, since the poll that
runs a thunk installs whatever is queued ahead of it. Polled
anyway, so that a failure here reads as the wrong value rather
than as a timing report nobody can act on. *)
let reads what code want =
if not (await ~ms:20000 (fun () -> value code = Some want)) then
fail "%s (%s): %s reads back as %S, wanted %S" what tag code
(Option.value ~default:"<none>" (value code)) want
in
let evals what code =
let r = request c ("(:op \"eval\" :code " ^ Wire.quote code ^ file) in
if status r <> "ok" then fail "%s (%s): %s" what tag (said r);
r
in
(* The value the process was built with, so that every number
below is a change and not a coincidence. 0xE6B800FF. *)
reads "the palette as built" "(i64 (at colors 0))" "3870818559";
(* The report, to the letter: a native array of colours. *)
ignore (evals "editing the palette"
"(def colors [4 u32] [1 2 3 4])");
reads "the edited palette" "(i64 (at colors 0))" "1";
(* The far element too: a store that reached only the first word
would pass the line above and be the bug in a smaller place. *)
reads "the edited palette's last element"
"(i64 (at colors 3))" "4";
ignore (evals "editing a scalar" "(def speed i64 42)");
reads "the edited scalar" "speed" "42";
ignore (evals "editing a struct"
"(def knobs Tuning {.gain 9 .bias 8})");
reads "the edited struct" "(i64 (.gain knobs))" "9";
reads "the edited struct's second field" "(i64 (.bias knobs))" "8";
(* A dyn, which is the one whose new value is on the heap: the
store has to land in storage the collector still roots. *)
ignore (evals "editing a dyn" "(def label dyn {:n 77})");
reads "the edited dyn" "(i64 (get label :n))" "77";
(* An initialiser that is a call rather than a literal, which is
the shape [Emit.initial_image] has no image for. *)
ignore (evals "editing a computed initialiser"
"(def computed i64 (+ (twice) 5))");
reads "the edited computed initialiser" "computed" "15";
(* The control, and it comes before the brand-new names below for
a reason of its own: once the session holds a global the host
lacks, every later evaluation has storage to allocate and so
has a module to build, and the sharpest form of this claim is
that there is nothing to send at all.
[defonce] is Common Lisp's [defvar]: a value the program
already holds is not touched, which is the whole of what tells
the two forms apart. *)
let r = evals "re-evaluating a defonce" "(defonce kept i64 99)" in
if Wire.string_field r "note" <> Some "nothing to install" then
fail "re-evaluating a defonce built a module (%s): %s" tag
(Option.value ~default:(said r) (Wire.string_field r "note"));
reads "the defonce beside them" "kept" "7";
(* A name the process was never built with. Its storage comes
from [flan_dev_global] and no startup call names its
initialiser, so without the store it would be calloc's zeroes
for the life of the process — and a computed one has no image
to fall back on. *)
ignore (evals "a brand-new def" "(def fresh i64 (twice))");
reads "the brand-new def" "fresh" "10";
ignore (evals "a brand-new def with a literal"
"(def plain i64 42)");
reads "the brand-new def with a literal" "plain" "42";
(* The two halves of the one thunk, in the order they have to be
in. A module carries one [flan_reload_call] and it holds the
class registrations and the def stores together; the
registrations go first, so an initialiser that constructs an
instance sees the slot list the registry now holds. Sent as
one form, which is what makes the ordering the only thing
that can decide the answer.
The def is a new name rather than one the fixture declares: a
class that gains or loses slots is checked against every
caller the running program has, and the lifted initialiser of
an existing def would be one of them. *)
ignore (evals "a class and a def that constructs one, together"
"(defclass point [x y z]) (def anchor dyn (point 7 8 9))");
reads "the slot the redefined class gained"
"(i64 (get anchor :z))" "9";
reads "a slot the class always had" "(i64 (get anchor :x))" "7";
(* [defconst], which this changes nothing about and which was
already the immediate one: a constant the checker never
consumed is just bytes in memory, so a new value is published
by value at the frame boundary. [dev-rerun.flan] pins the
re-run half; this is the live one. *)
ignore (evals "re-evaluating a defconst"
"(defconst limit f64 41.0)");
reads "the re-evaluated defconst" "(i64 limit)" "41";
(* And the one [def] spelling with nothing to run. [uninit] lifts
no initialiser, so there is nothing for the store to call and
nothing is stored — the byte the run wrote is still there. *)
reads "the byte the run wrote" "(i64 (at scratch 0))" "77";
ignore (evals "re-evaluating an uninit def"
"(def scratch [4 u8] uninit)");
reads "the byte an uninit def did not repaint"
"(i64 (at scratch 0))" "77";
(* A retype is refused before anything is stored, by the pass
that can name both types. *)
let r = request c ("(:op \"eval\" :code "
^ Wire.quote "(def speed string \"x\")" ^ file) in
if status r <> "error" then
fail "a def that changes type was accepted (%s)" tag
else if not (contains_sub (said r) "changes type") then
fail "the retype refusal reads %S (%s)" (said r) tag;
reads "the global a refused retype was about" "speed" "42";
(* An initialiser is arbitrary code and can signal, and what has
to happen then is that the program stops rather than carrying
on. A scalar is the case where the old value survives on both
backends: it comes back in a register and is stored after the
transfer guard, so the signal jumps past the store. An
aggregate is not, on x86 — see FIX.org, 2026-09-21 — which is
why the probe here is an [i64] and the claim below is about
this shape and not about every one. *)
ignore (evals "a def whose initialiser signals"
"(def speed i64 (blow))");
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await ~ms:20000
(fun () -> stopped (request c "(:op \"describe\")")))
then
fail "a signalling initialiser never stopped the program (%s)" tag
else begin
(* Named as the evaluation it is: the way out is the boundary
restart the agent establishes around every thunk it runs. *)
let r = request c "(:op \"break\")" in
(match Wire.field r "abandon" with
| Some { Form.v = Form.Int 0L; _ } -> ()
| _ ->
fail "the break a signalling initialiser took offers no way \
out (%s): %s" tag (said r));
reads "the global after a failed initialiser" "speed" "42";
let r =
request c
"(:op \"restart-at\" :index 0 :name \"abandon-evaluation\")"
in
if status r <> "ok" then
fail "abandoning a failed initialiser: %s (%s)" (said r) tag;
if not (await ~ms:20000
(fun () ->
not (stopped (request c "(:op \"describe\")"))))
then
fail "the program never carried on after the abandon (%s)" tag;
(* And the session is not wedged: the next evaluation of the
same name stores like any other. *)
ignore (evals "editing the same def again" "(def speed i64 5)");
reads "the def edited after a failed one" "speed" "5"
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ dsock; dout ])
[ ("x86", [||]); ("llvm", [| "--llvm" |]) ];
(* ── A daemon whose editor was killed ─────────────────────────────── *)
(* The defect FIX.org recorded and PDEATHSIG does not reach: an editor that
quits *politely* sends [close] and the daemon ends, but one that is
killed sends nothing, and before this the loop went on accepting for
ever. So the whole test is the missing goodbye — the connection is
dropped without a [close] on it, which is all a SIGKILLed Emacs leaves
behind, and what has to happen next is the daemon reaping itself.
[FLAN_DEV_CLIENT_GRACE] is here so this can be seconds instead of
minutes. It is a parameter rather than a constant for exactly this: a
default short enough to test would be one that fires on a person, and a
default long enough for a person is one no suite can wait out. *)
let gsock = tmp "gone.sock" and gout = tmp "gone.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_env flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; gsock |]
(Array.append (Unix.environment ()) [| "FLAN_DEV_CLIENT_GRACE=0.1" |])
Unix.stdin gfd Unix.stderr
in
Unix.close gfd;
if not (listening ~pid:gpid gsock) then begin
fail "the orphan-grace daemon %s" !listen_why;
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let reaped () =
match Unix.waitpid [ Unix.WNOHANG ] gpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true
in
let c = connect gsock in
let r = request c "(:op \"describe\")" in
if status r <> "ok" then fail "the orphan-grace daemon: %s" (status r);
(* Still there while a client is holding the socket, which is the half
that keeps an editor left open overnight alive. One second against a
program that is running, so the threshold in force is the longer one
— 6 × 0.1s = 0.6s, itself three ticks past the accept loop's own 0.2s
poll interval so the number is not fighting the loop's own
granularity — and the wait is past it with room to spare; a hold
shorter than that would pass whether or not the clock ran under an
attached client, and would pin nothing.
It cannot fail today, and that is the point of keeping it: the reason
an attached client is safe is structural, [serve] sitting in
[Wire.recv] while the accept loop is not cycling at all. This is the
guard for the refactor that serves a connection off the accept path
and turns a structural guarantee back into an arithmetic one. *)
ignore (await ~ms:1000 reaped);
if reaped () then
fail "the daemon ended while a client was still connected to it";
(* The kill, spelled as the kernel spells it: the fd goes away and
nothing is sent. *)
(try Unix.close c with Unix.Unix_error _ -> ());
if not (await ~ms:20000 reaped) then begin
fail "the daemon outlived its client: nothing ended it %s"
(In_channel.with_open_bin gout In_channel.input_all);
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ gsock; gout ];
(* ── A method added to a running program ───────────────────────
The one claim classes rest on, made end to end rather than at the
session's report: a generic function compiled with one method gets a
second one delivered into the live process, and the call that goes
through its cell answers with the new method's body. The session test
pins which name is installed; this pins that installing it works.
Its own daemon over [programs/dev-class.flan], which keeps running so
that an expression has a frame boundary to be run at. *)
let csock = tmp "class.sock" and cout = tmp "class.out" in
(try Sys.remove csock with Sys_error _ -> ());
let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let cpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-class.flan"; "-s"; csock |]
Unix.stdin cfd Unix.stderr
in
Unix.close cfd;
if not (listening ~pid:cpid csock) then begin
fail "the class daemon %s (%S)" !listen_why
(In_channel.with_open_bin cout In_channel.input_all);
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect csock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let ask code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")"
code)
in
(* Every answer is compared inside the expression rather than read out
of it. A generic answers a dyn, and a dyn value is rendered to the
program's own stdout rather than into the reply's :value — it does
reach a later reply's :output, which is how the dyn-global rows
below read one, but the flush is the next reply's and not this one's.
Asking the running program whether the answer is 12 puts a typed
value in :value and takes the timing out of the test.
The first ask is retried: the agent's thread is let go only after the
socket is bound, so an early ask is a race with the startup and not a
result. *)
let answered = ref "" in
let asked () =
let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in
status r = "ok" && (answered := value r; true)
in
if not (await asked) then
fail "the class daemon never reached a frame boundary"
else begin
if !answered <> "1" then
fail "the method the program was built with answered %S" !answered;
(* A circle has no method yet, so the dispatch misses and the generic
signals NoMethod — the answer a program handles, spelled here as
the thing that makes the next step's success mean something. *)
let r =
request c
"(:op \"eval\" :code \"(defmethod area circle [q] (* 3 (* (get q \
:r) (get q :r))))\" :file \"programs/dev-class.flan\")"
in
if status r <> "ok" then fail "delivering a new method: %s" (said r)
else begin
(* The call site in the generic's own cell now reaches a branch that
did not exist when the process started. *)
let r = ask "(if (= (area (circle 2)) 12) 1 0)" in
if status r <> "ok" then
fail "calling a generic after a method was added: %s" (said r)
else if value r <> "1" then
fail "the added method did not answer 12 (%S)" (value r);
(* And the method that was already there still answers, which is
what says the generic was extended rather than replaced. *)
let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in
if value r <> "1" then
fail "the original method stopped answering (%S)" (value r)
end
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ csock; cout ];
(* ══ The agent socket is not the editor protocol ══════════════════
Two daemons of their own, both about what a session owes an editor
before the program has bound the socket it receives modules on. The
row above about a program with *no* [(agent/start ...)] is the other
half of the same claim and lives where it always did. *)
(* ── A program that starts its agent late ──────────────────────────
The shape a real one has: sand.flan opens a window and starts the
agent afterwards, so the program's own [(agent/start ...)] is seconds
into the run. The merged session used to wait up to ten seconds for the
socket *before* running its accept loop, which charged those seconds to
the first thing the editor asked. Two claims, and the second is what
stops the first from being bought with a lie: the session answers during
the delay, and a redefinition sent during it is really installed once
the program is polling.
The socket itself is no longer late. The agent package's constructor
binds FLAN_AGENT_SOCKET before main (vendor/agent/flan_agent.c,
[auto_start]), so under a daemon it is there from the first instant
whatever the program does afterwards — which is what this fixture's
sleep was a stand-in for, and the window DISCUSS.org complained about,
closed. What is still late is the *poll*, and that is the half that
matters: a module queued now installs when the program reaches its loop
and not before.
So this is also where the double start is pinned against a real daemon.
The fixture keeps its explicit [(agent/start ...)] three seconds in,
arriving at an agent that is already listening, and the delivery below
is installed on the socket the constructor bound — one listener, not
two, or the module would be queued on a ring nothing drains. *)
let lsock = tmp "lateagent.sock" and lout = tmp "lateagent.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-lateagent.flan"; "-s"; lsock |]
Unix.stdin lfd Unix.stderr
in
Unix.close lfd;
if not (listening ~pid:lpid lsock) then begin
fail "the late-agent daemon %s (%S)" !listen_why
(In_channel.with_open_bin lout In_channel.input_all);
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let lc = connect lsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* The program sleeps for three seconds before [agent/start], so this is
asked inside the delay. Two seconds is the threshold for the reason
the agentless row gives: the reply is a fraction of one and the bug
was ten, so anything in between is a loaded machine rather than a
regression. *)
let lt0 = Unix.gettimeofday () in
let r = request lc "(:op \"describe\")" in
let ldt = Unix.gettimeofday () -. lt0 in
if status r <> "ok" then
fail "a program whose agent starts late was not described: %s" (said r);
if ldt > 2. then
fail
"the first editor request waited %.1fs on a program whose agent \
starts late; the accept loop is gated on the agent again" ldt;
(* And the delivery, also inside the delay. It is taken, and it carries
no note about [(agent/start ...)]: that sentence is for a program
whose socket is not bound, and the constructor bound this one before
main. [install_note] answering nothing here is therefore the evidence
that the socket is up — the assertion is on the absence because the
absence is the claim.
It used to be the presence. The program's own start call is still
three seconds away, so this is the same moment it always was; what
changed is that the moment is no longer one in which the program
cannot be reached. lib/dev.ml's branch still says the true thing for
a program that does not link the agent at all (the agentless row
above), and FIX.org records that a dev program which links it can no
longer get there. *)
let r =
request lc
"(:op \"eval\" :code \"(defn step [] i64 9)\" :file \
\"programs/dev-lateagent.flan\")"
in
if status r <> "ok" then
fail "a redefinition sent before (agent/start ...): %s" (said r)
else begin
let note = Option.value ~default:"" (Wire.string_field r "note") in
if contains_sub note "(agent/start ...)" then
fail
"the agent socket was not bound before main, so a delivery was \
told to wait for a call the program had not made: %S" note
end;
(* The claim the note makes, checked against the program rather than
against the reply: once the sleep is over and the program is polling,
the body that was queued is the one that runs. [await] because the
moment the agent comes up is the program's to choose, and each
[eval-expr] already waits five seconds of its own. *)
let answered = ref "" in
let installed () =
let r =
request lc
"(:op \"eval-expr\" :code \"(step)\" :file \
\"programs/dev-lateagent.flan\")"
in
answered := Option.value ~default:(said r) (Wire.string_field r "value");
!answered = "9"
in
if not (await ~ms:20000 installed) then
fail
"a redefinition queued before (agent/start ...) never installed: \
(step) answered %S" !answered;
(try
ignore (Wire.send lc "(:op \"close\")");
ignore (Wire.recv lc)
with _ -> ());
(try Unix.close lc with Unix.Unix_error _ -> ());
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock; lout ];
(* ── The parked note, once per park ────────────────────────────────
A finished program is parked, so re-evaluating while a run's output is
still on the screen is the commonest thing there is — and it used to
repeat a paragraph about what "queued" means for a park on every one.
The explanation is kept for the first delivery of each park and
shortened after it, which is a claim with two halves: the second note
is smaller than the first, and a *new* park gets the long one back.
The second half is why [rerun] clears the flag as well as [eval]: a run
can start and finish with nothing evaluated in between. *)
let psock = tmp "parknote.sock" and pout = tmp "parknote.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-parknote.flan"; "-s"; psock |]
Unix.stdin pfd Unix.stderr
in
Unix.close pfd;
if not (listening ~pid:ppid psock) then begin
fail "the park-note daemon %s (%S)" !listen_why
(In_channel.with_open_bin pout In_channel.input_all);
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let pc = connect psock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let parked () =
match Wire.field (request pc "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let redefine n =
let r =
request pc
(Printf.sprintf
"(:op \"eval\" :code \"(defn step [] i64 %d)\" :file \
\"programs/dev-parknote.flan\")" n)
in
if status r <> "ok" then begin
fail "a redefinition of a parked program: %s" (said r); ""
end
else Option.value ~default:"" (Wire.string_field r "note")
in
(* [main] returns as soon as it has printed, so this is a wait on the
park rather than on anything this test does. *)
if not (await parked) then
fail "the park-note program never parked"
else begin
let first = redefine 4241 in
let second = redefine 4242 in
(* The long one by what it explains and not by its length: the
sentence about an expression taking the module first is the part
that is worth reading once. *)
if not (contains_sub first "an expression evaluated in the meantime") then
fail "the first delivery to a park did not explain itself: %S" first;
if second = "" then
fail "the second delivery to a park said nothing at all"
else if String.length second >= String.length first then
fail
"the second delivery to the same park repeated the explanation: \
%S" second;
(* Still true, and that is the point of shortening rather than
dropping it: what the reader is told is smaller, not different. *)
if not (contains_sub second "next run") then
fail "the short park note stopped saying when it installs: %S" second;
(* ── And the note has to be true, which is a claim about the run ──
What the note promises is that a body delivered to a park installs
no later than the next run. It did not: [flan_merged_park] drained
the agent's ring only on the flag an *expression* sets, and left on
the re-run flag without draining at all — so a redefinition sent
while parked was still in the queue when the thread re-entered
[flan_program_main], and installed at the coming run's first frame
boundary instead. Everything main did before its first
[(agent/poll)] ran the old body, and the change turned up one run
late.
[programs/dev-parknote.flan]'s main prints [(step)] before it polls
at all, so the first run after a parked redefinition either shows
the new body or shows the lag. The output arrives on a reply rather
than in a file — [request] collects [:output] into [output] — so
the window is measured round the ops that follow the re-run.
A new park is a new reader, so the note's own reset is checked on
the far side of the same op: main runs and parks straight away with
nothing evaluated in between, which is the case [eval]'s clearing
cannot reach and [rerun]'s can. *)
let before = Buffer.length output in
let r = request pc "(:op \"rerun\")" in
if status r <> "ok" then fail "the park-note rerun: %s" (said r)
else if not (await parked) then
fail "the park-note program never parked a second time"
else begin
let printed = Buffer.sub output before (Buffer.length output - before) in
if not (contains_sub printed "4242") then
fail
"the run after a parked redefinition printed %S, so the module \
was still in the ring when main was re-entered" printed;
let again = redefine 4243 in
if not (contains_sub again "an expression evaluated in the meantime")
then
fail "a second park did not get the explanation back: %S" again
end
end;
(try
ignore (Wire.send pc "(:op \"close\")");
ignore (Wire.recv pc)
with _ -> ());
(try Unix.close pc with Unix.Unix_error _ -> ());
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ psock; pout ];
(* ── A class redefined under its own instances ──────────────────
CLHS 4.3.6's update protocol, end to end, with a real editor at one
end and the running program's own heap at the other. "A method added
to a running program", further up, adds a *method* to a live
program; this changes what the class *is*,
which is the case that used to be silent — a (defclass ...) is
compile-time sugar for a constructor, so redefining one replaced a
function body and told the instances nothing.
What closes it: the module the session builds now carries a
registration of the class's new slot list, run by the agent after the
bodies are published, and the runtime migrates each instance lazily at
its next touch. Everything below is asked of the program, on its own
thread, against objects it has been holding since before the edit.
Every answer is compared inside the expression for the reason the
block above gives: a dyn value renders to the program's stdout and a
typed [1] lands in the reply's [:value], which takes the timing out of
the test. *)
let msock = tmp "migrate.sock" and mout = tmp "migrate.out" in
(try Sys.remove msock with Sys_error _ -> ());
let mfd = Unix.openfile mout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let mpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-classes.flan"; "-s"; msock |]
Unix.stdin mfd Unix.stderr
in
Unix.close mfd;
if not (listening ~pid:mpid msock) then begin
fail "the migration daemon %s (%S)" !listen_why
(In_channel.with_open_bin mout In_channel.input_all);
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect msock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let ask code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-classes.flan\")"
code)
in
let redefine code =
request c
(Printf.sprintf
"(:op \"eval\" :code %S :file \"programs/dev-classes.flan\")"
code)
in
(* [what] is the claim, [code] an expression that answers 1 when it
holds. A miss reports the code as well as the answer, because at
this density the line number is not enough to say which step. *)
let holds what code =
let r = ask code in
if status r <> "ok" then fail "%s: %s" what (said r)
else if value r <> "1" then
fail "%s answered %S (%s)" what (value r) code
in
(* Two instances, built by the constructor the program was compiled
with. The first ask is retried for the class block's reason: the
agent's thread is let go only after the socket is bound. *)
let started () = status (ask "(do (push instances (point 3 4)) 1)") = "ok" in
if not (await started) then
fail "the migration daemon never reached a frame boundary"
else begin
holds "a second instance" "(do (push instances (point 5 6)) 1)";
holds "the class the program was built with"
"(if (= (area (at instances 0)) 12) 1 0)";
(* ── A slot gained ── *)
let r = redefine "(defclass point [x y z])" in
if status r <> "ok" then fail "adding a slot to a class: %s" (said r)
else begin
(* The instance is the one that was pushed before the edit — same
object, same position in the same global vec — and it now
answers the new definition. This is the whole feature in three
lines: the gained slot is nil, the kept slots kept their values,
and the count is the new one. *)
holds "a gained slot is nil on an old instance"
"(if (= (get (at instances 0) :z) nil) 1 0)";
holds "a kept slot keeps its value"
"(if (= (get (at instances 0) :x) 3) 1 0)";
holds "the migrated instance has the new slot count"
"(if (= (length (at instances 0)) 3) 1 0)";
(* Dispatch after migration. The generic reaches its method by the
instance's shape tag, and a migration rebuilds the instance's
entries — so this is the line that says the tag came through it.
[area] reads :x and :y, both of which the new definition still
has, so the answer is the one it always was. *)
holds "a generic still dispatches on a migrated instance"
"(if (= (area (at instances 0)) 12) 1 0)";
(* And an instance that has not been touched since the edit is not
special: it migrates when it is asked, not when the class
changed. *)
holds "an untouched instance migrates on its own first touch"
"(if (= (length (at instances 1)) 3) 1 0)"
end;
(* ── A slot lost, and a second generation ──
[:y] goes. Nothing calls [area] after this: its method reads :y,
which is now nil, and a generic that traps on a slot its class no
longer has is the program being wrong rather than the migration. *)
let r = redefine "(defclass point [x z])" in
if status r <> "ok" then fail "removing a slot from a class: %s" (said r)
else begin
holds "a lost slot reads as absent"
"(if (= (get (at instances 0) :y) nil) 1 0)";
holds "a lost slot is gone from the count"
"(if (= (length (at instances 0)) 2) 1 0)";
holds "the slots either side of it are untouched"
"(if (= (get (at instances 0) :x) 3) 1 0)"
end;
(* ── The third redefinition ──
Three changed definitions have now been registered, so the
generation has moved three times and the instances have followed
each move. A generation that was not bumped, or was bumped to a
value an instance already carried, would leave this one stale. *)
let r = redefine "(defclass point [x z w])" in
if status r <> "ok" then fail "a third redefinition: %s" (said r)
else begin
holds "the third definition's slot count"
"(if (= (length (at instances 1)) 3) 1 0)";
holds "the third definition's new slot is nil"
"(if (= (get (at instances 1) :w) nil) 1 0)";
holds "and the value from before the first edit is still there"
"(if (= (get (at instances 1) :x) 5) 1 0)";
(* The tag is not a slot and no migration touches it: [class-of]
answers what it always did, which is what keeps every method
ever written for this class reachable. *)
holds "the instance is still an instance of its class"
"(if (= (class-of (at instances 1)) :point) 1 0)"
end;
(* ── A definition that did not change ──
Every C-c C-k re-runs a file's class definitions, and a generation
bumped per registration rather than per *change* would migrate
every instance in the program on every save. Here that would be
visible: the value written below is put into a slot the class
declares, and a spurious migration would keep it — so the
discriminating half is the raw key on the line after, which a real
migration drops and an ignored re-registration leaves alone. *)
holds "a key written straight into an instance"
"(do (put (at instances 0) :scratch 7) 1)";
let r = redefine "(defclass point [x z w])" in
if status r <> "ok" then fail "re-evaluating an unchanged class: %s" (said r)
else
holds "an unchanged definition migrates nothing"
"(if (= (get (at instances 0) :scratch) 7) 1 0)";
(* And the same key after a definition that *did* change, which is
the advisory registry stated as a test rather than as a hope: a
class instance is an open map, [put] accepts any key, and the next
migration drops the ones the class does not declare. FIX.org says
so in as many words. *)
let r = redefine "(defclass point [x z w q])" in
if status r <> "ok" then fail "a fourth redefinition: %s" (said r)
else
holds "a migration drops a key the class never declared"
"(if (= (get (at instances 0) :scratch) nil) 1 0)"
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] mpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ msock; mout ];
(* ── The same thing through the other backend ───────────────────
The block above runs on x86, because that is what [flan dev] takes
when nobody says. The registration a redefined class carries rides
the [flan_reload_call] thunk, which both backends emit and the agent
finds by [dlsym] either way — and "both backends emit it" is a
sentence [x86.ml]'s own header got wrong for long enough to be worth
not trusting a second time. So the shortest subset that would notice:
one instance, one slot added, and the three answers that say the
migration happened.
Short on purpose. What is backend-specific is the thunk reaching the
runtime at all; everything the block above pins beyond that is
flan_dyn.c's, and flan_dyn.c does not know which backend called
it. *)
let lsock2 = tmp "migrate-llvm.sock" and lout2 = tmp "migrate-llvm.out" in
(try Sys.remove lsock2 with Sys_error _ -> ());
let lfd2 = Unix.openfile lout2 [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let lpid2 =
Unix.create_process flan
[| flan; "dev"; "programs/dev-classes.flan"; "-s"; lsock2; "--llvm" |]
Unix.stdin lfd2 Unix.stderr
in
Unix.close lfd2;
if not (listening ~pid:lpid2 lsock2) then begin
fail "the LLVM migration daemon %s (%S)" !listen_why
(In_channel.with_open_bin lout2 In_channel.input_all);
(try Unix.kill lpid2 Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect lsock2 in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let ask code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-classes.flan\")"
code)
in
let holds what code =
let r = ask code in
if status r <> "ok" then fail "llvm: %s: %s" what (said r)
else if value r <> "1" then
fail "llvm: %s answered %S (%s)" what (value r) code
in
let started () = status (ask "(do (push instances (point 3 4)) 1)") = "ok" in
if not (await started) then
fail "the LLVM migration daemon never reached a frame boundary"
else begin
let r =
request c
"(:op \"eval\" :code \"(defclass point [x y z])\" \
:file \"programs/dev-classes.flan\")"
in
if status r <> "ok" then
fail "llvm: adding a slot to a class: %s" (said r)
else begin
holds "a gained slot is nil through the LLVM backend"
"(if (= (get (at instances 0) :z) nil) 1 0)";
holds "a kept slot keeps its value through the LLVM backend"
"(if (= (get (at instances 0) :x) 3) 1 0)";
holds "the slot count through the LLVM backend"
"(if (= (length (at instances 0)) 3) 1 0)";
holds "a generic still dispatches through the LLVM backend"
"(if (= (area (at instances 0)) 12) 1 0)"
end
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill lpid2 Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] lpid2) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock2; lout2 ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
Test_support.report ~label:"dev" ()
| _ -> print_endline "dev: skipped (no clang or llc on PATH)"
Reference in New Issue View Git Blame Copy Permalink