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

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-20 00:27:40 +07:00
commit ba7f31e99f
2 changed files with 278 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

296
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)
(* 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,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
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. 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"
"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
@ -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"
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
@ -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"
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)";
@ -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"
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)";
@ -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;

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\