diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index b4ff412..6c6c7be 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -42,8 +42,19 @@ let () = let scratch = Filename.get_temp_dir_name () +(* 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 + sequential callers: a compile is still built, run and removed before the + next one reuses the name. What it buys is safety under the pool further + down, where a program's -O2 row and its -O0 row, or a dev row and a + plain row, are two different forked processes running at once — same + path, same basename, same [x86] flag, but never the same pid, so they can + never collide on the same file underfoot. *) let run exe arg = - let out = Filename.concat scratch "flan-acceptance.out" in + let out = + Filename.concat scratch + (Printf.sprintf "flan-acceptance-%d.out" (Unix.getpid ())) + in let cmd = Printf.sprintf "%s %s > %s 2>&1" (Filename.quote exe) @@ -58,10 +69,12 @@ let run exe arg = let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) ?(x86 = false) path = let exe = Filename.concat scratch - ("flan-t-" ^ Filename.remove_extension (Filename.basename path) - (* A name of its own, so an x86 row and an LLVM row over the same - program are two files and not one built twice over the other. *) - ^ if x86 then "-x86" else "") + (Printf.sprintf "flan-t-%s-%d%s" + (Filename.remove_extension (Filename.basename path)) + (Unix.getpid ()) + (* A name of its own, so an x86 row and an LLVM row over the same + 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. *) @@ -81,6 +94,136 @@ let contains hay needle = let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in go 0 +(* The pool that makes this binary's wall clock survivable. Almost all of the + 112 clang invocations below are independent of one another — different + programs, different scratch files, nothing shared — so there is no reason + to pay for them one at a time. Each [outputs] row now forks a worker that + does the compile, the run and the comparison, and reports back over a + pipe instead of printing directly; the parent reads those pipes and + prints in the same order the rows are written in below, so the log reads + exactly as it did serially, just faster to produce. + + The cap is 8, not the 16 cores this box has. dune already runs this + suite's eleven test binaries at once — test_dev alone runs a daemon and + is the actual critical path, at roughly 46s against this binary's 30 — + so handing this pool the whole machine would slow down the binary that + matters more, for a temporary win on the one that matters less. Half the + machine still turns ~86 serial compiles into about eleven waves. *) +module Pool = struct + let cap = 8 + + (* (row name, pid, read end of that job's result pipe), oldest first: FIFO + doubles as both the concurrency window and the print order. The name + rides along so a worker that never gets to write its result — killed, + segfaulted, OOM-killed — can still be named in a FAIL line instead of + silently costing this run one failure it never reports. *) + let inflight : (string * int * Unix.file_descr) Queue.t = Queue.create () + + (* If the watchdog fires, [dying] calls this before it exits: every forked + compile or compiled-program run still running is killed rather than + left to become an orphan under init. *) + let () = + Watchdog.on_cleanup (fun () -> + Queue.iter + (fun (_, pid, _) -> try Unix.kill pid Sys.sigkill with _ -> ()) + inflight) + + (* Block for [pid]'s result, report it exactly as the caller would have + inline, and reap it. Always called in queue order, so two rows can + never print out of the order they were written in below. + + A worker that exits without ever writing to the pipe — killed by a + signal, segfaulted mid-compile, OOM-killed — closes the write end on + the way out, which [Marshal.from_channel] sees as end of file (or, on a + write cut off mid-value, a bad marshal header). Either way that is a + row that did not pass; treating it as [None] would drop it from the + count entirely, which is the exact under-reporting bug requirement 2 + exists to keep out. So a missing or malformed payload is folded into a + failure that names the row and the exit status, the same as any other + FAIL line. *) + let drain_one (name, pid, fd) = + let ic = Unix.in_channel_of_descr fd in + let payload = + try Some (Marshal.from_channel ic : string option) + with End_of_file | Failure _ -> None + in + close_in ic; + let _, status = Unix.waitpid [] pid in + let msg = + match payload, status with + | Some (Some msg), _ -> Some msg + | Some None, Unix.WEXITED 0 -> None + | Some None, _ -> + (* Reported no failure, but did not exit cleanly: trust the exit + status over the payload. *) + Some + (Printf.sprintf "FAIL %s\n worker exited %s after reporting pass\n" + name + (match status with + | Unix.WEXITED n -> Printf.sprintf "with code %d" n + | Unix.WSIGNALED n -> Printf.sprintf "on signal %d" n + | Unix.WSTOPPED n -> Printf.sprintf "stopped on signal %d" n)) + | None, _ -> + Some + (Printf.sprintf + "FAIL %s\n worker died before reporting a result (%s)\n" + name + (match status with + | Unix.WEXITED n -> Printf.sprintf "exit %d" n + | Unix.WSIGNALED n -> Printf.sprintf "signal %d" n + | Unix.WSTOPPED n -> Printf.sprintf "stopped, signal %d" n)) + in + match msg with + | Some msg -> + incr failures; + print_string msg + | None -> () + + (* [f] runs in a forked child and must return [Some fail_message] or + [None]; it must not print anything itself, since the parent is what + decides when a row's output is due. *) + let submit name (f : unit -> string option) = + if Queue.length inflight >= cap then drain_one (Queue.pop inflight); + (* Flushed before the fork so the child starts from empty buffers: it + never writes to stdout/stderr directly, but a dirty buffer carried + across the fork would otherwise surface twice, once from each + process's own exit. *) + flush stdout; + flush stderr; + let r, w = Unix.pipe ~cloexec:true () in + match Unix.fork () with + | 0 -> + Unix.close r; + (* This process is a worker, not the binary the watchdog is timing: + the pending alarm itself is already cleared across fork (Linux does + not carry a running interval timer into the child), but the + handler function pointer is inherited regardless, and that handler + would kill this pool's *other* siblings using the parent's copy of + [inflight] frozen at fork time. Dropping back to the default + disposition makes "a worker cannot fire the parent's watchdog" + true by construction rather than by relying on the timer-clearing + behaviour alone. *) + Sys.set_signal Sys.sigalrm Sys.Signal_default; + let result = try f () with e -> Some (Printexc.to_string e) in + let oc = Unix.out_channel_of_descr w in + Marshal.to_channel oc result []; + close_out oc; + (* Not [exit]: this is a fork of a process that already registered an + [at_exit] guard over [failures], and this child's own copy of that + ref never moves. Going around the normal exit path skips that + guard (and every other at_exit action, all likewise meant for the + one real run) instead of re-running it once per worker. *) + Unix._exit 0 + | pid -> + Unix.close w; + Queue.push (name, pid, r) inflight + + let drain_all () = + while not (Queue.is_empty inflight) do + drain_one (Queue.pop inflight) + done +end + let () = match Sys.command "command -v clang > /dev/null 2>&1" with | 0 -> @@ -132,16 +275,33 @@ let () = surface calc-me does not reach — globals, 2-D arrays, places through a pointer, casts, match with either arm taken, and the value semantics of spec-memory.md. *) - let outputs ?opt ?dev ?x86 name path expected = + let outputs_job ?opt ?dev ?x86 name path expected () = let exe = compile ?opt ?dev ?x86 path in let code, text = run exe None in - if text <> expected || code <> 0 then begin - incr failures; - Printf.printf - "FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n" - name text code expected - end; - (try Sys.remove exe with Sys_error _ -> ()) + (try Sys.remove exe with Sys_error _ -> ()); + if text <> expected || code <> 0 then + Some + (Printf.sprintf + "FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n" + name text code expected) + else None + in + let outputs ?opt ?dev ?x86 name path expected = + Pool.submit name (outputs_job ?opt ?dev ?x86 name path expected) + in + (* Almost every [outputs] row compiles and runs a program that touches + nothing outside its own (pid-named) exe. slurp.flan is the exception: + it writes to fixed, relative paths ([slurp-out.txt], [slurp-made.txt]) + that its three variants below all share, with a [clean ()] between + them that only makes sense if one variant's write, read and cleanup + finish before the next variant's begin. Pooling those three would + hand them the same files at the same time — exactly the collision the + pool's pid-named exe and output paths exist to avoid everywhere else + — so they run straight through the job function instead of the pool. *) + let outputs_sync ?opt ?dev ?x86 name path expected = + match outputs_job ?opt ?dev ?x86 name path expected () with + | Some msg -> incr failures; print_string msg + | None -> () in let values_out = "1\n5\nel\n" in let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in @@ -1186,11 +1346,11 @@ let () = [ "slurp-out.txt"; "slurp-made.txt" ] in clean (); - outputs "slurp and barf, with restarts" "programs/slurp.flan" slurp_out; + outputs_sync "slurp and barf, with restarts" "programs/slurp.flan" slurp_out; clean (); - outputs ~opt:"-O0" "slurp and barf, -O0" "programs/slurp.flan" slurp_out; + outputs_sync ~opt:"-O0" "slurp and barf, -O0" "programs/slurp.flan" slurp_out; clean (); - outputs ~dev:true "slurp and barf, dev" "programs/slurp.flan" slurp_out; + outputs_sync ~dev:true "slurp and barf, dev" "programs/slurp.flan" slurp_out; clean (); (* slurp's use-value is the first restart clause the *compiler* emits with @@ -1217,8 +1377,8 @@ let () = of the difference is one #ifdef in flan_rt.c. Seeing both halves is what makes the claim a test rather than an assertion. *) (try Sys.remove "web-files-out.txt" with Sys_error _ -> ()); - outputs "files, the desktop half of the web case" "programs/web-files.flan" - "hello from a\nwrote it\n"; + outputs_sync "files, the desktop half of the web case" + "programs/web-files.flan" "hello from a\nwrote it\n"; (try Sys.remove "web-files-out.txt" with Sys_error _ -> ()); (* A missing file with nothing handling it. The same rule StorageExhausted @@ -1261,13 +1421,13 @@ let () = 1\ntrue\ntrue\ntrue\n1\ntrue\nfalse\n1\ntrue\nfalse\n" in clean_dir (); - outputs "the rest of the file surface" "programs/files.flan" files_out; + outputs_sync "the rest of the file surface" "programs/files.flan" files_out; clean_dir (); - outputs ~opt:"-O0" "the rest of the file surface, -O0" "programs/files.flan" - files_out; + outputs_sync ~opt:"-O0" "the rest of the file surface, -O0" + "programs/files.flan" files_out; clean_dir (); - outputs ~dev:true "the rest of the file surface, dev" "programs/files.flan" - files_out; + outputs_sync ~dev:true "the rest of the file surface, dev" + "programs/files.flan" files_out; clean_dir (); (* The epoch trap: a container whose allocator has been released. This is @@ -4648,6 +4808,11 @@ level "1" "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 ~says:[ "--debug"; "-O2"; "Drop one of the two" ]; + (* Every row above that went through the pool has been forked; nothing + after this point may look at [failures] until every one of them has + 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; diff --git a/test/watchdog.ml b/test/watchdog.ml index fccf284..aeadea7 100644 --- a/test/watchdog.ml +++ b/test/watchdog.ml @@ -32,7 +32,18 @@ let label = ref "test" let budget = ref 0 let deadline = ref 0.0 +(* A binary that forks workers of its own (test_acceptance's compile pool, at + least so far) can register cleanup here: something to run to stop those + workers before [dying] falls through to [Unix._exit]. Without it, an alarm + firing mid-run kills only this process and every child it had in flight + becomes an orphan, reparented to init and left to run — or hang — on its + own. Best-effort and swallowed: a cleanup action that itself fails must + not stop the rest of them, or the report of the hang, from happening. *) +let cleanup : (unit -> unit) list ref = ref [] +let on_cleanup f = cleanup := f :: !cleanup + let dying _ = + List.iter (fun f -> try f () with _ -> ()) !cleanup; Printf.eprintf "\nFAIL %s: no result after %ds — stopped by the test watchdog.\n\ \ A test that hangs reports nothing at all; this is that outcome\n\