Joseph Ferano
d57eeb3265
A (Vec Value) where a Value may itself hold a (Vec Value) — the recursive dynamic value an EDN reader has to answer with when nobody hands it a target struct type — was refused five different ways, and every one of the five gave the same reason: the container runtime is type-erased, so it copies and releases slots bytewise and cannot reach inside a slot. A free would release the slots and leave every block they point at stranded. That reason is about teardown, and it does not hold for a region. free-all never releases an individual slot; it takes the whole arena, and every block the elements own is in it, because they came out of it. The refusals were over-broad, and what they were guarding was never ownership — ownership tracking is untouched here, moves are still moves, and Types.is_move_only is the same function it was. So the question moved rather than disappeared. It could not stay at the type, because can-free is a capability on an allocator value and with-allocator rebinds a dynamic variable: which tier a (vec-new) will meet is not a property of the place its type is written. What is decided at compile time is only whether to ask, which is a property of the element type; the answer is a run-time branch on the allocator, one per container and never per element, because the alternative is a walk at release and a walk at release is the registry of destructors the frame tier's reset exists to not have. It is emitted at every growth and not only at the construction, because ZII means a container can exist without ever passing through (vec-new) — a case field left out of a literal, a global that starts zeroed — and those adopt the context on their first push. free on such a container is refused rather than made quietly shallow. It cannot recurse, which is the whole premise, and releasing the outer block alone would be "I freed it" written over a program that stranded everything inside; this runtime refuses that collapse everywhere else. The message names free-all, which is reachable by construction. clone stays refused for a reason the region does not dissolve, and the old message had bundled the two failures under one sentence: what disqualifies clone is not that it copies a header — so do at and get, and they are fine, because they promise nothing — it is that clone allocates a new block and promises independence, and a bytewise copy hands back elements still pointing into the original's region. A struct or union field is admitted only where the field's container holds owning elements, because that container can only have been built against a region. A field holding a plain (Vec u8) stays refused: nothing would force that one into a region, and two copies of the aggregate would be two headers over one heap block. vec-in-struct.flan still pins that. The epoch already covered use after free-all, including the case this makes reachable — an inner header copied out of an arena-held element into a local still traps, because an Allocator is a pointer and a copied-by-value one would carry its own epoch. arena-value.flan builds the value by hand; arena-edn.flan reads a real document through the tokenizer, and its reader takes no allocator and names none, because spec-memory.md already puts the allocator in the calling convention. arena-region.flan is the branch itself: run 0 is the (Vec (Vec i32)) control that must not trap, and runs 1 and 2 are the two ways this dies.
297 lines
14 KiB
OCaml
297 lines
14 KiB
OCaml
(* The corpus a second time, under AddressSanitizer and
|
|
UndefinedBehaviorSanitizer.
|
|
|
|
Not part of [dune test] and deliberately so: a sanitized build of one
|
|
program is a 1.8MB statically linked binary and takes ten to twenty seconds
|
|
to produce, so the sweep is minutes where the whole existing suite is
|
|
seconds. It has its own alias.
|
|
|
|
dune build --root . @sanitize
|
|
|
|
What this can and cannot see is written down in [Build.opts] and in
|
|
[Emit]'s [sanitize] comment, and it is not symmetric:
|
|
|
|
- ASan reaches Flan code, but only because [Emit] puts [sanitize_address]
|
|
on every function it defines; the attribute is what the pass selects on
|
|
and hand-written IR has none by default. The positive control for that is
|
|
[oob], below, which must report.
|
|
- UBSan reaches the runtime's C and nothing else. Its checks are branches
|
|
clang's *frontend* emits, and no attribute asks an LLVM pass to produce
|
|
them, so the shift-past-the-width and float-cast questions this sweep was
|
|
partly meant to answer are not answerable this way. [shift] records that
|
|
as a test rather than as a paragraph: it is a program with unambiguous
|
|
shift UB in it, and it is expected *not* to be caught.
|
|
|
|
The check is two-sided. A marker in the sanitized run's output is a
|
|
failure, and so is any divergence from the unsanitized run — same output,
|
|
same exit status. The second half is not redundant: UBSan recovers by
|
|
default, so a program can trip a check, carry on with a different value and
|
|
still exit 0, and several of these programs exit nonzero by design, so
|
|
"exit status 0" is not available as a pass condition. *)
|
|
|
|
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
|
|
|
|
let scratch = Filename.get_temp_dir_name ()
|
|
|
|
(* Leaks are off. Every allocation in the runtime is allocate-once-never-free
|
|
by design — [rt_args] says so in its own comment — so LeakSanitizer here
|
|
produces a suppression list and no information. Set in the environment
|
|
rather than baked in, so a session asking the leak question can ask it.
|
|
[print_stacktrace] is what turns a UBSan report from a source line into
|
|
something with a caller in it, and it is off by default. *)
|
|
let env =
|
|
"ASAN_OPTIONS=${ASAN_OPTIONS:-detect_leaks=0} \
|
|
UBSAN_OPTIONS=${UBSAN_OPTIONS:-print_stacktrace=1} "
|
|
|
|
let run exe args =
|
|
let out = Filename.concat scratch "flan-sanitize.out" in
|
|
let cmd =
|
|
Printf.sprintf "%s%s %s > %s 2>&1" env (Filename.quote exe)
|
|
(String.concat " " (List.map Filename.quote args))
|
|
(Filename.quote out)
|
|
in
|
|
let code = Sys.command cmd in
|
|
let text = In_channel.with_open_bin out In_channel.input_all in
|
|
(try Sys.remove out with Sys_error _ -> ());
|
|
(code, text)
|
|
|
|
let compile ~sanitize ~checks path =
|
|
let exe =
|
|
Filename.concat scratch
|
|
(Printf.sprintf "flan-san-%s-%s"
|
|
(if sanitize then "s" else "p")
|
|
(Filename.remove_extension (Filename.basename path)))
|
|
in
|
|
let l = Load.program ~file:path (Reader.read_file path) in
|
|
let p = Check.program l.Load.decls in
|
|
let p, csrcs, lflags = Reach.link ~dev:false l p in
|
|
ignore
|
|
(Build.executable
|
|
~opts:{ Build.default with checks; sanitize } ~csrcs ~lflags p ~out:exe);
|
|
exe
|
|
|
|
let contains hay needle =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
|
|
go 0
|
|
|
|
(* What a report looks like, whichever sanitizer wrote it. *)
|
|
let markers =
|
|
[ "ERROR: AddressSanitizer"; "runtime error:"; "ERROR: LeakSanitizer";
|
|
"SUMMARY: UndefinedBehaviorSanitizer" ]
|
|
|
|
let reported text = List.exists (contains text) markers
|
|
|
|
(* The corpus. Excluded, with the reason, rather than quietly absent:
|
|
|
|
- raylib-*, and the windowed examples, because raylib and libm are not
|
|
instrumented and every report through them would be about somebody
|
|
else's code.
|
|
- break.flan and agent.flan, which stop in the break loop and wait for an
|
|
editor to connect. They are covered by test_agent against a real daemon.
|
|
- the dev-* and reload-* programs, which need a host process or a dlopen
|
|
harness. The reload path is half-covered at best in any case: a
|
|
redefinition module is built by llc and ld, not by clang, so nothing
|
|
instruments it — one more thing this sweep does not prove.
|
|
- nth-gone, pkg-hidden-main, pkg-two-aliases, pkg-two-mains, pkg-cycle,
|
|
which are negative cases and are expected not to compile.
|
|
|
|
calc-me is here and is not in test/programs: it is the one string parser in
|
|
the corpus, which makes it the likeliest to push [scratch] or [escaped]
|
|
anywhere near their bounds. *)
|
|
let corpus =
|
|
[ (* bounds.flan selects its case from argv, and every case but 0 is one
|
|
that traps. Argument 0 is the in-bounds path — the last index of a
|
|
fixed array, a slice ending exactly at len, an empty slice at len —
|
|
which is the one the sweep has something to say about. The trapping
|
|
cases are where the ASan-without-bounds-checks question lives and they
|
|
are run separately; see [unchecked_controls]. Running this program with
|
|
*no* argument reads args[1] of a one-element argv, which is a bug in
|
|
the harness rather than in anything under test. *)
|
|
"programs/bounds.flan", [ "0" ];
|
|
"programs/arena-value.flan", [];
|
|
"programs/arena-edn.flan", [];
|
|
"programs/bytes2.flan", [];
|
|
"programs/cleanup.flan", [];
|
|
"programs/conditions.flan", [];
|
|
"programs/debug.flan", [];
|
|
"programs/debug-permuted.flan", [];
|
|
"programs/destructure.flan", [];
|
|
"programs/edn.flan", [];
|
|
"programs/enum-compare.flan", [];
|
|
"programs/error.flan", [];
|
|
"programs/handles.flan", [];
|
|
"programs/machine.flan", [];
|
|
"programs/math.flan", [];
|
|
"programs/pkg-diamond.flan", [];
|
|
"programs/pkg-return.flan", [];
|
|
"programs/pkg-shared.flan", [];
|
|
"programs/pkg-unused.flan", [];
|
|
"programs/printers.flan", [];
|
|
"programs/println.flan", [];
|
|
"programs/restarts.flan", [];
|
|
"programs/sand-headless.flan", [];
|
|
"programs/signedness.flan", [];
|
|
"programs/slices.flan", [];
|
|
"programs/string-of-bytes.flan", [];
|
|
"programs/text.flan", [];
|
|
"programs/unit-main.flan", [];
|
|
"programs/utf8.flan", [];
|
|
"programs/values.flan", [];
|
|
"programs/virtual-controls-headless.flan", [];
|
|
"../calc-me.flan", [ "1 + 2 * (3 - 0.5) / 2" ] ]
|
|
|
|
let sweep ~checks label =
|
|
List.iter
|
|
(fun (path, args) ->
|
|
match compile ~sanitize:false ~checks path with
|
|
| exception Failure m -> fail "%s %s: unsanitized build: %s" label path m
|
|
| plain ->
|
|
(match compile ~sanitize:true ~checks path with
|
|
| exception Failure m -> fail "%s %s: sanitized build: %s" label path m
|
|
| san ->
|
|
let c1, t1 = run plain args in
|
|
let c2, t2 = run san args in
|
|
if reported t2 then
|
|
fail "%s %s: sanitizer report\n%s" label path t2
|
|
else if c1 <> c2 || t1 <> t2 then
|
|
fail "%s %s: diverged from the unsanitized run\n \
|
|
plain (exit %d): %S\n sanitized (exit %d): %S"
|
|
label path c1 t1 c2 t2;
|
|
(try Sys.remove plain with Sys_error _ -> ());
|
|
(try Sys.remove san with Sys_error _ -> ())))
|
|
corpus
|
|
|
|
(* The positive controls, which are the only evidence that a clean sweep means
|
|
anything. Both are written here rather than kept in test/programs because
|
|
neither is a program anybody should build: one reads off the end of an
|
|
array and the other shifts an i32 by 32. *)
|
|
let control ~expect_report ?(args = []) ~why name src =
|
|
let path = Filename.concat scratch (name ^ ".flan") in
|
|
Out_channel.with_open_bin path (fun ch -> Out_channel.output_string ch src);
|
|
let exe = compile ~sanitize:true ~checks:false path in
|
|
let _, text = run exe args in
|
|
(match expect_report, reported text with
|
|
| true, false -> fail "control %s: nothing reported. %s\n%s" name why text
|
|
| false, true -> fail "control %s: reported. %s\n%s" name why text
|
|
| _ -> ());
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
(try Sys.remove path with Sys_error _ -> ())
|
|
|
|
(* The variant the checked build cannot ask for: with Flan's own bounds checks
|
|
off, is ASan enough on its own? bounds.flan is the program to ask it with —
|
|
every one of its selectors is a deliberate out-of-bounds access, and in a
|
|
checked build every one of them traps.
|
|
|
|
The answer is no, and it is worth having the shape of the no. [reports]
|
|
holds the cases ASan catches; the rest are listed with why it does not, and
|
|
they are printed rather than asserted, because a future LLVM that folds
|
|
differently would change them and that is information, not a regression.
|
|
|
|
[9] is the one that is not about ASan at all: at -O2 the access never
|
|
happens. The index is out of bounds on an [inbounds] getelementptr into a
|
|
string constant, so the whole load folds to zero and the program prints a
|
|
wrong answer instead of touching a redzone. At -O0, with the load still in
|
|
the program, ASan reports it. That divergence is why [--sanitize] does not
|
|
force -O0 the way [--debug] does — the optimiser is half of what is being
|
|
measured. *)
|
|
let unchecked_controls () =
|
|
let reports = [ "3"; "7"; "4" ] in
|
|
let silent =
|
|
[ "-1", "a negative index into a global. Not a property of the access: \
|
|
ASan lays a global out as {data, redzone}, so an underflow is \
|
|
caught when something redzoned precedes it and not when nothing \
|
|
does — measured both ways, and here nothing does. Whether \
|
|
reading before an array is seen at all is therefore up to what \
|
|
the linker put in front of it";
|
|
"9", "at -O2 the load is folded away — an out-of-bounds inbounds GEP \
|
|
into a string constant is poison, so nothing is read and a wrong \
|
|
value is printed. Reported at -O0.";
|
|
"2", "a reversed slice (lo 2, hi 1), whose length comes out negative; \
|
|
nothing is read, and flan_write_stdout ignores a negative count. \
|
|
No access, so nothing for ASan to see — the hazard is a slice \
|
|
with a negative length reaching user code, which is a checker \
|
|
question" ]
|
|
in
|
|
match compile ~sanitize:true ~checks:false "programs/bounds.flan" with
|
|
| exception Failure m -> fail "unchecked bounds.flan: build: %s" m
|
|
| exe ->
|
|
List.iter
|
|
(fun a ->
|
|
let _, t = run exe [ a ] in
|
|
if not (reported t) then
|
|
fail "unchecked bounds.flan %s: nothing reported, and this is the \
|
|
case that says ASan sees an unchecked build at all\n%s" a t)
|
|
reports;
|
|
List.iter
|
|
(fun (a, why) ->
|
|
let _, t = run exe [ a ] in
|
|
if reported t then
|
|
Printf.printf
|
|
"note unchecked bounds.flan %s now reports; it did not, on the \
|
|
grounds that %s\n" a why
|
|
else
|
|
Printf.printf "note unchecked bounds.flan %s: silent — %s\n" a why)
|
|
silent;
|
|
(try Sys.remove exe with Sys_error _ -> ())
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1" with
|
|
| 0 ->
|
|
(* A read one past the end of a four-element global. Index 5 and not 9,
|
|
and the difference is worth knowing: ASan registers this array as
|
|
"16 bytes in a 32-byte slot", so the poisoned redzone is bytes 16..31.
|
|
Index 5 is byte 20 and is caught; index 9 is byte 36, past the
|
|
registration entirely, and is silent. Overrunning a small object by
|
|
enough lands back in ordinary memory. *)
|
|
control ~expect_report:true "flan-san-ctl-oob"
|
|
~why:"This sweep is not instrumenting Flan code at all — check that \
|
|
Emit still puts every define in the sanitize_address attribute \
|
|
group, without which -fsanitize=address covers the runtime's C \
|
|
and nothing else."
|
|
"(defvar arr [4 i32])\n\
|
|
(defn main [] i32\n\
|
|
\ (set (at arr 0) 1)\n\
|
|
\ (let [i 5] (print (at arr i)) (println \"\"))\n\
|
|
\ 0)\n";
|
|
(* Shift by the full width of the type: undefined in C, poison in LLVM,
|
|
and invisible to UBSan here because nothing emitted a check for it. If
|
|
this ever starts reporting, the note above is stale. *)
|
|
control ~expect_report:false "flan-san-ctl-shift"
|
|
~why:"UBSan has started seeing Flan code, which contradicts what this \
|
|
file and Build.opts both say it reaches. Good news; rewrite them."
|
|
"(defn main [] i32\n\
|
|
\ (let [x 1] (let [n 32] (print (<< x n)) (println \"\")))\n\
|
|
\ 0)\n";
|
|
(* A regression case, and the one defect this exercise found: a slice's
|
|
length is signed, (slice s 2 1) is -1, and flan_bytes_to_i64 cast that
|
|
to size_t before comparing it against its buffer — so the memcpy copied
|
|
63 bytes out of whatever the slice pointed at. Every other (ptr, len)
|
|
entry point in the runtime already guarded the negative case; these two
|
|
were the exceptions. A checked build traps on the reversed slice long
|
|
before this, which is why it needs an unchecked build to show. *)
|
|
control ~expect_report:false ~args:[ "2" ] "flan-san-ctl-negslice"
|
|
~why:"flan_bytes_to_i64 or flan_bytes_to_f64 is reading off the end of \
|
|
a negative-length slice again — see clamp_len in flan_rt.c."
|
|
"(defn main [args [string]] i32\n\
|
|
\ (let [s (bytes \"42\")\n\
|
|
\ n (i32 (bytes->i64 (bytes (at args 1))))]\n\
|
|
\ (print (bytes->i64 (slice s n 1)))\n\
|
|
\ (println \"\"))\n\
|
|
\ 0)\n";
|
|
sweep ~checks:true "checked";
|
|
unchecked_controls ();
|
|
if !failures = 0 then print_endline "sanitizer sweep: clean"
|
|
else Printf.printf "%d sanitizer failure(s)\n" !failures;
|
|
exit (if !failures = 0 then 0 else 1)
|
|
| _ ->
|
|
print_endline "no clang on PATH; sanitizer sweep skipped"
|