The object cache outlives the run, and the await says which wait it was

Build.cachedir sat under TMPDIR, which dune makes private per run, so no
test run ever reused an object and every build in the suite was cold. It
moves to $XDG_CACHE_HOME/flan/objcache (FLAN_CACHE_DIR overrides), which
is safe because the keys are total: compile_c digests the source text,
the compiler's stamp and every flag; wasm_resource_dir digests the
builtins archive; compiler_object digests flan.cmxa and flan.a. Writes
were already .tmp-then-rename, so concurrent dune jobs are fine.

Macro.key was the one key that was not total -- prelude text plus the
call's forms, and nothing about the compiler whose codegen produced the
.so it names, which is dlopened straight back into this binary. Under a
per-run TMPDIR that never showed; under a durable cache it is a stale
expander that crashes rather than a compile error. It carries the
compiler's stamp now, handed across start_merged's exec in
FLAN_COMPILER_STAMP because a merged dev binary lives at a per-session
path and keying on that rebuilt a macro module every dev start.

Measured on dev-repl.flan, launch to bound socket: 2.0s cold against
0.48s warm. Whole-program flan build: 1.44s against 0.06s. Full dune
test 25.7s/30.1s before, 24.0s after, user CPU ~50s down to ~34s.

And the await: one timer covered two waits, a build then a bind, so
'the daemon never listened' was a wrong diagnosis of a build that had
not finished. listening now polls the process alongside the socket and
says which -- exited with a status, or still running and therefore still
building. A daemon that dies fails in milliseconds instead of costing
the whole timeout. Thirty seconds, down from a minute, because the build
it waits on is warm now.
This commit is contained in:
Joseph Ferano 2026-09-13 14:04:50 +07:00
parent 781295e862
commit cdcdd70c4e
8 changed files with 272 additions and 74 deletions

View File

@ -3720,7 +3720,9 @@ answered it, and neither `retry` nor `use-value` means *give up*. `web-files.fla
| link | 20ms | | link | 20ms |
Every C translation unit a build needs — the host shim and each package's shim — goes through `Build.compile_c`, which Every C translation unit a build needs — the host shim and each package's shim — goes through `Build.compile_c`, which
compiles to a `.o` under `$TMPDIR/flan-objcache` and reuses it. The key is a digest of the source text, the compiler compiles to a `.o` under `$XDG_CACHE_HOME/flan/objcache` (`~/.cache/flan/objcache`, or `$FLAN_CACHE_DIR`) and
reuses it. It used to sit under `$TMPDIR`, which meant dune — which gives every run a private `TMPDIR` — never reused
an object and every build in the test suite was cold. The key is a digest of the source text, the compiler
(its path, size and mtime, so an upgrade invalidates without paying a `clang --version` subprocess per build), (its path, size and mtime, so an upgrade invalidates without paying a `clang --version` subprocess per build),
`opts.opt` and `opts.target`. The opt level has to be in there: the acceptance table builds the same programs at `-O0` `opts.opt` and `opts.target`. The opt level has to be in there: the acceptance table builds the same programs at `-O0`
and `-O2`, and an `-O2` object must not serve an `-O0` build. The object is written to a temporary name and `rename`d and `-O2`, and an `-O2` object must not serve an `-O0` build. The object is written to a temporary name and `rename`d

56
NEXT.md
View File

@ -101,19 +101,29 @@ The fix is ordering, not timing: the test checked for `agent.sock` before comple
the check took it from 2/8 failures to 0/10, and closed a second race that was burning the full 10s timeout. the check took it from 2/8 failures to 0/10, and closed a second race that was burning the full 10s timeout.
`lib/dev.ml` was not touched. `lib/dev.ml` was not touched.
**The `the daemon never listened` flake is diagnosed and fixed, and it was never a race.** The wait is not for a **The `the daemon never listened` flake is closed at the root, and the root was a cold cache.** The wait is not for
socket but for an llc-and-link of the whole program before `flan dev` binds. That is ~600ms idle and was measured at a socket but for an llc-and-link of the whole program before `flan dev` binds, and that build was cold on every
**6.6s and 6.8s** with the rest of the suite running beside it under dune's own parallelism, against a 5s invocation because `Build.cachedir` sat under `$TMPDIR` — which dune makes private per run. The cache now lives under
(`test_dev.ml`) and 8s (`test_emacs.ml`, `test_repl.ml`) `await`. The message reads like a bug in the daemon and is `$XDG_CACHE_HOME/flan/objcache` (`$FLAN_CACHE_DIR` overrides). Measured on `dev-repl.flan`, launch to bound socket:
a build slower than the timeout. All three now wait a minute — the watchdog bounds the run, and this only has to be **2.0s cold, 0.48s warm**; whole-program `flan build` **1.44s cold, 0.06s warm**; full `dune test` 25.7s/30.1s before
long enough that a failure means the daemon is not coming. `test_dev.ml` has a named `listening` so the reason is against 24.0s after, with user CPU down from ~50s to ~34s — the wall gain is small because the suite is bound by
written once for its thirteen daemons. sequential test steps, not by compiles.
Two things found while chasing it that are worth not re-deriving. **The site was `test_dev.ml:77`**, not The move was safe because the keys are total, which is the thing to check before moving a cache and not after:
`test_emacs.ml`/`test_repl.ml` — the belief that only those two carry that wording was false and sent one lane after `compile_c` digests the source *text*, the compiler binary's stamp and every flag; `wasm_resource_dir` digests the
the wrong file. And **every build in the suite is cold**, because `Build.cachedir` (`lib/build.ml:59`) sits under builtins archive; `compiler_object` digests flan.cmxa and flan.a. Writes are already `.tmp`-then-`rename`, so a
dune's per-run `TMPDIR`, so no run ever reuses the object cache: ~550ms warm against 2.9-4.0s cold. That is the shared durable cache is safe under dune's own parallelism. **One key was not total**: `Macro.key` was prelude text
root of the timeout problem and a longer `await` only hides it. plus the call's forms, with nothing about the compiler that emitted the `.so` it names — and that `.so` is dlopened
back into this binary, so a codegen or ABI change served a stale expander as a crash rather than an error. It now
carries the compiler's stamp, passed across `start_merged`'s exec in `FLAN_COMPILER_STAMP` because a merged dev
binary's own path is a per-session throwaway under /tmp (keying on it rebuilt a macro module every dev start —
~350ms, most of what this cache exists to save).
`lib/cimport.ml` spells its own copy of the old `cachedir` (line 828) and still sits under `$TMPDIR`. Another lane
holds that file; folding it onto `Build.cachedir` is a one-line change when that lane lands.
Worth not re-deriving: **the site was `test_dev.ml:77`**, not `test_emacs.ml`/`test_repl.ml` — the belief that only
those two carry that wording was false and sent one lane after the wrong file.
**The socket ordering fix is confirmed** at 30 sequential full `dune test` runs, 0 failures, no `never bound` in any **The socket ordering fix is confirmed** at 30 sequential full `dune test` runs, 0 failures, no `never bound` in any
log — so the section this file used to carry about it is gone. log — so the section this file used to carry about it is gone.
@ -121,14 +131,20 @@ log — so the section this file used to carry about it is gone.
1. **Decide whether `merged_serve`'s 10s warning path deserves a test.** `lib/dev.ml:2322-2326` is exercised by 1. **Decide whether `merged_serve`'s 10s warning path deserves a test.** `lib/dev.ml:2322-2326` is exercised by
nothing now that the unlink race is closed. nothing now that the unlink race is closed.
**The other "never listened" was not a race, and the note that sent people after one was wrong twice.** That wording **The `never listened` message named the wrong thing, and now it names which.** One timer covered two waits — a
came from *three* sites, `test_dev.ml:77` included, not from the two this file named. And it is a bound too short for build, then a bind — so the message was a wrong diagnosis, which costs more than no message. `listening` in
a build, not contention: `flan dev` links the whole program before it binds, ~600ms warm and measured at 6.5-6.8s `test_dev.ml` (and the copy in `test_emacs.ml` and `test_repl.ml`) polls the daemon's process alongside the socket
under dune's own parallelism, against 5000ms in `test_dev.ml` and 8000ms in the other two — `Build.cachedir` lives and reports which of the two failed: "exited with status N before binding <sock>" when it died, "was still running
under dune's per-run `TMPDIR`, so that build is cold on every invocation. Fixed on another branch: the three awaits after 30s without binding <sock>, so it was the build that did not finish, not the socket" when it did not. A crash
wait a minute now, bounded by the watchdog, with a named `listening` helper in `test_dev.ml`. The one thing not to now fails in milliseconds instead of costing the whole timeout, which is the half of "split the waits" that was
re-derive from `HANDOFF-f1.md` is its "lengthening any timeout" bullet — that applies to the `agent.sock` check actually worth having. The timers are 30s, down from a minute, because the build they wait on is warm now.
only, and reading it as a rule is what kept this open.
1. **The two waits are still one wait.** Separating them needs a signal from `flan dev` that the build is done and
the bind has begun — a sentinel beside the socket in `start_merged` and `two_process`, or the existing
`flan dev: built %s in %.0fms` stderr line captured per daemon. The stderr route means redirecting stderr at
twelve spawn sites in `test_dev.ml` and polling a log for a substring; the sentinel is two lines in `lib/dev.ml`
and an unambiguous boundary, and is the one to do if this is picked up. Neither was done here because watching
the process already buys the fail-fast, and the message already says which wait it was.
### From `HANDOFF-f3.md` — the watch is built; two tests are not ### From `HANDOFF-f3.md` — the watch is built; two tests are not

View File

@ -52,13 +52,51 @@ let workdir () =
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
d d
(* [mkdir -p]: each component in turn, [EEXIST] swallowed at each, because the
cache now lives several directories down rather than one. *)
let rec mkdir_p d =
if not (Sys.file_exists d) then begin
let parent = Filename.dirname d in
if parent <> d then mkdir_p parent;
try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
end
(* The object cache, which unlike [workdir] is stable across builds. The C that (* The object cache, which unlike [workdir] is stable across builds. The C that
goes into a build the host shim and the packages' shims is the same on goes into a build the host shim and the packages' shims is the same on
every build and never the thing being edited, yet it was being recompiled every build and never the thing being edited, yet it was being recompiled
each time: 40ms of a 140ms build for [flan_rt.c] alone. *) each time: 40ms of a 140ms build for [flan_rt.c] alone.
Under the *cache* directory and not under [TMPDIR], which is where it used
to be, because dune gives every test run a fresh private [TMPDIR] so the
suite never once reused an object and every build in it was cold. Measured
on this program: [flan dev] to a bound socket in 2.0s cold against 0.48s
warm, and a whole-program [flan build] in 1.44s against 0.06s. The one
thing that made the move safe to do rather than a way to serve a stale
object is that the keys are total: [compile_c] digests the source *text*,
the compiler binary's own stamp, [opt] and every flag; [wasm_resource_dir]
digests the builtins archive it copies; [Dev.compiler_object] digests
flan.cmxa and flan.a. There is nothing an isolated directory was hiding.
(The one key that was *not* total is [Macro]'s see the note there.)
FLAN_CACHE_DIR overrides it, for a build that wants a cache of its own. *)
let cachedir () = let cachedir () =
let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-objcache" in let d =
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); match Sys.getenv_opt "FLAN_CACHE_DIR" with
| Some d when d <> "" -> d
| _ ->
let base =
match Sys.getenv_opt "XDG_CACHE_HOME" with
| Some d when d <> "" -> d
| _ ->
(match Sys.getenv_opt "HOME" with
| Some h when h <> "" -> Filename.concat h ".cache"
(* Neither set: back to where this used to live, because a cache
with nowhere to go must not be a build failure. *)
| _ -> Filename.get_temp_dir_name ())
in
Filename.concat (Filename.concat base "flan") "objcache"
in
mkdir_p d;
d d
type opts = { type opts = {

View File

@ -2443,6 +2443,12 @@ let start_merged ?(debug = false) ~file ~sock () =
Unix.putenv "FLAN_DEV_DIR" dir; Unix.putenv "FLAN_DEV_DIR" dir;
Unix.putenv "FLAN_DEV_HOST_LL" host_ll; Unix.putenv "FLAN_DEV_HOST_LL" host_ll;
Unix.putenv "FLAN_DEV_DEBUG" (if debug then "1" else "0"); Unix.putenv "FLAN_DEV_DEBUG" (if debug then "1" else "0");
(* Not read by the exec'd binary's dev path but by [Macro]: the merged binary
expands the prelude a second time, and the object cache's macro key is
keyed on the compiler's identity. Its own [Sys.executable_name] is this
session's throwaway under /tmp, new on every start, so without this the
macro module is rebuilt per session. See the note on [Macro.self]. *)
Unix.putenv "FLAN_COMPILER_STAMP" (Build.stamp_of Sys.executable_name);
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());
Printf.eprintf "flan dev: built %s in %.0fms\n%!" (Filename.basename file) Printf.eprintf "flan dev: built %s in %.0fms\n%!" (Filename.basename file)
((Unix.gettimeofday () -. t0) *. 1000.); ((Unix.gettimeofday () -. t0) *. 1000.);

View File

@ -51,10 +51,37 @@ type loaded = {
fns : (string * Dynload.addr) list; fns : (string * Dynload.addr) list;
} }
(* This compiler's own identity, and it belongs in the key for a reason the
other caches do not have. A [.o] under the object cache is decided entirely
by the C text and the C compiler that made it, so its key is total without
naming flan at all. A macro module is not: it is *this* binary's codegen,
dlopen'd back into *this* binary and called across a marshalled boundary.
Change [Emit] or the runtime ABI and the .so on disk is wrong while the
prelude text that keyed it has not moved a stale macro expander, which
fails as a crash inside [Expand.call] rather than as a compile error.
It never showed because the cache sat under dune's per-run [TMPDIR] and so
was empty on every run. Now that the cache outlives the run, the key has to
carry what the directory used to hide.
The stamp of the running binary is the identity, except in the one place
where that binary is not a stable thing: a [flan dev] merged build lives at
/tmp/flan-dev-<pid>/program, so its size-and-mtime is new on every start and
keying on it would rebuild a macro module per session measured at ~350ms
of every dev start, which is most of what this cache exists to save. So
[Dev.start_merged] passes its own stamp across the exec, and the merged
binary uses the stamp of the compiler that built it, which is the one this
key is actually about. *)
let self =
lazy
(match Sys.getenv_opt "FLAN_COMPILER_STAMP" with
| Some s when s <> "" -> s
| _ -> Build.stamp_of Sys.executable_name)
let key (extra : Form.t list) = let key (extra : Form.t list) =
Digest.to_hex Digest.to_hex
(Digest.string (Digest.string
(Prelude.source ^ "\000" (Lazy.force self ^ "\000" ^ Prelude.source ^ "\000"
^ String.concat "\000" (List.map Form.to_string extra))) ^ String.concat "\000" (List.map Form.to_string extra)))
(* True while a macro module is being built. [Build.macro_module] goes through (* True while a macro module is being built. [Build.macro_module] goes through

View File

@ -23,18 +23,59 @@ let rec await ?(ms = 5000) f =
else if ms <= 0 then false else if ms <= 0 then false
else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
(* Waiting for a daemon to listen is not waiting for a socket: [flan dev] (* Waiting for a daemon to listen is waiting for two different things with one
compiles the whole program first, and only then binds. The build is llc and timer: [flan dev] compiles the whole program first, and only then binds. The
a link, which is ~600ms on an idle machine and has been measured at 6.8s old message, "the daemon never listened", named the second and was almost
with this suite's other binaries running beside it under dune's own always the first which is a wrong diagnosis, and a wrong diagnosis costs
parallelism so the 5s default turned a busy machine into "the daemon never more than no message at all.
listened", a message that reads like a bug in the daemon and is not one.
A minute is not a guess about how slow the build can get; it is long enough So this says which. It cannot separate the two waits without a signal from
that a failure here means the daemon is not coming, which is the only thing [flan dev] that the build is done (see NEXT.md), but it can separate the two
this check is trying to find out. The watchdog is the thing that bounds the *failures*, and that is what actually gets read: a daemon still running when
run, and it is armed at 900s for exactly this reason. *) the timer expires was building, and a daemon that is gone bound nothing
let listening path = await ~ms:60000 (fun () -> Sys.file_exists path) because it died. The second no longer costs the whole timeout either
the poll watches the process as well as the socket, so a crash fails in
milliseconds instead of in half a minute, which is the part that makes a
suite worth trusting.
Thirty seconds, down from a minute, because the object cache is durable now
(Build.cachedir) and the build this waits on is warm: 0.48s idle against
2.0s cold, and the worst ever measured under dune's own parallelism was
6.8s cold. The watchdog at 900s is still what bounds the run.
[!listen_why] carries the reason to the caller so each site can keep its own
name for its daemon. One ref is enough: this file is single-threaded and the
next thing after a failed wait is always the report of it. *)
let listen_why = ref ""
let listening ?(ms = 30000) ~pid path =
let died = ref None in
ignore
(await ~ms (fun () ->
Sys.file_exists path
||
(* Reaped only once it is already gone, and only on the path that ends
in a failure, so a teardown's own [waitpid] is unaffected. *)
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _, st -> died := Some st; true
| exception Unix.Unix_error _ -> false));
if Sys.file_exists path then true
else begin
listen_why :=
(match !died with
| Some (Unix.WEXITED n) ->
Printf.sprintf "exited with status %d before binding %s" n path
| Some (Unix.WSIGNALED n) ->
Printf.sprintf "was killed by signal %d before binding %s" n path
| Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on signal %d" n
| None ->
Printf.sprintf
"was still running after %ds without binding %s, so it was the \
build that did not finish, not the socket"
(ms / 1000) path);
false
end
let rec connect ?(ms = 5000) path = let rec connect ?(ms = 5000) path =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
@ -86,8 +127,8 @@ let () =
in in
Unix.close fd; Unix.close fd;
if not (listening sock) then if not (listening ~pid sock) then
fail "the daemon never listened" fail "the daemon %s" !listen_why
else begin else begin
(* The daemon owns the program's lifetime and kills it on [close], so (* The daemon owns the program's lifetime and kills it on [close], so
every step waits for the program to have got there. "ok" from an eval every step waits for the program to have got there. "ok" from an eval
@ -421,8 +462,8 @@ let () =
Unix.stdin bfd Unix.stderr Unix.stdin bfd Unix.stderr
in in
Unix.close bfd; Unix.close bfd;
if not (listening bsock) then begin if not (listening ~pid:bpid bsock) then begin
fail "the break daemon never listened"; fail "the break daemon %s" !listen_why;
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -813,8 +854,8 @@ let () =
Unix.stdin xfd Unix.stderr Unix.stdin xfd Unix.stderr
in in
Unix.close xfd; Unix.close xfd;
if not (listening xsock) then begin if not (listening ~pid:xpid xsock) then begin
fail "the bad-index daemon never listened"; fail "the bad-index daemon %s" !listen_why;
(try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -941,8 +982,8 @@ let () =
Unix.stdin lfd Unix.stderr Unix.stdin lfd Unix.stderr
in in
Unix.close lfd; Unix.close lfd;
if not (listening lsock) then begin if not (listening ~pid:lpid lsock) then begin
fail "the locals daemon never listened"; fail "the locals daemon %s" !listen_why;
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1122,8 +1163,8 @@ let () =
Unix.stdin ifd Unix.stderr Unix.stdin ifd Unix.stderr
in in
Unix.close ifd; Unix.close ifd;
if not (listening isock) then begin if not (listening ~pid:ipid isock) then begin
fail "the inspect daemon never listened"; fail "the inspect daemon %s" !listen_why;
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1326,8 +1367,8 @@ let () =
Unix.stdin gfd Unix.stderr Unix.stdin gfd Unix.stderr
in in
Unix.close gfd; Unix.close gfd;
if not (listening gsock) then begin if not (listening ~pid:gpid gsock) then begin
fail "the globals daemon never listened"; fail "the globals daemon %s" !listen_why;
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1549,8 +1590,8 @@ let () =
Unix.stdin dfd Unix.stderr Unix.stdin dfd Unix.stderr
in in
Unix.close dfd; Unix.close dfd;
if not (listening dsock) then begin if not (listening ~pid:dpid dsock) then begin
fail "the disassembly daemon never listened"; fail "the disassembly daemon %s" !listen_why;
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1777,8 +1818,8 @@ let () =
env Unix.stdin sfd Unix.stderr env Unix.stdin sfd Unix.stderr
in in
Unix.close sfd; Unix.close sfd;
if not (listening ssock) then begin if not (listening ~pid:spid ssock) then begin
fail "the daemon with no working llc never listened"; fail "the daemon with no working llc %s" !listen_why;
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1845,8 +1886,8 @@ let () =
Unix.stdin gfd Unix.stderr Unix.stdin gfd Unix.stderr
in in
Unix.close gfd; Unix.close gfd;
if not (listening gsock) then begin if not (listening ~pid:gpid gsock) then begin
fail "the --debug daemon never listened"; fail "the --debug daemon %s" !listen_why;
(try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -1928,8 +1969,8 @@ let () =
Unix.stdin wfd Unix.stderr Unix.stdin wfd Unix.stderr
in in
Unix.close wfd; Unix.close wfd;
if not (listening wsock) then if not (listening ~pid:wpid wsock) then
fail "the watch daemon never listened" fail "the watch daemon %s" !listen_why
else begin else begin
let wc = connect wsock in let wc = connect wsock in
let ask q = Wire.parse (Wire.send wc q; Wire.recv wc) in let ask q = Wire.parse (Wire.send wc q; Wire.recv wc) in
@ -2099,8 +2140,8 @@ let () =
Unix.stdin pfd Unix.stderr Unix.stdin pfd Unix.stderr
in in
Unix.close pfd; Unix.close pfd;
if not (listening psock) then begin if not (listening ~pid:ppid psock) then begin
fail "the pause daemon never listened"; fail "the pause daemon %s" !listen_why;
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()) (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end end
else begin else begin
@ -2334,8 +2375,8 @@ let () =
Unix.stdin tfd Unix.stderr Unix.stdin tfd Unix.stderr
in in
Unix.close tfd; Unix.close tfd;
if not (listening tsock) then if not (listening ~pid:tpid tsock) then
fail "--two-process never listened" fail "--two-process %s" !listen_why
else begin else begin
let tc = connect tsock in let tc = connect tsock in
let seen = Buffer.create 64 in let seen = Buffer.create 64 in

View File

@ -20,6 +20,41 @@ let rec await ?(ms = 8000) f =
else if ms <= 0 then false else if ms <= 0 then false
else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
(* One timer covers two waits here — [flan dev] builds the whole program and
only then binds so the failure has to say which of them it was. See
[listening] in test_dev.ml for the whole of the reasoning; this is the same
helper, kept here rather than shared because these three files have no
module between them. Watching the process as well as the socket is what
makes a crash fail in milliseconds instead of costing the full timeout. *)
let listen_why = ref ""
let listening ?(ms = 30000) ~pid path =
let died = ref None in
ignore
(await ~ms (fun () ->
Sys.file_exists path
||
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _, st -> died := Some st; true
| exception Unix.Unix_error _ -> false));
if Sys.file_exists path then true
else begin
listen_why :=
(match !died with
| Some (Unix.WEXITED n) ->
Printf.sprintf "exited with status %d before binding %s" n path
| Some (Unix.WSIGNALED n) ->
Printf.sprintf "was killed by signal %d before binding %s" n path
| Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on signal %d" n
| None ->
Printf.sprintf
"was still running after %ds without binding %s, so it was the \
build that did not finish, not the socket"
(ms / 1000) path);
false
end
let () = let () =
let have cmd = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" cmd) = 0 in let have cmd = Sys.command (Printf.sprintf "command -v %s > /dev/null 2>&1" cmd) = 0 in
if not (have "emacs") then print_endline "emacs: skipped (no emacs on PATH)" if not (have "emacs") then print_endline "emacs: skipped (no emacs on PATH)"
@ -46,13 +81,12 @@ let () =
Unix.stdin fd Unix.stderr Unix.stdin fd Unix.stderr
in in
Unix.close fd; Unix.close fd;
(* A minute, not the 8s default: what is being waited for is not a socket (* Thirty seconds and not the 8s default: this waits on an llc-and-link of
but an llc-and-link of the whole program, which has been measured at the whole program, ~0.5s warm and 2s cold, worst measured at 6.8s with
6.8s with this suite's other binaries running beside it under dune's own this suite's other binaries running beside it. The watchdog bounds the
parallelism. It only has to be long enough that a failure here means the run; a crash no longer waits for either. *)
daemon is not coming; the watchdog is what bounds the run. *) if not (listening ~pid sock) then begin
if not (await ~ms:60000 (fun () -> Sys.file_exists sock)) then begin print_endline ("FAIL the daemon " ^ !listen_why);
print_endline "FAIL the daemon never listened";
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ()); (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
exit 1 exit 1
end; end;

View File

@ -31,6 +31,41 @@ let rec await ?(ms = 8000) f =
else if ms <= 0 then false else if ms <= 0 then false
else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end else begin ignore (Unix.select [] [] [] 0.005); await ~ms:(ms - 5) f end
(* One timer covers two waits here — [flan dev] builds the whole program and
only then binds so the failure has to say which of them it was. See
[listening] in test_dev.ml for the whole of the reasoning; this is the same
helper, kept here rather than shared because these three files have no
module between them. Watching the process as well as the socket is what
makes a crash fail in milliseconds instead of costing the full timeout. *)
let listen_why = ref ""
let listening ?(ms = 30000) ~pid path =
let died = ref None in
ignore
(await ~ms (fun () ->
Sys.file_exists path
||
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _, st -> died := Some st; true
| exception Unix.Unix_error _ -> false));
if Sys.file_exists path then true
else begin
listen_why :=
(match !died with
| Some (Unix.WEXITED n) ->
Printf.sprintf "exited with status %d before binding %s" n path
| Some (Unix.WSIGNALED n) ->
Printf.sprintf "was killed by signal %d before binding %s" n path
| Some (Unix.WSTOPPED n) -> Printf.sprintf "stopped on signal %d" n
| None ->
Printf.sprintf
"was still running after %ds without binding %s, so it was the \
build that did not finish, not the socket"
(ms / 1000) path);
false
end
let rec connect ?(ms = 8000) path = let rec connect ?(ms = 8000) path =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
match Unix.connect s (Unix.ADDR_UNIX path) with match Unix.connect s (Unix.ADDR_UNIX path) with
@ -68,13 +103,12 @@ let () =
Unix.stdin fd Unix.stderr Unix.stdin fd Unix.stderr
in in
Unix.close fd; Unix.close fd;
(* A minute, not the 8s default: what is being waited for is not a socket (* Thirty seconds and not the 8s default: this waits on an llc-and-link of
but an llc-and-link of the whole program, which has been measured at the whole program, ~0.5s warm and 2s cold, worst measured at 6.8s with
6.8s with this suite's other binaries running beside it under dune's own this suite's other binaries running beside it. The watchdog bounds the
parallelism. It only has to be long enough that a failure here means the run; a crash no longer waits for either. *)
daemon is not coming; the watchdog is what bounds the run. *) if not (listening ~pid sock) then
if not (await ~ms:60000 (fun () -> Sys.file_exists sock)) then fail "the daemon %s" !listen_why
fail "the daemon never listened"
else begin else begin
let c = connect sock in let c = connect sock in
let evals code = let evals code =