(* [flan dev]: the daemon an editor talks to (NEXT.md, the dev loop). What it adds over [flan reload] is that the session persists between evaluations and that the daemon owns the build, so its idea of the running process is not a guess. Both are tested here by sending a sequence: a name the program was never built with, then a second evaluation that uses it. If the session were rebuilt per request the second one would not even check. *) open Flan (* The watchdog first: a hang is the one failure mode that reports nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:900 "test_dev" let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt let scratch = Filename.get_temp_dir_name () let tmp n = Filename.concat scratch ("flan-devtest-" ^ n) let rec await ?(ms = 5000) f = if f () then true else if ms <= 0 then false else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end (* Waiting for a daemon to listen is waiting for two different things with one timer: [flan dev] compiles the whole program first, and only then binds. The old message, "the daemon never listened", named the second and was almost always the first — which is a wrong diagnosis, and a wrong diagnosis costs more than no message at all. So this says which. It cannot separate the two waits without a signal from [flan dev] that the build is done (see NEXT.md), but it can separate the two *failures*, and that is what actually gets read: a daemon still running when the timer expires was building, and a daemon that is gone bound nothing because it died. The second no longer costs the whole timeout either — the poll watches the process as well as the socket, so a crash fails in milliseconds instead of in half a minute, which is the part that makes a suite worth trusting. Thirty seconds, down from a minute, because the object cache is durable now (Build.cachedir) and the build this waits on is warm: 0.48s idle against 2.0s cold, and the worst ever measured under dune's own parallelism was 6.8s — cold. The watchdog at 900s is still what bounds the run. [!listen_why] carries the reason to the caller so each site can keep its own name for its daemon. One ref is enough: this file is single-threaded and the next thing after a failed wait is always the report of it. *) let listen_why = ref "" let listening ?(ms = 30000) ~pid path = let died = ref None in ignore (await ~ms (fun () -> Sys.file_exists path || (* Reaped only once it is already gone, and only on the path that ends in a failure, so a teardown's own [waitpid] is unaffected. *) match Unix.waitpid [ Unix.WNOHANG ] pid with | 0, _ -> false | _, st -> died := Some st; true | exception Unix.Unix_error _ -> false)); if Sys.file_exists path then true else begin listen_why := (match !died with | Some (Unix.WEXITED n) -> Printf.sprintf "exited with status %d before binding %s" n path | Some (Unix.WSIGNALED n) -> Printf.sprintf "was killed by signal %d before binding %s" n path (* Unreachable without WUNTRACED, and here only for exhaustiveness. *) | Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on signal %d without binding %s" n path | None -> Printf.sprintf "was still running after %ds without binding %s, so it was the \ build that did not finish, not the socket" (ms / 1000) path); false end (* ── 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 rec connect ?(ms = 5000) path = let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in match Unix.connect s (Unix.ADDR_UNIX path) with | () -> s | exception Unix.Unix_error (_, _, _) when ms > 0 -> Unix.close s; ignore (Unix.select [] [] [] 0.005); connect ~ms:(ms - 5) path (* The program's own output arrives on the replies, not on a file: the daemon reads its stdout through a pipe so an editor can see it. Every reply is drained into here, which is also what an editor does. *) let output = Buffer.create 256 let request fd sexp = let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in (match Wire.string_field r "output" with | Some t -> Buffer.add_string output t | None -> ()); r let status r = match Wire.string_field r "status" with Some s -> s | None -> "" let contains_sub hay needle = let n = String.length needle in let rec go i = i + n <= String.length hay && (String.equal (String.sub hay i n) needle || go (i + 1)) in go 0 (* ── 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 let pid = Unix.create_process flan [| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock |] Unix.stdin fd Unix.stderr in Unix.close fd; if not (listening ~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//exe says the process that built the program is the process now running it. Linux only, by /proc. Elsewhere it is skipped rather than faked: what is being checked is the process table, and there is no portable way to ask. *) if Sys.file_exists (Printf.sprintf "/proc/%d/exe" pid) then begin let want = Filename.concat (Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "flan-dev-%d" pid)) "program" in match Unix.readlink (Printf.sprintf "/proc/%d/exe" pid) with | link when link = want -> () | link -> fail "flan dev is still two processes: %s is running %s, not %s" (string_of_int pid) link want | exception Unix.Unix_error _ -> () end; (* And that the compiler is not talking to the program over a socket any more. In one process a delivery is a call into the agent's own verb table, so the *path* it used to connect on is now needed by nothing — removing it is therefore the decisive test, and the only one available from out here: a reply cannot say which way it came. Unlinking a bound unix socket does not disturb the listener; it makes new connects fail with ENOENT. So if every evaluation below still installs, nothing connected. The agent's own socket stays bound for [--two-process] and for a person at a raw socket, which is why it is still created at all. The path is the same one [start_merged] computes, and the /proc check above has already established that this pid is the program. *) let agent_sock = Filename.concat (Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "flan-dev-%d" pid)) "agent.sock" in (* A completed reply is what makes the check above deterministic, so [describe] is asked here rather than below. Connecting proves nothing: the listener is bound by [merged_setup], and the program's main thread — which is what calls [agent/start] — only runs after that returns, so a connect lands in the backlog. [merged_serve] waits for the agent socket before it accepts at all, so a reply having arrived means it has already seen the path bound. Asking after the unlink instead would be the same race from the other side: unlinking before [merged_serve] looks makes it wait out its full timeout and warn. *) let r = request c "(:op \"describe\")" in if status r <> "ok" then fail "describe: %s" (status r); if not (Sys.file_exists agent_sock) then fail "the merged program never bound %s" agent_sock else (try Unix.unlink agent_sock with Unix.Unix_error _ -> ()); (* The daemon owns the program's lifetime and kills it on [close], so every step waits for the program to have got there. "ok" from an eval means the module was queued, not that it has been installed. Output only rides along with a reply, so asking is how it is collected, and [describe] is the cheapest question there is. *) let lines () = List.length (String.split_on_char '\n' (Buffer.contents output)) - 1 in let settle n = await (fun () -> ignore (request c "(:op \"describe\")"); lines () >= n) in (* [defs] is its own op rather than more fields on [describe], because [describe] is what an editor polls to drain the program's output. It carries what eldoc, completion and find-definition each need: a kind, a signature, and where the name is written where that is knowable. An empty location is the honest answer for a global — Tast.global has no Loc — and an editor is expected to refuse rather than guess. *) let r = request c "(:op \"defs\")" in if status r <> "ok" then fail "defs: %s" (status r); (match Wire.field r "defs" with | Some { Form.v = Form.List entries; _ } -> let find name = List.find_map (fun (e : Form.t) -> match e.Form.v with | Form.List ({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str kind; _ } :: { Form.v = Form.Str sign; _ } :: { Form.v = Form.Str loc; _ } :: []) when String.equal n name -> Some (kind, sign, loc) | _ -> None) entries in (match find "step" with | Some ("fn", "step [] i64", loc) when String.length loc > 0 -> (* Absolute, because an editor is not in this process's working directory and cannot resolve a relative one. *) if loc.[0] <> '/' then fail "a fn's location is relative: %s" loc | Some (k, s, l) -> fail "step is described as (%s, %s, %s)" k s l | None -> fail "defs did not mention step"); (match find "ticks" with | Some ("var", "ticks i64", "") -> () | Some (k, s, l) -> fail "ticks is described as (%s, %s, %s)" k s l | None -> fail "defs did not mention ticks"); (match find "agent/wait-raw" with | Some ("extern", _, _) -> () | Some (k, _, _) -> fail "an extern is described as %s" k | None -> fail "defs did not mention an imported extern") | _ -> fail "defs did not answer with a list"); (* [layout]: a struct's fields and their types, out of [Tast.structs], with no running program involved at all. *) let strings_of f = match f with | Some { Form.v = Form.List xs; _ } -> List.filter_map (fun (x : Form.t) -> match x.Form.v with Form.Str s -> Some s | _ -> None) xs | _ -> [] in let fields r = match Wire.field r "fields" with | Some { Form.v = Form.List fs; _ } -> List.filter_map (fun (f : Form.t) -> match f.Form.v with | Form.List [ { Form.v = Form.Str n; _ }; { Form.v = Form.Str t; _ } ] -> Some (n ^ " " ^ t) | _ -> None) fs | _ -> [] in let r = request c "(:op \"layout\" :type \"Missing\")" in if status r <> "ok" then fail "layout Missing: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if Wire.string_field r "type" <> Some "Missing" then fail "layout answered a different type than it was asked for"; if fields r <> [ "id i32" ] then fail "Missing's fields: %s" (String.concat ", " (fields r)) end; (* The prelude's structs are in [Tast.structs] because [Check.program] prepends the prelude, and they are answered for the same reason the REPL's renderer resolves against the same list: an editor that could see a type printed and not ask about it would be the two disagreeing. [Rune] also pins the spelling — the types read exactly as [defs] spells a signature, because both go through [Types.to_string]. *) let r = request c "(:op \"layout\" :type \"Split\")" in if fields r <> [ "rest [u8]"; "sep u8"; "more bool" ] then fail "Split's fields: %s" (String.concat ", " (fields r)); let r = request c "(:op \"layout\" :type \"Nonesuch\")" in if status r <> "error" then fail "a type that does not exist got a layout"; (* A name that plainly exists and is not a struct is refused by *kind*. Both of these are types the checker knows and this op cannot describe, and "no struct is named X" would read as "X does not exist". *) let refusal r = Option.value ~default:(status r) (Wire.string_field r "message") in let contains hay needle = let n = String.length needle in let rec go i = i + n <= String.length hay && (String.equal (String.sub hay i n) needle || go (i + 1)) in go 0 in let r = request c "(:op \"eval\" :code \"(defenum Colour [red 0 green 1])\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "a new enum: %s" (refusal r) else begin let r = request c "(:op \"layout\" :type \"Colour\")" in if status r <> "error" then fail "an enum answered a struct layout" else if not (contains (refusal r) "is an enum") then fail "an enum is refused as: %s" (refusal r) end; let r = request c "(:op \"eval\" :code \"(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 \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "adding a var: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* Wait for the program to have installed it before sending the next. Both queued at once is a legitimate thing for the agent to do — one poll installs everything pending — but then only the last is observed and the sequencing is not what was tested. *) if not (settle 2) then fail "the first reload was never installed"; let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "reusing a var added earlier: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* A change the running process cannot be told, refused with the reason rather than delivered. *) let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in if status r <> "error" || not (match Wire.string_field r "message" with | Some m -> String.length m > 0 | None -> false) then fail "retyping a global was not refused"; if not (settle 3) then fail "the second reload was never installed"; (* A restart-case in a body the process was never built with. The frame it offers is an alloca in the newly loaded module's text, the call it guards goes through the host's cell, and the transfer starts in a handler and crosses [probe], which the host was compiled with. None of those three meet anywhere else in the tests. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "a redefinition with a restart-case: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (settle 4) then fail "the third reload was never installed"; (* ── 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; (* [eval] is the one op a parked program takes, because it queues and waits for nothing: the module sits in the agent's ring until the game thread next reaches a frame boundary, and the next frame boundary a parked program reaches is in its next run. 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" -> () | _ -> 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")); (* Two lines, and between them the whole claim. The first is [step] as the third reload left it, printed before the new run has reached a frame boundary; the second is the body delivered while it was parked, installed at the first [agent/wait] of the new run — 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. *) 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 \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "a declaration was accepted as an expression"; ignore (request c "(:op \"close\")"); Unix.close c; (* Closing the connection ends the program, and its transcript is the proof: 1 before any reload, 5 from a body over a var that did not exist when it started, 105 from a second body reading the same one, and 777 from a restart clause in a third — reached by a transfer that started in a handler and crossed a function the host was built with. Then the same [main], run a second time in the same process: 777 again, from the body the first run ended with, and 106 from the one delivered while it was parked. 106 and not 1 is the line that says the globals are the finished run's — the process never died, so [extra] is where the first run left it. *) ignore (Unix.waitpid [] pid); let text = Buffer.contents output in let wanted = "1\n5\n105\n777\n777\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 |] 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"); (* What is on offer, innermost first. [break] carries the names and nothing else — the state is the annotation's business, so there is one place in the daemon that decides it. *) let r = ask "(:op \"break\")" in if status r <> "ok" then fail "break: %s" (status r); (match Wire.field r "restarts" with | Some { Form.v = Form.List names; _ } -> let names = List.filter_map (fun (n : Form.t) -> match n.Form.v with Form.Str s -> Some s | _ -> None) names in if names <> [ "retry"; "use-placeholder" ] then fail "restarts on offer: %s" (String.concat ", " names) | _ -> fail "break did not list the restarts"); (* Where it is, which is the other half of what a stopped program can be asked. The shadow stack is dev-only and the daemon owns the build, so a frame per Flan call is there to be walked; the names come off the frames themselves rather than out of any DWARF, which is what makes this work in the break loop rather than in lldb. Innermost first, [main] last, and both marked as the program's: nothing is being evaluated here, so nothing is the evaluation's. *) let frames r = match Wire.field r "frames" with | Some { Form.v = Form.List l; _ } -> List.filter_map (fun (e : Form.t) -> match e.Form.v with | Form.List ({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str loc; _ } :: { Form.v = Form.Str origin; _ } :: _) -> Some (n, loc, origin) | _ -> None) l | _ -> [] in let r = ask "(:op \"backtrace\")" in if status r <> "ok" then fail "backtrace: %s" (Option.value ~default:(status r) (Wire.string_field r "message")) else begin match frames r with | [ ("fetch", floc, "program"); ("main", _, "program") ] -> (* Absolute and pointing into the program's own source, for the same reason [defs] is: an editor is not in this process's working directory. It comes off the frame, not off this end's session, so a redefined body reports where the *installed* one is written. *) if String.length floc = 0 || floc.[0] <> '/' then fail "a frame's location is not absolute: %s" floc | fs -> fail "backtrace of a stopped program: %s" (String.concat ", " (List.map (fun (n, _, o) -> n ^ "/" ^ o) fs)) end; (* The payoff. The break loop is the poll loop, so an expression evaluated here is a module the listener queues and the *stopped* thread runs — which is the only reason C-x C-e works at the one moment anybody wants it to. *) let r = ask "(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\")" in if Wire.string_field r "value" <> Some "23" then fail "C-x C-e while stopped: %s" (Option.value ~default:(status r) (Wire.string_field r "message")); (* And installing, which the break loop deliberately allows: there is no frame in progress, so the rule about swapping a body that is on the stack does not apply. This is the fix-it-and-retry loop. *) let r = ask "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 100)) ticks)\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "installing while stopped: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* -- A break inside a thunk, and the frames it cannot reach ---- *) (* Evaluating here runs a thunk through [flan_reload_call], which holds its own transfer channel and drops it on return. So a restart below that C frame — the two this program was already stopped on — has nowhere for a transfer to land: it would unwind to the thunk, stop, and the program would carry on as though nothing had been chosen. It used to be accepted and announced and silently not taken, which is the worst of the three things that could happen. Now the list says so and the choice is refused with the reason. *) let r = ask "(:op \"eval-expr\" :code \"(i64 (fetch 9))\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "an expression that stopped inside a break answered anyway"; let r = ask "(:op \"break\")" in if status r <> "ok" then fail "break inside a thunk: %s" (status r); (* Four now: the thunk's own [fetch] frame over the one below it. *) let names = match Wire.field r "restarts" with | Some { Form.v = Form.List l; _ } -> List.filter_map (fun (n : Form.t) -> match n.Form.v with Form.Str x -> Some x | _ -> None) l | _ -> [] in if names <> [ "retry"; "use-placeholder"; "retry"; "use-placeholder" ] then fail "restarts at a break inside a thunk: %s" (String.concat ", " names); let unreachable = match Wire.field r "unreachable" with | Some { Form.v = Form.List l; _ } -> List.filter_map (fun (n : Form.t) -> match n.Form.v with | Form.Int i -> Some (Int64.to_int i) | _ -> None) l | _ -> [] in if unreachable <> [ 2; 3 ] then fail "positions below the thunk: %s" (String.concat ", " (List.map string_of_int unreachable)); (* And the backtrace says the same thing the restart list does, in its own words: the two frames on top belong to the evaluation, the two below them to the program. A backtrace that did not draw that line would answer "where is my program" with [eval/1], which is true and not the question. *) (match frames (ask "(:op \"backtrace\")") with | [ ("fetch", _, "eval"); (thunk, _, "eval"); ("fetch", _, "program"); ("main", _, "program") ] when String.length thunk > 5 && String.sub thunk 0 5 = "eval/" -> () | fs -> fail "backtrace at a break inside a thunk: %s" (String.concat ", " (List.map (fun (n, _, o) -> n ^ "/" ^ o) fs))); (* Refused, and refused *here* — not accepted and dropped. *) let r = ask "(:op \"restart-at\" :index 2 :name \"retry\")" in if status r <> "error" then fail "a restart below the thunk boundary was accepted"; (* The ones above it still work, so this refuses a case rather than disabling the feature. *) let r = ask "(:op \"restart-at\" :index 0 :name \"retry\")" in if status r <> "ok" then fail "a restart inside the thunk was refused: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* And the program is back on the *outer* break, which is the one it was on before any of this — the inner resume must not have been read as the outer one resuming. *) if not (await (fun () -> let r = ask "(:op \"break\")" in status r = "ok" && (match Wire.field r "restarts" with | Some { Form.v = Form.List l; _ } -> List.length l = 2 | _ -> false))) then fail "the outer break did not come back after the inner one"; (* A name nothing offers is refused against the live stack, on the program's listener thread, before the reply. *) let r = ask "(:op \"restart\" :name \"nonesuch\")" in if status r <> "error" then fail "a restart nobody offers was accepted"; let r = ask "(:op \"restart\" :name \"retry\")" in if status r <> "ok" then fail "choosing a restart: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* [retry] returns 7 and [use-placeholder] returns -1, so the number in the transcript is the proof that this choice and not the other one was taken. *) let printed () = ignore (ask "(:op \"describe\")"); List.exists (String.equal "7") (String.split_on_char '\n' (Buffer.contents boutput)) in if not (await printed) then fail "the chosen restart never resumed"; (* Running again, and now every break verb is refused by name. There is no restart stack to walk from a running program, and answering an empty list would read as "no restarts are active". *) if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the program still reads as stopped after resuming" else begin let r = ask "(:op \"restart\" :name \"retry\")" in if status r <> "error" then fail "a restart was accepted by a running program"; let r = ask "(:op \"abort\")" in if status r <> "error" then fail "an abort was accepted by a running program"; (* Refused for the same reason, and it is not a missing feature: the frame chain is the game thread's and it is pushed and popped on every call, so a walk from this end would have the shape of a backtrace and the contents of a race. *) let r = ask "(:op \"backtrace\")" in if status r <> "error" then fail "a running program answered with a backtrace"; (* ...and an ordinary evaluation works again on the far side of it. *) let r = ask "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/buf.flan\")" in if Wire.string_field r "value" <> Some "2" then fail "an expression after the break: %s" (Option.value ~default:(status r) (Wire.string_field r "message")); (* An expression that stops *itself*. The thunk runs on the game thread from inside a poll, and the break loop it lands in polls again from inside that very call — so the agent's poll has to be re-entrant. One that cached its indices and wrote them back at the end would rewind over everything the nested poll consumed and run this same thunk again, which is not a stumble but an unbounded recursion of breaks. The evaluation cannot answer from in there and says so, with the reason, rather than waiting forever or claiming a value. *) let r = ask "(:op \"eval-expr\" :code \"(i64 (fetch 2))\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "an expression that stopped the program answered anyway"; if not (stopped r) then fail "an expression that stopped the program did not report it"; let r = ask "(:op \"restart\" :name \"use-placeholder\")" in if status r <> "ok" then fail "resuming an expression that stopped: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the stopped expression never resumed" else let r = ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")" in (* Still there, and evaluating once per evaluation: a thunk run twice by a rewound queue would have broken a second time. *) if Wire.string_field r "value" <> Some "4" then fail "an expression after a break inside a thunk: %s" (Option.value ~default:(status r) (Wire.string_field r "message")) end end; (* ...and the other way out. Every check above is of an abort being *refused*; the accepted path is the one that must not be left as code that has never run, because it is the one that ends a program. Break it once more — the daemon's own program calls [step] every time round its loop, so a body that errors stops it — and take the exit. *) (match ask "(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (error (Missing {.id 9})) 0) (use-placeholder [] -1)))\" :file \"/tmp/buf.flan\")" with | r when status r <> "ok" -> fail "installing a body that errors: %s" (Option.value ~default:"" (Wire.string_field r "message")) | _ -> if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then fail "the program never stopped on the body that errors" else begin (* The claim this test exists for, and the one thing about a shadow stack that is easy to get wrong: **the pop happens on the transfer path too**. Five breaks have been taken and resumed by now, every one of them by a condition transfer that unwound past the frame that erred. A pop written only on the normal return path would have left one dead frame behind each time, and this backtrace would be [step, main] with a pile of stale [fetch]es under it. It is two frames or the feature is a liar. *) (match List.map (fun (n, _, o) -> (n, o)) (match Wire.field (ask "(:op \"backtrace\")") "frames" with | Some { Form.v = Form.List l; _ } -> List.filter_map (fun (e : Form.t) -> match e.Form.v with | Form.List ({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str loc; _ } :: { Form.v = Form.Str o; _ } :: _) -> Some (n, loc, o) | _ -> None) l | _ -> []) with | [ ("step", "program"); ("main", "program") ] -> () | fs -> fail "frames left on the shadow stack by five handled errors: %s" (String.concat ", " (List.map (fun (n, o) -> n ^ "/" ^ o) fs))); let r = ask "(:op \"abort\")" in if status r <> "ok" then fail "abort was refused by a stopped program: %s" (Option.value ~default:"" (Wire.string_field r "message")) end); Unix.close c; (* No [close] op: an abort ends the program, and the daemon owns the program's lifetime, so it comes down on its own. A daemon still running here would be one waiting on a socket nobody will use. *) if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] bpid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin fail "the daemon outlived the program it aborted"; (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ()) end end; (* ── A break over a bad index ──────────────────────────────────── *) (* The block above stops on an [error] the program wrote. This one stops on one nobody wrote: an out-of-bounds index, which until now printed its location and called exit(134) — taking the compiler and the session with it, since [flan dev] is one process. Three claims, and the third is the point. The condition arrives named [BoundsError] and its name resolves to a layout, so the conditions buffer can show the numbers without anything special-casing it. The restart on offer is the *program's* own [continue] — nothing is established at the failing index, deliberately, because nothing a handler could do would make index 9 valid for a length-4 array. And taking it resumes: the transcript says 1, which is what [continue]'s clause set, and the program goes on polling on the far side. Its own daemon and its own program, for the reason every block here has one: these claims are about one frame of one program. *) let xsock = tmp "break-bounds.sock" and xout = tmp "break-bounds.out" in (try Sys.remove xsock with Sys_error _ -> ()); let xfd = Unix.openfile xout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let xpid = Unix.create_process flan [| flan; "dev"; "programs/dev-break-bounds.flan"; "-s"; xsock |] Unix.stdin xfd Unix.stderr in Unix.close xfd; if not (listening ~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"); (* Only the program's own restart is on offer. Nothing is pushed at the failing index, so a list with anything else on it would mean a site restart had been established after all. *) let r = ask "(:op \"break\")" in if status r <> "ok" then fail "break over a bad index: %s" (status r); (match Wire.field r "restarts" with | Some { Form.v = Form.List l; _ } -> let names = List.filter_map (fun (n : Form.t) -> match n.Form.v with Form.Str x -> Some x | _ -> None) l in if names <> [ "continue" ] then fail "restarts at a bad index: %s" (String.concat ", " names) | _ -> fail "break over a bad index listed no restarts"); (* And the payoff: taking it resumes, which is the difference between a stop you can recover from and a dead session. *) let r = ask "(:op \"restart\" :name \"continue\")" in if status r <> "ok" then fail "continuing past a bad index: %s" (Option.value ~default:"" (Wire.string_field r "message")); let printed () = ignore (ask "(:op \"describe\")"); List.exists (String.equal "1") (String.split_on_char '\n' (Buffer.contents xoutput)) in if not (await printed) then fail "the program never resumed past a bad index"; (* Ordinary work on the far side of it, which is the whole claim: the session outlived the index. *) let r = ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")" in if Wire.string_field r "value" <> Some "4" then fail "an expression after a bad index: %s" (Option.value ~default:(status r) (Wire.string_field r "message")) end; ignore (ask "(:op \"close\")"); Unix.close c; if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] xpid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin (try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] xpid) with Unix.Unix_error _ -> ()) end end; (* ── 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 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 let last = ref (ask "(:op \"describe\")") in if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last)) 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); (* 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")); (* 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. *) let r = ask "(:op \"abort\")" in 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 "null allocator" "dev-trap-null-alloc.flan" "NullAllocator" []; (* ── The locals of a stopped frame ─────────────────────────────── *) (* A third daemon, over a program that stops with something worth looking at. This is the half of the shadow stack the backtrace was built for: the frame chain gives the addresses, [Tast.fn] gives the types and the names, and a thunk compiled here renders those types at those addresses inside the stopped program. Nothing is copied out — a Flan value has no header, so bytes read from another process would be bytes with no meaning. Its own daemon and its own program, for the same reason the break block has: the claims are about one frame of one program. *) let lsock = tmp "locals.sock" and lout = tmp "locals.out" in (try Sys.remove lsock with Sys_error _ -> ()); let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let lpid = Unix.create_process flan [| flan; "dev"; "programs/dev-locals.flan"; "-s"; lsock |] Unix.stdin lfd Unix.stderr in Unix.close lfd; if not (listening ~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") ] in if got <> want then fail "locals of the stopped frame: %s" (String.concat ", " (List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got)); (* And the one that must not be rendered. [after] is bound inside the restart-case *past* the error, so its slot is storage nothing has written: the frame records a null for it, and a thunk that printed it would dereference that null on the game thread of a program that is already stopped. Refused by name, with the reason, rather than left off the list — a local that is missing and a local that could not be read are different facts. *) match List.filter (fun (n, _, _) -> n = "after") (pairs r "refused") with | [ (_, why, _) ] when why <> "" -> () | _ -> fail "a slot bound after the error was not refused by name: %s" (String.concat ", " (List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused"))) end; (* A frame whose every slot the compiler invented is not an error and is not an empty answer either: it says which it is. *) let r = ask "(:op \"locals\" :frame 1)" in if status r <> "ok" then fail "locals of main: %s" (status r); (* Out of range is refused with the depth, so a client can tell a bad index from a frame with nothing in it. *) let r = ask "(:op \"locals\" :frame 9)" in if status r <> "error" then fail "a frame index past the end answered"; (* The inverse, first, because it is the cheap half of the same claim: a redefinition that really does change the slots must be refused too, and that one a count comparison can see. This body drops [flag] and keeps the signature, so the frame on the stack has one slot more than the body this session now holds. *) let r = ask "(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [p (Point {.x 1.5 .y 2.5}) xs [10 20 30]] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "installing a body with fewer slots while stopped: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin let r = ask "(:op \"locals\" :frame 0)" in if status r <> "error" then fail "the frame of a body whose slots changed answered anyway" end; (* And the case that makes this a fingerprint rather than a slot count. Installing while stopped is deliberately allowed — it is the fix-it-and-retry loop — so the body on the stack and the body the session holds can be two different bodies of one function. This one renames every local and keeps the count and the types, which a count comparison cannot see: without the hash, [q] would be shown holding [p]'s value and nothing would say so. *) let r = ask "(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0)] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "installing a renamed body while stopped: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin let r = ask "(:op \"locals\" :frame 0)" in if status r <> "error" then fail "the frame of a superseded body answered with the new body's names"; (* And the other half of that claim, which is the one a fingerprint that never matched would fail: redefining [look] says nothing about [main], and its frame must still answer. A refusal that fires for every frame would pass the test above and make the whole verb useless. *) let r = ask "(:op \"locals\" :frame 1)" in if status r <> "ok" then fail "redefining one function refused an untouched frame: %s" (Option.value ~default:(status r) (Wire.string_field r "message")) end end; (* Running again, and then the locals verb is refused: a frame that is still executing does not hold still long enough to be read. *) let r = ask "(:op \"restart\" :name \"carry-on\")" in if status r <> "ok" then fail "resuming the locals program: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the locals program never resumed" else begin let r = ask "(:op \"locals\" :frame 0)" in if status r <> "error" then fail "a running program answered with its locals" end; ignore (ask "(:op \"close\")"); Unix.close c; if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] lpid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin (try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ()) end end; (* ── Which frame the inspector answered from ───────────────────── *) (* The locals listing was already frame-accurate; the inspector was not. `i' in the break buffer sent the local's *name* to be evaluated, and an expression is evaluated where the evaluator stands — the right frame only when the frame is the innermost one. dev-inspect.flan is built so that failing to root at the frame is visible in the value rather than only in the reasoning: `mark' is a global holding 99 and a local of the *outer* frame holding a Point, and the two are not even the same type. So the discriminating pair below is one evaluation and one inspection of the same name. It also carries the two shapes an expression cannot reach at all: an option's payload, which no accessor form in the language names, and a 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 |] 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 \"\")" 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; (* ── 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 |] 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 []; this is what having somebody to ask buys. *) (match find "live" with | Some ("live", "(Ptr Enemy)", "") -> () | 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 = " 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 \"\")" 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 <> "" 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) " "ok" then fail "reading a live address as a named type: %s" (message r) else begin if value r <> "" 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 <> "" 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 |] 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 (ask "(:op \"abort\")"); Unix.close c; if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] gpid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ()) end end; (* ── Disassembly ───────────────────────────────────────────────── *) (* A third daemon, over a program that keeps running, because the two claims here are about *which* module owns a name and what the answer is allowed to say it means — and both change the moment a body is delivered. Its own session rather than a reuse of the first: the first one's program has been reloaded four times and abandoned by the time it gets here, and a generation counter tested against a session someone else drove says nothing. *) let dsock = tmp "disasm.sock" and dout = tmp "disasm.out" in (try Sys.remove dsock with Sys_error _ -> ()); let dfd = Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let dpid = Unix.create_process flan [| flan; "dev"; "programs/dev-repl.flan"; "-s"; dsock |] Unix.stdin dfd Unix.stderr in Unix.close dfd; if not (listening ~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 hay needle = let n = String.length needle and h = String.length hay in let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n > 0 && go 0 in let have_objdump = Sys.command "command -v objdump > /dev/null 2>&1" = 0 in (* Nothing has been delivered, so the cell still holds the body the process was launched with. This is the one case where "what is installed now" is knowable, and the reply has to say so rather than hedging like the others. *) let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "the IR of a name the program was built with: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if generation r <> Some 0 then fail "an untouched name is not generation 0"; if not (has (text r) "define") || not (has (text r) "flan.step") then fail "the IR of step is not a define of it: %S" (text r); (* One function, not the module: dev-repl.flan defines [main] too, and a slice that ran past its own closing brace would carry it. *) if has (text r) "flan.main" then fail "the IR of step carried another function with it"; if not (has (basis r) "host executable") then fail "an untouched name does not say it is the host's: %S" (basis r) end; (* Delivering one moves the ownership, and with it everything the reply derives from it: the generation, the object, the location the body was typed at, and what the answer is now allowed to claim. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 7)) ticks)\" :file \"/tmp/disasm.flan\")" in if status r <> "ok" then fail "installing a body to disassemble: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "the IR of a redefined name: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if generation r <> Some 1 then fail "a redefined name is not generation 1: %s" (match generation r with Some n -> string_of_int n | None -> "none"); (* The body that was just sent, not the one the program was built with — the two differ only in the constant. *) if not (has (text r) "7") then fail "the IR shown is not the body that was delivered: %S" (text r); if Wire.string_field r "loc" <> Some "/tmp/disasm.flan:1:7" then fail "the location is not where the new body was typed: %s" (Option.value ~default:"" (Wire.string_field r "loc")); match Wire.string_field r "object" with | Some o when Filename.check_suffix o ".ll" -> () | o -> fail "the IR did not come from a .ll: %s" (Option.value ~default:"" o) end; (* The honesty rule, and the whole reason this op is not allowed to say "installed": the daemon delivered a module and the agent queued it, which is not the same as the game thread having stored it into a cell — and there is no verb that would let the daemon find out. *) let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if has (basis r) "host executable" then fail "a delivered body still claims to be the host's"; if not (has (basis r) "cannot read the cell back") && not (has (basis r) "not installed yet") && not (has (basis r) "cannot be said") then fail "a delivered body claims more than delivery: %S" (basis r) end; if not have_objdump then print_endline "dev: disassembly skipped (no objdump on PATH)" else begin let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in if status r <> "ok" then fail "the machine code of a redefined name: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin (* Offsets from the function's own start, SBCL's way: an address into a .so is the one number on the line a reader cannot use. The first instruction is therefore at 0000 whatever the object's layout. *) if not (has (text r) " 0000 ") then fail "the listing is not rebased to the function's start: %S" (text r); if not (has (text r) "ret") then fail "the listing has no instructions in it: %S" (text r); (* Not faked. There are no line tables in this build, so the reply says that rather than printing a listing with no source in it. *) if not (has (Option.value ~default:"" (Wire.string_field r "note")) "line tables") then fail "the listing does not say why there is no source in it"; match Wire.string_field r "object" with | Some o when Filename.check_suffix o ".so" -> () | o -> fail "the code did not come from a .so: %s" (Option.value ~default:"" o) end; (* The other presentation borrow, and the one that needs a body with somewhere to jump to: a branch inside the function reads as [L0] rather than as an address into an object nobody will open. *) let r = request c "(:op \"eval\" :code \"(defn wind [n i32] i32 (let [acc 0] (dotimes [i n] (set acc (+ acc i))) acc))\" :file \"/tmp/disasm.flan\")" in if status r <> "ok" then fail "installing a body with a loop in it: %s" (Option.value ~default:"" (Wire.string_field r "message")) else let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in if status r <> "ok" then fail "the machine code of a loop: %s" (Option.value ~default:"" (Wire.string_field r "message")) else if not (has (text r) "L0:") then fail "a branch target is not labelled: %S" (text r) else if has (text r) " "error" then fail "%s was not refused" what else match Wire.string_field r "message" with | Some m when has m wanted -> () | m -> fail "%s was refused for the wrong reason: %s" what (Option.value ~default:"" m) in refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")" "not a function"; refused "a name nothing defines" "(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")" "no function named"; refused "a form that is neither ir nor asm" "(:op \"disassemble\" :name \"step\" :form \"pdf\")" "\"ir\" or"; refused "a request with no name" "(:op \"disassemble\" :form \"asm\")" "needs :name"; (* A stopped program has not thereby failed to install. The commonest way to stop is to install a body and have it error, so the one thing the basis must not say here is "not installed yet" — it would be asserting non-installation in exactly the case where the body is running. *) let stopped r = match Wire.field r "stopped" with | Some { Form.v = Form.Sym "t"; _ } -> true | _ -> false in let r = request c "(:op \"eval\" :code \"(defn step [] i64 (error (Missing {.id 3})))\" :file \"/tmp/disasm.flan\")" in if status r <> "ok" then fail "installing a body that errors: %s" (Option.value ~default:"" (Wire.string_field r "message")) else if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then fail "the program never stopped on the body that errors" else begin let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "disassembling while the program is stopped: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if not (has (basis r) "stopped on Missing") then fail "a stopped program is not mentioned in the basis: %S" (basis r); if has (basis r) "not installed" then fail "a stopped program is said not to have installed: %S" (basis r) end end; ignore (request c "(:op \"close\")"); Unix.close c; if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] dpid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ()) end end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ]; (* ── A location that survives an evaluation that did not land ───── *) (* [Session.eval] replaces the checked program the moment a form checks, which is before the build and before delivery. So there is a window in which the session holds a body the running process has never seen, and a disassembly that took its source location from the session would point into the buffer of code that never landed — while showing the host's code and saying, correctly, that nothing had been delivered. One reply contradicting itself in two fields. A daemon whose [llc] is [false] reproduces it exactly and cheaply: the host is built by clang and runs, every redefinition checks and then fails to build, and nothing is ever delivered. *) let ssock = tmp "stale.sock" and sout = tmp "stale.out" in (try Sys.remove ssock with Sys_error _ -> ()); let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let env = Array.append (Unix.environment ()) [| "FLAN_LLC=false" |] in let spid = Unix.create_process_env flan [| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |] env Unix.stdin sfd Unix.stderr in Unix.close sfd; if not (listening ~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 hay needle = let n = String.length needle and h = String.length hay in let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n > 0 && go 0 in let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")" in if status r <> "error" then fail "an evaluation that cannot be built was reported as installed"; let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "disassembling after a build that failed: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin let loc = Option.value ~default:"" (Wire.string_field r "loc") in if has loc "never-landed" then fail "the location is a buffer whose code was never delivered: %s" loc; if not (has loc "dev-repl.flan") then fail "the location is not the source the process was built from: %s" loc end; ignore (request c "(:op \"close\")"); Unix.close c; if not (await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] spid with | 0, _ -> false | _ -> true | exception Unix.Unix_error _ -> true)) then begin (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()) end end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ]; (* ── 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 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 ]; (* --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-, one module per eval, and never reuses a name — dlopen caches by path. The first is m1.so. *) let so = Filename.concat (Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "flan-dev-%d" gpid)) "m1.so" in if not (Sys.file_exists so) then fail "the --debug daemon left no module at %s" so else begin let dump = tmp "dbg.dwarf" in let code = Sys.command (Printf.sprintf "llvm-dwarfdump --debug-line %s > %s 2>&1" (Filename.quote so) (Filename.quote dump)) in let text = if code <> 0 then "" else In_channel.with_open_bin dump In_channel.input_all in (try Sys.remove dump with Sys_error _ -> ()); let has hay needle = let n = String.length needle and h = String.length hay in let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n > 0 && go 0 in if not (has text "dbg.flan") then fail "a --debug daemon's module carries no line table for the form's \ file, so a line breakpoint would stay pending across C-c C-c" end end; (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ()) end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ] end; (* ── The watch table ───────────────────────────────────────────── *) (* The claim being tested is the one that makes the watch buffer possible at all: values reach the editor *without anything being compiled*. Every other listing here — locals, globals, inspect — is a thunk built from the types, sent over and run at a frame boundary, which is fine at the rate a person presses a key and ruinous at the rate a HUD refreshes. This op compiles nothing. The program pushes into a table from inside its own loop and the daemon reads memory. Four things in order: nothing is written while nobody is watching; a value appears once the table is armed; the *rendering* is per type, so an f64 and a string do not come back looking like the i64 beside them; and disarming stops it again. The first and the last are the ones that make watching free when a watch buffer is closed, which is the whole reason arming is a message rather than something inferred. *) let wsock = tmp "watch.sock" and wout = tmp "watch.out" in (try Sys.remove wsock with Sys_error _ -> ()); let wfd = Unix.openfile wout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let wpid = Unix.create_process flan [| flan; "dev"; "programs/dev-watch.flan"; "-s"; wsock |] Unix.stdin wfd Unix.stderr in Unix.close wfd; if not (listening ~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:"" (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:"" c) "Pause"); let r = ask "(:op \"break\")" in let names = match Wire.field r "restarts" with | Some { Form.v = Form.List l; _ } -> List.filter_map (fun (n : Form.t) -> match n.Form.v with Form.Str x -> Some x | _ -> None) l | _ -> [] in if not (List.exists (String.equal "continue") names) then fail "a break at (pause) offers %s, wanted continue among them" (String.concat ", " names); (* The second claim, and the one this block exists for. A plain re-evaluation of the same form replaces the stored declaration with an unmarked one — that single statement is the whole of "it sticks until evaluated plainly", and nothing else holds the mark. Sent while stopped, which the break loop allows: there is no frame in progress for [step]. *) let r = ask (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")" (Wire.quote body)) in if status r <> "ok" then fail "re-evaluating a marked form plainly: %s" (Option.value ~default:"" (Wire.string_field r "message")); if Wire.field r "pause" <> None then fail "a plain evaluation echoed a pause position"; let r = ask "(:op \"restart\" :name \"continue\")" in if status r <> "ok" then fail "continue at a breakpoint: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the program never resumed from its breakpoint" else begin (* And then it has to *stay* running. A single sample proves nothing: the frame that resumed is still in the old marked body, past the [(pause)] call, so the first look is running whether or not the mark was cleared. The program calls [step] every 5ms, so half a second of polling is a hundred calls through the body just installed — and if the mark were still there, one of them would stop. *) let deadline = Unix.gettimeofday () +. 0.5 in let rec run_on () = if Unix.gettimeofday () > deadline then () else if stopped (ask "(:op \"describe\")") then fail "the mark was still there after a plain re-evaluation" else begin ignore (Unix.select [] [] [] 0.01); run_on () end in run_on () end end end; (* C-u C-x C-e: the same feature for §9's "last expression" target, and a flag rather than a position because the expression sent is the whole of it. The reply it must *not* give is the timeout, which is what a thunk parked in the break loop looks like from the daemon's side and what this path used to answer. *) let r = ask "(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\" :pause t)" in if status r <> "ok" then fail "C-u C-x C-e was reported as a failure: %s" (Option.value ~default:"" (Wire.string_field r "message")); if Wire.string_field r "value" <> None then fail "an expression that stopped at (pause) answered with a value"; if not (stopped r) then fail "an expression that stopped at (pause) did not say so"; if Wire.string_field r "condition" <> Some "Pause" then fail "C-u C-x C-e stopped on %s, wanted Pause" (Option.value ~default:"" (Wire.string_field r "condition")); (* It does not stick, and cannot: a thunk is built and thrown away, so taking [continue] leaves nothing marked behind it. *) let r = ask "(:op \"restart\" :name \"continue\")" in if status r <> "ok" then fail "continue at an expression's breakpoint: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the program never resumed from an expression's breakpoint" else begin let r = ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")" in if Wire.string_field r "value" <> Some "4" then fail "an ordinary expression after a paused one: %s" (Option.value ~default:(status r) (Wire.string_field r "message")) end; (* And the same key on a program that is *already* stopped, which the break loop allows. The wait has to be looking for a [Pause] and not for "stopped at all": the outer break is already there when the request arrives, so anything less specific would answer for a thunk that has not run yet — and answer it on a reply whose own [:condition] names the other condition. *) let r = ask "(:op \"eval-expr\" :code \"(i64 (boom))\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "an expression that erred inside a thunk answered anyway"; if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then fail "the program never stopped on the expression that errs" else begin let r = ask "(:op \"eval-expr\" :code \"(+ 5 5)\" :file \"/tmp/buf.flan\" :pause t)" in if Wire.string_field r "condition" <> Some "Pause" then fail "C-u C-x C-e on an already-stopped program answered for %s, not Pause" (Option.value ~default:"" (Wire.string_field r "condition")); if Wire.string_field r "value" <> None then fail "C-u C-x C-e under an outer break answered with a value"; (* Innermost first, so this is the thunk's own [continue] and not anything the outer break offers. *) let r = ask "(:op \"restart\" :name \"continue\")" in if status r <> "ok" then fail "continue at a breakpoint under an outer break: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* Back on the outer break, which was never resumed, and out of it the ordinary way. *) if not (await (fun () -> Wire.string_field (ask "(:op \"describe\")") "condition" = Some "Missing")) then fail "the outer break did not come back after the inner pause"; let r = ask "(:op \"restart\" :name \"carry-on\")" in if status r <> "ok" then fail "resuming the outer break: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then fail "the program never resumed from the outer break" end; ignore (ask "(:op \"close\")"); Unix.close c end; (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ()); List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ psock; pout ]; (* ── The escape hatch, which still has to work ─────────────────── *) (* [--two-process] is the old shape: a compiler process that builds the program, launches it as a child and talks to it over the agent socket. It exists for a machine that cannot build the compiler object — no ocamlfind, no flan.cmxa beside the binary — and it is what every behaviour above was originally written against, so it is worth one round trip rather than none. The same three questions, briefly: it answers, it installs, and the program's output comes back. *) let tsock = tmp "twoproc.sock" and tout = tmp "twoproc.out" in (try Sys.remove tsock with Sys_error _ -> ()); let tfd = Unix.openfile tout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let tpid = Unix.create_process flan [| flan; "dev"; "programs/dev-loop.flan"; "-s"; tsock; "--two-process" |] Unix.stdin tfd Unix.stderr in Unix.close tfd; if not (listening ~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 is still answering after the wait ran out. 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. The block costs the full ten seconds of [merged_serve]'s [await] ([lib/dev.ml]) and there is no way to spend less: [accept_loop] is not reached until the wait expires, so the reply cannot arrive sooner. Shortening it would mean a timeout override in [lib/dev.ml] that exists for the test and for nothing else, which is a worse trade than ten seconds in a suite that already takes minutes. *) 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 let npid = Unix.create_process flan [| flan; "dev"; "programs/dev-noagent.flan"; "-s"; nsock |] 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 nc = connect nsock in (* Blocks for the whole of [merged_serve]'s wait, by construction. 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. *) (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)); (try ignore (Wire.send nc "(:op \"close\")"); ignore (Wire.recv nc) with _ -> ()); (try Unix.close nc with Unix.Unix_error _ -> ()) end; (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()); let nlog_text = try In_channel.with_open_bin nlog In_channel.input_all with Sys_error _ -> "" in if not (contains_sub nlog_text "does it call (agent/start ...)?") then fail "a program without (agent/start ...) drew no warning from flan dev:\n%s" nlog_text; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ nsock; nlog ]; (* ── 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 -> "") | None -> "" 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 defvar 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 \"(defvar fresh i64 41)\" :file \"/tmp/x86buf.flan\")" in if status r <> "ok" then fail "x86 new defvar: %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); ignore (request c "(:op \"close\")"); (try Unix.close c with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] xpid2) with Unix.Unix_error _ -> ()) end; (* 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 ]; (* ── 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.2" |]) 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. Three seconds against a program that is running, so the threshold in force is the longer one — 6 × 0.2s — 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:3000 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 ]; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; if !failures = 0 then print_endline "dev: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures; exit 1 end | _ -> print_endline "dev: skipped (no clang or llc on PATH)"