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

A worker pool for the 112 clang calls test_acceptance was making one at a time

Browse Source 
They were the whole of this binary's wall clock, and none of it was CPU the
machine did not have: one core busy, fifteen idle, for 30-odd seconds of
independent programs run strictly one after another. A small pool now forks
up to eight of them at once and reads results back through a pipe in the
order the rows are written in, so the log is byte-for-byte what it always
was — just produced faster.

Eight, not sixteen: dune already runs this suite's eleven binaries at once,
and test_dev's daemon is the actual critical path at roughly 46s against
this one's 30. Handing the pool the whole box would rob the binary that
matters more to speed up the one that matters less.

Every temporary path a worker touches now carries its own pid, so a
program's -O2 row and its -O0 row, run in different forked processes, can
never collide on the same exe or the same captured stdout underfoot. Three
rows could not be pooled that way regardless: slurp.flan and files.flan
write to fixed relative paths their own variants share, with a clean()
between them that only makes sense run in order, so those three stay on the
direct, unpooled path the whole file used before.

A worker that dies without ever writing its result — signalled, OOM-killed,
segfaulted mid-compile — is counted and named rather than silently read as
a pass; the exit status is trusted over a payload that never arrived. And a
worker clears its own SIGALRM handler on the way in, so the parent's
watchdog can never be triggered from inside a child holding a stale copy of
its sibling list. If the watchdog does fire from the parent, it now kills
every worker still in flight before it exits, so a hang does not also leave
orphans behind it.

Standalone, test_acceptance went from 43.4s to 13.8-20.8s across three runs
with identical output every time. The full dune test did not move — 49.4-
49.9s after against 49.8s before — which is the eleven-way sibling
parallelism already claiming what this pool would have used.
This commit is contained in:
Joseph Ferano 2026-09-19 22:22:29 +07:00
parent 7c1a818001
commit 7b3773c344
2 changed files with 199 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
test/test_acceptance.ml
View File

@ -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)
(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 "")
(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
(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
end;
(try Sys.remove exe with Sys_error _ -> ())
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;

11
test/watchdog.ml
View File

@ -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\