The six blind spots a mutation pass found, each watched fail before it passed
This commit is contained in:
commit
4a7eaaa425
52
NEXT.md
52
NEXT.md
@ -89,11 +89,13 @@ it *would* have written.
|
||||
which is a compiler feature of the same shape the bounds checks already have, or they belong to the checker. Not
|
||||
decided. `test_sanitize` pins the current answer with a control that must *not* report, so a future clang changing
|
||||
this is a test failure rather than a discovery.
|
||||
2. **Two of the four named buffers now have evidence; two still do not.** The 4K result cap and `condition_name[128]`
|
||||
are driven over the agent's socket from `test_agent.ml` — a 5000-byte value comes back as 4096 ending in the
|
||||
ellipsis, a 198-character condition class comes back from `status` as 127. The **dev registry overflow guard** and
|
||||
`SNAP_MAX`/`SNAP_NAMES` are still read rather than tested: four thousand interned names and sixty-five nested
|
||||
`restart-case`s are a lot of program for a clamp each. `escaped[ESCAPE_MAX]` is covered because `println.flan`
|
||||
2. **Three of the four named buffers now have evidence; one still does not.** Two lanes closed different pairs and
|
||||
they combine. The 4K result cap and `condition_name[128]` are driven over the agent's socket from `test_agent.ml`
|
||||
— a 5000-byte value comes back as 4096 ending in the ellipsis, a 198-character condition class comes back from
|
||||
`status` as 127. The 4K cap and the **dev registry overflow guard** are also run directly by `test/dev_limits.c`,
|
||||
a C main beside `reload_host.c`, one process per limit because the name table never shrinks and the overflow case
|
||||
aborts. Only `SNAP_MAX`/`SNAP_NAMES` is still read rather than tested: sixty-five nested `restart-case`s are a lot
|
||||
of program for a clamp. `escaped[ESCAPE_MAX]` was already covered, because `println.flan`
|
||||
drives a 1100-character string through it on purpose — 1019 bytes out against a worst case of 1021 into 1024.
|
||||
`scratch[SCRATCH]` never sees more than 20 characters of 64.
|
||||
3. **Valgrind over the headless corpus, not done.** ASan does not see uninitialised reads, which is where `zeroed` and
|
||||
@ -582,18 +584,36 @@ expander last, on 6's unions.
|
||||
|
||||
### Test blind spots, from a mutation pass
|
||||
|
||||
Sixty mutations, nineteen left the whole suite green. The severe cluster is closed (`cleanup.flan`,
|
||||
`signedness.flan`); these are not:
|
||||
Sixty mutations, nineteen left the whole suite green. The severe cluster was closed first (`cleanup.flan`,
|
||||
`signedness.flan`); the rest are closed now. Every one below was re-planted, watched leave the suite green, and then
|
||||
watched fail against the new test before the mutation was reverted — a test nobody saw fail is not evidence.
|
||||
|
||||
- `Reach`'s walk of index expressions, `addr` places and `restart-case` clause bodies — each confirmed to prune a
|
||||
function a valid program calls, so the build fails to link.
|
||||
- `flan_dev_global`'s size-change guard — the layout-drift check, with no test that retypes a global across a reload.
|
||||
- A local shadowing an imported name is qualified anyway.
|
||||
- The registry overflow guard has **no coverage at all**, rather than a missing assertion. The 4K result cap that used
|
||||
to sit beside it here is driven over the agent's socket now.
|
||||
- The reader accepts an unknown string escape; `+5` stops being a number.
|
||||
- And a warning: a reader mutation makes the suite **hang** rather than fail. A green run is not the only outcome to
|
||||
plan for in CI.
|
||||
- **`Reach`'s walk of index expressions, `addr` places and `restart-case` clause bodies.** `programs/reach-walk.flan`
|
||||
calls three functions from three places that are each the only route to them. The failure is not a wrong answer:
|
||||
the function is not emitted and the program stops linking, so the case catches the build exception rather than
|
||||
comparing output. The `addr` case goes through a `deref` place deliberately, so the index case cannot stand in for
|
||||
it.
|
||||
- **`flan_dev_global`'s size-change guard.** `programs/reload-v5.flan` is v4 with `extra` as an `i32`, loaded on top
|
||||
of v3 in a host run of its own, because what it does is abort. The message is asserted next to the exit status: a
|
||||
process that died for another reason is not this guard firing.
|
||||
- **A local shadowing an imported name.** `programs/shadow-pkg.flan` binds locals over its own constant and var;
|
||||
`pkg-shadow.flan` prints four numbers that separate the expression renamer from the place renamer. Nothing refuses
|
||||
a renamer that qualifies through a binding — it reads the top-level name instead and runs — so only the number says
|
||||
so.
|
||||
- **The 4K result cap and the registry overflow guard.** `test/dev_limits.c`, a second C main beside `reload_host.c`,
|
||||
drives them directly: neither has a Flan spelling and no corpus program reaches either. One process per mode — the
|
||||
name table never shrinks and the overflow case aborts.
|
||||
- **The reader's unknown string escape, and `+5`.** Rows in the reader table, with the escapes it *does* know
|
||||
asserted on their decoded bytes rather than through `Form.to_string`, which escapes them again and would compare
|
||||
the source with itself.
|
||||
- **The hang.** A reader branch that forgets to advance loops for ever, and `dune test` waits as long as it is left
|
||||
to; in CI that is a job the runner kills with nothing named. `test/watchdog.ml` arms an alarm on every test binary
|
||||
— generous, because an alarm that fires on a slow machine is a flake and a flake is how a watchdog gets deleted —
|
||||
and a five-second one around every read in `test_flan`. The first read that does not return wedges the rest, so a
|
||||
looping reader costs five seconds and names the row instead of never finishing.
|
||||
|
||||
What is still open here: the mutation pass has not been re-run since, so the count of nineteen is the old one. The
|
||||
sanitized sweep (`@sanitize`) is under the same watchdog but has never been observed to fire it.
|
||||
|
||||
### Asked for by the editor lanes
|
||||
|
||||
|
||||
107
test/dev_limits.c
Normal file
107
test/dev_limits.c
Normal file
@ -0,0 +1,107 @@
|
||||
/* dev_limits.c — the two fixed-size limits in runtime/flan_dev.c, driven
|
||||
* directly.
|
||||
*
|
||||
* Neither is reachable from a Flan program that behaves. The result buffer
|
||||
* only truncates when a renderer emits more than 4K, which no fixture does,
|
||||
* and the name table only fills after 4096 distinct run-time-introduced names,
|
||||
* which is more forms than the whole corpus has. So both were code nothing had
|
||||
* ever run: the first thing either would do in anger is either lose the end of
|
||||
* a value or scribble past the end of a static array, and the ellipsis and the
|
||||
* abort are the two behaviours that say which.
|
||||
*
|
||||
* A C main, for the same reason reload_host.c is one: these are C entry points
|
||||
* with no Flan spelling, and flan_dev.c is compiled into every build (see
|
||||
* build.ml), so linking any Flan program brings them along. The .flan this is
|
||||
* linked against therefore has no [main] of its own.
|
||||
*
|
||||
* One mode per run, chosen by argv, because both of them are one-way: the
|
||||
* name table never shrinks and the overflow case aborts the process.
|
||||
*/
|
||||
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
void **flan_dev_cell(const char *name);
|
||||
void flan_dev_result_begin(void);
|
||||
void flan_dev_emit(const uint8_t *bytes, int64_t len);
|
||||
void flan_dev_result_end(void);
|
||||
const char *flan_dev_result_get(uint64_t *gen, uint64_t *len);
|
||||
void flan_rt_init(int32_t argc, char **argv);
|
||||
|
||||
#define CAP 4096
|
||||
|
||||
/* Emit more than fits, twice the buffer's worth, and report what came back.
|
||||
* What is printed is everything a wrong cap gets wrong: the length, the three
|
||||
* characters that say it was truncated, a byte from the middle to show the
|
||||
* content up to the cut is the content that was emitted, and the generation
|
||||
* counter, which is what a reader waits on and must move exactly once. */
|
||||
static int cap(void) {
|
||||
static uint8_t a[3000], b[3000];
|
||||
uint64_t gen0, gen1, len;
|
||||
const char *r;
|
||||
|
||||
memset(a, 'a', sizeof a);
|
||||
memset(b, 'b', sizeof b);
|
||||
|
||||
r = flan_dev_result_get(&gen0, &len);
|
||||
|
||||
flan_dev_result_begin();
|
||||
flan_dev_emit(a, (int64_t)sizeof a);
|
||||
/* A negative length is not a huge one: the cast to size_t would make it
|
||||
* about 2^64 and the clamp would then be the only thing between it and a
|
||||
* memcpy of everything. */
|
||||
flan_dev_emit(b, -1);
|
||||
flan_dev_emit(b, (int64_t)sizeof b);
|
||||
flan_dev_result_end();
|
||||
|
||||
r = flan_dev_result_get(&gen1, &len);
|
||||
printf("len %llu\n", (unsigned long long)len);
|
||||
printf("tail %.3s\n", len >= 3 ? r + len - 3 : "");
|
||||
printf("mid %c\n", len > 3500 ? r[3500] : '?');
|
||||
printf("head %c\n", len > 0 ? r[0] : '?');
|
||||
printf("gen %llu\n", (unsigned long long)(gen1 - gen0));
|
||||
|
||||
/* And a short value after a truncated one: the flag has to be cleared by
|
||||
* [begin] or every later render ends in an ellipsis it did not earn. */
|
||||
flan_dev_result_begin();
|
||||
flan_dev_emit((const uint8_t *)"12", 2);
|
||||
flan_dev_result_end();
|
||||
r = flan_dev_result_get(&gen1, &len);
|
||||
printf("again %.*s\n", (int)len, r);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Fill the name table and then ask for one more. The table is fixed and never
|
||||
* moves — a module holds the address of a cell for as long as it is loaded —
|
||||
* so the only honest answer past the end is to stop. */
|
||||
static int names(void) {
|
||||
char buf[32];
|
||||
for (int i = 0; i < CAP; i++) {
|
||||
snprintf(buf, sizeof buf, "n%d", i);
|
||||
if (flan_dev_cell(buf) == NULL) {
|
||||
printf("null cell at %d\n", i);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
/* Distinct names, all of them: a table that deduplicated wrongly would not
|
||||
* be full here and the line below would not abort. */
|
||||
printf("interned %d\n", CAP);
|
||||
fflush(stdout);
|
||||
(void)flan_dev_cell("one-too-many");
|
||||
printf("survived\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
int main(int argc, char **argv) {
|
||||
flan_rt_init(argc, argv);
|
||||
if (argc < 2) {
|
||||
fprintf(stderr, "usage: %s cap|names\n", argv[0]);
|
||||
return 2;
|
||||
}
|
||||
if (strcmp(argv[1], "cap") == 0) return cap();
|
||||
if (strcmp(argv[1], "names") == 0) return names();
|
||||
fprintf(stderr, "unknown mode %s\n", argv[1]);
|
||||
return 2;
|
||||
}
|
||||
@ -2,8 +2,10 @@
|
||||
(names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider)
|
||||
; Explicit because test_sanitize lives in this directory and is not one of
|
||||
; these: two stanzas in one directory have to say which modules are whose.
|
||||
; watchdog is every binary's clock: a hanging test reports nothing, so each
|
||||
; of these arms an alarm that turns "for ever" into a failing run.
|
||||
(modules test_flan test_acceptance test_reload test_agent test_session
|
||||
test_dev test_emacs test_repl test_cider)
|
||||
test_dev test_emacs test_repl test_cider watchdog)
|
||||
(libraries flan unix)
|
||||
; The acceptance programs are part of the test corpus: if the reader, the
|
||||
; parser or the checker regresses on them we want to know here, not at the CLI.
|
||||
@ -28,6 +30,9 @@
|
||||
; A shared object that is not a redefinition module, for the agent's refusal
|
||||
; path. Its destructor is what proves the handle was closed rather than lost.
|
||||
(file noinstall.c)
|
||||
; The other C main: flan_dev.c's two fixed limits, which no Flan program
|
||||
; reaches, driven directly.
|
||||
(file dev_limits.c)
|
||||
; test_dev runs the compiler itself: flan dev launches and owns a program.
|
||||
(file %{workspace_root}/bin/main.exe)
|
||||
; The Emacs client, which test_emacs drives against a real daemon.
|
||||
@ -64,7 +69,7 @@
|
||||
; is the whole point here.
|
||||
(executable
|
||||
(name test_sanitize)
|
||||
(modules test_sanitize)
|
||||
(modules test_sanitize watchdog)
|
||||
(libraries flan unix))
|
||||
|
||||
(rule
|
||||
|
||||
17
test/programs/pkg-shadow.flan
Normal file
17
test/programs/pkg-shadow.flan
Normal file
@ -0,0 +1,17 @@
|
||||
;;;; A local shadowing an imported name (test/programs/shadow-pkg.flan).
|
||||
;;;;
|
||||
;;;; Nothing about this program is unusual; the package it imports is where the
|
||||
;;;; shadowing is. What is asserted is that qualification stopped at the local:
|
||||
;;;; 7 rather than the constant's 5, and 20 out of [assigned] with the
|
||||
;;;; package's own [sink] still zero. A renamer that qualifies through a
|
||||
;;;; binding produces no error anywhere — it silently reads and writes the
|
||||
;;;; top-level name instead.
|
||||
|
||||
(import shd "shadow-pkg.flan")
|
||||
|
||||
(defn main [] i32
|
||||
(print (shd/shadowed)) (println "")
|
||||
(print (shd/assigned)) (println "")
|
||||
(print shd/sink) (println "")
|
||||
(print shd/limit) (println "")
|
||||
0)
|
||||
53
test/programs/reach-walk.flan
Normal file
53
test/programs/reach-walk.flan
Normal file
@ -0,0 +1,53 @@
|
||||
;;;; Three edges of Reach's walk, each the only route to one function.
|
||||
;;;;
|
||||
;;;; A release build is pruned: a function nothing reachable from main or from
|
||||
;;;; a global initialiser calls is not emitted at all. So an edge the walk
|
||||
;;;; forgets does not produce a wrong answer — it produces a program that does
|
||||
;;;; not link, with a message about a symbol nobody wrote. Each of the three
|
||||
;;;; functions below is called from exactly one place, and that place is an
|
||||
;;;; edge no other program in the corpus exercises:
|
||||
;;;;
|
||||
;;;; index-of the index expression of a place, (set (at a (f)) v)
|
||||
;;;; through a place under (addr ...), here a (deref ...) so that it is
|
||||
;;;; the addr edge and not the index one again
|
||||
;;;; placeholder a restart-case clause body, which is reached by a transfer
|
||||
;;;; and never by a call the walk can see from the body
|
||||
;;;;
|
||||
;;;; Nothing here is about the values; the values are how the test notices that
|
||||
;;;; the program was built and ran at all.
|
||||
|
||||
(defvar cells [4 i32])
|
||||
(defvar slot i32)
|
||||
|
||||
(defstruct Nope [id i32])
|
||||
|
||||
(defn index-of [] i32 2)
|
||||
|
||||
(defn through [] (Ptr i32) (addr slot))
|
||||
|
||||
(defn placeholder [] i32 42)
|
||||
|
||||
;;; Signals with nothing to return, so the clause body is the only way past.
|
||||
(defn missing [] i32
|
||||
(error (Nope {:id 1})))
|
||||
|
||||
(defn pick [] i32
|
||||
(restart-case (missing)
|
||||
(use-placeholder [] (placeholder))))
|
||||
|
||||
(defn main [] i32
|
||||
;; The index of a place is an expression, and it can call.
|
||||
(set (at cells (index-of)) 10)
|
||||
(print (at cells 2)) (println "")
|
||||
|
||||
;; (addr (deref p)) is p, so this is the addr edge over a place whose own
|
||||
;; walk is Pderef rather than Pindex — the index case above cannot stand in
|
||||
;; for it.
|
||||
(let [q (addr (deref (through)))]
|
||||
(set (deref q) 20))
|
||||
(print slot) (println "")
|
||||
|
||||
;; The clause body, reached only because the handler transfers into it.
|
||||
(handler-bind [(Nope [c] (invoke-restart 'use-placeholder))]
|
||||
(print (pick)) (println ""))
|
||||
0)
|
||||
29
test/programs/reload-v5.flan
Normal file
29
test/programs/reload-v5.flan
Normal file
@ -0,0 +1,29 @@
|
||||
;;;; v5 is v4 with one difference: [extra] is an i32 rather than an i64.
|
||||
;;;;
|
||||
;;;; [extra] does not exist in the host — v3 introduced it at run time, so its
|
||||
;;;; storage was allocated by runtime/flan_dev.c the first time a module asked
|
||||
;;;; for it, and every later module that mentions the name is handed back that
|
||||
;;;; same allocation. Handing it back for a differently shaped type is layout
|
||||
;;;; drift: the new body would read and write at offsets the old allocation was
|
||||
;;;; never laid out for, and nothing downstream could ever say so. The registry
|
||||
;;;; compares the size it recorded against the size it is asked for and aborts
|
||||
;;;; instead — retyping a var needs a restart, and this is the file that says
|
||||
;;;; the guard is real.
|
||||
;;;;
|
||||
;;;; Loaded on top of v3, and never alongside v4: the process it aborts is the
|
||||
;;;; whole of the test.
|
||||
(defvar counter i64)
|
||||
(defvar extra i32)
|
||||
|
||||
(defn helper [x i64] i64 (* x 2))
|
||||
|
||||
(defn added [] i32
|
||||
(set extra (+ extra 100))
|
||||
extra)
|
||||
|
||||
(defn bump [] i64
|
||||
(println "v5")
|
||||
(set counter (+ counter (i64 (added))))
|
||||
(helper counter))
|
||||
|
||||
(defn outer [] i64 (bump))
|
||||
21
test/programs/shadow-pkg.flan
Normal file
21
test/programs/shadow-pkg.flan
Normal file
@ -0,0 +1,21 @@
|
||||
;;;; A package whose own bodies bind locals named after its own top-level
|
||||
;;;; names. Imported, every name this file owns is rewritten to shd/name
|
||||
;;;; wherever it is *used* — and a local binding shadows, so inside these two
|
||||
;;;; functions the bare name is the local and must be left alone. Get that
|
||||
;;;; wrong and the code still compiles and still runs; it just reads a
|
||||
;;;; different variable, which is why this needs a fixture and not a refusal.
|
||||
|
||||
(defconst limit 5)
|
||||
(defvar sink i32)
|
||||
|
||||
;;; The expression case: the body's [limit] is the let's, not the constant.
|
||||
(defn shadowed [] i32
|
||||
(let [limit 7]
|
||||
limit))
|
||||
|
||||
;;; The place case, which is a separate line in the renamer: [set] takes a
|
||||
;;; place, and a place that is a bare name has its own shadowing check.
|
||||
(defn assigned [] i32
|
||||
(let [sink 0]
|
||||
(set sink 20)
|
||||
sink))
|
||||
@ -6,6 +6,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:1200 "test_acceptance"
|
||||
|
||||
let failures = ref 0
|
||||
|
||||
let scratch = Filename.get_temp_dir_name ()
|
||||
@ -755,6 +759,42 @@ let () =
|
||||
raylib itself. Loading it twice would declare every binding twice. *)
|
||||
outputs "a package reached along two routes" "programs/pkg-shared.flan"
|
||||
"ok\n";
|
||||
(* A local shadows an imported name. Qualification rewrites a package's own
|
||||
names wherever they are used, and a binding is where it has to stop —
|
||||
in an expression and in a place, which are two separate lines of the
|
||||
renamer. Nothing refuses a renamer that qualifies through a binding:
|
||||
the program builds and runs and reads the top-level name instead, so
|
||||
what says it is wrong is the number. 7 is the let's and not the
|
||||
constant's 5; 20 comes back out of [assigned] while the package's own
|
||||
[sink] is still 0, which is the place half. *)
|
||||
outputs "a local shadows an imported name" "programs/pkg-shadow.flan"
|
||||
"7\n20\n0\n5\n";
|
||||
|
||||
(* Reach's walk, edge by edge. Pruning is what makes the link follow the
|
||||
program, and the cost of getting it wrong is not a wrong answer: a
|
||||
function the walk fails to reach is not emitted, and the build dies in
|
||||
the linker naming a symbol nobody wrote. reach-walk.flan calls three
|
||||
functions from three places that are each the only route to them — the
|
||||
index expression of a place, a place under [addr], and a restart-case
|
||||
clause body — so a walk that forgets any one of the three fails to build
|
||||
here. Caught rather than raised, because a build that dies takes the
|
||||
rest of the table with it. *)
|
||||
(match compile "programs/reach-walk.flan" with
|
||||
| exception Failure m ->
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL Reach's walk: it did not build, which is what a pruned function looks like\n%s\n"
|
||||
m
|
||||
| exe ->
|
||||
let code, text = run exe None in
|
||||
let want = "10\n20\n42\n" in
|
||||
if text <> want || code <> 0 then begin
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL Reach's walk\n got: %S (exit %d)\n wanted: %S\n"
|
||||
text code want
|
||||
end;
|
||||
(try Sys.remove exe with Sys_error _ -> ()));
|
||||
|
||||
(* The refusals. Each is a thing that would otherwise fail later and
|
||||
elsewhere — as a name the checker says is unknown, or as a collision
|
||||
|
||||
@ -14,6 +14,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_agent"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
|
||||
@ -12,6 +12,9 @@
|
||||
Skipped, not failed, where there is no emacs: the compiler does not depend
|
||||
on one. *)
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_cider"
|
||||
let () =
|
||||
if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then
|
||||
print_endline "cider: skipped (no emacs on PATH)"
|
||||
|
||||
@ -8,6 +8,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:900 "test_dev"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
|
||||
@ -9,6 +9,9 @@
|
||||
Skipped, not failed, where there is no emacs — the compiler does not depend
|
||||
on one. *)
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_emacs"
|
||||
let scratch = Filename.get_temp_dir_name ()
|
||||
let tmp n = Filename.concat scratch ("flan-emacs-" ^ n)
|
||||
|
||||
|
||||
@ -3,6 +3,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_flan"
|
||||
|
||||
let failures = ref 0
|
||||
|
||||
let check name cond =
|
||||
@ -16,8 +20,34 @@ let contains hay needle =
|
||||
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
|
||||
n = 0 || go 0
|
||||
|
||||
(* Every read in this table runs under a five-second alarm. The reader is the
|
||||
one part of the compiler whose mistakes loop rather than raise — a branch
|
||||
that forgets to advance reads the same character for ever — and a hanging
|
||||
case reports nothing at all. Five seconds is thousands of times what any
|
||||
row here needs; what it buys is that a loop becomes a named failing row and
|
||||
the rest of the table still runs. *)
|
||||
(* Once one read has not returned, the reader is looping and every row after
|
||||
it would spend the same five seconds proving the same thing — a hundred
|
||||
rows is eight minutes of that. So the first timeout wedges the rest: they
|
||||
fail immediately and the binary still reports, which is the whole point of
|
||||
the alarm. *)
|
||||
let wedged = ref false
|
||||
|
||||
let guarded seconds f =
|
||||
if !wedged then raise Watchdog.Timeout
|
||||
else
|
||||
match Watchdog.within seconds f with
|
||||
| x -> x
|
||||
| exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout
|
||||
|
||||
let read ?(file = "<test>") src =
|
||||
guarded 5 (fun () -> Reader.read_all ~file src)
|
||||
|
||||
(* The corpus files, which are larger and are read from disk. *)
|
||||
let read_file path = guarded 30 (fun () -> Reader.read_file path)
|
||||
|
||||
let reads name src expected =
|
||||
match Reader.read_all ~file:"<test>" src with
|
||||
match read src with
|
||||
| forms ->
|
||||
let got = String.concat " " (List.map Form.to_string forms) in
|
||||
if got <> expected then begin
|
||||
@ -29,13 +59,20 @@ let reads name src expected =
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
|
||||
name src (Loc.to_string loc) msg
|
||||
| exception Watchdog.Timeout ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
|
||||
name src
|
||||
|
||||
(* [needle] is the point: a read error that fires for the wrong reason is not
|
||||
the test passing. Without it "backtick at end of input" would be green even
|
||||
if the backtick were still an ordinary symbol character. *)
|
||||
let rejects ?needle name src =
|
||||
match Reader.read_all ~file:"<test>" src with
|
||||
match read src with
|
||||
| _ -> incr failures; Printf.printf "FAIL %s: expected a read error\n" name
|
||||
| exception Watchdog.Timeout ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s: the reader did not return\n" name
|
||||
| exception Loc.Error (_, msg) ->
|
||||
(match needle with
|
||||
| Some n when not (contains msg n) ->
|
||||
@ -47,6 +84,15 @@ let () =
|
||||
(* ── Atoms ─────────────────────────────────────────────────────── *)
|
||||
reads "integer" "42" "42";
|
||||
reads "negative" "-1" "-1";
|
||||
(* A sign is part of the number, both ways. [+5] is the one that reads as a
|
||||
symbol the moment the '+' case is dropped from the dispatch, and a symbol
|
||||
named "+5" is an unknown name much later and somewhere else. *)
|
||||
reads "leading plus" "+5" "5";
|
||||
reads "plus float" "+0.5" "0.5";
|
||||
reads "plus in a call" "(f +5 -5)" "(f 5 -5)";
|
||||
(* And the operator is still itself: [+] alone is the addition symbol, and
|
||||
[(+ 1 2)] must not read its head as a number. *)
|
||||
reads "bare plus" "+" "+";
|
||||
reads "float" "0.05" "0.05";
|
||||
reads "hex" "0xE6B800FF" "3870818559";
|
||||
reads "string" "\"SAND\"" "\"SAND\"";
|
||||
@ -131,7 +177,7 @@ let () =
|
||||
`(i ~j ~@k) `(l `(m ~n)) [`o ~p] {:q `r} (f a~b x`y)"
|
||||
in
|
||||
check "no sigils leak into names"
|
||||
(bad_names (Form.make (Form.List (Reader.read_all ~file:"<test>" corpus))
|
||||
(bad_names (Form.make (Form.List (read corpus))
|
||||
Loc.unknown) = []);
|
||||
|
||||
(* ── Errors ────────────────────────────────────────────────────── *)
|
||||
@ -141,6 +187,18 @@ let () =
|
||||
rejects "unterminated str" "\"abc";
|
||||
rejects "empty keyword" ":";
|
||||
rejects "unknown char" "\\bogus";
|
||||
(* An escape the reader does not know is a typo, not a character: accepting
|
||||
\q as 'q' silently reads a different string than the one that was
|
||||
written, and nothing downstream can tell. *)
|
||||
rejects "unknown string escape" "\"a\\qb\"" ~needle:"unknown string escape";
|
||||
(* The escapes it does know still decode, which is what says the rejection
|
||||
above rejects the unknown one and not escaping itself. Asserted on the
|
||||
string's bytes rather than through [Form.to_string], which escapes them
|
||||
again and would compare the source with itself. *)
|
||||
(match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with
|
||||
| [ { Form.v = Form.Str s; _ } ] ->
|
||||
check "known escapes" (s = "a\nb\tc\\d\"e\000f")
|
||||
| _ -> check "known escapes: one string" false);
|
||||
rejects "metadata" "^:async";
|
||||
rejects "dangling quote" "'";
|
||||
(* Each of these asserts the reason, not merely that something failed. *)
|
||||
@ -150,14 +208,14 @@ let () =
|
||||
rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed";
|
||||
|
||||
(* ── Locations ─────────────────────────────────────────────────── *)
|
||||
(match Reader.read_all ~file:"f.flan" "(a)\n (b)" with
|
||||
(match read ~file:"f.flan" "(a)\n (b)" with
|
||||
| [ a; b ] ->
|
||||
check "loc line 1" (a.loc.line = 1 && a.loc.col = 1);
|
||||
check "loc line 2" (b.loc.line = 2 && b.loc.col = 3);
|
||||
check "loc file" (a.loc.file = "f.flan")
|
||||
| _ -> check "loc: two forms" false);
|
||||
|
||||
(match Reader.read_all ~file:"f.flan" "(f\n bad" with
|
||||
(match read ~file:"f.flan" "(f\n bad" with
|
||||
| _ -> check "unclosed reports opening loc" false
|
||||
| exception Loc.Error (loc, _) ->
|
||||
check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));
|
||||
@ -171,12 +229,12 @@ let () =
|
||||
(* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)
|
||||
|
||||
let parse1 src =
|
||||
match Reader.read_all ~file:"<test>" src with
|
||||
match read src with
|
||||
| [ f ] -> Parse.expr f
|
||||
| _ -> failwith "test source must be exactly one form"
|
||||
|
||||
let parse_decl src =
|
||||
match Reader.read_all ~file:"<test>" src with
|
||||
match read src with
|
||||
| [ f ] -> Parse.decl f
|
||||
| _ -> failwith "test source must be exactly one form"
|
||||
|
||||
@ -184,7 +242,7 @@ let parse_decl src =
|
||||
name with the reason, so a test that only proves *something* failed does not
|
||||
observe the rule it is there for. *)
|
||||
let parse_rejects ?needle name src =
|
||||
match Reader.read_all ~file:"<test>" src |> Parse.program with
|
||||
match read src |> Parse.program with
|
||||
| _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name
|
||||
| exception Loc.Error (_, msg) ->
|
||||
(match needle with
|
||||
@ -339,7 +397,7 @@ let () =
|
||||
(* ── The corpus parses ─────────────────────────────────────────── *)
|
||||
List.iter
|
||||
(fun path ->
|
||||
match Reader.read_file path |> Parse.program with
|
||||
match read_file path |> Parse.program with
|
||||
| _ -> ()
|
||||
| exception Loc.Error (loc, msg) ->
|
||||
incr failures;
|
||||
@ -361,7 +419,9 @@ let () =
|
||||
capitalisation — otherwise a body starting with a constructor call gets
|
||||
silently eaten as a return type. *)
|
||||
|
||||
let program src = Reader.read_all ~file:"<test>" src |> Parse.program
|
||||
(* Through [read], so the parser and checker tables are under the reader's
|
||||
alarm too: their sources go through the same reader. *)
|
||||
let program src = read src |> Parse.program
|
||||
|
||||
let () =
|
||||
let open Ast in
|
||||
@ -419,6 +479,10 @@ let infers name src expected =
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
|
||||
name src (Loc.to_string loc) msg
|
||||
| exception Watchdog.Timeout ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
|
||||
name src
|
||||
|
||||
let accepts name src =
|
||||
match checked src with
|
||||
@ -427,6 +491,10 @@ let accepts name src =
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
|
||||
name src (Loc.to_string loc) msg
|
||||
| exception Watchdog.Timeout ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
|
||||
name src
|
||||
|
||||
(* [needle] pins the *reason* down: a rejection for the wrong reason is not a
|
||||
passing test, and the unimplemented-feature errors are the whole point. *)
|
||||
|
||||
@ -21,6 +21,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_reload"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
@ -78,6 +82,10 @@ let () =
|
||||
not exist. This is the C-c C-k unit. *)
|
||||
let so3, ir3, _, _ = module_of p3 [ "bump"; "added" ] "v3.so" in
|
||||
let so4, ir4, _, _ = module_of p4 [ "added" ] "v4.so" in
|
||||
(* v5 retypes [extra], which v3 introduced at run time. It is built here
|
||||
and loaded in a process of its own below: what it does is abort. *)
|
||||
let p5 = checked "programs/reload-v5.flan" in
|
||||
let so5, _, _, _ = module_of p5 [ "added" ] "v5.so" in
|
||||
|
||||
(* A redefinition module must not define what the host already owns:
|
||||
defining [counter] would give the loaded object a private copy and the
|
||||
@ -192,6 +200,78 @@ let () =
|
||||
if code <> 0 || text <> want then
|
||||
fail "reload\n got: %S (exit %d)\n wanted: %S" text code want;
|
||||
|
||||
(* The layout-drift guard, which needs a process of its own because what it
|
||||
does is abort one. [extra] does not exist in the host: v3 introduced it
|
||||
at run time, so flan_dev.c allocated its storage and recorded its size,
|
||||
and every later module asking for that name is handed the same
|
||||
allocation back. v5 asks for it as an i32. Handing back eight bytes for
|
||||
a four-byte type is not an error anything downstream can detect — the
|
||||
new body simply reads fields at offsets the allocation was never laid
|
||||
out for — so the registry compares sizes and dies at the first chance
|
||||
it has.
|
||||
|
||||
Asserted on the message as well as on the exit status: a process that
|
||||
died for some other reason is not this guard firing, and the exit code
|
||||
alone cannot tell the two apart. *)
|
||||
let out5 = tmp "out5" and err5 = tmp "err5" in
|
||||
let code5 =
|
||||
Sys.command
|
||||
(Printf.sprintf "%s %s %s %s > %s 2> %s" (Filename.quote host)
|
||||
(Filename.quote so1) (Filename.quote so3) (Filename.quote so5)
|
||||
(Filename.quote out5) (Filename.quote err5))
|
||||
in
|
||||
let said = In_channel.with_open_bin err5 In_channel.input_all in
|
||||
if code5 = 0 then
|
||||
fail "a global retyped across a reload was accepted (exit 0)";
|
||||
if not (has said "size changed") then
|
||||
fail "a retyped global did not stop on the size guard: %S" said;
|
||||
|
||||
(* The two fixed-size limits in flan_dev.c, which nothing had ever
|
||||
reached: the 4K result buffer a renderer emits into, and the 4096-name
|
||||
registry. Both are driven from dev_limits.c rather than from Flan,
|
||||
because neither has a Flan spelling and a program that reached either
|
||||
one by accident would be a program nobody wants in the corpus.
|
||||
|
||||
One process per mode. The name table never shrinks, so the two cases
|
||||
would contaminate each other, and the overflow case ends in abort. *)
|
||||
let limits = tmp "limits" in
|
||||
ignore
|
||||
(Build.executable ~opts:dev ~csrcs:[ "dev_limits.c" ] p1 ~out:limits);
|
||||
let mode m =
|
||||
let o = tmp ("limits-" ^ m ^ ".out") and e = tmp ("limits-" ^ m ^ ".err") in
|
||||
let code =
|
||||
Sys.command
|
||||
(Printf.sprintf "%s %s > %s 2> %s" (Filename.quote limits) m
|
||||
(Filename.quote o) (Filename.quote e))
|
||||
in
|
||||
let out = In_channel.with_open_bin o In_channel.input_all in
|
||||
let err = In_channel.with_open_bin e In_channel.input_all in
|
||||
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ o; e ];
|
||||
(code, out, err)
|
||||
in
|
||||
(* 6000 bytes emitted into 4096. The length is the cap itself, the three
|
||||
dots are what says the value was cut rather than being that short, the
|
||||
middle byte says the content before the cut is the content that was
|
||||
emitted, and the generation moved exactly once — a reader waits on that
|
||||
counter and a value published twice would be read half-formed. The last
|
||||
line is the flag being cleared: a short value after a truncated one must
|
||||
not inherit its ellipsis. *)
|
||||
let code, out, _ = mode "cap" in
|
||||
let want_cap = "len 4096\ntail ...\nmid b\nhead a\ngen 1\nagain 12\n" in
|
||||
if code <> 0 || out <> want_cap then
|
||||
fail "the 4K result cap\n got: %S (exit %d)\n wanted: %S"
|
||||
out code want_cap;
|
||||
(* 4096 distinct names fit; the next one stops the process. The table is
|
||||
fixed and never moves, because a loaded module holds the address of a
|
||||
cell in it, so growing is not available and overrunning is the only
|
||||
other thing it could do. *)
|
||||
let code, out, err = mode "names" in
|
||||
if code = 0 then fail "the registry accepted a 4097th name (exit 0)";
|
||||
if out <> "interned 4096\n" then
|
||||
fail "the registry did not take 4096 names first: %S" out;
|
||||
if not (has err "out of dev name slots") then
|
||||
fail "the registry overflowed without saying so: %S" err;
|
||||
|
||||
Printf.printf
|
||||
"reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n"
|
||||
emit_ms t1.Build.llc_ms t1.Build.link_ms emit2_ms t2.Build.llc_ms
|
||||
@ -199,7 +279,7 @@ let () =
|
||||
print_string timings;
|
||||
|
||||
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ())
|
||||
[ host; so1; so2; so3; so4; out; tmp "err" ];
|
||||
[ host; limits; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ];
|
||||
if !failures = 0 then print_endline "reload: all tests passed"
|
||||
else begin
|
||||
Printf.printf "\n%d failure(s)\n" !failures;
|
||||
|
||||
@ -16,6 +16,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_repl"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
|
||||
@ -31,6 +31,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:3600 "test_sanitize"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt =
|
||||
Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
@ -9,6 +9,10 @@
|
||||
|
||||
open Flan
|
||||
|
||||
(* The watchdog first: a hang is the one failure mode that reports
|
||||
nothing at all. See watchdog.ml. *)
|
||||
let () = Watchdog.arm ~seconds:600 "test_session"
|
||||
|
||||
let failures = ref 0
|
||||
let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt
|
||||
|
||||
|
||||
64
test/watchdog.ml
Normal file
64
test/watchdog.ml
Normal file
@ -0,0 +1,64 @@
|
||||
(* A clock on every test binary, because a green run is not the only outcome
|
||||
to plan for.
|
||||
|
||||
The mutation pass that produced NEXT.md's blind-spot list turned up one
|
||||
defect that did not make the suite fail — it made it *hang*. A reader loop
|
||||
that forgets to advance reads the same character for ever, and every binary
|
||||
that reads a .flan file stops there. Nothing prints, nothing exits, and
|
||||
[dune test] waits as long as it is left to. In CI that is a job killed by
|
||||
the runner's own timeout, with no failing case named and no output to read.
|
||||
|
||||
So: an alarm, at two scales.
|
||||
|
||||
[arm] is the per-binary backstop. It is deliberately generous — test_dev
|
||||
launches a daemon and test_acceptance builds for wasm32 — because an alarm
|
||||
that fires on a slow machine is a flake, and a flake is how a watchdog gets
|
||||
deleted. It is here to turn "for ever" into "fails in ten minutes", not to
|
||||
measure anything.
|
||||
|
||||
[within] is the tight one, for a call whose budget really is small: reading
|
||||
a few characters of source. It raises [Timeout] rather than exiting, so the
|
||||
caller can report one failing row and carry on through the rest of its
|
||||
table — a binary that dies on the first hang tells you much less than one
|
||||
that finishes and names every case that hung.
|
||||
|
||||
SIGALRM is delivered at OCaml's safepoints, which are inserted at loop
|
||||
back-edges and function entries, so a tight loop that allocates nothing is
|
||||
still interruptible. *)
|
||||
|
||||
exception Timeout
|
||||
|
||||
let label = ref "test"
|
||||
let budget = ref 0
|
||||
let deadline = ref 0.0
|
||||
|
||||
let dying _ =
|
||||
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\
|
||||
\ turned into a failing run.\n"
|
||||
!label !budget;
|
||||
flush stderr;
|
||||
(* [exit] rather than [_exit]: the rows that did pass are in stdout's buffer
|
||||
and a watchdog that threw them away would be worse than the hang. *)
|
||||
exit 2
|
||||
|
||||
(* Re-arm the backstop for whatever is left of its budget. One second is the
|
||||
floor, because [alarm 0] cancels rather than fires. *)
|
||||
let backstop () =
|
||||
Sys.set_signal Sys.sigalrm (Sys.Signal_handle dying);
|
||||
let left = !deadline -. Unix.gettimeofday () in
|
||||
ignore (Unix.alarm (max 1 (int_of_float left)))
|
||||
|
||||
let arm ?(seconds = 600) name =
|
||||
label := name;
|
||||
budget := seconds;
|
||||
deadline := Unix.gettimeofday () +. float_of_int seconds;
|
||||
backstop ()
|
||||
|
||||
(* [f] under a tighter alarm, with the backstop restored afterwards however
|
||||
[f] left. *)
|
||||
let within seconds f =
|
||||
Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
|
||||
ignore (Unix.alarm seconds);
|
||||
Fun.protect ~finally:backstop f
|
||||
Loading…
x
Reference in New Issue
Block a user