JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rebased onto defdata, and the untagged union is refused by name

Browse Source 
The tagged sum is Tast.data now and Tast.unions is C's untagged union, which
arrives as a structure whose every field sits at offset zero. That is a
layout, and a layout is the one thing an object has none of here -- two
properties cannot share a run of bytes -- so it is refused with the type's own
name rather than met as "not a struct".

Two hardenings the sweep could not have found. $str built a view onto node's
Buffer pool, where small Buffers share one ArrayBuffer, so a write through one
string literal's slice could have reached another's bytes; native puts a
literal in .rodata where that write is a fault. And copy_of's Option arm named
its argument three times, which evaluates it three times.

SURVEY_FLAGS reaches both sides now, as it does in the x86 sweep, so the
unchecked indexing path -- a bare a[i] with no $at around it, which nothing
had ever run -- is swept too: 23 match, 0 differ.
This commit is contained in:
Joseph Ferano 2026-09-17 22:08:42 +07:00
parent f0fd54f0f0
commit 4d1af07cd0
2 changed files with 67 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
lib/js.ml
View File

@ -247,7 +247,12 @@ const $fs = require("fs");
// a length. The store is a Uint8Array for bytes and an Array otherwise; both
// answer a[i] and both are written through, which is what a view must do.
function $view(a, o, n) { return { a: a, o: o, n: n }; }
function $str(s) { const b = Buffer.from(s, "utf8"); return $view(new Uint8Array(b.buffer, b.byteOffset, b.length), 0, b.length); }
// Uint8Array.from rather than a view onto the Buffer: node pools small
// Buffers inside one ArrayBuffer, so a view would let a write through one
// string literal's slice reach the bytes of another. Native puts a literal in
// .rodata, where a write is a fault; this is the nearest thing to that which
// costs nothing.
function $str(s) { const b = Buffer.from(s, "utf8"); const a = Uint8Array.from(b); return $view(a, 0, a.length); }
function $bytes(xs) { const a = Uint8Array.from(xs); return $view(a, 0, a.length); }
function $buf(s) {
const a = s.a;
@ -377,7 +382,8 @@ function $argv() {
type m = {
out : Buffer.t; (* the program text *)
structs : (string, Tast.structure) Hashtbl.t;
unions : (string, Tast.union) Hashtbl.t;
datas : (string, Tast.data) Hashtbl.t; (* the tagged sums, defdata *)
cunions : (string, unit) Hashtbl.t; (* C's untagged unions, refused *)
checks : bool;
mutable strs : (string * string) list; (* literal -> its const name *)
mutable nstr : int;
@ -458,7 +464,7 @@ let rec copy_of m (t : Types.t) v =
| Types.Named n when Hashtbl.mem m.structs n ->
if not (List.mem n m.copies) then m.copies <- n :: m.copies;
Some (Printf.sprintf "%s$copy(%s)" (ident n) v)
| Types.Named n when Hashtbl.mem m.unions n ->
| Types.Named n when Hashtbl.mem m.datas n ->
if not (List.mem n m.copies) then m.copies <- n :: m.copies;
Some (Printf.sprintf "%s$copy(%s)" (ident n) v)
| Types.Array (_, e) -> (
@ -468,8 +474,13 @@ let rec copy_of m (t : Types.t) v =
| Types.Option e -> (
match copy_of m e "x" with
| None -> None
(* [v] is named once, through the parameter: spelling it twice would
evaluate the argument twice, and the argument may be a checked index
whose own subexpression has an effect. *)
| Some c ->
Some (Printf.sprintf "(%s === null ? null : { v: ((x) => %s)(%s.v) })" v c v))
Some
(Printf.sprintf
"((o) => (o === null ? null : { v: ((x) => %s)(o.v) }))(%s)" c v))
| _ -> None
(* A value that was just built is already private; cloning it would be a copy
@ -557,6 +568,12 @@ let rec zero m loc (t : Types.t) =
syntax error rather than an object. *)
Printf.sprintf "Array.from({ length: %Ld }, () => (%s))" n
(zero m loc e))
| Types.Named n when Hashtbl.mem m.cunions n ->
at loc
"%s is an untagged union, which is not in the JS dialect — its members \
share one run of bytes and two properties of an object cannot. A \
defdata carries its case and does map"
n
| Types.Named n when Hashtbl.mem m.structs n ->
let s = Hashtbl.find m.structs n in
Printf.sprintf "{ %s }"
@ -566,10 +583,10 @@ let rec zero m loc (t : Types.t) =
Printf.sprintf "%s: %s" (prop fl.Tast.fname)
(zero m loc fl.Tast.fty))
s.Tast.fields))
| Types.Named n when Hashtbl.mem m.unions n ->
| Types.Named n when Hashtbl.mem m.datas n ->
(* Declaration order from zero is the tag, so an all-bytes-zero union is
the first case with a zeroed payload. Tast.case_index says so. *)
let u = Hashtbl.find m.unions n in
let u = Hashtbl.find m.datas n in
(match u.Tast.cases with
| [] -> at loc "union %s has no cases" n
| c :: _ ->
@ -586,9 +603,23 @@ let rec zero m loc (t : Types.t) =
(* ── Places and expressions ─────────────────────────────────────────── *)
(* C's untagged union, which arrives as a [structure] whose every field sits
at offset zero. Two fields sharing one run of bytes is a layout, and an
object has none here — so it is named rather than met as "not a struct". *)
let refuse_cunion m loc n =
if Hashtbl.mem m.cunions n then
at loc
"%s is an untagged union, which is not in the JS dialect — its members \
share one run of bytes and two properties of an object cannot. A \
defdata carries its case and does map"
n
let struct_of m loc (t : Types.t) =
match t with
| Types.Named n when Hashtbl.mem m.structs n -> Hashtbl.find m.structs n
| Types.Named n ->
refuse_cunion m loc n;
at loc "a field of %s, which is not a struct" (Types.to_string t)
| t -> at loc "a field of %s, which is not a struct" (Types.to_string t)
let elem_ty loc (t : Types.t) =
@ -649,7 +680,7 @@ let rec value f (e : Tast.expr) : string =
let v = spill f x in
if i = 0 then Printf.sprintf "(%s === null ? 0 : 1)" v
else Printf.sprintf "%s.v" v
| Types.Named n when Hashtbl.mem f.md.unions n ->
| Types.Named n when Hashtbl.mem f.md.datas n ->
if i <> 0 then
at e.Tast.loc "field %d of the union %s, which has only a tag" i n;
if not (List.mem n f.md.tags) then f.md.tags <- n :: f.md.tags;
@ -664,7 +695,7 @@ let rec value f (e : Tast.expr) : string =
| Types.Named n -> n
| t -> at e.Tast.loc "case field of %s" (Types.to_string t)
in
let u = Hashtbl.find f.md.unions n in
let u = Hashtbl.find f.md.datas n in
(match Tast.case_index u case with
| Some (_, c) ->
Printf.sprintf "%s.%s" (spill f x)
@ -680,7 +711,7 @@ let rec value f (e : Tast.expr) : string =
Printf.sprintf "%s: %s" (prop fl.Tast.fname) v)
s.Tast.fields vs))
| Tast.MakeCase (n, case, parts) ->
let u = Hashtbl.find f.md.unions n in
let u = Hashtbl.find f.md.datas n in
(match Tast.case_index u case with
| None -> at e.Tast.loc "no case %s of %s" case n
| Some (_, c) ->
@ -1195,7 +1226,7 @@ and emit_match f dest (s : Tast.expr) (arms : Tast.arm list) =
in
let uname =
match s.Tast.ty with
| Types.Named n when Hashtbl.mem f.md.unions n -> Some n
| Types.Named n when Hashtbl.mem f.md.datas n -> Some n
| Types.Option _ -> None
| t -> at s.Tast.loc "match on %s" (Types.to_string t)
in
@ -1234,7 +1265,7 @@ and emit_match f dest (s : Tast.expr) (arms : Tast.arm list) =
in
line f "%s = %s;" name v
| false, Some c, Some n ->
let u = Hashtbl.find f.md.unions n in
let u = Hashtbl.find f.md.datas n in
(match Tast.case_index u c with
| Some (_, cs) ->
let fl = List.nth cs.Tast.vfields i in
@ -1350,7 +1381,7 @@ let func m (fn : Tast.fn) =
is a union's contract — an all-bytes-zero union is its first case. The
printer asks for the number; the value carries the name. *)
let tag_fn m name =
let u = Hashtbl.find m.unions name in
let u = Hashtbl.find m.datas name in
let arms =
List.mapi
(fun i (c : Tast.variant) ->
@ -1371,7 +1402,7 @@ let copy_fn m name =
Printf.sprintf "function %s$copy(v) { return { %s }; }\n" (ident name)
(String.concat ", " (List.map field_copy s.Tast.fields))
else
let u = Hashtbl.find m.unions name in
let u = Hashtbl.find m.datas name in
let arm (c : Tast.variant) =
Printf.sprintf
" if (v.case === %s) return { case: v.case%s };\n"
@ -1388,14 +1419,22 @@ let copy_fn m name =
let program ?(checks = true) (p : Tast.program) : string =
let m =
{ out = Buffer.create 8192; structs = Hashtbl.create 16;
unions = Hashtbl.create 8; checks; strs = []; nstr = 0; copies = [];
tags = [] }
datas = Hashtbl.create 8; cunions = Hashtbl.create 4; checks;
strs = []; nstr = 0; copies = []; tags = [] }
in
List.iter
(fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
p.Tast.structs;
List.iter
(fun (u : Tast.union) -> Hashtbl.replace m.unions u.Tast.uname u)
(fun (u : Tast.data) -> Hashtbl.replace m.datas u.Tast.dname u)
p.Tast.datas;
(* C's untagged unions, which arrive as [structure] values whose every field
is at offset zero. That is a layout, and a layout is the one thing an
object has none of here: two fields sharing storage cannot be two
properties. Registered so the refusal can name the type rather than
failing as "not a struct". *)
List.iter
(fun (u : Tast.structure) -> Hashtbl.replace m.cunions u.Tast.sname ())
p.Tast.unions;
if p.Tast.externs <> [] then begin
let e = List.hd p.Tast.externs in

14
spike/js/survey.sh
View File

@ -65,6 +65,16 @@ forever="dev-loop dev-watch"
TIMEOUT=${TIMEOUT:-20}
# Extra flags, given to *both* sides, the way the x86 sweep hands them over.
# SURVEY_FLAGS=--no-bounds-checks is the one with a use here: this backend
# emits a *second* indexing path when the checks are off -- a bare a[i] and a
# bare s.a[s.o + i], with no $at around either -- and a path the sweep never
# walks is a path nobody has run. Swept: 23 MATCH, 0 DIFFER, with arith.flan
# the one CRASH, and it is not one -- that program indexes out of range on
# purpose, so with the checks off the native build segfaults and node throws,
# and neither answer is defined. Nothing else changes.
read -r -a extra <<<"${SURVEY_FLAGS:-}"
declare -a match=() differ=() refused=() crash=() skip=()
for src in "$corpus"/test/programs/*.flan "$corpus"/spike/js/*.flan; do
@ -78,7 +88,7 @@ for src in "$corpus"/test/programs/*.flan "$corpus"/spike/js/*.flan; do
# LLVM first. A program that does not compile at all, or has no main, is not
# this backend's business -- the frontend refused it either way.
if ! "$flan" build "$src" -o "$out/$name.llvm" \
if ! "$flan" build "$src" "${extra[@]}" -o "$out/$name.llvm" \
>"$out/$name.llvm.err" 2>&1; then
if grep -q "in function \`_start\|undefined reference to \`main\|crt1.o" "$out/$name.llvm.err"; then
skip+=("$name:no-main")
@ -88,7 +98,7 @@ for src in "$corpus"/test/programs/*.flan "$corpus"/spike/js/*.flan; do
continue
fi
"$flan" build "$src" --target=js -o "$out/$name.js" \
"$flan" build "$src" --target=js "${extra[@]}" -o "$out/$name.js" \
>"$out/$name.js.err" 2>&1
rc=$?
if [ $rc = 3 ]; then