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.
               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
     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

   One binary, built once, run twenty-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 = 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;

    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;

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

    (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 five runs\n"
        (List.length refusals)
    else exit 1
  | _ -> print_endline "SKIP  test_dyn: no clang"