Joseph Ferano
5a67cf458a
The first of the three things HANDOFF-x86-redef.md left: a function or a defvar the running process has no symbol for. ELF cannot grow one, so the address is asked for by string at install time -- flan_dev_cell for a cell, flan_dev_global for a global's storage -- and parked in a slot this module defines. The reference side is one new [loc] case and nothing else. [Lslot] loads the slot and answers [Reg (scratch, d)], which is exactly what [Lgot] already did with [Got] where this has [Sym]; every site that reaches a cell already double-loads, so no call site, no place expression and no [sym_loc] caller had to learn a third case. [fnctx.slot] is a second predicate rather than a widened [ext] because they answer different questions -- [ext] says "the host's, reach it through the GOT", [slot] says "nobody's yet, reach it through a slot I filled". It defaults to [fun _ -> None], so the whole-program path emits byte-identical output and the survey goes on being a structural check. flan_reload_install is now a function with a frame rather than a run of loads and stores, because it makes calls and a call on an unaligned stack faults inside glibc's movaps rather than anywhere a reader would look. Its shape is emit_globals_init's, down to owning the null transfer cell no caller hands it. A new global's declared value travels with it: flan_dev_global copies the image onto the allocation the first time the name is interned and ignores it after, which is where "a reload must not reset the state" lives. emit.ml folds that value into an LLVM constant and this file has no folder, so the image is a module-local buffer written by the initialiser lowered as ordinary code -- the same bargain emit_globals_data already documents. Republishing a defconst came free once the rest was there: one store of the new constant into the host's global, which is what emit.ml does. reload-v6.flan is new. v3's [extra] is declared zero, which calloc also gives, so a run-time-new global whose initial value never arrived would still pass; v6's [tuning] is 42 and the host prints 88. test_reload.ml's x86 section now runs all four modules against the same transcript the LLVM path is held to, and the refusal it used to assert is gone.
538 lines
27 KiB
OCaml
538 lines
27 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 (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
|
|
(* v5 retypes [extra], which v3 introduced at run time. It is built here
|
|
and loaded in a process of its own below: what it does is abort. *)
|
|
let p5 = checked "programs/reload-v5.flan" in
|
|
let so5, _, _, _ = module_of p5 [ "added" ] "v5.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;
|
|
|
|
(* The same thing again, compiled by the dev backend end to end (x86.ml's
|
|
header, docs/handoffs/HANDOFF-x86-rt.md item 1). Both halves, host and module, because
|
|
the two backends' conventions agree on every scalar and disagree on
|
|
every aggregate: an LLVM-built module dlopened into an --x86 host would
|
|
be correct until the first redefined function took or returned a struct.
|
|
So an --x86 host gets --x86 modules and the two never meet.
|
|
|
|
All four modules, and the same expected string as the LLVM path above:
|
|
v3 introduces a defvar and a defn the host was never built with, and v4
|
|
redefines the one v3 introduced. Neither has a symbol anywhere, so both
|
|
go through flan_dev.c's by-name registry into a slot the module defines
|
|
and [flan_reload_install] fills -- [X86.Lslot], which is the GOT path
|
|
with the relocation swapped.
|
|
|
|
Read by running, not by reading. A disassembly reads correctly beside a
|
|
wrong answer often enough (docs/DISCUSS.md item 15) that only the printed
|
|
transcript settles it: [outer] is compiled once into the host and never
|
|
rebuilt, so "after2 1204" can only mean its call site followed a body
|
|
that this backend emitted, published through a cell it reached via the
|
|
GOT. *)
|
|
let x86 = { dev with Build.x86 = true } in
|
|
let xhost = tmp "xhost" in
|
|
ignore
|
|
(Build.executable ~opts:x86 ~csrcs:[ "reload_host.c" ]
|
|
~lflags:[ "-ldl" ] p1 ~out:xhost);
|
|
let xmodule q fns name =
|
|
let o = tmp name in
|
|
let asm = X86.redefinition ~checks:true ~dev:true ~known q ~fns in
|
|
ignore (Build.shared_x86 ~opts:x86 ~asm ~out:o ());
|
|
o
|
|
in
|
|
let xso1 = xmodule p1 [ "bump" ] "xv1.so" in
|
|
let xso2 = xmodule p2 [ "bump" ] "xv2.so" in
|
|
let xso3 = xmodule p3 [ "bump"; "added" ] "xv3.so" in
|
|
let xso4 = xmodule p4 [ "added" ] "xv4.so" in
|
|
let xout = tmp "xout" in
|
|
let xcode =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s %s %s %s > %s 2> %s" (Filename.quote xhost)
|
|
(Filename.quote xso1) (Filename.quote xso2) (Filename.quote xso3)
|
|
(Filename.quote xso4) (Filename.quote xout)
|
|
(Filename.quote (tmp "xerr")))
|
|
in
|
|
let xtext = In_channel.with_open_bin xout In_channel.input_all in
|
|
if xcode <> 0 || xtext <> want then
|
|
fail "x86 reload\n got: %S (exit %d)\n wanted: %S" xtext xcode
|
|
want;
|
|
(* [extra] is a defvar the host has no storage for, so its declared value
|
|
has to travel with it: [flan_dev_global] copies the module's image onto
|
|
the allocation the first time the name is interned and ignores it every
|
|
time after. [extra] is declared zero here, which calloc would also give,
|
|
so the case is asserted where it is visible -- a run-time-new global
|
|
with a value of its own. *)
|
|
let p6 = checked "programs/reload-v6.flan" in
|
|
let xso6 = xmodule p6 [ "bump" ] "xv6.so" in
|
|
let xhost6 = tmp "xhost6" in
|
|
ignore
|
|
(Build.executable ~opts:x86 ~csrcs:[ "reload_host.c" ]
|
|
~lflags:[ "-ldl" ] p1 ~out:xhost6);
|
|
let xout6 = tmp "xout6" in
|
|
let xcode6 =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s > %s 2> %s" (Filename.quote xhost6)
|
|
(Filename.quote xso6) (Filename.quote xout6)
|
|
(Filename.quote (tmp "xerr6")))
|
|
in
|
|
let xtext6 = In_channel.with_open_bin xout6 In_channel.input_all in
|
|
let xwant6 = "v1\nhost 2\nv6\nafter1 88\ncounter 44\n" in
|
|
if xcode6 <> 0 || xtext6 <> xwant6 then
|
|
fail "x86 reload of a new global with a value\n \
|
|
got: %S (exit %d)\n wanted: %S" xtext6 xcode6 xwant6;
|
|
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
|
|
[ xso1; xso2; xso3; xso4; xso6; xhost; xhost6; xout; xout6 ];
|
|
|
|
(* The aggregate case, which is the whole reason X86.redefinition exists
|
|
rather than an --x86 host dlopening what Emit.redefinition made.
|
|
|
|
Everything above this point is scalar, and scalars are the half of the
|
|
calling convention the two backends cannot disagree about. They disagree
|
|
on every aggregate: x86.ml passes each one by pointer and returns it
|
|
through a hidden sret, LLVM classifies per eightbyte. So a redefined
|
|
function taking or returning a struct is the case that would expose a
|
|
mismatch, and until now the claim that an --x86 host plus --x86 modules
|
|
is same-convention-by-construction was an argument rather than a
|
|
measurement.
|
|
|
|
programs/reload-agg.flan crosses the boundary in four shapes at once —
|
|
two integer eightbytes, thirty-two bytes of MEMORY, two SSE eightbytes,
|
|
and one of each — because SysV treats those four differently and this
|
|
backend treats them identically, so a single shape would measure a
|
|
quarter of the disagreement and read like all of it. Each `step' takes
|
|
an aggregate and returns one, so a single call crosses in both
|
|
directions, and each calls a `weigh' the module does not define, which
|
|
hands an aggregate the other way.
|
|
|
|
Both backends run the same fixture and are compared against the same
|
|
transcript. The LLVM row is not decoration: a wrong expected number
|
|
would otherwise be indistinguishable from a backend that is right, and
|
|
two independently-built agreements on one string are what rule that
|
|
out. *)
|
|
let a1 = checked "programs/reload-agg.flan" in
|
|
let a2 = checked "programs/reload-agg-v2.flan" in
|
|
let agg_known =
|
|
let names =
|
|
List.map (fun (f : Tast.fn) -> f.Tast.name) a1.Tast.fns
|
|
@ List.map (fun (g : Tast.global) -> g.Tast.gname) a1.Tast.globals
|
|
in
|
|
fun n -> List.exists (String.equal n) names
|
|
in
|
|
let agg_fns = [ "step-pair"; "step-quad"; "step-duo"; "step-mix" ] in
|
|
(* The arithmetic, derived rather than observed, because a number read off
|
|
a run is a record of what happened and not a statement of what should:
|
|
|
|
v1 Pair {1,2} -> weigh 1+3*2 = 7, so {2, 2+7} and 2 + 100*9 = 902
|
|
Quad {1,2,3,4} -> weigh (1+6)+(15+28) = 50, so {2,4,6,54} and
|
|
2 + 400 + 60000 + 54000000 = 54060402
|
|
Duo {1,2} -> weigh 7, so {2.0, 9.0} and 902
|
|
Mix {1,2} -> weigh 7, so {2, 9.0} and 902
|
|
total 54063108
|
|
v2 Pair -> weigh is still the *host's* 7, so {11, 2+14} and 1611
|
|
Quad -> weigh still 50, so {11,22,33,104} and
|
|
11 + 2200 + 330000 + 104000000 = 104332211
|
|
Duo -> {11.0, 16.0} and 1611
|
|
Mix -> {11, 16.0} and 1611
|
|
total 104337044
|
|
|
|
1611 rather than 12411 in the first term is the tripwire: v2's text for
|
|
`weigh-pair' multiplies by thirty, and a module that grew its own copy
|
|
of a sibling rather than reaching the host's through a cell would say
|
|
so here. `counter' is stepped from inside the redefined body, by one in
|
|
v1 and by ten in v2, so 1 + 1 + 10 = 12 is the host's global being
|
|
written by three different bodies in turn. *)
|
|
let agg_want =
|
|
"a1\nhost 54063108\na1\nafter1 54063108\na2\nafter2 104337044\n\
|
|
counter 12\n"
|
|
in
|
|
let agg_run label opts mkmod =
|
|
let h = tmp ("agg-host-" ^ label) in
|
|
ignore
|
|
(Build.executable ~opts ~csrcs:[ "reload_host.c" ] ~lflags:[ "-ldl" ]
|
|
a1 ~out:h);
|
|
let m1 = mkmod a1 ("agg-" ^ label ^ "-1.so") in
|
|
let m2 = mkmod a2 ("agg-" ^ label ^ "-2.so") in
|
|
let o = tmp ("agg-out-" ^ label) and e = tmp ("agg-err-" ^ label) in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s %s > %s 2> %s" (Filename.quote h)
|
|
(Filename.quote m1) (Filename.quote m2) (Filename.quote o)
|
|
(Filename.quote e))
|
|
in
|
|
let text = In_channel.with_open_bin o In_channel.input_all in
|
|
if code <> 0 || text <> agg_want then
|
|
fail "%s aggregate reload\n got: %S (exit %d)\n wanted: %S"
|
|
label text code agg_want;
|
|
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
|
|
[ h; m1; m2; o; e ]
|
|
in
|
|
let agg_llvm_mod q name =
|
|
let o = tmp name in
|
|
let ir = Emit.redefinition ~dev:true ~known:agg_known q ~fns:agg_fns in
|
|
ignore (Build.shared ~opts:dev ~ir ~out:o ());
|
|
o
|
|
in
|
|
let agg_x86_mod q name =
|
|
let o = tmp name in
|
|
let asm =
|
|
X86.redefinition ~checks:true ~dev:true ~known:agg_known q ~fns:agg_fns
|
|
in
|
|
ignore (Build.shared_x86 ~opts:x86 ~asm ~out:o ());
|
|
o
|
|
in
|
|
agg_run "llvm" dev agg_llvm_mod;
|
|
agg_run "x86" x86 agg_x86_mod;
|
|
|
|
(* The same measurement run crossed, which is what the marker symbol is
|
|
for. Before it, an --x86 host given LLVM-built modules loaded them and
|
|
then died with SIGSEGV on the first call into a redefined aggregate
|
|
body:
|
|
|
|
got: "a1\nhost 54063108\na1\n" (exit 139)
|
|
|
|
That could not be asserted. It was undefined behaviour and what it
|
|
printed was a property of whichever LLVM happened to be installed; a
|
|
test pinning it would have been pinning the shape of a crash.
|
|
|
|
It is deterministic now, which is why it is here. A dev build defines a
|
|
marker naming the backend that built it — [flan.abi.x86] or
|
|
[flan.abi.llvm] — and a redefinition module holds a pointer to the one
|
|
it was itself built for. That pointer is a relocation the loader has to
|
|
resolve while it maps the object, so a crossed pair fails the [dlopen]
|
|
outright, before a single instruction of the new body runs. Both
|
|
directions, because a marker only one of the two backends emitted would
|
|
refuse in one direction and say nothing in the other.
|
|
|
|
Asserted on the message as well as the exit status, the way the
|
|
retyped-global and registry-overflow cases below are: a nonzero exit is
|
|
not by itself this refusal, and the point of the exercise is that what
|
|
reaches a user names the reason rather than repeating the loader's
|
|
"undefined symbol". *)
|
|
let agg_cross label opts mkmod wants =
|
|
let h = tmp ("agg-xhost-" ^ label) in
|
|
ignore
|
|
(Build.executable ~opts ~csrcs:[ "reload_host.c" ] ~lflags:[ "-ldl" ]
|
|
a1 ~out:h);
|
|
let m1 = mkmod a1 ("agg-cross-" ^ label ^ "-1.so") in
|
|
let o = tmp ("agg-xout-" ^ label) and e = tmp ("agg-xerr-" ^ label) in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s > %s 2> %s" (Filename.quote h)
|
|
(Filename.quote m1) (Filename.quote o) (Filename.quote e))
|
|
in
|
|
let said = In_channel.with_open_bin e In_channel.input_all in
|
|
if code = 0 then
|
|
fail "%s: a crossed pair loaded and ran (exit 0)" label;
|
|
if not (has said "built by different backends") then
|
|
fail "%s: a crossed pair was refused without naming the reason: %S"
|
|
label said;
|
|
(* Which marker is missing is which backend built the module, so this is
|
|
also what says the refusal fired for the right direction rather than
|
|
for the other one. *)
|
|
if not (has said wants) then
|
|
fail "%s: the refusal named the wrong marker (wanted %s): %S" label
|
|
wants said;
|
|
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
|
|
[ h; m1; o; e ]
|
|
in
|
|
(* An --x86 host handed an LLVM module: the pair the CLI can build today,
|
|
since [flan reload] has no --x86 spelling. *)
|
|
agg_cross "x86-host-llvm-module" x86 agg_llvm_mod "flan.abi.llvm";
|
|
(* And the reverse, which no command spells but [X86.redefinition] does. *)
|
|
agg_cross "llvm-host-x86-module" dev agg_x86_mod "flan.abi.x86";
|
|
|
|
(* The option-record guard, which is the older and narrower half of the
|
|
same answer: [Build.opts] is where the backend choice lives, so a
|
|
builder handed the *other* backend's option record refuses by name. It
|
|
catches a caller holding one option record and reaching for the wrong
|
|
builder. It cannot catch a caller holding two — the crossed runs above
|
|
pass both of these refusals — which is what the marker is for. See
|
|
docs/handoffs/HANDOFF-x86-aggregates.md and docs/handoffs/HANDOFF-x86-abi-marker.md. *)
|
|
(match Build.shared ~opts:x86 ~ir:"" ~out:(tmp "never.so") () with
|
|
| _ -> fail "Build.shared accepted an --x86 option record"
|
|
| exception Failure m when has m "--x86" -> ()
|
|
| exception Failure m -> fail "Build.shared refused for the wrong reason: %s" m);
|
|
(match Build.shared_x86 ~opts:dev ~asm:"" ~out:(tmp "never.so") () with
|
|
| _ -> fail "Build.shared_x86 accepted an LLVM option record"
|
|
| exception Failure m when has m "--x86" -> ()
|
|
| exception Failure m ->
|
|
fail "Build.shared_x86 refused for the wrong reason: %s" m);
|
|
|
|
(* The layout-drift guard, which needs a process of its own because what it
|
|
does is abort one. [extra] does not exist in the host: v3 introduced it
|
|
at run time, so flan_dev.c allocated its storage and recorded its size,
|
|
and every later module asking for that name is handed the same
|
|
allocation back. v5 asks for it as an i32. Handing back eight bytes for
|
|
a four-byte type is not an error anything downstream can detect — the
|
|
new body simply reads fields at offsets the allocation was never laid
|
|
out for — so the registry compares sizes and dies at the first chance
|
|
it has.
|
|
|
|
Asserted on the message as well as on the exit status: a process that
|
|
died for some other reason is not this guard firing, and the exit code
|
|
alone cannot tell the two apart. *)
|
|
let out5 = tmp "out5" and err5 = tmp "err5" in
|
|
let code5 =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s %s %s > %s 2> %s" (Filename.quote host)
|
|
(Filename.quote so1) (Filename.quote so3) (Filename.quote so5)
|
|
(Filename.quote out5) (Filename.quote err5))
|
|
in
|
|
let said = In_channel.with_open_bin err5 In_channel.input_all in
|
|
if code5 = 0 then
|
|
fail "a global retyped across a reload was accepted (exit 0)";
|
|
if not (has said "size changed") then
|
|
fail "a retyped global did not stop on the size guard: %S" said;
|
|
|
|
(* The two fixed-size limits in flan_dev.c, which nothing had ever
|
|
reached: the 4K result buffer a renderer emits into, and the 4096-name
|
|
registry. Both are driven from dev_limits.c rather than from Flan,
|
|
because neither has a Flan spelling and a program that reached either
|
|
one by accident would be a program nobody wants in the corpus.
|
|
|
|
One process per mode. The name table never shrinks, so the two cases
|
|
would contaminate each other, and the overflow case ends in abort. *)
|
|
let limits = tmp "limits" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:[ "dev_limits.c" ] p1 ~out:limits);
|
|
let mode m =
|
|
let o = tmp ("limits-" ^ m ^ ".out") and e = tmp ("limits-" ^ m ^ ".err") in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s > %s 2> %s" (Filename.quote limits) m
|
|
(Filename.quote o) (Filename.quote e))
|
|
in
|
|
let out = In_channel.with_open_bin o In_channel.input_all in
|
|
let err = In_channel.with_open_bin e In_channel.input_all in
|
|
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ o; e ];
|
|
(code, out, err)
|
|
in
|
|
(* 6000 bytes emitted into 4096. The length is the cap itself, the three
|
|
dots are what says the value was cut rather than being that short, the
|
|
middle byte says the content before the cut is the content that was
|
|
emitted, and the generation moved exactly once — a reader waits on that
|
|
counter and a value published twice would be read half-formed. The last
|
|
line is the flag being cleared: a short value after a truncated one must
|
|
not inherit its ellipsis. *)
|
|
let code, out, _ = mode "cap" in
|
|
let want_cap = "len 4096\ntail ...\nmid b\nhead a\ngen 1\nagain 12\n" in
|
|
if code <> 0 || out <> want_cap then
|
|
fail "the 4K result cap\n got: %S (exit %d)\n wanted: %S"
|
|
out code want_cap;
|
|
(* 4096 distinct names fit; the next one stops the process. The table is
|
|
fixed and never moves, because a loaded module holds the address of a
|
|
cell in it, so growing is not available and overrunning is the only
|
|
other thing it could do. *)
|
|
let code, out, err = mode "names" in
|
|
if code = 0 then fail "the registry accepted a 4097th name (exit 0)";
|
|
if out <> "interned 4096\n" then
|
|
fail "the registry did not take 4096 names first: %S" out;
|
|
if not (has err "out of dev name slots") then
|
|
fail "the registry overflowed without saying so: %S" err;
|
|
|
|
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; limits; so1; so2; so3; so4; so5; out; out5; err5; 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)"
|