265 lines
12 KiB
OCaml
265 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 = 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-dyn-" ^ name)
|
|
|
|
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
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1" with
|
|
| 0 ->
|
|
let p =
|
|
Check.program
|
|
(Load.program ~file:"programs/dyn-host.flan"
|
|
(Reader.read_file "programs/dyn-host.flan")).Load.decls
|
|
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"
|