(* 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"