diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 0c3c773..32559ee 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,188 @@ 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 order the rows are written in below. That order is fully + deterministic — three runs in a row come out byte-identical — but it is + not the same thing as serial: an inline FAIL a few rows down still prints + the moment it happens, while a pooled FAIL can sit behind up to [cap] + other submissions before its turn to drain comes up. The log is + reproducible, not a live narration of what finished when. + + 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. + + An entry stays in this queue for as long as its worker is alive or + un-reaped — including the whole time the parent is blocked reading its + pipe in [drain_one] below. That is what lets the watchdog's cleanup + hook find the one worker a hang is actually stuck in, not just the + ones still waiting for a slot. *) + let inflight : (string * int * Unix.file_descr) Queue.t = Queue.create () + + (* If the watchdog fires, [dying] calls this before it exits: every forked + worker still in [inflight] is killed rather than left to become an + orphan under init. Killing the worker's own pid is not enough — its + clang, spawned through [Sys.command] -> [/bin/sh] -> clang, is a + grandchild this process never sees a pid for. Each worker calls + [Unix.setsid] on the way in (see [submit]) so it heads its own process + group, with clang inheriting that group rather than starting one of + its own; signalling the *negated* pid reaches the whole group in one + call, worker and clang together. *) + let () = + Watchdog.on_cleanup (fun () -> + Queue.iter + (fun (_, pid, _) -> try Unix.kill (-pid) Sys.sigkill with _ -> ()) + inflight) + + (* The row's own workdir (see [Build.workdir], keyed on the calling + process's pid) so a passing worker does not leave a directory behind + for every compile it ran — a plain per-run cost before this pool + existed, multiplied by every worker's own distinct pid now. Left in + place on failure: that is the one case where "findable by name when + something is wrong with it" (the reason [workdir] does not clean up + after itself) is exactly what the next person wants. *) + let cleanup_workdir () = + let d = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-%d" (Unix.getpid ())) + in + ignore (Sys.command (Printf.sprintf "rm -rf %s" (Filename.quote d))) + + (* Block for the queue's front entry, report its result exactly as the + caller would have inline, and reap it — only then is it popped, so it + is still visible to the watchdog's cleanup hook for the entire time + this call can block. + + 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 () = + let name, pid, fd = Queue.peek inflight in + 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 + ignore (Queue.pop inflight); + 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 (); + (* Flushed before the fork so the child starts from empty buffers. Every + worker below exits through [Unix._exit], never through stdio, so + nothing it does prints from its own copy of these buffers directly — + but a copy carried across the fork with pending bytes in it would + still be sitting there, unflushed, in the child's own address space; + without this flush the parent's not-yet-written prose would be + duplicated the moment anything in the child *did* touch the channel + (an uncaught exception's backtrace, for one). Flushing first empties + both copies before the fork, so there is nothing left to duplicate. *) + flush stdout; + flush stderr; + (* [~cloexec:true] on both ends, not just the one each side closes + immediately: [compile] shells out through [Sys.command], which forks + and execs clang, and without CLOEXEC that grandchild would inherit + the pipe's write end along with the worker. A hung or merely slow + clang would then keep the write end open long after the worker + meant to close it, and the parent's blocking read in [drain_one] + would wait on clang instead of on the row it is actually timing. *) + let r, w = Unix.pipe ~cloexec:true () in + match Unix.fork () with + | 0 -> + Unix.close r; + (* A session and process group of its own, so everything this worker + goes on to spawn — clang, chiefly, through [Sys.command] -> [sh] -> + clang — lands in that same group rather than the parent's. That is + what lets the watchdog's cleanup hook reach clang with one signal + to the negated pid instead of a pid this process never learns. *) + ignore (Unix.setsid ()); + (* 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 + if result = None then cleanup_workdir (); + 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 () + done +end + let () = match Sys.command "command -v clang > /dev/null 2>&1" with | 0 -> @@ -132,16 +327,39 @@ 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. A handful are the exception: + slurp.flan, files.flan and the two raylib programs below all write to + fixed paths — relative for the first two, an absolute /tmp path baked + into the program itself for raylib's PNG/WAV export — that their own + -O0/dev/etc. variants share, with a [clean] between variants that + only makes sense if one variant's write, read and cleanup finish + before the next begins. [outputs_sync] runs the job function directly + rather than through the pool, so within one such cluster that + ordering is exact. Callers additionally run [Pool.drain_all ()] + before a cluster starts, so no *unrelated* pooled row from earlier in + the file is still running against the filesystem at the same time + either — belt and braces, since nothing pooled touches these same + paths today, but a future row added to the pool for one of these + programs would otherwise race silently instead of failing loudly. *) + 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 @@ -1185,12 +1403,13 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ "slurp-out.txt"; "slurp-made.txt" ] in + Pool.drain_all (); 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 @@ -1216,9 +1435,10 @@ let () = either - nothing in parse.ml or check.ml reads the target, and the whole of the difference is one #ifdef in flan_rt.c. Seeing both halves is what makes the claim a test rather than an assertion. *) + Pool.drain_all (); (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 @@ -1260,14 +1480,15 @@ let () = "true\nfalse\ntrue\n13\nnone\ntrue\n10\nfalse\ntrue\nfalse\n\ 1\ntrue\ntrue\ntrue\n1\ntrue\nfalse\n1\ntrue\nfalse\n" in + Pool.drain_all (); 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 @@ -1496,11 +1717,19 @@ let () = sheet at 5,0 200 0 0 255\n\ sheet at 4,2 0 200 0 255\n" in + (* Not pooled: raylib-image.flan exports through the raylib FFI to a + *fixed* absolute path ([png-path] in the program itself, under /tmp), + not through any Flan file builtin this file already checks for + collisions. The default and -O0 rows below write and read that same + path, so run concurrently they race each other's file underfoot — + measured directly as a ~1.7% flake before this was pulled off the + pool. *) + Pool.drain_all (); if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin - outputs "raylib images, headless" "programs/raylib-image.flan" + outputs_sync "raylib images, headless" "programs/raylib-image.flan" raylib_image_out; - outputs ~opt:"-O0" "raylib images, headless, -O0" "programs/raylib-image.flan" - raylib_image_out + outputs_sync ~opt:"-O0" "raylib images, headless, -O0" + "programs/raylib-image.flan" raylib_image_out end else print_endline "acceptance: skipping the raylib Image case (no libraylib)"; @@ -1659,11 +1888,15 @@ let () = loaded frame 1 is +1000 yes\n\ loaded frame 4 is -3000 yes\n" in + (* Not pooled, for the same reason as the Image case just above: + raylib-audio.flan writes its Wave export to a fixed absolute path + under /tmp that the default and -O0 rows share. *) + Pool.drain_all (); if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin - outputs "raylib audio, headless" "programs/raylib-audio.flan" + outputs_sync "raylib audio, headless" "programs/raylib-audio.flan" raylib_audio_out; - outputs ~opt:"-O0" "raylib audio, headless, -O0" "programs/raylib-audio.flan" - raylib_audio_out + outputs_sync ~opt:"-O0" "raylib audio, headless, -O0" + "programs/raylib-audio.flan" raylib_audio_out end else print_endline "acceptance: skipping the raylib Wave case (no libraylib)"; @@ -4728,6 +4961,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\