Merge branch 'worktree-agent-a0b464fd2273c74d2' into dev-loop

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,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
+      (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. 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"
+    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
@@ -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"
+    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
@@ -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"
+      outputs_sync ~opt:"-O0" "raylib images, headless, -O0"
-        raylib_image_out
+        "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"
+      outputs_sync ~opt:"-O0" "raylib audio, headless, -O0"
-        raylib_audio_out
+        "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;

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\