308 lines
15 KiB
OCaml
308 lines
15 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
|
|
classes a (defclass ...) redefined: the registry, the generation an
|
|
instance carries, and the lazy migration at its next touch —
|
|
a slot gained, a slot lost, both at once, three definitions
|
|
an instance never woke up for, two generations compared,
|
|
a plain map left alone, and two thousand instances migrated
|
|
while the collector runs
|
|
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-nine 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;
|
|
|
|
(* Redefining a class, which is CLHS 4.3.6's lazy update protocol as
|
|
flan_dyn.c implements it: a registry of slot lists per class name, a
|
|
generation on the instance, and a migration at the first access after
|
|
the definition moved. Driven from C because the event has no Flan
|
|
spelling — a class definition changes between two *modules*, so no
|
|
single program can see one change. test_dev.ml's daemon case is the
|
|
same protocol with a real editor at one end. *)
|
|
let code, out, err = run "classes" in
|
|
if code <> 0 || out <> "classes ok\n" then
|
|
fail "redefining a class\n got: %S (exit %d, err %S)" out code err;
|
|
|
|
(* A migration's hook re-entered from the building of its own
|
|
arguments, and a hook that grows the class registry under it — see
|
|
dyn_ops.c's [hook_reentry]. *)
|
|
let code, out, err = run "hook" in
|
|
if code <> 0 || out <> "hook ok\n" then
|
|
fail "a re-entered migration hook\n got: %S (exit %d, err %S)"
|
|
out code err;
|
|
|
|
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. *)
|
|
(* A walk's site does not outlive a trap that leaves the walk: the second
|
|
sentence, from a lookup with no site, must not carry the first's. *)
|
|
let code, out, err = run "walkreset" in
|
|
(match String.split_on_char '-' err with
|
|
| _ when code <> 0 || out <> "walkreset done\n" ->
|
|
fail "a walk left by a trap\n got: %S (exit %d, err %S)" out
|
|
code err
|
|
| _ ->
|
|
let after =
|
|
match String.index_opt err '\n' with
|
|
| Some i -> String.sub err i (String.length err - i)
|
|
| None -> ""
|
|
in
|
|
if not (has err "walk-site:1:1") then
|
|
fail "the first walk's trap did not name its site: %S" err
|
|
else if has after "walk-site" then
|
|
fail "a later walk named an abandoned walk's site: %S" err
|
|
else if not (has after "above the largest dyn int") then
|
|
fail "the second walk did not trap: %S" err);
|
|
|
|
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");
|
|
("neg", "dyn -: text, and it takes a number");
|
|
("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 length: 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 or a map 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");
|
|
("inexactfloat", "9007199254740993 has no exact f64");
|
|
("flatpush", "this view is a slice or an array and cannot grow");
|
|
(* And the operator's own name in that sentence. [flan_dyn_len] hands
|
|
a string down twice — once to its type trap and once to the view
|
|
check — and the two are easy to move apart, which is exactly what
|
|
happened when the builtin was renamed. Both say [length] because
|
|
both are naming the same Flan word. *)
|
|
("stalelen", "dyn length: this view's container's allocator was \
|
|
released") ]
|
|
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 ten runs\n"
|
|
(List.length refusals + List.length view_refusals)
|
|
else exit 1
|
|
| _ -> print_endline "SKIP test_dyn: no clang"
|