Joseph Ferano
7f92136401
CLHS 4.3.6's update protocol, minus the user hook, on the dyn side's defclass. Redefining a class used to be silent: a class is sugar for a constructor defn, so the edit replaced a body and the instances already in the program kept their old keys for ever. Three pieces. A registry in flan_dyn.c holding each class's current slot list and a generation, made only of interned kw_entry pointers so the collector has nothing to trace in it and no root to push for it. A uint32 generation on the instance, fitted into the padding kind and mark leave in front of len's alignment — sizeof(flan_obj) is 48 with it and was 48 without, and flan_dyn_obj_size is there so a later field that moves it fails a test. And a registration thunk per reload, run by the agent through flan_reload_call after the module's bodies are published: it has to be a thunk, because the case this exists for is a class redefined and not constructed. Migration is lazy, at want_map, len's map arm and dyn_equal's. Slots kept by name, gained slots nil, dropped slots gone, identity preserved, entries rebuilt in the class's order so a migrated instance is indistinguishable from a fresh one. Equality migrates both operands first, so it is over the class as it is now. The session had to stop refusing the constructor's signature change, and does so only for a defclass and only when no compiled caller is left behind. The checker gets there first in practice; the walk in eval holds the reason locally rather than inheriting it. The registry is advisory: a class instance is an open map, so a key a raw put wrote that the class never declared is dropped by the next migration. FIX.org says that plainly rather than pretending enforcement.
271 lines
13 KiB
OCaml
271 lines
13 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;
|
|
|
|
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 ten runs\n"
|
|
(List.length refusals + List.length view_refusals)
|
|
else exit 1
|
|
| _ -> print_endline "SKIP test_dyn: no clang"
|