From 7b3773c3444494429f833fec515ca1064f12aff2 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 19 Sep 2026 22:22:29 +0700 Subject: [PATCH 1/2] A worker pool for the 112 clang calls test_acceptance was making one at a time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 | 211 +++++++++++++++++++++++++++++++++++----- test/watchdog.ml | 11 +++ 2 files changed, 199 insertions(+), 23 deletions(-) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index b4ff412..6c6c7be 100644 --- a/test/test_acceptance.ml +++ b/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) - (* 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 "") + (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 "")) 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 - "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 _ -> ()) + (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) + 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; diff --git a/test/watchdog.ml b/test/watchdog.ml index fccf284..aeadea7 100644 --- a/test/watchdog.ml +++ b/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\ From 31b0f2175ffbeb7ee2d2354ac43d83257dc84bab Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 20 Sep 2026 00:26:37 +0700 Subject: [PATCH 2/2] Four holes review found in the compile pool, closed one at a time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- test/test_acceptance.ml | 133 +++++++++++++++++++++++++++++++--------- 1 file changed, 103 insertions(+), 30 deletions(-) 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)";