(* [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 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 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 () = 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 (await (fun () -> Sys.file_exists sock)) then fail "the daemon never listened" else begin (* The daemon owns the program's lifetime and kills it on [close], so every step waits for the program to have got there. "ok" from an eval means the module was queued, not that it has been installed. *) let c = connect sock in (* 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 (* describe: what the daemon believes about the program it launched. *) let r = request c "(:op \"describe\")" in if status r <> "ok" then fail "describe: %s" (status r); (* [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"); (* A form that does not check comes back as an error with a location, and must not disturb the session. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "a bad form was accepted"; (match Wire.string_field r "loc" with | Some l when String.length l > 0 -> () | _ -> fail "an error carried no location"); (* A name the program was never built with, then a second evaluation that uses it. The second one only checks at all because the session kept the first. *) let r = request c "(:op \"eval\" :code \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "adding a var: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* Wait for the program to have installed it before sending the next. Both queued at once is a legitimate thing for the agent to do — one poll installs everything pending — but then only the last is observed and the sequencing is not what was tested. *) if not (settle 2) then fail "the first reload was never installed"; let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "reusing a var added earlier: %s" (Option.value ~default:"" (Wire.string_field r "message")); (* A change the running process cannot be told, refused with the reason rather than delivered. *) let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in if status r <> "error" || not (match Wire.string_field r "message" with | Some m -> String.length m > 0 | None -> false) then fail "retyping a global was not refused"; if not (settle 3) then fail "the second reload was never installed"; (* A restart-case in a body the process was never built with. The frame it offers is an alloca in the newly loaded module's text, the call it guards goes through the host's cell, and the transfer starts in a handler and crosses [probe], which the host was compiled with. None of those three meet anywhere else in the tests. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")" in if status r <> "ok" then fail "a redefinition with a restart-case: %s" (Option.value ~default:"" (Wire.string_field r "message")); if not (settle 4) then fail "the third reload was never installed"; (* Expression evaluation, which is a different primitive: no name to install a body into, so a thunk runs at a frame boundary and the value comes back rendered. The program has stopped reaching frame boundaries by now, so this only checks that the types that have no printer say so rather than guessing — the live path is test_repl. *) let r = request c "(:op \"eval-expr\" :code \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in if status r <> "error" then fail "a declaration was accepted as an expression"; ignore (request c "(:op \"close\")"); Unix.close c; (* Closing the connection ends the program, and its transcript is the proof: 1 before any reload, 5 from a body over a var that did not exist when it started, 105 from a second body reading the same one, and 777 from a restart clause in a third — reached by a transfer that started in a handler and crossed a function the host was built with. *) ignore (Unix.waitpid [] pid); let text = Buffer.contents output in let wanted = "1\n5\n105\n777\n" in if text <> wanted then fail "program transcript\n got: %S\n wanted: %S" text wanted end; (* ── The break loop, from the editor's side ────────────────────── *) (* A second daemon, over a program that stops on its first frame. The claims are that an editor can find out it stopped without having been told, that everything an editor does still works while it is stopped — C-x C-e most of all, since the break loop *is* the poll loop — and that a choice comes back refused or accepted, never "probably". Its own daemon, its own program and its own output buffer: the block above ends by checking a transcript, and sharing either with this would make that check about two programs at once. *) let bsock = tmp "break.sock" and bout = tmp "break.out" in (try Sys.remove bsock with Sys_error _ -> ()); let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let bpid = Unix.create_process flan [| flan; "dev"; "programs/dev-break.flan"; "-s"; bsock |] Unix.stdin bfd Unix.stderr in Unix.close bfd; if not (await (fun () -> Sys.file_exists bsock)) then begin fail "the break daemon never listened"; (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ()) end else begin let boutput = Buffer.create 256 in let c = connect bsock in let ask sexp = let r = Wire.parse (Wire.send c sexp; Wire.recv c) in (match Wire.string_field r "output" with | Some t -> Buffer.add_string boutput t | None -> ()); r in (* [:stopped] is on every reply, whatever was asked. An editor that had to ask would find out only when it happened to wonder, and a program stops at moments nobody is wondering about. *) let stopped r = match Wire.field r "stopped" with | Some { Form.v = Form.Sym "t"; _ } -> true | _ -> false in let condition r = match Wire.string_field r "condition" with Some c -> c | None -> "" in let last = ref (ask "(:op \"describe\")") in if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last)) then fail "a stopped program never said so on a reply it was already sending" else begin if condition !last <> "Missing" then fail "the condition is reported as %S, wanted %S" (condition !last) "Missing"; (* 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"); (* 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 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"; (* ...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 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; (* ── 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 (await (fun () -> Sys.file_exists dsock)) then begin fail "the disassembly daemon never listened"; (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()) end else begin let c = connect dsock in let generation r = match Wire.field r "generation" with | Some { Form.v = Form.Int n; _ } -> Some (Int64.to_int n) | _ -> None in let text r = Option.value ~default:"" (Wire.string_field r "text") in let basis r = Option.value ~default:"" (Wire.string_field r "basis") in let has hay needle = let n = String.length needle and h = String.length hay in let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n > 0 && go 0 in let have_objdump = Sys.command "command -v objdump > /dev/null 2>&1" = 0 in (* Nothing has been delivered, so the cell still holds the body the process was launched with. This is the one case where "what is installed now" is knowable, and the reply has to say so rather than hedging like the others. *) let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "the IR of a name the program was built with: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if generation r <> Some 0 then fail "an untouched name is not generation 0"; if not (has (text r) "define") || not (has (text r) "flan.step") then fail "the IR of step is not a define of it: %S" (text r); (* One function, not the module: dev-repl.flan defines [main] too, and a slice that ran past its own closing brace would carry it. *) if has (text r) "flan.main" then fail "the IR of step carried another function with it"; if not (has (basis r) "host executable") then fail "an untouched name does not say it is the host's: %S" (basis r) end; (* Delivering one moves the ownership, and with it everything the reply derives from it: the generation, the object, the location the body was typed at, and what the answer is now allowed to claim. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 7)) ticks)\" :file \"/tmp/disasm.flan\")" in if status r <> "ok" then fail "installing a body to disassemble: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if status r <> "ok" then fail "the IR of a redefined name: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin if generation r <> Some 1 then fail "a redefined name is not generation 1: %s" (match generation r with Some n -> string_of_int n | None -> "none"); (* The body that was just sent, not the one the program was built with — the two differ only in the constant. *) if not (has (text r) "7") then fail "the IR shown is not the body that was delivered: %S" (text r); if Wire.string_field r "loc" <> Some "/tmp/disasm.flan:1:7" then fail "the location is not where the new body was typed: %s" (Option.value ~default:"" (Wire.string_field r "loc")); match Wire.string_field r "object" with | Some o when Filename.check_suffix o ".ll" -> () | o -> fail "the IR did not come from a .ll: %s" (Option.value ~default:"" o) end; (* The honesty rule, and the whole reason this op is not allowed to say "installed": the daemon delivered a module and the agent queued it, which is not the same as the game thread having stored it into a cell — and there is no verb that would let the daemon find out. *) let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in if has (basis r) "host executable" then fail "a delivered body still claims to be the host's"; if not (has (basis r) "cannot read the cell back") && not (has (basis r) "not installed yet") && not (has (basis r) "cannot be said") then fail "a delivered body claims more than delivery: %S" (basis r) end; if not have_objdump then print_endline "dev: disassembly skipped (no objdump on PATH)" else begin let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in if status r <> "ok" then fail "the machine code of a redefined name: %s" (Option.value ~default:"" (Wire.string_field r "message")) else begin (* Offsets from the function's own start, SBCL's way: an address into a .so is the one number on the line a reader cannot use. The first instruction is therefore at 0000 whatever the object's layout. *) if not (has (text r) " 0000 ") then fail "the listing is not rebased to the function's start: %S" (text r); if not (has (text r) "ret") then fail "the listing has no instructions in it: %S" (text r); (* Not faked. There are no line tables in this build, so the reply says that rather than printing a listing with no source in it. *) if not (has (Option.value ~default:"" (Wire.string_field r "note")) "line tables") then fail "the listing does not say why there is no source in it"; match Wire.string_field r "object" with | Some o when Filename.check_suffix o ".so" -> () | o -> fail "the code did not come from a .so: %s" (Option.value ~default:"" o) end end; (* Refused by name, each for its own reason: [ok] would have to mean "probably" otherwise. *) let refused what req wanted = let r = request c req in if status r <> "error" then fail "%s was not refused" what else match Wire.string_field r "message" with | Some m when has m wanted -> () | m -> fail "%s was refused for the wrong reason: %s" what (Option.value ~default:"" m) in refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")" "not a function"; refused "a name nothing defines" "(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")" "no function named"; refused "a form that is neither ir nor asm" "(:op \"disassemble\" :name \"step\" :form \"pdf\")" "\"ir\" or"; refused "a request with no name" "(:op \"disassemble\" :form \"asm\")" "needs :name"; 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 ]; 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)"