76270eac0d
Ten test binaries share a directory and had shared nothing in it but watchdog.ml. Everything else each one needed it wrote out again: the failure counter and its FAIL line, the three-line report tail, a poll, a socket connect, the wait for a [flan dev] daemon to bind, a substring search, and the Load -> Check -> Reach.link front half of a compile. [listening] was the clearest case. Three copies, byte for byte apart from one comment, and two of them said in that comment that they were kept separate because "these three files have no module between them". That was not true when it was written: watchdog.ml was already named in the same (modules ...) stanzas. test_support.ml is the second such module, wired the same way, and those two sentences go with the copies they were explaining. test_repl.ml's [quote] was Wire.quote character for character, in a file that already links Wire and already names Wire.quote in a comment about what the case below it is checking. It is Wire.quote now. One real behaviour change, and it is a fix. [connect] existed twice over with different retries: the agent's narrowed to ECONNREFUSED with a comment saying why -- the socket file appears at bind, a moment before listen -- while dev's and repl's retried any Unix_error, which meant an ENOENT or an EACCES was retried to the full timeout before raising something the reader still had to interpret. The shared one takes the narrow version. Every caller connects to a socket [listening] has already seen on disk, so the race it does catch is the only one left. The rest is left where it is, on purpose. The three output-capturing [run]s differ in what they wrap -- a pid suffix, a sanitizer environment, a valgrind invocation -- and are not the same function. The report tails in test_repl, test_web and the two sweep binaries print different things for different reasons. The per-file scratch prefixes are the feature that keeps two suites running at once from unlinking each other's sockets, so the shared helper takes the prefix rather than choosing one. And the [match Sys.command "command -v clang ..."] probes stay as they are: their skip lines are output this suite pins. bin/main.ml has the compile pipeline written out twice more. Left alone -- this was a test/-scoped change and bin/ should not be reaching into a test module -- and noted in FIX.org as what it actually needs, which is the pipeline moving into lib/. dune test: exit 0, and its output is the same line for line once the temp-directory hash and the millisecond counts are normalised.
254 lines
12 KiB
OCaml
254 lines
12 KiB
OCaml
(* The dynamic-value runtime, driven from C.
|
|
|
|
runtime/flan_dyn.c is a C ABI with no Flan spelling yet — the compiler lane
|
|
is what gives it one — so the only way to reach every operation, and every
|
|
way each one refuses, is a C main. test/dyn_ops.c is that main and
|
|
programs/dyn-host.flan is the program it is linked against, which has no
|
|
[main] of its own for the same reason programs/reload.flan does not.
|
|
|
|
What is asserted here, and why each is its own thing:
|
|
|
|
ops every operation's happy path, the tags, the printed form of
|
|
each, text identity against text equality, and a vec that
|
|
contains itself
|
|
gc a million allocations against a hundred live, and the heap's
|
|
high-water mark bounded
|
|
unrooted the positive control: an object nothing points at is reclaimed.
|
|
park the root stack cut back to its globals with no frame having
|
|
returned, which is what the dev daemon's park does between one
|
|
run and the next: the globals stay rooted, the frames' go
|
|
desc an aggregate root: a struct whose dyn fields are named by a
|
|
descriptor rather than pushed one at a time.
|
|
Without it a collector that never freed would pass everything
|
|
nested a chain of vecs sixty-four deep, traced through one root
|
|
sharing one object held three times — written through one path and read
|
|
through another, and swept once when the last goes
|
|
view M2 item 3: a typed container's view, driven directly over a
|
|
hand-built flan_vec header and a plain C array — the runtime
|
|
half of "typed containers into dyn as views", with no
|
|
compiler in the loop. Also carries the view-aware equality
|
|
review's third finding asked for: two views, a view against
|
|
a heap vec, equal contents and differing ones
|
|
layout the three restatements of flan_vec's layout — flan_rt.c's
|
|
real one, flan_dyn.c's mirror, and this file's [hand_vec] —
|
|
compared field by field, which is what turns a struct any one
|
|
of the three reorders into a FAIL line here instead of a
|
|
silent corruption at whichever view next reads through it
|
|
refuse:* twenty-four refusals, one process each, asserted on the sentence
|
|
as well as on the status: a process that died some other way is
|
|
not the guard firing, and the exit code cannot tell them apart
|
|
refuseview:* five more refusals, the view's own: out of range and a
|
|
mismatched write on each of the three element kinds, and a
|
|
push against a flat (slice or array) view
|
|
|
|
One binary, built once, run thirty-eight times. The build is the expensive
|
|
part and the runs are milliseconds, which is what keeps this inside
|
|
`dune test` rather than behind an alias. *)
|
|
|
|
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_dyn"
|
|
|
|
let failures = Test_support.failures
|
|
let fail fmt = Test_support.fail fmt
|
|
let tmp name = Test_support.tmp "flan-dyn-" name
|
|
let has = Test_support.contains
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1" with
|
|
| 0 ->
|
|
let p = Test_support.checked "programs/dyn-host.flan" in
|
|
let exe = tmp "ops" in
|
|
ignore (Build.executable ~csrcs:[ "dyn_ops.c" ] p ~out:exe);
|
|
|
|
let run mode =
|
|
let o = tmp (mode ^ ".out") and e = tmp (mode ^ ".err") in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "%s %s > %s 2> %s" (Filename.quote exe)
|
|
(Filename.quote mode) (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 x -> try Sys.remove x with Sys_error _ -> ()) [ o; e ];
|
|
(code, out, err)
|
|
in
|
|
|
|
(* The happy paths. Each assertion inside prints its own FAIL line, so the
|
|
output is the report and this only has to notice that there was one. *)
|
|
let code, out, err = run "ops" in
|
|
if code <> 0 || out <> "ops ok\n" then
|
|
fail "the operations\n got: %S (exit %d, err %S)" out code err;
|
|
|
|
(* The collector. Four sentences, each a yes: the high-water mark stayed
|
|
under half a megabyte across forty megabytes of allocation, the heap
|
|
settled small, the object count stayed bounded, and the hundred rooted
|
|
values were all still what they were set to. *)
|
|
let code, out, err = run "gc" in
|
|
let want_gc =
|
|
"peak under 512K: yes\nsettled under 32K: yes\n\
|
|
live objects bounded: yes\nlive set intact: yes\n"
|
|
in
|
|
if code <> 0 || out <> want_gc then
|
|
fail "a million allocations against a hundred live\n\
|
|
\ got: %S (exit %d, err %S)\n wanted: %S"
|
|
out code err want_gc;
|
|
|
|
(* And the control. A collector that never freed anything would pass every
|
|
other case in this file; this is the one it cannot. *)
|
|
let code, out, _ = run "unrooted" in
|
|
let want_un = "allocated: yes\nreclaimed all but the ring: yes\n" in
|
|
if code <> 0 || out <> want_un then
|
|
fail "an unrooted object\n got: %S (exit %d)\n wanted: %S"
|
|
out code want_un;
|
|
|
|
(* The park: a root stack cut back to its globals with no frame having
|
|
returned, which is what the merged dev build does between a run and the
|
|
next. Both halves are asserted, because each on its own is met by doing
|
|
nothing — a reset that dropped everything keeps no global, and a reset
|
|
that dropped nothing keeps every frame. *)
|
|
let code, out, _ = run "park" in
|
|
let want_park =
|
|
"a dyn global survives a parked thunk: yes\n\
|
|
a finished run's frame roots go: yes\n"
|
|
in
|
|
if code <> 0 || out <> want_park then
|
|
fail "the park's root reset\n got: %S (exit %d)\n wanted: %S"
|
|
out code want_park;
|
|
|
|
(* The aggregate roots the per-type descriptors added: a struct with dyn
|
|
fields at three offsets, one of them inside a nested struct, rooted by
|
|
address and descriptor rather than word by word.
|
|
|
|
The second line is the one that discriminates, and the first on its own
|
|
does not: a marker that walked every word of the struct would keep the
|
|
named fields too. So the struct also holds five hundred objects behind a
|
|
dyn word at an offset the descriptor leaves out, and the claim is that
|
|
they are *not* kept. *)
|
|
let code, out, _ = run "desc" in
|
|
let want_desc =
|
|
"aggregate root survives collection: yes\n\
|
|
a dyn at an offset the descriptor omits is not marked: yes\n\
|
|
and is reclaimed once dropped: yes\n"
|
|
in
|
|
if code <> 0 || out <> want_desc then
|
|
fail "an aggregate root\n got: %S (exit %d)\n wanted: %S"
|
|
out code want_desc;
|
|
|
|
let code, out, _ = run "nested" in
|
|
if code <> 0 || out <> "chain of 64 intact: yes\n" then
|
|
fail "a chain of nested vecs\n got: %S (exit %d)" out code;
|
|
|
|
let code, out, _ = run "sharing" in
|
|
let want_sh =
|
|
"three slots hold one object: yes\n\
|
|
write through one path is seen through another: yes\n\
|
|
shared object survives on the holder alone: yes\n\
|
|
still reachable: yes\n\
|
|
live bytes after dropping everything: ok\n"
|
|
in
|
|
if code <> 0 || out <> want_sh then
|
|
fail "interior sharing\n got: %S (exit %d)\n wanted: %S"
|
|
out code want_sh;
|
|
|
|
(* M2 item 3, the runtime's half: a flat view over a fixed C array (reads
|
|
box, writes tag-check, and a write through the view is the array's own
|
|
write and vice versa — proving it is a view and not a copy), a Vec
|
|
view over a hand-built header, pushed through twenty times so the
|
|
header's own [ptr] moves under it — the case that says the descriptor
|
|
pointing AT the header rather than snapshotting it is what survives a
|
|
growth — a bool view and a float view, so the element dispatch is
|
|
exercised on all three kinds dyn_ops.c's [view] carries, and
|
|
[dyn_equal] made view-aware: two views over equal bytes, two views
|
|
over different bytes, a view against an equal heap vec and against a
|
|
differing one. *)
|
|
let code, out, err = run "view" in
|
|
if code <> 0 || out <> "view ok\n" then
|
|
fail "a typed container's view\n got: %S (exit %d, err %S)"
|
|
out code err;
|
|
|
|
(* The three restatements of flan_vec's layout, compared field by field —
|
|
see dyn_ops.c's [layout] and [hand_vec]'s comment for what ties them
|
|
together and why nothing at compile time otherwise does. *)
|
|
let code, out, err = run "layout" in
|
|
if code <> 0 || out <> "layout ok\n" then
|
|
fail "flan_vec's three restatements\n got: %S (exit %d, err %S)"
|
|
out code err;
|
|
|
|
(* Every refusal. The pair is (mode, a phrase the sentence must contain);
|
|
the phrase is chosen to be the part that says *which* mistake it was,
|
|
so a message that named the wrong operation or the wrong tag would not
|
|
pass by accident.
|
|
|
|
The tag names are asserted here too, as words: "int" and "text" and not
|
|
2 and 4. A message with a number in it is a puzzle, and the rule is
|
|
written down in flan_dyn.c beside the table the words come from. *)
|
|
let refusals =
|
|
[ ("add", "dyn +: int and text");
|
|
("sub", "dyn -: nil and int");
|
|
("mul", "dyn *: bool and int");
|
|
("div", "dyn /: vec and int");
|
|
("rem", "dyn %: int and nil");
|
|
("divzero", "does not divide by zero");
|
|
("remzero", "does not divide by zero");
|
|
("divover", "one past the largest i64");
|
|
("lt", "dyn <: int and text");
|
|
("le", "dyn <=: text and nil");
|
|
("gt", "dyn >: vec and vec");
|
|
("ge", "dyn >=: bool and bool");
|
|
("len", "dyn len: int");
|
|
("at", "dyn at: int and int");
|
|
("atindex", "an index must be an int");
|
|
("atrange", "index 9 is out of bounds for text of length 2");
|
|
("atnegative", "index -1 is out of bounds");
|
|
("setattext", "a text is immutable");
|
|
("setatnotvec", "only a vec is assigned into");
|
|
("setatrange", "index 0 is out of bounds for vec of length 0");
|
|
("push", "only a vec is pushed to");
|
|
("needi64", "dyn i64: text");
|
|
("needf64", "dyn f64: int");
|
|
("needbool", "dyn bool: nil") ]
|
|
in
|
|
List.iter
|
|
(fun (mode, phrase) ->
|
|
let code, out, err = run ("refuse:" ^ mode) in
|
|
if code = 0 then
|
|
fail "%s returned rather than trapping: %S" mode out
|
|
else if not (has err phrase) then
|
|
fail "%s did not say %S; it said %S" mode phrase err)
|
|
refusals;
|
|
|
|
(* The view's own refusals: an index outside it, a write whose dyn tag
|
|
does not match the element the view holds — once per element kind, so
|
|
the tag-check is asserted on int, on float and on bool separately and
|
|
not only on the one this file happens to build first — and a push
|
|
against a flat (slice or array) view, which cannot grow by
|
|
construction and says so rather than corrupting whatever follows it
|
|
in memory. *)
|
|
let view_refusals =
|
|
[ ("range", "index 2 is out of bounds for vec of length 2");
|
|
("wrongwrite", "this view's elements are int");
|
|
("wrongbool", "this view's elements are bool");
|
|
("wrongfloat", "this view's elements are float");
|
|
("flatpush", "this view is a slice or an array and cannot grow") ]
|
|
in
|
|
List.iter
|
|
(fun (mode, phrase) ->
|
|
let code, out, err = run ("refuseview:" ^ mode) in
|
|
if code = 0 then
|
|
fail "%s returned rather than trapping: %S" mode out
|
|
else if not (has err phrase) then
|
|
fail "%s did not say %S; it said %S" mode phrase err)
|
|
view_refusals;
|
|
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
(* A line on the way out, because a test that says nothing when it passes
|
|
is a test nobody can tell from a test that did not run. *)
|
|
if !failures = 0 then
|
|
Printf.printf " ok the dyn runtime: %d refusals and nine runs\n"
|
|
(List.length refusals + List.length view_refusals)
|
|
else exit 1
|
|
| _ -> print_endline "SKIP test_dyn: no clang"
|