flan/test/test_dyn.ml

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