diff --git a/NEXT.md b/NEXT.md index 45f8d8d..6c2815f 100644 --- a/NEXT.md +++ b/NEXT.md @@ -24,7 +24,7 @@ reader ✅ → parse ✅ → check ✅ → emit ✅ → clang ✅ | `runtime/flan_rt.c` | the whole host ABI: argv, stdout, exit, 4 conversions | | `bin/main.ml` | `flan read \| parse \| check \| emit \| build \| run` | | `test/test_flan.ml` | reader, parser and checker | -| `test/test_acceptance.ml` | 20 expression/result pairs + 3 whole programs | +| `test/test_acceptance.ml` | 20 expression/result pairs + 3 whole programs + the traps | | `test/programs/*.flan` | the milestone-2 surface calc-me does not reach | ``` @@ -86,16 +86,65 @@ nothing marshals. Two consequences carry the semantics: Non-local exit is lowered explicitly: `return` and `some` are branches to a `ret`, never platform unwinding, so wasm32 needs no exception proposal. +## Bounds checks — done + +`at` and `slice` no longer emit a bare `getelementptr`. A failure is a branch +to a `noreturn cold` call and then `unreachable` — the same explicit shape as +`return` and `some`, so wasm32 needs nothing extra for it either. The message +carries the source location, because `Tast.expr` keeps a `Loc.t` and a language +that threads locations through the whole frontend should not trap anonymously: + +``` +$ flan run test/programs/bounds.flan 2 +test/programs/bounds.flan:25:29: slice [2 1) is out of bounds for length 5 (exit 134) +``` + +Three check sites, and the third is the one with the trap in it: + +- **`at` on `[n T]`** — the bound is static, so LLVM folds the check away for a + literal index. A literal that is *out* of bounds still only traps at runtime; + rejecting it in `check.ml` is a separate job. +- **`at` on a slice or string** — the bound is the runtime len. +- **`slice`** — *two* comparisons, `lo <= hi` and `hi <= len`, both non-strict + because a slice ending at len (or an empty one at `lo = len`) is legal and + its one-past-the-end gep is defined. `lo <= hi` is not redundant: without it + a reversed range yields `hi - lo` as a huge unsigned length, which is a worse + hole than the missing check was. + +All comparisons are unsigned. Indices are i32 sign-extended to i64 for the gep, +so a negative one arrives as a huge unsigned value and one test catches both +directions; the runtime still prints the signed value in the message. + +`Build.opts.checks` is on by default and **is not tied to `opts.opt`** — dev +traps, release does not, and that is a release decision rather than an +optimisation one. Keeping them separate is what lets the acceptance table go on +running the same programs at `-O0` and `-O2` with identical checks. The CLI +flag is `--no-bounds-checks`, on `build` and `emit`. + +The write path is its own case. `(set (at arr n) …)` lowers through +`place`/`Pindex`, not through `At`, so a refactor that split them would break +the write check silently — the test covers both. + +`test/programs/bounds.flan` is one program with one case per argument, because +a trap ends the process. The acceptance test asserts the exit code, that the +message names the file, and the reason — but not line and column, so editing +the program does not break the test that reads it. It runs at both `-O0` and +`-O2`, and one more case checks the IR directly: `--no-bounds-checks` emits no +`call` to either failure function. (The two `declare`s stay in the header +unconditionally; LLVM drops the unused ones.) + ## Next 1. **wasm32.** The backend is there (`llc` lists `wasm32`) and `Build.opts.target` already plumbs `--target`, but there is **no wasi sysroot on this machine** — `clang --target=wasm32-wasi` cannot find - `stdio.h`. Install `wasi-sdk`/`wasi-libc`, then run the same acceptance - table on both targets in CI. That is milestone 3's real remaining work. -2. **Bounds checks.** `at` and `slice` emit a bare `getelementptr`. Dev builds - should trap; release should not. -3. **Then milestone 4** — sand.flan: fixed 2-D arrays (done), `dotimes`, + `stdio.h`. Install `wasi-sdk`/`wasi-libc` (`dnf search wasi` for the Fedora + package name), then run the same acceptance table on both targets in CI. + That is milestone 3's real remaining work. The bounds work above was written + to survive the port — no unwinding, and `exit(134)` rather than `abort()`, + so the same trap assertion should hold on wasm32 — but that is intent, not a + tested result: nothing here has ever been built for wasm32. +2. **Then milestone 4** — sand.flan: fixed 2-D arrays (done), `dotimes`, `defer`, and typed raylib FFI with keyword→enum coercion. ## Watch for diff --git a/bin/main.ml b/bin/main.ml index bf1c411..a181df8 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -23,6 +23,10 @@ let summarise (d : Flan.Ast.decl) = (match fn.ret with None -> "Unit" | Some _ -> "explicit") (List.length fn.fbody) +(* Bounds checks are on unless a build asks for them off — the release + decision, not the optimisation level (NEXT.md, Bounds checks). *) +let no_checks_flag = "--no-bounds-checks" + let () = match Array.to_list Sys.argv with | _ :: "read" :: files when files <> [] -> @@ -63,28 +67,35 @@ let () = (Flan.Types.to_string f.ret) (Array.length f.slots)) p.fns)) files - | _ :: "emit" :: files when files <> [] -> + | _ :: "emit" :: args when List.exists (fun a -> a <> no_checks_flag) args -> + let checks = not (List.mem no_checks_flag args) in + let files = List.filter (fun a -> a <> no_checks_flag) args in List.iter (fun path -> with_errors path (fun () -> Flan.Reader.read_file path |> Flan.Parse.program |> Flan.Check.program - |> Flan.Emit.program + |> Flan.Emit.program ~checks |> print_string)) files | _ :: "build" :: path :: rest -> + let checks = not (List.mem no_checks_flag rest) in let out = - match rest with + match List.filter (fun a -> a <> no_checks_flag) rest with | [ "-o"; o ] -> o | [] -> Filename.remove_extension (Filename.basename path) - | _ -> prerr_endline "usage: flan build [-o out]"; exit 2 + | _ -> + prerr_endline + "usage: flan build [-o out] [--no-bounds-checks]"; + exit 2 in with_errors path (fun () -> Flan.Reader.read_file path |> Flan.Parse.program |> Flan.Check.program - |> fun p -> ignore (Flan.Build.executable p ~out)) + |> fun p -> + ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks } p ~out)) | _ :: "run" :: path :: args -> with_errors path (fun () -> let exe = @@ -104,6 +115,6 @@ let () = | _ -> prerr_endline "usage: flan (read|parse|check|emit) ...\n\ - \ flan build [-o out]\n\ + \ flan build [-o out] [--no-bounds-checks]\n\ \ flan run [args...]"; exit 2 diff --git a/lib/build.ml b/lib/build.ml index 903e730..f88245e 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -29,15 +29,20 @@ type opts = { target : string option; (* None is the host; "wasm32-wasi" is the other *) opt : string; keep : bool; (* leave the .ll behind *) + checks : bool; (* bounds-check [at] and [slice] *) } -let default = { target = None; opt = "-O2"; keep = false } +(* Checks are deliberately independent of [opt]: the acceptance table runs the + same programs at -O0 and -O2 to compare the emitted IR against what mem2reg + makes of it, and that comparison is only meaningful if both emit the same + checks. Dropping them is a release decision, not an optimisation one. *) +let default = { target = None; opt = "-O2"; keep = false; checks = true } let executable ?(opts = default) (p : Tast.program) ~out = let dir = workdir () in let ll = Filename.concat dir (Filename.basename out ^ ".ll") in let rt = Filename.concat dir "flan_rt.c" in - write ll (Emit.program p); + write ll (Emit.program ~checks:opts.checks p); write rt Runtime_src.source; let cmd = String.concat " " diff --git a/lib/emit.ml b/lib/emit.ml index b5d21e9..eedaa39 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -80,6 +80,7 @@ type m = { strs : Buffer.t; (* string literal constants *) structs : (string, Tast.structure) Hashtbl.t; globals : (string, Types.t) Hashtbl.t; + checks : bool; (* emit bounds checks *) mutable nstr : int; } @@ -141,14 +142,67 @@ let escape s = s; Buffer.contents b -let string_const m s = +(* The constant itself, as the pointer and length a caller needs separately — + a bounds message crosses to C as ptr+len like any other slice. *) +let string_bytes m s = let id = Printf.sprintf "@\".str.%d\"" m.nstr in m.nstr <- m.nstr + 1; Buffer.add_string m.strs (Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n" id (String.length s) (escape s)); + id, String.length s + +let string_const m s = + let id, n = string_bytes m s in (* The value alone: LLVM takes the type from the operand's context. *) - Printf.sprintf "{ ptr %s, i64 %d }" id (String.length s) + Printf.sprintf "{ ptr %s, i64 %d }" id n + +(* ── Bounds checks ───────────────────────────────────────────────────── *) + +(* A failure is a branch to a [noreturn] call and then [unreachable] — the same + explicit shape as [return] and [some], so wasm32 needs no unwinding for it + either. Whether to check is its own flag, not the optimisation level: dev + builds trap, release builds do not (NEXT.md), and the acceptance table runs + at both -O0 and -O2 with the checks on either way. + + Indices are i32 in Flan and sign-extended to i64 for the gep, so a negative + one arrives here as a huge unsigned value: an unsigned comparison catches + the negative and the too-large case in a single test. *) +let fail_block f (loc : Loc.t) ok emit_call = + let good = fresh_label f "inb" and bad = fresh_label f "oob" in + term f "br i1 %s, label %%%s, label %%%s" ok good bad; + label f bad; + let id, n = string_bytes f.md (Loc.to_string loc) in + emit_call id n; + term f "unreachable"; + label f good + +(* [at] is strict: the last valid index is len - 1. *) +let check_at f loc idx len = + if f.md.checks then begin + let ok = fresh f in + ins f "%s = icmp ult i64 %s, %s" ok idx len; + fail_block f loc ok (fun id n -> + ins f "call void @flan_bounds_fail(ptr %s, i64 %d, i64 %s, i64 %s)" + id n idx len) + end + +(* [slice] is not: a slice ending at len — or an empty one at lo = len — is + legal, and its one-past-the-end gep is defined. [lo <= hi] is not redundant + with it, because a reversed range would otherwise yield hi - lo as a huge + unsigned length, which is a worse hole than the missing check. *) +let check_slice f loc lo hi len = + if f.md.checks then begin + let a = fresh f in + ins f "%s = icmp ule i64 %s, %s" a lo hi; + let b = fresh f in + ins f "%s = icmp ule i64 %s, %s" b hi len; + let ok = fresh f in + ins f "%s = and i1 %s, %s" ok a b; + fail_block f loc ok (fun id n -> + ins f "call void @flan_slice_fail(ptr %s, i64 %d, i64 %s, i64 %s, i64 %s)" + id n lo hi len) + end (* ── Expressions ───────────────────────────────────────────────────── *) @@ -254,7 +308,9 @@ and element_addr f (target : Tast.expr) idx = let i64 = fresh f in ins f "%s = sext %s %s to i64" i64 (ll i.Tast.ty) iv; (match ty with - | Types.Array (_, elem) -> + | Types.Array (n, elem) -> + (* The bound is static; LLVM folds the check away for a literal index. *) + check_at f i.Tast.loc i64 (Int64.to_string n); let p = fresh f in ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s" p (ll ty) ptr i64; @@ -264,6 +320,9 @@ and element_addr f (target : Tast.expr) idx = let s = load f ptr ty in let base = fresh f in ins f "%s = extractvalue %%slice %s, 0" base s; + let len = fresh f in + ins f "%s = extractvalue %%slice %s, 1" len s; + check_at f i.Tast.loc i64 len; let p = fresh f in ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64; go p elem rest @@ -424,7 +483,6 @@ and emit_unwrap f ty v = (* ── Primitives ────────────────────────────────────────────────────── *) and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = - ignore e; match p, args with | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] -> let a = value f x in @@ -480,10 +538,15 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = let hiv = value f hi in let lo64 = fresh f in ins f "%s = sext i32 %s to i64" lo64 lov; + let hi64 = fresh f in + ins f "%s = sext i32 %s to i64" hi64 hiv; + (* The source is read once, and the check goes between reading it and the + gep: the length it is checked against must be the one the gep uses. *) let base = match target.Tast.ty with - | Types.Array (_, _) -> + | Types.Array (n, _) -> let a = addr f target in + check_slice f e.Tast.loc lo64 hi64 (Int64.to_string n); let p = fresh f in ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s" p (ll target.Tast.ty) a lo64; @@ -492,6 +555,9 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = let v = value f target in let q = fresh f in ins f "%s = extractvalue %%slice %s, 0" q v; + let n = fresh f in + ins f "%s = extractvalue %%slice %s, 1" n v; + check_slice f e.Tast.loc lo64 hi64 n; let p = fresh f in ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) q lo64; p @@ -499,19 +565,20 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = let v = value f target in let q = fresh f in ins f "%s = extractvalue %%slice %s, 0" q v; + let n = fresh f in + ins f "%s = extractvalue %%slice %s, 1" n v; + check_slice f e.Tast.loc lo64 hi64 n; let p = fresh f in ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64; p | t -> failwith ("slice of " ^ Types.to_string t) in let d = fresh f in - ins f "%s = sub i32 %s, %s" d hiv lov; - let n = fresh f in - ins f "%s = sext i32 %s to i64" n d; + ins f "%s = sub i64 %s, %s" d hi64 lo64; let a = fresh f in ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a base; let b = fresh f in - ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a n; + ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a d; b (* string and [u8] have the same layout, so bytes is the identity — a view, no copy (plan.org, Milestone-2 primitives). *) @@ -668,6 +735,8 @@ declare double @flan_bytes_to_f64(ptr, i64) declare i64 @flan_bytes_to_i64(ptr, i64) declare void @flan_f64_to_bytes(double, ptr) declare void @flan_i64_to_bytes(i64, ptr) +declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold +declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold |} (* C's main, adapting to whichever of the four shapes Flan's main has: argv and @@ -695,10 +764,13 @@ let emit_main m (fn : Tast.fn) = Buffer.add_string b ")\n unreachable\n}\n"; Buffer.add_string m.out (Buffer.contents b) -let program (p : Tast.program) : string = +(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or + [slice], a release build is told to drop them. *) +let program ?(checks = true) (p : Tast.program) : string = let m = { out = Buffer.create 8192; strs = Buffer.create 512; - structs = Hashtbl.create 16; globals = Hashtbl.create 16; nstr = 0; + structs = Hashtbl.create 16; globals = Hashtbl.create 16; + checks; nstr = 0; } in List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) p.Tast.structs; diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 57889ff..fef67da 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -84,3 +84,38 @@ void flan_i64_to_bytes(int64_t x, flan_slice *out) { out->ptr = (const uint8_t *)scratch; out->len = n < 0 ? 0 : (int64_t)n; } + +/* Bounds failures. The emitted code branches here and then falls off the end + * with `unreachable`, so these must not return — the same explicit shape as + * every other non-local exit, which is what keeps wasm32 free of unwinding. + * + * The location is passed as ptr+len because that is what a Flan string already + * is; nothing here allocates. Exit 134 is abort()'s status without abort()'s + * signal, so the same assertion should hold once wasm32 builds. + * + * stdout is flushed *before* the message: stderr is unbuffered and a + * redirected stdout is not, so without this the error appears above the output + * that led to it. */ + +static _Noreturn void rt_die(void) { + fflush(stdout); + fflush(stderr); + exit(134); +} + +_Noreturn void flan_bounds_fail(const uint8_t *loc, int64_t loclen, + int64_t idx, int64_t len) { + fflush(stdout); + fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n", + (int)loclen, (const char *)loc, (long long)idx, (long long)len); + rt_die(); +} + +_Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen, + int64_t lo, int64_t hi, int64_t len) { + fflush(stdout); + fprintf(stderr, "%.*s: slice [%lld %lld) is out of bounds for length %lld\n", + (int)loclen, (const char *)loc, (long long)lo, (long long)hi, + (long long)len); + rt_die(); +} diff --git a/test/programs/bounds.flan b/test/programs/bounds.flan new file mode 100644 index 0000000..218ce8d --- /dev/null +++ b/test/programs/bounds.flan @@ -0,0 +1,31 @@ +;;;; Bounds checks, NEXT.md item 2. One program, one case per argument, so a +;;;; trap is observable: the checked build exits 134 with the source location +;;;; on stderr, the unchecked one runs off the end and is not asserted on. +;;;; +;;;; The selector is also the index wherever it can be, which is what keeps the +;;;; index dynamic — a literal would let the checker reject it outright one day +;;;; (that is a separate job) and lets LLVM fold the branch away here. +(defvar arr [3 i32]) + +(defn main [args [string]] i32 + (let [n (i32 (bytes->i64 (bytes (at args 1)))) + s (bytes "hello")] ; len 5 + (cond + ;; In bounds, including both edges: the last index, and a slice that + ;; ends exactly at len. Neither may trap. + (= n 0) (do (print-i64 (i64 (at arr 2))) + (print-bytes (slice s 1 5)) + (print-bytes (slice s 5 5)) ; empty at len is legal + (newline)) + + (= n 3) (print-i64 (i64 (at arr n))) ; past the end of a fixed array + (= n -1) (print-i64 (i64 (at arr n))) ; negative index + (= n 9) (print-i64 (i64 (at s n))) ; past the end of a slice + ;; The write path lowers through place/Pindex rather than through At, so + ;; it is checked separately even though the message is the same. + (= n 7) (set (at arr n) 1) ; write past the end + (= n 4) (print-bytes (slice s n 9)) ; hi past the end + (= n 2) (print-bytes (slice s n 1)) ; reversed range + + :else (print-line "?")) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 007d5cc..15327d2 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -23,15 +23,21 @@ let run exe arg = Sys.remove out; (code, text) -let compile ?(opt = "-O2") path = +let compile ?(opt = "-O2") ?(checks = true) path = let exe = Filename.concat scratch ("flan-t-" ^ Filename.remove_extension (Filename.basename path)) in let p = Reader.read_file path |> Parse.program |> Check.program in - ignore (Build.executable ~opts:{ Build.default with opt } p ~out:exe); + ignore (Build.executable ~opts:{ Build.default with opt; checks } p ~out:exe); exe +(* No Str, and the reader is hand-written for the same reason. *) +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 + let () = match Sys.command "command -v clang > /dev/null 2>&1" with | 0 -> @@ -106,6 +112,71 @@ let () = outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out; outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out; + (* Bounds checks, NEXT.md item 2. A trap has no result — it has a nonzero + exit and a message on stderr — so it needs a case shape the table above + does not have. What is asserted is the *reason*: the location, and which + index against which length. The line and column are not pinned, because + editing the program should not break the test that reads it. *) + let bounds ?opt () = + let exe = compile ?opt "programs/bounds.flan" in + let traps name arg reason = + let code, text = run exe (Some arg) in + if code <> 134 + || not (contains text "programs/bounds.flan:") + || not (contains text reason) + then begin + incr failures; + Printf.printf + "FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n" + name text code reason + end + in + (* Both edges are in bounds and must not trap: the last index of a fixed + array, a slice ending exactly at len, and an empty slice at len. *) + let code, text = run exe (Some "0") in + if text <> "0ello\n" || code <> 0 then begin + incr failures; + Printf.printf "FAIL in-bounds edges\n got: %S (exit %d)\n" text code + end; + traps "at past a fixed array" "3" + "index 3 is out of bounds for length 3"; + (* Negative indices sext to a huge unsigned, so the one unsigned + comparison catches them; the message still reports the signed value. *) + traps "at with a negative index" "-1" + "index -1 is out of bounds for length 3"; + traps "at past a slice" "9" + "index 9 is out of bounds for length 5"; + (* A different lowering — place/Pindex, not At — so it is its own case. *) + traps "set past a fixed array" "7" + "index 7 is out of bounds for length 3"; + traps "slice with hi past len" "4" + "slice [4 9) is out of bounds for length 5"; + (* Without the lo <= hi test this one would not trap: it would build a + slice of length hi - lo as a huge unsigned, which is worse. *) + traps "slice with a reversed range" "2" + "slice [2 1) is out of bounds for length 5"; + (try Sys.remove exe with Sys_error _ -> ()) + in + bounds (); + bounds ~opt:"-O0" (); + + (* The release build drops them — the calls, that is; the two declarations + stay in the header and LLVM discards the unused ones. Asserted on the IR + rather than by running an unchecked out-of-bounds program, which has no + defined behaviour to assert on. *) + let p = + Reader.read_file "programs/bounds.flan" |> Parse.program |> Check.program + in + if not (contains (Emit.program p) "call void @flan_bounds_fail(") then begin + incr failures; + print_endline "FAIL checks on: no bounds call emitted" + end; + let off = Emit.program ~checks:false p in + if contains off "call void @flan_bounds_fail(" || contains off "call void @flan_slice_fail(" then begin + incr failures; + print_endline "FAIL --no-bounds-checks: a check survived" + end; + if !failures = 0 then print_endline "acceptance: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures;