Joseph Ferano
3ace7c262f
The mutation pass turned up one defect that did not make the suite go red: a reader branch that forgets to advance reads the same character for ever, and dune test waits as long as it is left to. In CI that is a job killed by the runner with nothing named and no output to read. watchdog.ml puts an alarm on every test binary — generous, because an alarm that fires on a slow machine is a flake — and a five-second one around each read in test_flan, where the budget really is small. The first read that does not return wedges the rest, so a looping reader costs five seconds and names the row instead of costing eight minutes or never finishing. Both were watched: the string-escape loop now fails in five seconds with the case named, and the per-binary backstop was armed short and observed to fire.
213 lines
10 KiB
OCaml
213 lines
10 KiB
OCaml
(* The reload primitive, measured (NEXT.md, dev loop step 1).
|
|
|
|
One function is recompiled into its own object and loaded into a process
|
|
that is already running. Everything after this — indirection cells, the
|
|
agent in the game, the daemon — assumes this works and is fast; nothing in
|
|
the codebase had ever done it, and plan.org's 16ms was measured with clang
|
|
in isolation somewhere else.
|
|
|
|
The parts, all of them new here:
|
|
|
|
Emit.program ~dev a cell per function; every call goes through one
|
|
Emit.redefinition a form list defined, everything else [external],
|
|
plus [flan_reload_install] to publish it into its cell
|
|
flan_dev.c the by-name registry a run-time-new name needs
|
|
Build.shared that IR text through llc + ld -shared, timed
|
|
reload_host.c dlopen, install, call — twice, in one process
|
|
|
|
The host is C rather than OCaml because that is where it has to end up: the
|
|
agent of step 3 lives in the game process, next to flan_rt.c, and there is
|
|
no OCaml runtime there. *)
|
|
|
|
open Flan
|
|
|
|
(* The watchdog first: a hang is the one failure mode that reports
|
|
nothing at all. See watchdog.ml. *)
|
|
let () = Watchdog.arm ~seconds:600 "test_reload"
|
|
|
|
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 name = Filename.concat scratch ("flan-reload-" ^ name)
|
|
|
|
let checked path =
|
|
Check.program
|
|
(Load.program ~file:path (Parse.program (Reader.read_file path))).Load.decls
|
|
|
|
let ms f =
|
|
let t0 = Unix.gettimeofday () in
|
|
let x = f () in
|
|
(x, (Unix.gettimeofday () -. t0) *. 1000.)
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
|
|
| 0 ->
|
|
let p1 = checked "programs/reload.flan" in
|
|
let p2 = checked "programs/reload-v2.flan" in
|
|
let p3 = checked "programs/reload-v3.flan" in
|
|
let p4 = checked "programs/reload-v4.flan" in
|
|
|
|
(* What the running process was built with. Everything else — v3's [extra]
|
|
and [added] — has no symbol to bind to and goes through the registry.
|
|
A session would keep this set and grow it; the test states it. *)
|
|
let host_names =
|
|
List.map (fun (f : Tast.fn) -> f.Tast.name) p1.Tast.fns
|
|
@ List.map (fun (g : Tast.global) -> g.Tast.gname) p1.Tast.globals
|
|
in
|
|
let known n = List.exists (String.equal n) host_names in
|
|
|
|
(* [dev] is the two halves of a reloadable build together: cells, so a
|
|
call site can be made to follow a redefinition, and [-rdynamic], so the
|
|
cells and globals are visible to a dlopen'd object at all. [-ldl] is the
|
|
host's own, for its dlopen. *)
|
|
let dev = { Build.default with Build.dev = true } in
|
|
let host = tmp "host" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:[ "reload_host.c" ]
|
|
~lflags:[ "-ldl" ] p1 ~out:host);
|
|
|
|
(* Two paths, not one rewritten in place: dlopen caches by path and would
|
|
hand back the first handle, so the swap would silently not happen. *)
|
|
let module_of p fns name =
|
|
let out = tmp name in
|
|
let ir, emit_ms = ms (fun () -> Emit.redefinition ~dev:true ~known p ~fns) in
|
|
let t = Build.shared ~opts:dev ~ir ~out () in
|
|
(out, ir, emit_ms, t)
|
|
in
|
|
let so1, _ir1, emit_ms, t1 = module_of p1 [ "bump" ] "v1.so" in
|
|
let so2, ir2, emit2_ms, t2 = module_of p2 [ "bump" ] "v2.so" in
|
|
(* One module, two forms: the var and the function that uses it have to
|
|
arrive together or the intermediate state refers to storage that does
|
|
not exist. This is the C-c C-k unit. *)
|
|
let so3, ir3, _, _ = module_of p3 [ "bump"; "added" ] "v3.so" in
|
|
let so4, ir4, _, _ = module_of p4 [ "added" ] "v4.so" in
|
|
|
|
(* A redefinition module must not define what the host already owns:
|
|
defining [counter] would give the loaded object a private copy and the
|
|
state would reset on every reload, and defining [helper] would freeze a
|
|
stale copy of it into the module. *)
|
|
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
|
|
go 0
|
|
in
|
|
(* No Str, for the same reason the reader is hand-written. [`First] and
|
|
[`Last] are which occurrence; the pair shape keeps the match below
|
|
readable. *)
|
|
let find hay needle which =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i acc =
|
|
if i + n > h then acc
|
|
else if String.sub hay i n = needle then
|
|
match which with `First -> Some i | `Last -> go (i + 1) (Some i)
|
|
else go (i + 1) acc
|
|
in
|
|
go 0 None
|
|
in
|
|
if not (has ir2 "@\"flan.counter\" = external global i64") then
|
|
fail "redefinition defines the global instead of declaring it";
|
|
(* In a dev module a sibling is reached only through its cell, so there is
|
|
nothing to declare and a [define] would be a private copy. *)
|
|
if has ir2 "declare i64 @\"flan.helper\"" then
|
|
fail "dev redefinition declares a sibling it should reach by cell";
|
|
if has ir2 "define i64 @\"flan.helper\"" then
|
|
fail "redefinition emitted a second body for a function it does not own";
|
|
if has ir2 "define i32 @main" then fail "redefinition emitted an entry point";
|
|
(* [hidden], or the module's own [@"flan.bump"] is interposed by the host's
|
|
and the installer publishes the very function it is replacing. *)
|
|
if not (has ir2 "define hidden i64 @\"flan.bump\"") then
|
|
fail "redefinition's own body is interposable";
|
|
if not (has ir2 "@\"flan.cell.helper\" = external global ptr") then
|
|
fail "redefinition defines a cell instead of using the host's";
|
|
(* A name the host has is a symbol; a name it lacks is a registry lookup
|
|
cached in a module-local slot. Getting this backwards either fails to
|
|
link or silently gives each module its own copy. *)
|
|
if not (has ir3 "@\"flan.cellp.added\" = internal global ptr null") then
|
|
fail "a run-time-new function did not get a slot";
|
|
if not (has ir3 "@\"flan.gp.extra\" = internal global ptr null") then
|
|
fail "a run-time-new global did not get a slot";
|
|
if has ir3 "@\"flan.extra\" = " then
|
|
fail "a run-time-new global was given storage in the module";
|
|
(* Every lookup is resolved before any body is published: publishing first
|
|
exposes a function whose module-local slots are still null to anything
|
|
that calls it. Not race-testable, so it is asserted on the text. *)
|
|
(* v4 redefines a name that exists only in the registry, so it publishes
|
|
through the cell it looked up rather than into a symbol — there is no
|
|
[@"flan.cell.added"] anywhere to store into. *)
|
|
if has ir4 "@\"flan.cell.added\"" then
|
|
fail "a run-time-new function was published into a symbol";
|
|
if not (has ir4 "call ptr @flan_dev_cell") then
|
|
fail "v4 did not look its target up by name";
|
|
(match find ir3 "store ptr @\"flan." `First, find ir3 "@flan_dev_(" `Last with
|
|
| Some publish, Some resolve when resolve > publish ->
|
|
fail "flan_reload_install publishes a body before resolving a lookup"
|
|
| None, _ -> fail "flan_reload_install publishes nothing"
|
|
| _ -> ());
|
|
(* A dev host's calls are indirect; a release host's are not. That is the
|
|
only difference between the two, and the whole of C-c C-c rests on it. *)
|
|
let host_ir = Emit.program ~dev:true p1 in
|
|
if not (has host_ir "@\"flan.cell.bump\" = global ptr @\"flan.bump\"") then
|
|
fail "dev build emitted no cell";
|
|
if has (Emit.program p1) "flan.cell." then
|
|
fail "release build emitted a cell";
|
|
|
|
let out = tmp "out" in
|
|
let cmd =
|
|
(* stderr kept apart from stdout: the host times its own dlopen there,
|
|
and stdout is what the expected transcript is compared against. *)
|
|
Printf.sprintf "%s %s %s %s %s > %s 2> %s" (Filename.quote host)
|
|
(Filename.quote so1) (Filename.quote so2) (Filename.quote so3)
|
|
(Filename.quote so4) (Filename.quote out)
|
|
(Filename.quote (tmp "err"))
|
|
in
|
|
let (code, dlopen_ms) = ms (fun () -> Sys.command cmd) in
|
|
let text = In_channel.with_open_bin out In_channel.input_all in
|
|
let timings = In_channel.with_open_bin (tmp "err") In_channel.input_all in
|
|
|
|
(* Every call is [outer], compiled once into the host and never rebuilt, so
|
|
a changed answer can only mean its call site followed the redefinition.
|
|
The arithmetic, in order:
|
|
|
|
host counter 0 -> 1, helper 1 = 2
|
|
v1 counter 1 -> 2, helper 2 = 4 (a rebuild of the same)
|
|
v2 +10 and +1000, recursing through its own cell until the
|
|
counter passes 100: 2 -> 12 -> ... -> 102, ten "v2" lines,
|
|
helper 102 = 204, so 1204. An interposed self-call would reach
|
|
the host's v1 body, print "v1", and land nowhere near it.
|
|
v3 extra 0 -> 7, counter 102 -> 109, helper 109 = 218. [extra]
|
|
and [added] are new names, so both came from the registry.
|
|
v4 redefines [added] only. v3's [bump] is still the installed one
|
|
and is not rebuilt here, so it reaches v4 only through a cell
|
|
the two modules found by the same name: extra 7 -> 107,
|
|
counter 109 -> 216, helper 216 = 432. Had v3 cached the
|
|
function's address rather than its cell's, this would be 246.
|
|
|
|
The "v1"/"v2"/"v3" lines come from inside each [bump] and are what
|
|
exercise a redefinition module's own string constants. 1204 rather than
|
|
1236 is [helper]: v2's text for it multiplies by three, and the module
|
|
declares it rather than defining it, so the host's copy is the one that
|
|
ran. *)
|
|
let v2s = String.concat "" (List.init 10 (fun _ -> "v2\n")) in
|
|
let want =
|
|
"v1\nhost 2\nv1\nafter1 4\n" ^ v2s ^ "after2 1204\n\
|
|
v3\nafter3 218\nv3\nafter4 432\ncounter 216\n"
|
|
in
|
|
if code <> 0 || text <> want then
|
|
fail "reload\n got: %S (exit %d)\n wanted: %S" text code want;
|
|
|
|
Printf.printf
|
|
"reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n"
|
|
emit_ms t1.Build.llc_ms t1.Build.link_ms emit2_ms t2.Build.llc_ms
|
|
t2.Build.link_ms dlopen_ms;
|
|
print_string timings;
|
|
|
|
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
|
|
[ host; so1; so2; so3; so4; out; tmp "err" ];
|
|
if !failures = 0 then print_endline "reload: all tests passed"
|
|
else begin
|
|
Printf.printf "\n%d failure(s)\n" !failures;
|
|
exit 1
|
|
end
|
|
| _ -> print_endline "reload: skipped (no clang or llc on PATH)"
|