diff --git a/FIX.org b/FIX.org index 6804dfd..4b025ec 100644 --- a/FIX.org +++ b/FIX.org @@ -858,3 +858,16 @@ skipping its stores on a re-run is safe against all of that because the pushes take the global's slot address, never its value, and they sit before the startup call on both backends — nothing in the bracket depends on an initialiser having run. + +** bin/main.ml still spells the compile pipeline out by hand +The test directory's copies of Load → Check → Reach.link now go through +[Test_support.linked] (test/test_support.ml). bin/main.ml has the same shape +twice more — :684 and :864, each a load, a check and a [Reach.link] feeding +[Build.executable] — and they were left alone, because the lane that did this +was test/-scoped and because they are not quite the same three calls: the CLI +loads through its own [load] and checks with [Check.program_all] rather than +[Check.program]. So closing this is not a matter of calling the test module +from bin/, which would be backwards anyway; it means the pipeline moving into +lib/ — Build, or a small front-end module beside it — with the two checkers' +difference made an argument, and bin/ and test_support.ml both calling that. +Not queued. diff --git a/test/dune b/test/dune index dd80114..a3680cb 100644 --- a/test/dune +++ b/test/dune @@ -3,9 +3,13 @@ ; Explicit because test_sanitize lives in this directory and is not one of ; these: two stanzas in one directory have to say which modules are whose. ; watchdog is every binary's clock: a hanging test reports nothing, so each - ; of these arms an alarm that turns "for ever" into a failing run. + ; of these arms an alarm that turns "for ever" into a failing run. test_support + ; is the other shared module: the failure counter, the report tail, the poll, + ; the daemon wait and the front half of a compile, which the binaries that + ; wanted them had each been carrying their own copy of. (modules test_flan test_acceptance test_reload test_agent test_session - test_dev test_emacs test_repl test_cider test_dyn watchdog) + test_dev test_emacs test_repl test_cider test_dyn watchdog + test_support) (libraries flan unix) ; The acceptance programs are part of the test corpus: if the reader, the ; parser or the checker regresses on them we want to know here, not at the CLI. @@ -100,7 +104,7 @@ ; skips with the reason, so it is green on a machine that has neither. (test (name test_web) - (modules test_web) + (modules test_web test_support) (libraries flan unix) (deps (glob_files programs/*.flan) @@ -131,7 +135,7 @@ ; is the whole point here. (executable (name test_sanitize) - (modules test_sanitize watchdog) + (modules test_sanitize watchdog test_support) (libraries flan unix)) (rule @@ -177,7 +181,7 @@ ; all. NEXT.md asked for exactly this. (executable (name test_valgrind) - (modules test_valgrind watchdog) + (modules test_valgrind watchdog test_support) (libraries flan unix str)) (rule diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 46f4fc2..fdd20bf 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -10,7 +10,7 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:1200 "test_acceptance" -let failures = ref 0 +let failures = Test_support.failures (* The tail of this file already exits 1 when [failures] is nonzero, and there is no path through this binary that skips it: it is one match on @@ -40,7 +40,7 @@ let () = at_exit (fun () -> if !failures > 0 then begin flush_all (); Unix._exit 1 end) -let scratch = Filename.get_temp_dir_name () +let scratch = Test_support.scratch (* Every temporary path below carries the calling process's own pid. Within one process that is a constant, so it changes nothing about the existing @@ -76,23 +76,16 @@ let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) ?(x86 = false) path = program are two files and not one built twice over the other. *) (if x86 then "-x86" else "")) in - (* Through [Load], so a program with an (import ...) is buildable here: it - brings back the package's C shim and linker arguments as well. *) - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - (* [Reach.link] decides the link from the program: a package nothing - reachable calls into hands over no C and no linker argument, and its - functions are not emitted. *) - let p, csrcs, lflags = Reach.link ~dev l p in + (* [Test_support.linked] is the read, the load, the check and the link — + through [Load], so a program with an (import ...) is buildable here, and + through [Reach.link], so a package nothing reachable calls into hands + over no C and no linker argument. *) + let p, csrcs, lflags = Test_support.linked ~dev path in ignore (Build.executable ~opts:{ Build.default with opt; checks; dev; x86 } ~csrcs ~lflags p ~out:exe); exe -(* No Str, and the reader is hand-written for the same reason. *) -let contains 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 contains = Test_support.contains (* The pool that makes this binary's wall clock survivable. Almost all of the 112 clang invocations below are independent of one another — different @@ -2660,9 +2653,7 @@ let () = else None in let wasm_build ?(opt = "-O2") path out = - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - let p, csrcs, lflags = Reach.link l p in + let p, csrcs, lflags = Test_support.linked path in ignore (Build.executable ~opts:{ Build.default with opt; target = Some "wasm32-wasi" } @@ -5139,9 +5130,5 @@ level "1" been drained, in the order they were submitted in. *) Pool.drain_all (); - if !failures = 0 then print_endline "acceptance: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"acceptance" () | _ -> print_endline "acceptance: skipped (no clang on PATH)" diff --git a/test/test_agent.ml b/test/test_agent.ml index 464b494..7fb1fe0 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -18,36 +18,21 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_agent" -let failures = ref 0 -let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt +(* The counter, the scratch paths, the poll and the connect are in + test_support.ml — the note there on why a retry is narrowed to + ECONNREFUSED is this file's own reasoning, moved with the code it explains. -let scratch = Filename.get_temp_dir_name () -let tmp name = Filename.concat scratch ("flan-agent-" ^ name) - -(* Poll for a condition rather than sleeping a fixed time: the program has to - bind its socket before there is anything to connect to, and how long that - takes is not ours to predict. *) -let rec await ?(ms = 3000) f = - if f () then true - else if ms <= 0 then false - else begin - ignore (Unix.select [] [] [] 0.005); - await ~ms:(ms - 5) f - end - -(* The socket file appears at [bind], which is a moment before [listen], so a - connect can lose that race and get ECONNREFUSED. Retry rather than sleep. *) -let rec connect ?(ms = 2000) path = - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - match Unix.connect s (Unix.ADDR_UNIX path) with - | () -> s - | exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 -> - Unix.close s; - ignore (Unix.select [] [] [] 0.005); - connect ~ms:(ms - 5) path + Both budgets below are shorter than the shared defaults, and deliberately: + everything this file waits on is a program that has already been built and + launched, so three seconds is a wait for a bind rather than for a compile, + and the two the connect retries for are the width of the bind/listen race + itself. *) +let fail fmt = Test_support.fail fmt +let tmp name = Test_support.tmp "flan-agent-" name +let await ?(ms = 3000) f = Test_support.await ~ms f let send path line = - let s = connect path in + let s = Test_support.connect ~ms:2000 path in let msg = line ^ "\n" in ignore (Unix.write_substring s msg 0 (String.length msg)); (* Read to EOF, not once: a reply arrives in several pieces, and closing @@ -555,9 +540,5 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ exe; so1; so2; sock; out; bsock; bout; bexe; qexe; qso; qsock; qout; noinstall; lexe; lsock; lout ]; - if !failures = 0 then print_endline "agent: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"agent" () | _ -> print_endline "agent: skipped (no clang or llc on PATH)" diff --git a/test/test_dev.ml b/test/test_dev.ml index 77cdd24..2c17de5 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -12,72 +12,16 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:900 "test_dev" -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 n = Filename.concat scratch ("flan-devtest-" ^ n) - -let rec await ?(ms = 5000) f = - if f () then true - else if ms <= 0 then false - else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end - -(* Waiting for a daemon to listen is waiting for two different things with one - timer: [flan dev] compiles the whole program first, and only then binds. The - old message, "the daemon never listened", named the second and was almost - always the first — which is a wrong diagnosis, and a wrong diagnosis costs - more than no message at all. - - So this says which. It cannot separate the two waits without a signal from - [flan dev] that the build is done (see NEXT.md), but it can separate the two - *failures*, and that is what actually gets read: a daemon still running when - the timer expires was building, and a daemon that is gone bound nothing - because it died. The second no longer costs the whole timeout either — - the poll watches the process as well as the socket, so a crash fails in - milliseconds instead of in half a minute, which is the part that makes a - suite worth trusting. - - Thirty seconds, down from a minute, because the object cache is durable now - (Build.cachedir) and the build this waits on is warm: 0.48s idle against - 2.0s cold, and the worst ever measured under dune's own parallelism was - 6.8s — cold. The watchdog at 900s is still what bounds the run. - - [!listen_why] carries the reason to the caller so each site can keep its own - name for its daemon. One ref is enough: this file is single-threaded and the - next thing after a failed wait is always the report of it. *) -let listen_why = ref "" - -let listening ?(ms = 30000) ~pid path = - let died = ref None in - ignore - (await ~ms (fun () -> - Sys.file_exists path - || - (* Reaped only once it is already gone, and only on the path that ends - in a failure, so a teardown's own [waitpid] is unaffected. *) - match Unix.waitpid [ Unix.WNOHANG ] pid with - | 0, _ -> false - | _, st -> died := Some st; true - | exception Unix.Unix_error _ -> false)); - if Sys.file_exists path then true - else begin - listen_why := - (match !died with - | Some (Unix.WEXITED n) -> - Printf.sprintf "exited with status %d before binding %s" n path - | Some (Unix.WSIGNALED n) -> - Printf.sprintf "was killed by signal %d before binding %s" n path - (* Unreachable without WUNTRACED, and here only for exhaustiveness. *) - | Some (Unix.WSTOPPED n) -> - Printf.sprintf "stopped on signal %d without binding %s" n path - | None -> - Printf.sprintf - "was still running after %ds without binding %s, so it was the \ - build that did not finish, not the socket" - (ms / 1000) path); - false - end +(* The counter, the scratch paths, the poll and the daemon wait are all in + test_support.ml, which is where [listening]'s long note about telling a + still-building daemon from a dead one now lives too. The watchdog armed + just above is what bounds this particular run. *) +let failures = Test_support.failures +let fail fmt = Test_support.fail fmt +let tmp n = Test_support.tmp "flan-devtest-" n +let await = Test_support.await +let listen_why = Test_support.listen_why +let listening = Test_support.listening (* ── Three states, without a program to be in them ──────────────────── *) @@ -150,14 +94,7 @@ let () = (Dev.orphaned ~grace:0. ~served:true ~idle:10_000. Dev.Parked) false -let rec connect ?(ms = 5000) path = - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - match Unix.connect s (Unix.ADDR_UNIX path) with - | () -> s - | exception Unix.Unix_error (_, _, _) when ms > 0 -> - Unix.close s; - ignore (Unix.select [] [] [] 0.005); - connect ~ms:(ms - 5) path +let connect = Test_support.connect (* The program's own output arrives on the replies, not on a file: the daemon reads its stdout through a pipe so an editor can see it. Every reply is @@ -174,13 +111,7 @@ let request fd sexp = let status r = match Wire.string_field r "status" with Some s -> s | None -> "" -let contains_sub hay needle = - let n = String.length needle in - let rec go i = - i + n <= String.length hay - && (String.equal (String.sub hay i n) needle || go (i + 1)) - in - go 0 +let contains_sub = Test_support.contains (* ── Whose fault a full reload ring is ──────────────────────────────── *) @@ -2668,11 +2599,7 @@ let () = in let text r = Option.value ~default:"" (Wire.string_field r "text") in let basis r = Option.value ~default:"" (Wire.string_field r "basis") in - 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 - n > 0 && go 0 - in + let has = contains_sub in let have_objdump = Sys.command "command -v objdump > /dev/null 2>&1" = 0 in @@ -2894,11 +2821,7 @@ let () = end else begin let c = connect ssock in - 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 - n > 0 && go 0 - in + let has = contains_sub in let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")" @@ -3110,13 +3033,7 @@ let () = else In_channel.with_open_bin dump In_channel.input_all in (try Sys.remove dump with Sys_error _ -> ()); - 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 - n > 0 && go 0 - in + let has = contains_sub in if not (has text "dbg.flan") then fail "a --debug daemon's module carries no line table for the form's \ @@ -4920,9 +4837,5 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; - if !failures = 0 then print_endline "dev: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"dev" () | _ -> print_endline "dev: skipped (no clang or llc on PATH)" diff --git a/test/test_dyn.ml b/test/test_dyn.ml index 8944db3..6e80f33 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -51,26 +51,15 @@ open Flan 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 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 = - Check.program - (Load.program ~file:"programs/dyn-host.flan" - (Reader.read_file "programs/dyn-host.flan")).Load.decls - in + 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); diff --git a/test/test_emacs.ml b/test/test_emacs.ml index 743866a..ecee324 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -12,53 +12,15 @@ (* The watchdog first: a hang is the one failure mode that reports nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_emacs" -let scratch = Filename.get_temp_dir_name () -let tmp n = Filename.concat scratch ("flan-emacs-" ^ n) - -let rec await ?(ms = 8000) f = - if f () then true - else if ms <= 0 then false - else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end - -(* One timer covers two waits here — [flan dev] builds the whole program and - only then binds — so the failure has to say which of them it was. See - [listening] in test_dev.ml for the whole of the reasoning; this is the same - helper, kept here rather than shared because these three files have no - module between them. Watching the process as well as the socket is what - makes a crash fail in milliseconds instead of costing the full timeout. *) -let listen_why = ref "" - -let listening ?(ms = 30000) ~pid path = - let died = ref None in - ignore - (await ~ms (fun () -> - Sys.file_exists path - || - match Unix.waitpid [ Unix.WNOHANG ] pid with - | 0, _ -> false - | _, st -> died := Some st; true - | exception Unix.Unix_error _ -> false)); - if Sys.file_exists path then true - else begin - listen_why := - (match !died with - | Some (Unix.WEXITED n) -> - Printf.sprintf "exited with status %d before binding %s" n path - | Some (Unix.WSIGNALED n) -> - Printf.sprintf "was killed by signal %d before binding %s" n path - (* Unreachable without WUNTRACED, and here only for exhaustiveness. *) - | Some (Unix.WSTOPPED n) -> - Printf.sprintf "stopped on signal %d without binding %s" n path - | None -> - Printf.sprintf - "was still running after %ds without binding %s, so it was the \ - build that did not finish, not the socket" - (ms / 1000) path); - false - end +(* The scratch paths, the poll and the daemon wait are in test_support.ml. The + long note on what [listening] can and cannot tell apart is there with it. *) +let tmp n = Test_support.tmp "flan-emacs-" n +let await = Test_support.await +let listen_why = Test_support.listen_why +let listening = Test_support.listening let () = - let have cmd = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" cmd) = 0 in + let have = Test_support.have in if not (have "emacs") then print_endline "emacs: skipped (no emacs on PATH)" else if not (have "clang" && have "llc") then print_endline "emacs: skipped (no clang or llc on PATH)" diff --git a/test/test_flan.ml b/test/test_flan.ml index 857c050..f4d4892 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -7,7 +7,7 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_flan" -let failures = ref 0 +let failures = Test_support.failures let check name cond = if not cond then begin @@ -15,10 +15,7 @@ let check name cond = Printf.printf "FAIL %s\n" name end -let contains 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 - n = 0 || go 0 +let contains = Test_support.contains (* Every read in this table runs under a five-second alarm. The reader is the one part of the compiler whose mistakes loop rather than raise — a branch @@ -281,11 +278,7 @@ let () = check "multi-line span has no single-line width" (Loc.width l.loc = None) | _ -> check "span: one multi-line form" false); - if !failures = 0 then print_endline "reader: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"reader" () (* ═══ Parse: forms → AST ═══════════════════════════════════════════ *) @@ -677,11 +670,7 @@ let () = dep in test/dune and lands at the build root. *) [ "../calc-me.flan"; "../sand.flan" ]; - if !failures = 0 then print_endline "parse: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"parse" () (* ═══ The return type is the slot, not a guess ══════════════ *) (* (Option f64) and (Some 1) are the same s-expression shape, and the parser @@ -3579,8 +3568,4 @@ let () = accepts "calc-me.flan type checks" (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all); - if !failures = 0 then print_endline "all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report () diff --git a/test/test_reload.ml b/test/test_reload.ml index 99d285e..9aceb84 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -25,15 +25,9 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_reload" -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-reload-" ^ name) - -let checked path = - Check.program - (Load.program ~file:path (Reader.read_file path)).Load.decls +let fail fmt = Test_support.fail fmt +let tmp name = Test_support.tmp "flan-reload-" name +let checked = Test_support.checked let ms f = let t0 = Unix.gettimeofday () in @@ -632,9 +626,5 @@ let () = List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ host; limits; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ]; - if !failures = 0 then print_endline "reload: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"reload" () | _ -> print_endline "reload: skipped (no clang or llc on PATH)" diff --git a/test/test_repl.ml b/test/test_repl.ml index 5b0c847..2687cc2 100644 --- a/test/test_repl.ml +++ b/test/test_repl.ml @@ -20,77 +20,24 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_repl" -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 n = Filename.concat scratch ("flan-repl-" ^ n) - -let rec await ?(ms = 8000) f = - if f () then true - else if ms <= 0 then false - else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end - -(* One timer covers two waits here — [flan dev] builds the whole program and - only then binds — so the failure has to say which of them it was. See - [listening] in test_dev.ml for the whole of the reasoning; this is the same - helper, kept here rather than shared because these three files have no - module between them. Watching the process as well as the socket is what - makes a crash fail in milliseconds instead of costing the full timeout. *) -let listen_why = ref "" - -let listening ?(ms = 30000) ~pid path = - let died = ref None in - ignore - (await ~ms (fun () -> - Sys.file_exists path - || - match Unix.waitpid [ Unix.WNOHANG ] pid with - | 0, _ -> false - | _, st -> died := Some st; true - | exception Unix.Unix_error _ -> false)); - if Sys.file_exists path then true - else begin - listen_why := - (match !died with - | Some (Unix.WEXITED n) -> - Printf.sprintf "exited with status %d before binding %s" n path - | Some (Unix.WSIGNALED n) -> - Printf.sprintf "was killed by signal %d before binding %s" n path - (* Unreachable without WUNTRACED, and here only for exhaustiveness. *) - | Some (Unix.WSTOPPED n) -> - Printf.sprintf "stopped on signal %d without binding %s" n path - | None -> - Printf.sprintf - "was still running after %ds without binding %s, so it was the \ - build that did not finish, not the socket" - (ms / 1000) path); - false - end - -let rec connect ?(ms = 8000) path = - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - match Unix.connect s (Unix.ADDR_UNIX path) with - | () -> s - | exception Unix.Unix_error _ when ms > 0 -> - Unix.close s; - ignore (Unix.select [] [] [] 0.005); - connect ~ms:(ms - 5) path +(* The counter, the poll, the daemon wait and the connect are all in + test_support.ml: see its header for why they are not here. *) +let failures = Test_support.failures +let fail fmt = Test_support.fail fmt +let tmp n = Test_support.tmp "flan-repl-" n +let listen_why = Test_support.listen_why +let listening = Test_support.listening +let connect = Test_support.connect let request fd sexp = Wire.send fd sexp; Wire.parse (Wire.recv fd) let field r k = Wire.string_field r k let status r = match field r "status" with Some s -> s | None -> "" -let quote s = - let b = Buffer.create (String.length s + 8) in - Buffer.add_char b '"'; - String.iter - (fun c -> - if c = '"' || c = '\\' then Buffer.add_char b '\\'; - Buffer.add_char b c) - s; - Buffer.add_char b '"'; - Buffer.contents b +(* [Wire.quote] itself, not a copy of it: the escaping the daemon's own + replies are written with is the escaping a request has to be written with, + and the case below named "every string escape survives the printer and the + wire" is checking exactly that function's stated ground. *) +let quote = Wire.quote let () = match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with @@ -112,7 +59,7 @@ let () = if not (listening ~pid sock) then fail "the daemon %s" !listen_why else begin - let c = connect sock in + let c = connect ~ms:8000 sock in let evals code = request c (Printf.sprintf "(:op \"eval-expr\" :code %s :file \"/tmp/buf.flan\")" diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index b3467a2..04bb183 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -35,11 +35,9 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:3600 "test_sanitize" -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 failures = Test_support.failures +let fail fmt = Test_support.fail fmt +let scratch = Test_support.scratch (* Leaks are off. Every allocation in the runtime is allocate-once-never-free by design — [rt_args] says so in its own comment — so LeakSanitizer here @@ -70,18 +68,13 @@ let compile ~sanitize ~checks path = (if sanitize then "s" else "p") (Filename.remove_extension (Filename.basename path))) in - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - let p, csrcs, lflags = Reach.link ~dev:false l p in + let p, csrcs, lflags = Test_support.linked path in ignore (Build.executable ~opts:{ Build.default with checks; sanitize } ~csrcs ~lflags p ~out:exe); exe -let contains 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 contains = Test_support.contains (* What a report looks like, whichever sanitizer wrote it. *) let markers = @@ -291,9 +284,7 @@ let sweep ~checks label = let dyn_sweep () = let exe = Filename.concat scratch "flan-san-dyn" in let path = "programs/dyn-host.flan" in - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - let p, csrcs, lflags = Reach.link ~dev:false l p in + let p, csrcs, lflags = Test_support.linked path in match Build.executable ~opts:{ Build.default with Build.sanitize = true } diff --git a/test/test_session.ml b/test/test_session.ml index e942f69..7351a61 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -13,19 +13,12 @@ open Flan nothing at all. See watchdog.ml. *) let () = Watchdog.arm ~seconds:600 "test_session" -let failures = ref 0 -let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt - -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 fail fmt = Test_support.fail fmt +let has = Test_support.contains (* Every rejection is asserted on its reason, not just on the failure: the reason is the part that has to survive a refactor. *) -let checked_program file = - Check.program - (Load.program ~file (Reader.read_file file)).Load.decls +let checked_program = Test_support.checked let refuses ?(file = "programs/reload.flan") name src reason = let t, _ = Session.create ~file () in @@ -997,8 +990,4 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "an expression that instantiates a generic: %s" m); - if !failures = 0 then print_endline "session: all tests passed" - else begin - Printf.printf "\n%d failure(s)\n" !failures; - exit 1 - end + Test_support.report ~label:"session" () diff --git a/test/test_support.ml b/test/test_support.ml new file mode 100644 index 0000000..d2bd6a5 --- /dev/null +++ b/test/test_support.ml @@ -0,0 +1,207 @@ +(* The plumbing every test binary in this directory needs, in one place. + + Nothing here tests anything. It is the scaffolding the cases stand on: a + failure counter and the three lines that report it, a poll, a socket + connect that survives the bind/listen race, the wait for a [flan dev] + daemon to come up, a substring search, and the Load → Check → Reach.link + front half of a compile. + + It exists because each of those had been written out again in every file + that wanted it — [listening] three times byte for byte apart from one + comment, the substring search ten times, a report tail in every suite — and + two of those copies carried a comment saying they were kept separate + because "these three files have no module between them". That was not true + when it was written: watchdog.ml was already named in the same + [(modules ...)] stanzas, which is exactly the module between them. This + file is the second such module, named in all four of test/dune's stanzas + the way watchdog is in three of them. + + No [let () = ...] at the top level here on purpose. A module linked into + ten binaries must not do anything on the way in; the watchdog is armed by + each test's own first line, where the seconds are that test's decision. *) + +open Flan + +(* ── Failures, and the report of them ─────────────────────────────── *) + +(* One counter per process, and every [fail] goes through it. Each binary + binds its own [failures] to this ref rather than making one of its own, so + [report] below sees what the file's own [incr failures] did. *) +let failures = ref 0 + +let fail fmt = + Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt + +(* The tail every suite ends on: a single line when nothing failed, and a + count plus a nonzero exit when something did. The label names the suite, + because these binaries run under dune's parallelism and their output is + interleaved — "all tests passed" on its own says nothing about which. + [?label] is optional for the one caller that has no label to give: the + last of test_flan.ml's three tails covers the whole file and has always + printed the bare sentence, and this keeps that byte for byte. + + Not every tail in this directory is this one, and the others are left + where they are: test_repl.ml quotes the daemon's exit status underneath + the count, test_web.ml says "web: ok", and the two sweep binaries print a + count without exiting on the spot. Those differ because they report + different things, not because they drifted. *) +let report ?label () = + if !failures = 0 then + print_endline + (match label with + | Some l -> l ^ ": all tests passed" + | None -> "all tests passed") + else begin + Printf.printf "\n%d failure(s)\n" !failures; + exit 1 + end + +(* ── Strings ──────────────────────────────────────────────────────── *) + +(* Substring search, hand-written because Str is a dependency the rest of + this directory does not take (test_valgrind.ml is the one exception, and + it takes it for a regexp over memcheck's summary line). + + An empty needle is contained in anything, which is the answer the majority + of the copies this replaces gave and the one that agrees with every other + [contains] in the world. Three inline copies in test_dev.ml answered + [false] instead; every needle passed to any of them was a non-empty string + literal, so no call site could tell the difference. *) +let contains 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 + +(* ── Scratch files ────────────────────────────────────────────────── *) + +let scratch = Filename.get_temp_dir_name () + +(* [tmp prefix name] is a path in the scratch directory. The prefix is the + caller's, not a default, and that is the point: these binaries run at the + same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock" + being different files is what keeps two suites from unlinking each other's + sockets. *) +let tmp prefix name = Filename.concat scratch (prefix ^ name) + +(* ── Toolchain probes ─────────────────────────────────────────────── *) + +(* Whether a program is on PATH. Missing tools are a skip with the reason in + this directory, never a red test — the compiler does not depend on emacs, + emscripten or valgrind being installed. *) +let have prog = + Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" prog) = 0 + +(* ── Waiting ──────────────────────────────────────────────────────── *) + +(* Poll for a condition rather than sleeping a fixed time: a program has to + bind its socket before there is anything to connect to, and how long that + takes is not ours to predict. Five milliseconds a turn, [ms] milliseconds + in total, [false] if the budget ran out. + + Five seconds by default, which is what test_dev.ml's copy had and what its + several dozen bare call sites were written against. The callers that want + another budget pass one. *) +let rec await ?(ms = 5000) f = + if f () then true + else if ms <= 0 then false + else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end + +(* The socket file appears at [bind], which is a moment before [listen], so a + connect can lose that race and get ECONNREFUSED. Retry rather than sleep. + + ECONNREFUSED and not any [Unix_error], which is the narrower of the two + spellings this had grown. The wide one retried ENOENT and EACCES to the + full timeout as well, so a path that was never going to exist cost seconds + before raising something a reader still had to interpret; narrowed, those + two come straight back out of [Unix.connect] with their own name on them. + Every caller here connects to a socket [listening] has already seen on + disk, so the race this does catch is the only one left. *) +let rec connect ?(ms = 5000) path = + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + match Unix.connect s (Unix.ADDR_UNIX path) with + | () -> s + | exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 -> + Unix.close s; + ignore (Unix.select [] [] [] 0.005); + connect ~ms:(ms - 5) path + +(* Waiting for a daemon to listen is waiting for two different things with one + timer: [flan dev] compiles the whole program first, and only then binds. The + old message, "the daemon never listened", named the second and was almost + always the first — which is a wrong diagnosis, and a wrong diagnosis costs + more than no message at all. + + So this says which. It cannot separate the two waits without a signal from + [flan dev] that the build is done (see NEXT.md), but it can separate the two + *failures*, and that is what actually gets read: a daemon still running when + the timer expires was building, and a daemon that is gone bound nothing + because it died. The second no longer costs the whole timeout either — + the poll watches the process as well as the socket, so a crash fails in + milliseconds instead of in half a minute, which is the part that makes a + suite worth trusting. + + Thirty seconds, down from a minute, because the object cache is durable now + (Build.cachedir) and the build this waits on is warm: 0.48s idle against + 2.0s cold, and the worst ever measured under dune's own parallelism was + 6.8s — cold. Each caller's watchdog is still what bounds its run. + + [!listen_why] carries the reason to the caller so each site can keep its own + name for its daemon. One ref is enough even though three binaries now share + this code: they are three processes, each single-threaded, and the next + thing after a failed wait is always the report of it. *) +let listen_why = ref "" + +let listening ?(ms = 30000) ~pid path = + let died = ref None in + ignore + (await ~ms (fun () -> + Sys.file_exists path + || + (* Reaped only once it is already gone, and only on the path that ends + in a failure, so a teardown's own [waitpid] is unaffected. *) + match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> false + | _, st -> died := Some st; true + | exception Unix.Unix_error _ -> false)); + if Sys.file_exists path then true + else begin + listen_why := + (match !died with + | Some (Unix.WEXITED n) -> + Printf.sprintf "exited with status %d before binding %s" n path + | Some (Unix.WSIGNALED n) -> + Printf.sprintf "was killed by signal %d before binding %s" n path + (* Unreachable without WUNTRACED, and here only for exhaustiveness. *) + | Some (Unix.WSTOPPED n) -> + Printf.sprintf "stopped on signal %d without binding %s" n path + | None -> + Printf.sprintf + "was still running after %ds without binding %s, so it was the \ + build that did not finish, not the socket" + (ms / 1000) path); + false + end + +(* ── The front half of a compile ──────────────────────────────────── *) + +(* Read, load and check a program: the same two calls [flan build] makes + before it reaches the backend. Through [Load], so a program with an + (import ...) is buildable here — it brings back the package's declarations + as well as the file's own. *) +let checked path = + Check.program (Load.program ~file:path (Reader.read_file path)).Load.decls + +(* And the third call, which is where the binaries below actually differ from + one another: [Reach.link] decides the link from the checked program — a + package nothing reachable calls into hands over no C and no linker + argument, and its functions are not emitted — and returns the program + together with the C sources and linker flags the build needs. + + This stops at [Build.executable] deliberately. Every caller passes a + different [Build.opts] (a sanitized build, a -O0 one, an x86 one, a web + one) and several want the exception rather than the executable, so the + options record is the one part that is genuinely theirs. *) +let linked ?(dev = false) path = + let l = Load.program ~file:path (Reader.read_file path) in + let p = Check.program l.Load.decls in + Reach.link ~dev l p diff --git a/test/test_valgrind.ml b/test/test_valgrind.ml index fb4a0ab..c36556c 100644 --- a/test/test_valgrind.ml +++ b/test/test_valgrind.ml @@ -36,11 +36,9 @@ open Flan slower, so the clock is looser than the sanitize sweep's. See watchdog.ml. *) let () = Watchdog.arm ~seconds:5400 "test_valgrind" -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 failures = Test_support.failures +let fail fmt = Test_support.fail fmt +let scratch = Test_support.scratch let supp = "valgrind.supp" (* Leak checking is off, and the reason is [test_sanitize.ml]'s reason for @@ -98,9 +96,7 @@ let compile ~checks path = (if checks then "c" else "u") (Filename.remove_extension (Filename.basename path))) in - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - let p, csrcs, lflags = Reach.link ~dev:false l p in + let p, csrcs, lflags = Test_support.linked path in ignore (Build.executable ~opts:{ Build.default with checks } ~csrcs ~lflags p ~out:exe); diff --git a/test/test_web.ml b/test/test_web.ml index 3cb4390..afa2247 100644 --- a/test/test_web.ml +++ b/test/test_web.ml @@ -14,11 +14,9 @@ open Flan -let failures = ref 0 - -let scratch = Filename.get_temp_dir_name () - -let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt +let failures = Test_support.failures +let scratch = Test_support.scratch +let fail fmt = Test_support.fail fmt let read path = let ch = open_in_bin path in @@ -26,19 +24,13 @@ let read path = let s = really_input_string ch n in close_in ch; s -let contains 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 have prog = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" prog) = 0 +let contains = Test_support.contains +let have = Test_support.have (* One web build, through [Load] and [Reach] exactly as [flan build] does it, so a package's per-target link lines are selected here too. *) let web_build ?(opt = "-O2") path out = - let l = Load.program ~file:path (Reader.read_file path) in - let p = Check.program l.Load.decls in - let p, csrcs, lflags = Reach.link l p in + let p, csrcs, lflags = Test_support.linked path in ignore (Build.executable ~opts:{ Build.default with opt; target = Some "web" } ~csrcs ~lflags p ~out) @@ -279,11 +271,7 @@ let () = else if not (contains m why) then fail "%s was refused for the wrong reason: wanted %S, said %S" what why m in - let unit_main () = - let path = "programs/unit-main.flan" in - let l = Load.program ~file:path (Reader.read_file path) in - Check.program l.Load.decls - in + let unit_main () = Test_support.checked "programs/unit-main.flan" in refused "--dev --target=web" "--dev is native only" (fun () -> ignore (Build.executable ~opts:{ Build.default with target = Some "web"; dev = true }