Joseph Ferano
36c3e5a56d
The globals section attributed a frame by its slot fingerprint, which is the wrong cut for it: a redefined body can name entirely different globals while binding identical locals, so the check saw no change and the new body's reference set went into the union under the old body's frame, with the frame numbers beside an entry saying so. So a second fingerprint. Reach.ref_fingerprint hashes the set of globals a body names — sorted and deduplicated, because a reference set is not ordered, where slot indices make the slot fingerprint order-sensitive on purpose — and it travels the path the first one already cut: %fninfo, flan_dev_frame_refsig, the agent's snapshot, the backtrace line, Dev.globals_op. Different means the frame is skipped by name with its reason, and the rest of the stack still contributes. Two numbers rather than one, because they are two facts. A frame whose slots match and whose globals do not has locals that are perfectly readable and attribution that is not, and a combined hash would make locals refuse a frame with nothing wrong with it. locals still checks the slot fingerprint alone. It lives in reach.ml because expr_refs is already the walk that answers what a body refers to, and is the walk the union itself is built from. One consequence: emit now reaches reach, which closes a cycle through Load if cimport calls Build.cachedir, so the header cache spells the object cache directory itself. test_dev.ml drives the exact case — a body that binds identical locals and names untouched where the stopped frame names pressure. With the check disabled it fails twice: the missing refusal, and untouched appearing under frame 0.
1491 lines
71 KiB
OCaml
1491 lines
71 KiB
OCaml
(* [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
|
|
|
|
let rec connect ?(ms = 5000) path =
|
|
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
|
|
match Unix.connect s (Unix.ADDR_UNIX path) with
|
|
| () -> s
|
|
| exception Unix.Unix_error (_, _, _) when ms > 0 ->
|
|
Unix.close s;
|
|
ignore (Unix.select [] [] [] 0.005);
|
|
connect ~ms:(ms - 5) path
|
|
|
|
(* The program's own output arrives on the replies, not on a file: the daemon
|
|
reads its stdout through a pipe so an editor can see it. Every reply is
|
|
drained into here, which is also what an editor does. *)
|
|
let output = Buffer.create 256
|
|
|
|
let request fd sexp =
|
|
let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in
|
|
(match Wire.string_field r "output" with
|
|
| Some t -> Buffer.add_string output t
|
|
| None -> ());
|
|
r
|
|
|
|
let status r =
|
|
match Wire.string_field r "status" with Some s -> s | None -> "<none>"
|
|
|
|
let () =
|
|
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");
|
|
|
|
(* [layout]: a struct's fields and their types, out of [Tast.structs],
|
|
with no running program involved at all. *)
|
|
let strings_of f =
|
|
match f with
|
|
| Some { Form.v = Form.List xs; _ } ->
|
|
List.filter_map
|
|
(fun (x : Form.t) ->
|
|
match x.Form.v with Form.Str s -> Some s | _ -> None)
|
|
xs
|
|
| _ -> []
|
|
in
|
|
let fields r =
|
|
match Wire.field r "fields" with
|
|
| Some { Form.v = Form.List fs; _ } ->
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.List
|
|
[ { Form.v = Form.Str n; _ }; { Form.v = Form.Str t; _ } ] ->
|
|
Some (n ^ " " ^ t)
|
|
| _ -> None)
|
|
fs
|
|
| _ -> []
|
|
in
|
|
let r = request c "(:op \"layout\" :type \"Missing\")" in
|
|
if status r <> "ok" then
|
|
fail "layout Missing: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if Wire.string_field r "type" <> Some "Missing" then
|
|
fail "layout answered a different type than it was asked for";
|
|
if fields r <> [ "id i32" ] then
|
|
fail "Missing's fields: %s" (String.concat ", " (fields r))
|
|
end;
|
|
|
|
(* The prelude's structs are in [Tast.structs] because [Check.program]
|
|
prepends the prelude, and they are answered for the same reason the
|
|
REPL's renderer resolves against the same list: an editor that could
|
|
see a type printed and not ask about it would be the two disagreeing.
|
|
[Rune] also pins the spelling — the types read exactly as [defs]
|
|
spells a signature, because both go through [Types.to_string]. *)
|
|
let r = request c "(:op \"layout\" :type \"Split\")" in
|
|
if fields r <> [ "rest [u8]"; "sep u8"; "more bool" ] then
|
|
fail "Split's fields: %s" (String.concat ", " (fields r));
|
|
|
|
let r = request c "(:op \"layout\" :type \"Nonesuch\")" in
|
|
if status r <> "error" then fail "a type that does not exist got a layout";
|
|
|
|
(* A name that plainly exists and is not a struct is refused by *kind*.
|
|
Both of these are types the checker knows and this op cannot
|
|
describe, and "no struct is named X" would read as "X does not
|
|
exist". *)
|
|
let refusal r =
|
|
Option.value ~default:(status r) (Wire.string_field r "message")
|
|
in
|
|
let contains hay needle =
|
|
let n = String.length needle in
|
|
let rec go i =
|
|
i + n <= String.length hay
|
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
|
in
|
|
go 0
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defenum Colour [red 0 green 1])\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then fail "a new enum: %s" (refusal r)
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"Colour\")" in
|
|
if status r <> "error" then fail "an enum answered a struct layout"
|
|
else if not (contains (refusal r) "is an enum") then
|
|
fail "an enum is refused as: %s" (refusal r)
|
|
end;
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defunion Shape [(Circle [r f32])])\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then fail "a new union: %s" (refusal r)
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"Shape\")" in
|
|
if status r <> "error" then fail "a union answered a struct layout"
|
|
else if not (contains (refusal r) "is a union") then
|
|
fail "a union is refused as: %s" (refusal r)
|
|
end;
|
|
|
|
(* The identity rule, and the case NEXT.md named: a second [Blob] typed
|
|
into a package is [agent/Blob], the qualified name resolves, and the
|
|
bare one is refused with the names it could have meant rather than
|
|
resolved to either. The daemon derives the package from the path, so
|
|
the file this is sent with is the one the import qualified. *)
|
|
let agent_file =
|
|
let p = "../vendor/agent/agent.flan" in
|
|
try Unix.realpath p with Unix.Unix_error _ -> p
|
|
in
|
|
let r =
|
|
request c
|
|
(Printf.sprintf
|
|
"(:op \"eval\" :code \"(defstruct Blob [id i32])\" :file %s)"
|
|
(Wire.quote agent_file))
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a struct typed into a package: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = request c "(:op \"layout\" :type \"agent/Blob\")" in
|
|
if status r <> "ok" || fields r <> [ "id i32" ] then
|
|
fail "a qualified name did not resolve: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let r = request c "(:op \"layout\" :type \"Blob\")" in
|
|
if status r <> "error" then
|
|
fail "a bare package-qualified name was resolved rather than refused"
|
|
else if strings_of (Wire.field r "candidates") <> [ "agent/Blob" ] then
|
|
fail "the refusal did not name what it could have meant: %s"
|
|
(String.concat ", " (strings_of (Wire.field r "candidates")))
|
|
end;
|
|
|
|
(* A form that does not check comes back as an error with a location,
|
|
and must not disturb the session. *)
|
|
let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error" then fail "a bad form was accepted";
|
|
(match Wire.string_field r "loc" with
|
|
| Some l when String.length l > 0 -> ()
|
|
| _ -> fail "an error carried no location");
|
|
|
|
(* A name the program was never built with, then a second evaluation
|
|
that uses it. The second one only checks at all because the session
|
|
kept the first. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defvar extra i64) (defn step [] i64 (set extra (+ extra 5)) extra)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "adding a var: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
(* Wait for the program to have installed it before sending the next.
|
|
Both queued at once is a legitimate thing for the agent to do — one
|
|
poll installs everything pending — but then only the last is observed
|
|
and the sequencing is not what was tested. *)
|
|
if not (settle 2) then fail "the first reload was never installed";
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "reusing a var added earlier: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
|
|
(* A change the running process cannot be told, refused with the reason
|
|
rather than delivered. *)
|
|
let r = request c "(:op \"eval\" :code \"(defvar ticks i32)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error"
|
|
|| not
|
|
(match Wire.string_field r "message" with
|
|
| Some m -> String.length m > 0
|
|
| None -> false)
|
|
then fail "retyping a global was not refused";
|
|
|
|
if not (settle 3) then fail "the second reload was never installed";
|
|
|
|
(* A restart-case in a body the process was never built with. The frame
|
|
it offers is an alloca in the newly loaded module's text, the call it
|
|
guards goes through the host's cell, and the transfer starts in a
|
|
handler and crosses [probe], which the host was compiled with. None of
|
|
those three meet anywhere else in the tests. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (handler-bind [(Missing [c] (invoke-restart 'use-fallback))] (probe)) 0) (use-fallback [] 777)))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a redefinition with a restart-case: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (settle 4) then fail "the third reload was never installed";
|
|
|
|
(* Expression evaluation, which is a different primitive: no name to
|
|
install a body into, so a thunk runs at a frame boundary and the value
|
|
comes back rendered. The program has stopped reaching frame boundaries
|
|
by now, so this only checks that the types that have no printer say so
|
|
rather than guessing — the live path is test_repl. *)
|
|
let r = request c "(:op \"eval-expr\" :code \"(defvar x i64)\" :file \"/tmp/buf.flan\")" in
|
|
if status r <> "error" then fail "a declaration was accepted as an expression";
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
(* Closing the connection ends the program, and its transcript is the
|
|
proof: 1 before any reload, 5 from a body over a var that did not
|
|
exist when it started, 105 from a second body reading the same one,
|
|
and 777 from a restart clause in a third — reached by a transfer that
|
|
started in a handler and crossed a function the host was built with. *)
|
|
ignore (Unix.waitpid [] pid);
|
|
let text = Buffer.contents output in
|
|
let wanted = "1\n5\n105\n777\n" in
|
|
if text <> wanted then
|
|
fail "program transcript\n got: %S\n wanted: %S" text wanted
|
|
end;
|
|
|
|
(* ── The break loop, from the editor's side ────────────────────── *)
|
|
|
|
(* A second daemon, over a program that stops on its first frame. The
|
|
claims are that an editor can find out it stopped without having been
|
|
told, that everything an editor does still works while it is stopped —
|
|
C-x C-e most of all, since the break loop *is* the poll loop — and that
|
|
a choice comes back refused or accepted, never "probably".
|
|
|
|
Its own daemon, its own program and its own output buffer: the block
|
|
above ends by checking a transcript, and sharing either with this would
|
|
make that check about two programs at once. *)
|
|
let bsock = tmp "break.sock" and bout = tmp "break.out" in
|
|
(try Sys.remove bsock with Sys_error _ -> ());
|
|
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let bpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-break.flan"; "-s"; bsock |]
|
|
Unix.stdin bfd Unix.stderr
|
|
in
|
|
Unix.close bfd;
|
|
if not (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";
|
|
|
|
(* 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;
|
|
(* ── 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 (await (fun () -> Sys.file_exists lsock)) then begin
|
|
fail "the locals daemon never listened";
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect lsock in
|
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the locals program never stopped"
|
|
else begin
|
|
let pairs r key =
|
|
match Wire.field r key with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List ({ Form.v = Form.Str a; _ }
|
|
:: { Form.v = Form.Str b; _ } :: rest) ->
|
|
Some (a, b,
|
|
match rest with
|
|
| { Form.v = Form.Str c; _ } :: _ -> c
|
|
| _ -> "")
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "ok" then
|
|
fail "locals: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
(* One of each shape the structural printer has an arm for, rendered
|
|
in the program and read back as text. The values are the ones
|
|
[look] was called with, which is the claim: this is the frame's
|
|
own storage and not a guess from the source. *)
|
|
let got =
|
|
List.map (fun (n, ty, v) -> (n, ty, v)) (pairs r "locals")
|
|
in
|
|
let want =
|
|
[ ("n", "i64", "3");
|
|
("label", "string", "\"hello\"");
|
|
(* The *renderer's* output, not source — and it is a dot now.
|
|
[render.ml] and [emacs/flan-inspect.el] are the two ends of
|
|
one wire format, and they moved together, which is what the
|
|
note here used to say was still owed. *)
|
|
("p", "Point", "(Point {.x 1.5 .y 2.5})");
|
|
("xs", "[3 i32]", "[ 10 20 30]");
|
|
("flag", "bool", "true") ]
|
|
in
|
|
if got <> want then
|
|
fail "locals of the stopped frame: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
|
|
(* And the one that must not be rendered. [after] is bound inside
|
|
the restart-case *past* the error, so its slot is storage nothing
|
|
has written: the frame records a null for it, and a thunk that
|
|
printed it would dereference that null on the game thread of a
|
|
program that is already stopped. Refused by name, with the
|
|
reason, rather than left off the list — a local that is missing
|
|
and a local that could not be read are different facts. *)
|
|
match List.filter (fun (n, _, _) -> n = "after") (pairs r "refused") with
|
|
| [ (_, why, _) ] when why <> "" -> ()
|
|
| _ ->
|
|
fail "a slot bound after the error was not refused by name: %s"
|
|
(String.concat ", "
|
|
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
|
|
end;
|
|
(* A frame whose every slot the compiler invented is not an error and
|
|
is not an empty answer either: it says which it is. *)
|
|
let r = ask "(:op \"locals\" :frame 1)" in
|
|
if status r <> "ok" then fail "locals of main: %s" (status r);
|
|
(* Out of range is refused with the depth, so a client can tell a bad
|
|
index from a frame with nothing in it. *)
|
|
let r = ask "(:op \"locals\" :frame 9)" in
|
|
if status r <> "error" then fail "a frame index past the end answered";
|
|
|
|
(* The inverse, first, because it is the cheap half of the same
|
|
claim: a redefinition that really does change the slots must be
|
|
refused too, and that one a count comparison can see. This body
|
|
drops [flag] and keeps the signature, so the frame on the stack has
|
|
one slot more than the body this session now holds. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [p (Point {.x 1.5 .y 2.5}) xs [10 20 30]] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with fewer slots while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "the frame of a body whose slots changed answered anyway"
|
|
end;
|
|
|
|
(* And the case that makes this a fingerprint rather than a slot
|
|
count. Installing while stopped is deliberately allowed — it is the
|
|
fix-it-and-retry loop — so the body on the stack and the body the
|
|
session holds can be two different bodies of one function. This one
|
|
renames every local and keeps the count and the types, which a
|
|
count comparison cannot see: without the hash, [q] would be shown
|
|
holding [p]'s value and nothing would say so. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0)] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a renamed body while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "the frame of a superseded body answered with the new body's names";
|
|
(* And the other half of that claim, which is the one a fingerprint
|
|
that never matched would fail: redefining [look] says nothing
|
|
about [main], and its frame must still answer. A refusal that
|
|
fires for every frame would pass the test above and make the
|
|
whole verb useless. *)
|
|
let r = ask "(:op \"locals\" :frame 1)" in
|
|
if status r <> "ok" then
|
|
fail "redefining one function refused an untouched frame: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
end
|
|
end;
|
|
(* Running again, and then the locals verb is refused: a frame that is
|
|
still executing does not hold still long enough to be read. *)
|
|
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
|
if status r <> "ok" then
|
|
fail "resuming the locals program: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
|
fail "the locals program never resumed"
|
|
else begin
|
|
let r = ask "(:op \"locals\" :frame 0)" in
|
|
if status r <> "error" then
|
|
fail "a running program answered with its locals"
|
|
end;
|
|
ignore (ask "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] lpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
|
|
(* ── 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 (await (fun () -> Sys.file_exists gsock)) then begin
|
|
fail "the globals daemon never listened";
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect gsock in
|
|
let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
|
fail "the globals program never stopped"
|
|
else begin
|
|
(* (name type value (frame ...)) — four fields, the fourth a list of
|
|
numbers, which is what makes the annotation readable against the
|
|
stack section's own numbering. *)
|
|
let rows r =
|
|
match Wire.field r "globals" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List [ { Form.v = Form.Str n; _ };
|
|
{ Form.v = Form.Str ty; _ };
|
|
{ Form.v = Form.Str v; _ };
|
|
{ Form.v = Form.List fs; _ } ] ->
|
|
Some
|
|
(n, ty, v,
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.Int i -> Some (Int64.to_int i)
|
|
| _ -> None)
|
|
fs)
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
|
else begin
|
|
let want =
|
|
(* [grid] before [pressure] because that is the order they are
|
|
declared in and both are touched by frame 0; [label] last
|
|
because the innermost frame that touches it is 1, even though
|
|
it is declared before either. Ordering by proximity to the
|
|
error is what puts the likely culprit on top of a deep stack,
|
|
and declaring [label] first is how this notices that the sort
|
|
happened at all.
|
|
|
|
[grid]'s two writes are the two frames: [main] set element 1
|
|
before calling, [inner] set element 0 after. The value is read
|
|
out of the program's own storage, so both are in it. *)
|
|
[ ("grid", "[4 i32]", "[ 7 5 0 0]", [ 0; 1 ]);
|
|
("pressure", "i64", "12", [ 0 ]);
|
|
("label", "string", "\"running\"", [ 1 ]) ]
|
|
in
|
|
let got = rows r in
|
|
if got <> want then
|
|
fail "the globals of the stopped stack: %s"
|
|
(String.concat ", "
|
|
(List.map
|
|
(fun (n, ty, v, fs) ->
|
|
Printf.sprintf "%s %s = %s (%s)" n ty v
|
|
(String.concat " " (List.map string_of_int fs)))
|
|
got));
|
|
(* And the one that must not be there. [untouched] is a global of
|
|
this program that no frame on this stack reads, and a section
|
|
that listed it would be the "all the globals" answer this op
|
|
exists instead of. The prelude's own globals are the same claim
|
|
at scale: [rand-state] is in the session too. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "a global no frame on the stack references was listed anyway";
|
|
if List.exists (fun (n, _, _, _) -> n = "rand-state") got then
|
|
fail "the prelude's globals were listed; the section is not scoped \
|
|
to the stack"
|
|
end;
|
|
(* A frame whose body has been redefined since it was entered cannot
|
|
be attributed: what this session holds is a different body's
|
|
reference set. It is named in [:skipped] rather than dropped,
|
|
because "the union is incomplete and here is why" and "these are
|
|
all of them" are different answers.
|
|
|
|
The redefinition binds a local, deliberately, because that is what
|
|
the detector can see. [Emit.slot_fingerprint] hashes a body's
|
|
*slots*, so a new body with the same slots and different global
|
|
references is not caught — the hole is stated in BUILT.md, and a
|
|
test that asserted otherwise would be asserting a mechanism that is
|
|
not there. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn inner [] i64 (let [z (i64 1)] (set untouched z)) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a new body while stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals after a redefinition: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let skipped =
|
|
match Wire.field r "skipped" with
|
|
| Some { Form.v = Form.List l; _ } -> List.length l
|
|
| _ -> 0
|
|
in
|
|
if skipped = 0 then
|
|
fail "the frame of a superseded body was attributed anyway";
|
|
(* [main] is untouched by that redefinition and must still
|
|
contribute: a refusal that fired for every frame would pass the
|
|
check above and make the whole verb useless. *)
|
|
let got = rows r in
|
|
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
|
|
fail "redefining one function dropped an untouched frame's globals";
|
|
(* And the new body's references must not have leaked in under the
|
|
old frame. [untouched] is what the installed body reads and the
|
|
frame on the stack does not. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "a superseded frame contributed the *new* body's references"
|
|
end;
|
|
(* And the case the slot fingerprint cannot see, which is the one this
|
|
section needs its own fingerprint for. This body binds exactly the
|
|
locals the frame on the stack binds — none, and the same
|
|
temporaries, because every expression in it has the same shape —
|
|
and names [untouched] where the frame's body names [pressure]. The
|
|
slot check passes; only [Reach.ref_fingerprint] can tell that what
|
|
this session now holds refers to different program state.
|
|
|
|
Refused by name and for that reason, like everything else in the
|
|
break loop. What would happen without it is not an error message:
|
|
it is [untouched] appearing in the union marked as touched by frame
|
|
0, and [pressure] missing from it, both of which read as facts
|
|
about the stopped program and are not. *)
|
|
let r =
|
|
ask
|
|
"(:op \"eval\" :code \"(defn inner [] i64 (set untouched 12) (set (at grid 0) 7) (error (Boom {.why 3})) 0)\" :file \"/tmp/buf.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with the same slots and other globals: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let r = ask "(:op \"globals\")" in
|
|
if status r <> "ok" then
|
|
fail "globals after a reference-set change: %s"
|
|
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
|
let whys =
|
|
match Wire.field r "skipped" with
|
|
| Some { Form.v = Form.List l; _ } ->
|
|
List.filter_map
|
|
(fun (e : Form.t) ->
|
|
match e.Form.v with
|
|
| Form.List [ _; { Form.v = Form.Str w; _ } ] -> Some w
|
|
| _ -> None)
|
|
l
|
|
| _ -> []
|
|
in
|
|
let mentions hay needle =
|
|
let n = String.length needle in
|
|
let rec go i =
|
|
i + n <= String.length hay
|
|
&& (String.equal (String.sub hay i n) needle || go (i + 1))
|
|
in
|
|
go 0
|
|
in
|
|
if not
|
|
(List.exists
|
|
(fun w -> mentions w "names different globals")
|
|
whys)
|
|
then
|
|
fail
|
|
"a frame whose body now names different globals was attributed \
|
|
anyway (skipped: %s)"
|
|
(String.concat " | " whys);
|
|
let got = rows r in
|
|
(* The new body's globals must not have leaked in under the old
|
|
frame, and the frame that did not change must still contribute:
|
|
a refusal that swallowed the whole stack would satisfy the check
|
|
above and say nothing. *)
|
|
if List.exists (fun (n, _, _, _) -> n = "untouched") got then
|
|
fail "the new body's globals were attributed to the old frame";
|
|
if not (List.exists (fun (n, _, _, _) -> n = "label") got) then
|
|
fail "refusing one frame dropped an untouched frame's globals"
|
|
end
|
|
end;
|
|
(* Nothing handled the condition, so there is no restart to resume by
|
|
and [abort] is the only way out. The daemon owns the program's
|
|
lifetime, so it comes down on its own. *)
|
|
ignore (ask "(:op \"abort\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] gpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
|
|
(* ── Disassembly ───────────────────────────────────────────────── *)
|
|
|
|
(* A third daemon, over a program that keeps running, because the two
|
|
claims here are about *which* module owns a name and what the answer is
|
|
allowed to say it means — and both change the moment a body is
|
|
delivered. Its own session rather than a reuse of the first: the first
|
|
one's program has been reloaded four times and abandoned by the time it
|
|
gets here, and a generation counter tested against a session someone
|
|
else drove says nothing. *)
|
|
let dsock = tmp "disasm.sock" and dout = tmp "disasm.out" in
|
|
(try Sys.remove dsock with Sys_error _ -> ());
|
|
let dfd = Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let dpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; dsock |]
|
|
Unix.stdin dfd Unix.stderr
|
|
in
|
|
Unix.close dfd;
|
|
if not (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;
|
|
(* The other presentation borrow, and the one that needs a body with
|
|
somewhere to jump to: a branch inside the function reads as [L0]
|
|
rather than as an address into an object nobody will open. *)
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn wind [n i32] i32 (let [acc 0] (dotimes [i n] (set acc (+ acc i))) acc))\" :file \"/tmp/disasm.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body with a loop in it: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else
|
|
let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in
|
|
if status r <> "ok" then
|
|
fail "the machine code of a loop: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else if not (has (text r) "L0:") then
|
|
fail "a branch target is not labelled: %S" (text r)
|
|
else if has (text r) "<flan.wind+" then
|
|
fail "a branch still names the function it is inside: %S" (text r)
|
|
end;
|
|
|
|
(* Refused by name, each for its own reason: [ok] would have to mean
|
|
"probably" otherwise. *)
|
|
let refused what req wanted =
|
|
let r = request c req in
|
|
if status r <> "error" then fail "%s was not refused" what
|
|
else
|
|
match Wire.string_field r "message" with
|
|
| Some m when has m wanted -> ()
|
|
| m ->
|
|
fail "%s was refused for the wrong reason: %s" what
|
|
(Option.value ~default:"" m)
|
|
in
|
|
refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")"
|
|
"not a function";
|
|
refused "a name nothing defines"
|
|
"(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")"
|
|
"no function named";
|
|
refused "a form that is neither ir nor asm"
|
|
"(:op \"disassemble\" :name \"step\" :form \"pdf\")"
|
|
"\"ir\" or";
|
|
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
|
|
"needs :name";
|
|
|
|
(* A stopped program has not thereby failed to install. The commonest way
|
|
to stop is to install a body and have it error, so the one thing the
|
|
basis must not say here is "not installed yet" — it would be asserting
|
|
non-installation in exactly the case where the body is running. *)
|
|
let stopped r =
|
|
match Wire.field r "stopped" with
|
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
|
| _ -> false
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (error (Missing {.id 3})))\" :file \"/tmp/disasm.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "installing a body that errors: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else if
|
|
not (await (fun () -> stopped (request c "(:op \"describe\")")))
|
|
then fail "the program never stopped on the body that errors"
|
|
else begin
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "disassembling while the program is stopped: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
if not (has (basis r) "stopped on Missing") then
|
|
fail "a stopped program is not mentioned in the basis: %S" (basis r);
|
|
if has (basis r) "not installed" then
|
|
fail "a stopped program is said not to have installed: %S" (basis r)
|
|
end
|
|
end;
|
|
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] dpid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ];
|
|
|
|
(* ── A location that survives an evaluation that did not land ───── *)
|
|
|
|
(* [Session.eval] replaces the checked program the moment a form checks,
|
|
which is before the build and before delivery. So there is a window in
|
|
which the session holds a body the running process has never seen, and a
|
|
disassembly that took its source location from the session would point
|
|
into the buffer of code that never landed — while showing the host's
|
|
code and saying, correctly, that nothing had been delivered. One reply
|
|
contradicting itself in two fields.
|
|
|
|
A daemon whose [llc] is [false] reproduces it exactly and cheaply: the
|
|
host is built by clang and runs, every redefinition checks and then
|
|
fails to build, and nothing is ever delivered. *)
|
|
let ssock = tmp "stale.sock" and sout = tmp "stale.out" in
|
|
(try Sys.remove ssock with Sys_error _ -> ());
|
|
let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let env =
|
|
Array.append (Unix.environment ()) [| "FLAN_LLC=false" |]
|
|
in
|
|
let spid =
|
|
Unix.create_process_env flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |]
|
|
env Unix.stdin sfd Unix.stderr
|
|
in
|
|
Unix.close sfd;
|
|
if not (await (fun () -> Sys.file_exists ssock)) then begin
|
|
fail "the daemon with no working llc never listened";
|
|
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect ssock in
|
|
let has hay needle =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
|
|
n > 0 && go 0
|
|
in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")"
|
|
in
|
|
if status r <> "error" then
|
|
fail "an evaluation that cannot be built was reported as installed";
|
|
let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in
|
|
if status r <> "ok" then
|
|
fail "disassembling after a build that failed: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
let loc = Option.value ~default:"" (Wire.string_field r "loc") in
|
|
if has loc "never-landed" then
|
|
fail "the location is a buffer whose code was never delivered: %s" loc;
|
|
if not (has loc "dev-repl.flan") then
|
|
fail "the location is not the source the process was built from: %s" loc
|
|
end;
|
|
ignore (request c "(:op \"close\")");
|
|
Unix.close c;
|
|
if not
|
|
(await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] spid with
|
|
| 0, _ -> false
|
|
| _ -> true
|
|
| exception Unix.Unix_error _ -> true))
|
|
then begin
|
|
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ())
|
|
end
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ];
|
|
|
|
(* --debug, and the half the IR cannot show.
|
|
|
|
[test_session.ml] asserts that a debug session *emits* the metadata,
|
|
which is the unpassed-argument defect itself. It cannot see the other
|
|
half: [Build.shared] is what turns the flag into [-g] and [-O0] on the
|
|
module, and a daemon that dropped [Build.debug] from its opts would
|
|
still emit perfect IR and then compile it away — [llvm.dbg.declare]
|
|
describes an alloca and mem2reg deletes the alloca. So this goes to the
|
|
.so the daemon actually wrote and asks the object, not the text.
|
|
|
|
The line table is the needle because it is what a breakpoint in a .flan
|
|
buffer resolves against, and it names the file the form was typed in
|
|
rather than any file on disk. *)
|
|
if Sys.command "command -v llvm-dwarfdump > /dev/null 2>&1" = 0 then begin
|
|
let gsock = tmp "dbg.sock" and gout = tmp "dbg.out" in
|
|
(try Sys.remove gsock with Sys_error _ -> ());
|
|
let gfd =
|
|
Unix.openfile gout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
|
in
|
|
let gpid =
|
|
Unix.create_process flan
|
|
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; gsock; "--debug" |]
|
|
Unix.stdin gfd Unix.stderr
|
|
in
|
|
Unix.close gfd;
|
|
if not (await (fun () -> Sys.file_exists gsock)) then begin
|
|
fail "the --debug daemon never listened";
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let c = connect gsock in
|
|
let r =
|
|
request c
|
|
"(:op \"eval\" :code \"(defn step [] i64 (let [n (i64 3)] (set ticks (+ ticks n)) ticks))\" :file \"/tmp/dbg.flan\")"
|
|
in
|
|
if status r <> "ok" then
|
|
fail "a --debug daemon refused an ordinary redefinition: %s"
|
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
|
else begin
|
|
(* The daemon builds into /tmp/flan-dev-<pid>, one module per eval,
|
|
and never reuses a name — dlopen caches by path. The first is
|
|
m1.so. *)
|
|
let so =
|
|
Filename.concat
|
|
(Filename.concat (Filename.get_temp_dir_name ())
|
|
(Printf.sprintf "flan-dev-%d" gpid))
|
|
"m1.so"
|
|
in
|
|
if not (Sys.file_exists so) then
|
|
fail "the --debug daemon left no module at %s" so
|
|
else begin
|
|
let dump = tmp "dbg.dwarf" in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "llvm-dwarfdump --debug-line %s > %s 2>&1"
|
|
(Filename.quote so) (Filename.quote dump))
|
|
in
|
|
let text =
|
|
if code <> 0 then ""
|
|
else In_channel.with_open_bin dump In_channel.input_all
|
|
in
|
|
(try Sys.remove dump with Sys_error _ -> ());
|
|
let has hay needle =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i =
|
|
i + n <= h && (String.sub hay i n = needle || go (i + 1))
|
|
in
|
|
n > 0 && go 0
|
|
in
|
|
if not (has text "dbg.flan") then
|
|
fail
|
|
"a --debug daemon's module carries no line table for the form's \
|
|
file, so a line breakpoint would stay pending across C-c C-c"
|
|
end
|
|
end;
|
|
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
(try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]
|
|
end;
|
|
|
|
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)"
|