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

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.

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)
+      (Printf.sprintf "flan-t-%s-%d%s"
-       (* A name of its own, so an x86 row and an LLVM row over the same
+         (Filename.remove_extension (Filename.basename path))
-          program are two files and not one built twice over the other. *)
+         (Unix.getpid ())
-       ^ if x86 then "-x86" else "")
+         (* 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
+      (try Sys.remove exe with Sys_error _ -> ());
-        incr failures;
+      if text <> expected || code <> 0 then
-        Printf.printf
+        Some
-          "FAIL  %s\n        got: %S (exit %d)\n     wanted: %S (exit 0)\n"
+          (Printf.sprintf
-          name text code expected
+             "FAIL  %s\n        got: %S (exit %d)\n     wanted: %S (exit 0)\n"
-      end;
+             name text code expected)
-      (try Sys.remove exe with Sys_error _ -> ())
+      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"
+    outputs_sync "files, the desktop half of the web case"
-      "hello from a\nwrote it\n";
+      "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"
+    outputs_sync ~opt:"-O0" "the rest of the file surface, -O0"
-      files_out;
+      "programs/files.flan" files_out;
     clean_dir ();
-    outputs ~dev:true "the rest of the file surface, dev" "programs/files.flan"
+    outputs_sync ~dev:true "the rest of the file surface, dev"
-      files_out;
+      "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;

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\