(* 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. 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 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-five 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 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), and 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. And a bool view and a float view, so the element dispatch is exercised on all three kinds dyn_ops.c's [view] carries. *) 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; (* 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 seven runs\n" (List.length refusals + List.length view_refusals) else exit 1 | _ -> print_endline "SKIP test_dyn: no clang"