JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Four holes review found in the compile pool, closed one at a time

Browse Source 
A worker's own pid was not enough to keep two variants of the same program
from colliding: raylib-image.flan and raylib-audio.flan export through the
raylib FFI to a fixed absolute path under /tmp, baked into the program
itself rather than passed in, so a default row and its -O0 row running as
two different workers could still race each other's file. Measured at a
~1.7% flake before. Both clusters now run through outputs_sync, off the
pool, the same as slurp.flan and files.flan already were for the same
reason.

The watchdog's own cleanup had two gaps. First, an inflight entry was popped
off the queue before the parent blocked reading its pipe, which is exactly
the moment a hang leaves the queue blind to the one worker it needs to see.
The entry now stays visible until its result is actually in hand. Second,
killing a worker's pid did not reach its clang, spawned three processes
away through Sys.command -> sh -> clang, which a forced alarm could leave
running as an orphan. Each worker now calls setsid on the way in, so it and
everything it goes on to spawn share one process group, and the cleanup
hook signals the negated pid to reach the whole group in one call. Eight
repeated forced alarms, zero processes left behind afterward.

Two comments claimed more than the code delivered. The order rows print in
is fully deterministic but is not serial — an inline FAIL still prints the
moment it happens, while a pooled one can sit behind up to eight other
submissions first — so the comment now says reproducible rather than
serial. And outputs_sync's isolation from the pool was true only because
nothing pooled happened to touch the same paths; a Pool.drain_all () now
runs before each of the four unpooled clusters, so that isolation holds
regardless of what gets added to the pool later.

And a worker now removes its own Build.workdir on the way out when its row
passed, rather than leaving one directory behind for every compile it ran
on top of what a single serial run already left. Left in place on failure,
where the original reason that directory is never swept — findable by name
when something is wrong with it — is exactly what the next person wants.

Reverified after all four: the raylib probe clean across twelve full runs,
the forced-alarm probe clean across eight, dune test read for FAIL lines
rather than trusted by exit code, three standalone runs byte-identical.
This commit is contained in:
Joseph Ferano 2026-09-20 00:26:37 +07:00
parent 7b3773c344
commit 31b0f2175f
1 changed files with 103 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
test/test_acceptance.ml
View File

@ -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)";