diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 6c6c7be..3c38d0f 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -100,8 +100,12 @@ let contains hay needle = 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. + 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 @@ -116,21 +120,48 @@ module Pool = struct 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. *) + 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 - compile or compiled-program run still running is killed rather than - left to become an orphan under init. *) + 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 _ -> ()) + (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. + (* 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 @@ -141,7 +172,8 @@ module Pool = struct 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 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) @@ -173,6 +205,7 @@ module Pool = struct | 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; @@ -183,17 +216,35 @@ module Pool = struct [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. *) + 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 @@ -205,6 +256,7 @@ module Pool = struct 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; @@ -220,7 +272,7 @@ module Pool = struct let drain_all () = while not (Queue.is_empty inflight) do - drain_one (Queue.pop inflight) + drain_one () done end @@ -290,14 +342,20 @@ let () = 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. *) + 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 @@ -1345,6 +1403,7 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ "slurp-out.txt"; "slurp-made.txt" ] in + Pool.drain_all (); clean (); outputs_sync "slurp and barf, with restarts" "programs/slurp.flan" slurp_out; clean (); @@ -1376,6 +1435,7 @@ 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_sync "files, the desktop half of the web case" "programs/web-files.flan" "hello from a\nwrote it\n"; @@ -1420,6 +1480,7 @@ 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_sync "the rest of the file surface" "programs/files.flan" files_out; clean_dir (); @@ -1656,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)"; @@ -1819,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)";