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:
parent
781295e862
commit
cdcdd70c4e
4
BUILT.md
4
BUILT.md
@ -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
56
NEXT.md
@ -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
|
||||||
|
|
||||||
|
|||||||
44
lib/build.ml
44
lib/build.ml
@ -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 = {
|
||||||
|
|||||||
@ -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.);
|
||||||
|
|||||||
29
lib/macro.ml
29
lib/macro.ml
@ -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
|
||||||
|
|||||||
111
test/test_dev.ml
111
test/test_dev.ml
@ -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
|
||||||
|
|||||||
@ -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;
|
||||||
|
|||||||
@ -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 =
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user