From dfe0296479f7d044bd34660e19dfbf9c337c648b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Thu, 17 Sep 2026 21:59:25 +0700 Subject: [PATCH] The sweep is the evidence: 24 match, 0 differ, 71 refused by name spike/js/survey.sh is the x86 sweep's shape with one deliberate difference in what it counts. That backend is behind, so a refusal there is a regression and its strict mode fails on one. This is a dialect, so a refusal is the design working -- a pointer, an allocator, a Map, the FFI and conditions are refused permanently and correctly. What fails the @js alias is a DIFFER, which is a wrong answer, and a CRASH, which is JS this backend emitted and node would not run. Two probes carry the decisions the corpus does not reach. p1-int-semantics prints wrapping at all eight widths, a multiply past 2^53, truncating division with a negative operand, shifts whose count is out of range, bitwise over a u32, f32 that is not a double, and the conversions both ways -- 35 lines, all identical to the LLVM build. It found two real bugs: >>> binds tighter than & in JavaScript, so a bit-and on a u32 answered -1; and a 64-bit value through Number() rounds to 53 bits before it can be truncated, so (i32 i64hi) answered 0 where it must answer -1. p2-value-copies goes past values.flan to the cases a shallow copy would pass: a struct inside a struct, a struct returned out of a function, an element read out of an array of structs, and a global. Also fixed, and all three were found by the sweep rather than by reading: a unit-typed call in statement position was compiled to an expression nobody emitted, so (load-xs) silently did not happen; an arrow body that starts with a brace is a block, so a zeroed array of structs was a syntax error; and a bounds message must carry the index expression's location, not the form's, because that is the one emit.ml passes to check_at. Render reads an Option's tag as field 0 and a union's as field 0, which is the LLVM layout and not this one, so both are answered here rather than refused. fdefers is dropped rather than refused: nothing in the dialect can start a transfer, so the transfer exit path is unreachable, and refusing it would have refused every program that writes a plain defer. --- lib/js.ml | 161 +++++++++++++++++++++++++-------- spike/js/p1-int-semantics.flan | 106 ++++++++++++++++++++++ spike/js/p2-value-copies.flan | 87 ++++++++++++++++++ spike/js/survey.sh | 158 ++++++++++++++++++++++++++++++++ 4 files changed, 473 insertions(+), 39 deletions(-) create mode 100644 spike/js/p1-int-semantics.flan create mode 100644 spike/js/p2-value-copies.flan create mode 100755 spike/js/survey.sh diff --git a/lib/js.ml b/lib/js.ml index f13548a..c38bc9e 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -382,6 +382,7 @@ type m = { mutable strs : (string * string) list; (* literal -> its const name *) mutable nstr : int; mutable copies : string list; (* struct names needing a $copy *) + mutable tags : string list; (* union names needing a $tag *) } type f = { @@ -487,8 +488,14 @@ let rec fresh_value (e : Tast.expr) = let big k = match k with Types.I64 | Types.U64 -> true | _ -> false -(* Put an expression back inside its type's range. The header's table. *) +(* Put an expression back inside its type's range. The header's table. + + [s] is parenthesised first, and that is not decoration: [>>>] binds tighter + than [&], [|] and [^] in JavaScript, so [a & b >>> 0] is [a & (b >>> 0)] and + a [bit-and] on a [u32] would answer -1 where the other backends answer + 4294967295. The probe caught exactly that. *) let norm (k : Types.ikind) s = + let s = "(" ^ s ^ ")" in match k with | Types.I64 -> Printf.sprintf "BigInt.asIntN(64, %s)" s | Types.U64 -> Printf.sprintf "BigInt.asUintN(64, %s)" s @@ -545,7 +552,10 @@ let rec zero m loc (t : Types.t) = (match e with | Types.Int Types.U8 -> Printf.sprintf "new Uint8Array(%Ld)" n | _ -> - Printf.sprintf "Array.from({ length: %Ld }, () => %s)" n + (* The parentheses are not decoration: an arrow whose body starts with + a brace is parsed as a block, so [() => { x: 0 }] is a label and a + 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.structs n -> let s = Hashtbl.find m.structs n in @@ -626,10 +636,28 @@ let rec value f (e : Tast.expr) : string = | Tast.CallPtr (fn, args) -> let fv = spill f fn in Printf.sprintf "%s(%s)" fv (String.concat ", " (call_args f args)) - | Tast.Field (x, i) -> - let s = struct_of f.md e.Tast.loc x.Tast.ty in - let fl = List.nth s.Tast.fields i in - Printf.sprintf "%s.%s" (spill f x) (prop fl.Tast.fname) + (* [Field] is a struct's field almost everywhere, and [Render] is the + exception: the structural printer reads an [Option]'s tag as field 0 and + its payload as field 1, and a union's tag as field 0, because that is the + LLVM layout. Neither shape exists here — an Option is null-or-a-box and a + union carries its case by name — so both are answered rather than + refused, and a union's tag goes through a generated [Shape$tag] that maps + the name back to the declaration order [Tast.case_index] fixed. *) + | Tast.Field (x, i) -> ( + match x.Tast.ty with + | Types.Option _ -> + 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 -> + 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; + Printf.sprintf "%s$tag(%s)" (ident n) (spill f x) + | _ -> + let s = struct_of f.md e.Tast.loc x.Tast.ty in + let fl = List.nth s.Tast.fields i in + Printf.sprintf "%s.%s" (spill f x) (prop fl.Tast.fname)) | Tast.CaseField (x, case, i) -> let n = match x.Tast.ty with @@ -829,9 +857,15 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = the container the next step indexes. *) and index f loc target idxs = let tv = spill f target in - let step base (bty : Types.t) iv = + (* The location on the check is the *index expression's*, not the form's: + emit.ml's [element_addr] passes [i.Tast.loc] to [check_at], and the + survey diffs stderr, so a bounds message that names a different column is + a DIFFER. [slice] is the other way round and uses the form's, which is + why the two are not shared. *) + let step base (bty : Types.t) (i : Tast.expr) iv = let fn = match bty with Types.Array _ -> "$aat" | _ -> "$at" in - if f.md.checks then Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr loc) + if f.md.checks then + Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr i.Tast.loc) else match bty with | Types.Array _ -> Printf.sprintf "%s[%s]" base iv @@ -839,9 +873,9 @@ and index f loc target idxs = in let rec go base bty = function | [] -> base - | [ i ] -> step base bty (value f i) + | [ i ] -> step base bty i (value f i) | i :: rest -> - let one = step base bty (value f i) in + let one = step base bty i (value f i) in let t = fresh f in line f "const %s = %s;" t one; go t (elem_ty loc bty) rest @@ -951,12 +985,17 @@ and cast f loc (t : Types.t) (x : Tast.expr) = let bk = match t with Types.Int k -> Some k | _ -> None in let sbig = match src with Types.Int k -> big k | _ -> false in let dbig = match bk with Some k -> big k | None -> false in - let v = - if sbig && not dbig then Printf.sprintf "Number(%s)" v - else if dbig && not sbig then Printf.sprintf "BigInt(%s)" v - else v - in - (match bk with Some k -> norm k v | None -> Printf.sprintf "(%s | 0)" v) + if sbig && not dbig then + (* The truncation has to happen in BigInt and not after: a 64-bit value + through Number() is rounded to 53 bits first, so (i32 i64hi) would + answer 0 where every other backend answers -1. *) + let k = match bk with Some k -> k | None -> Types.I32 in + Printf.sprintf "Number(BigInt.as%sN(%d, %s))" + (if Types.signed k then "Int" else "Uint") + (Types.bits k) v + else + let v = if dbig && not sbig then Printf.sprintf "BigInt(%s)" v else v in + (match bk with Some k -> norm k v | None -> Printf.sprintf "(%s | 0)" v) | Types.Float _, Types.Float k -> fround k v | (Types.Int _ | Types.Enum _), Types.Float k -> let sbig = match src with Types.Int k -> big k | _ -> false in @@ -1021,7 +1060,12 @@ and dec_sub1 s = (* ── Statements ─────────────────────────────────────────────────────── *) and assign f dest v = - match dest with None -> line f "%s;" v | Some d -> line f "%s = %s;" d v + match dest with + (* A form whose value is discarded and whose text is [undefined] did + nothing; emitting it as a statement is noise in the output and nothing + else. *) + | None -> if not (String.equal v "undefined") then line f "%s;" v + | Some d -> line f "%s = %s;" d v and stmt f dest (e : Tast.expr) = match e.Tast.e with @@ -1117,7 +1161,7 @@ and set f loc (p : Tast.place) (v : Tast.expr) = let rhs = bind_value f v in if f.md.checks then let fn = match bty with Types.Array _ -> "$aset" | _ -> "$set" in - line f "%s(%s, %s, %s, %s);" fn base iv rhs (locstr loc) + line f "%s(%s, %s, %s, %s);" fn base iv rhs (locstr i.Tast.loc) else ( match bty with | Types.Array _ -> line f "%s[%s] = %s;" base iv rhs @@ -1127,7 +1171,7 @@ and set f loc (p : Tast.place) (v : Tast.expr) = let fn = match bty with Types.Array _ -> "$aat" | _ -> "$at" in let one = if f.md.checks then - Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr loc) + Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr i.Tast.loc) else match bty with | Types.Array _ -> Printf.sprintf "%s[%s]" base iv @@ -1244,10 +1288,14 @@ let func m (fn : Tast.fn) = List.iter (refuse_ty fn.Tast.floc) fn.Tast.params; refuse_ty fn.Tast.floc fn.Tast.ret; Array.iter (refuse_ty fn.Tast.floc) fn.Tast.slots; - if fn.Tast.fdefers <> [] then - at fn.Tast.floc - "a defer on the transfer path is not in the JS dialect yet — the \ - transfer channel is the conditions lane"; + (* [fdefers] is the same defer list again, for the *transfer* exit path. + Nothing in this dialect can start a transfer — signal, handler-bind, + restart-case and invoke-restart are all refused above, and a bounds or + arithmetic failure here dies where the native runtime would signal — so + that path is unreachable and the list is dropped rather than emitted. The + defers on the ordinary path are already spliced into [body] and do run. + This is the one place a refusal would have been wrong: it would refuse + every program that writes a plain [defer]. *) let names = slot_names fn in let f = { md = m; b = Buffer.create 512; ind = 1; n = 0; names; @@ -1262,19 +1310,32 @@ let func m (fn : Tast.fn) = in if locals <> [] then line f "let %s;" (String.concat ", " locals); - let last = ref "undefined" in - List.iter (fun e -> last := value f e) fn.Tast.body; - if not (Types.equal fn.Tast.ret Types.Unit) - && not (Types.equal fn.Tast.ret Types.Never) - then begin - let tail = List.rev fn.Tast.body in - match tail with - | e :: _ when not (fresh_value e) -> ( - match copy_of m fn.Tast.ret !last with - | Some c -> line f "return %s;" c - | None -> line f "return %s;" !last) - | _ -> line f "return %s;" !last - end; + (* The body is a list of forms and the last one is the return value — the + same rule [emit.ml] follows. Every form before it is a statement, and a + statement it is not is the bug this used to have: a unit-typed call + compiled to an expression nobody emitted, so [(load-xs)] silently did not + happen. A Unit function's body may end on a form of any type; the value is + discarded there, exactly as emit.ml discards it. *) + let void = + Types.equal fn.Tast.ret Types.Unit || Types.equal fn.Tast.ret Types.Never + in + let n = List.length fn.Tast.body in + List.iteri + (fun i (e : Tast.expr) -> + if i < n - 1 || void then stmt f None e + else + match e.Tast.e with + | Tast.Do _ | Tast.Let _ | Tast.If _ | Tast.While _ | Tast.Match _ + | Tast.UnwrapSome _ | Tast.Set _ | Tast.Return _ | Tast.Break _ + | Tast.Continue _ -> + let t = fresh f in + line f "let %s;" t; + stmt f (Some t) e; + (match copy_of m fn.Tast.ret t with + | Some c -> line f "return %s;" c + | None -> line f "return %s;" t) + | _ -> line f "return %s;" (bind_value f e)) + fn.Tast.body; Buffer.add_string m.out (Printf.sprintf "\nfunction %s(%s) {\n%s}\n" (fname fn.Tast.name) (String.concat ", " @@ -1285,6 +1346,20 @@ let func m (fn : Tast.fn) = (* The per-struct copy, which is where the value-semantics rule is actually spent. Recursive, because a field may be a struct or an array of them. *) +(* A union's declaration order is its tag ([Tast.case_index]), and that order + 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 arms = + List.mapi + (fun i (c : Tast.variant) -> + Printf.sprintf "v.case === %s ? %d : " (js_string c.Tast.vname) i) + u.Tast.cases + in + Printf.sprintf "function %s$tag(v) { return %s-1; }\n" (ident name) + (String.concat "" arms) + let copy_fn m name = let field_copy (fl : Tast.field) = let v = Printf.sprintf "v.%s" (prop fl.Tast.fname) in @@ -1313,7 +1388,8 @@ 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 = [] } + unions = Hashtbl.create 8; checks; strs = []; nstr = 0; copies = []; + tags = [] } in List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) @@ -1358,6 +1434,7 @@ let program ?(checks = true) (p : Tast.program) : string = hoisted above by JS's own function hoisting. *) let copies = String.concat "" (List.map (copy_fn m) (List.sort compare m.copies)) + ^ String.concat "" (List.map (tag_fn m) (List.sort compare m.tags)) in let strs = String.concat "" @@ -1382,9 +1459,15 @@ let program ?(checks = true) (p : Tast.program) : string = List.find (fun (fn : Tast.fn) -> String.equal fn.Tast.name "main") p.Tast.fns in + (* [main] takes the command line or nothing, which is the whole of the + entry point's contract. node's own argv starts at the interpreter, so + the slice starts at the script — which is where a native argv[0] is + the program. *) + let arg = if mainfn.Tast.params = [] then "" else "$argv()" in if Types.equal mainfn.Tast.ret Types.Unit then - Printf.sprintf "\n%s();\nprocess.exit(0);\n" (fname "main") - else Printf.sprintf "\nprocess.exit(Number(%s()));\n" (fname "main") + Printf.sprintf "\n%s(%s);\nprocess.exit(0);\n" (fname "main") arg + else + Printf.sprintf "\nprocess.exit(Number(%s(%s)));\n" (fname "main") arg else "" in runtime ^ "\n// ── string literals ──\n" ^ strs diff --git a/spike/js/p1-int-semantics.flan b/spike/js/p1-int-semantics.flan new file mode 100644 index 0000000..1bd155e --- /dev/null +++ b/spike/js/p1-int-semantics.flan @@ -0,0 +1,106 @@ +;;;; The evidence for lib/js.ml's integer decisions, run by the survey. +;;;; +;;;; JavaScript has one number type and it is a double. Flan has eight integer +;;;; types and they wrap. Every line below is a place where the two disagree +;;;; unless the backend normalises, and the survey diffs this program's output +;;;; against the LLVM build's byte for byte — so a wrong answer here is a +;;;; DIFFER and not a discussion. +;;;; +;;;; Everything goes through a global rather than a literal, for the reason +;;;; arith.flan gives: a literal operand is exactly what a constant folder +;;;; removes, and a folded program does not contain the code being tested. + +(defvar i8hi i8 127) +(defvar i16hi i16 32767) +(defvar i32hi i32 2147483647) +(defvar u8hi u8 255) +(defvar u16hi u16 65535) +(defvar u32hi u32 4294967295) +(defvar i64hi i64 9223372036854775807) +(defvar u64zero u64 0) + +(defvar one8 i8 1) +(defvar one16 i16 1) +(defvar one32 i32 1) +(defvar oneu8 u8 1) +(defvar oneu16 u16 1) +(defvar oneu32 u32 1) +(defvar one64 i64 1) +(defvar oneu64 u64 1) + +(defvar big32 i32 123456789) +(defvar big64 i64 1234567890123) +(defvar three i32 3) +(defvar three64 i64 3) +(defvar seven i32 7) +(defvar negsev i32 -7) +(defvar shift i32 33) +(defvar shift8 i8 9) +(defvar f32one f32 1.0) +(defvar f32big f32 16777217.0) + +(defn main [] i32 + ;; ── Wrapping at every width ────────────────────────────────────── + ;; The top of the type plus one. A JS number would answer 128, 32768, + ;; 2147483648, 256, 65536, 4294967296 and never wrap at all. + (println (+ i8hi one8)) + (println (+ i16hi one16)) + (println (+ i32hi one32)) + (println (+ u8hi oneu8)) + (println (+ u16hi oneu16)) + (println (+ u32hi oneu32)) + (println (+ i64hi one64)) + (println (- u64zero oneu64)) ; the top of u64, which no literal spells + + ;; A multiply whose exact product passes 2^53, where a * b in JS is not + ;; exact and Math.imul is. 123456789 * 123456789 = 15241578750190521, which + ;; is above 2^53, so a double rounds it before the truncation can happen. + (println (* big32 big32)) + (println (* big64 big64)) + + ;; ── Truncating division, and the sign of a remainder ───────────── + ;; C truncates toward zero and so does JS's %, but (a / b) | 0 is only the + ;; same answer below 2^31, which is why the backend uses Math.trunc. + (println (/ seven three)) + (println (/ negsev three)) + (println (% seven three)) + (println (% negsev three)) + (println (/ big64 three64)) + + ;; ── Shifts, with the count masked to the operand's width ───────── + ;; 33 is not a legal shift count for a 32-bit type, and the checker only + ;; rejects a *literal* out of range, so this is the computed case emit.ml + ;; masks and this backend has to mask too. JS masks a 32-bit shift itself + ;; and has no 8- or 16-bit shift at all, which is why the mask is written + ;; out rather than relied on. + (println (<< one32 shift)) + (println (<< one8 shift8)) + (println (>> i32hi one32)) + (println (>> (- (i32 0) i32hi) one32)) ; arithmetic: signed stays signed + (println (>> u32hi oneu32)) ; logical: unsigned stays unsigned + (println (<< one64 (i64 65))) + + ;; ── Bitwise over an unsigned 32-bit value ──────────────────────── + ;; JS bitwise operators produce a *signed* 32-bit result, so every one of + ;; these needs the >>> 0 back. + (println (bit-and u32hi u32hi)) + (println (bit-or u32hi oneu32)) + (println (bit-xor u32hi oneu32)) + + ;; ── f32 is not a double ────────────────────────────────────────── + ;; 16777217 is the first integer a float cannot hold, so this prints + ;; 16777216 under a real f32 and 16777218 under a double. + (println (+ f32big f32one)) + (println (/ (f32 1.0) (f32 3.0))) + (println (/ (f64 1.0) (f64 3.0))) + + ;; ── The conversions, both ways ─────────────────────────────────── + (println (i8 i32hi)) + (println (u8 (- (i32 0) one32))) + (println (i32 i64hi)) + (println (i64 big32)) + (println (u64 i64hi)) + (println (f64 i64hi)) + (println (i32 (f64 2.9))) + (println (i32 (f64 -2.9))) + 0) diff --git a/spike/js/p2-value-copies.flan b/spike/js/p2-value-copies.flan new file mode 100644 index 0000000..8d6eb62 --- /dev/null +++ b/spike/js/p2-value-copies.flan @@ -0,0 +1,87 @@ +;;;; The evidence for lib/js.ml's value-semantics decision. +;;;; +;;;; A Flan struct and a fixed array are values: binding one copies it, and +;;;; emit.ml spends a memcpy at every such site. A JS object assigns by +;;;; reference, so an object mapping that does nothing aliases where the LLVM +;;;; build copied — and the divergence is invisible until something mutates a +;;;; copy, which is what every line below does. +;;;; +;;;; test/programs/values.flan already pins the two simplest cases. This goes +;;;; past them, to the ones a shallow copy would pass and a wrong one would +;;;; not: a struct inside a struct, a struct returned out of a function, an +;;;; element read out of an array of structs, and a global. +;;;; +;;;; Fable answers the same question the other way for F# structs on its JS +;;;; backend — it inserts no clone at all, and its Rust backend does — so this +;;;; is the property that says which of the two this dialect chose. + +(defstruct Point [x i32 y i32]) +(defstruct Box [lo Point hi Point n i32]) + +(defvar gp Point) + +;; A parameter is a copy: writing to it must not reach the caller's value. +(defn bump [p Point] Point + (set (.x p) (+ (.x p) 100)) + p) + +;; A returned struct is a copy of whatever it names, not a second name for it. +(defn origin-of [b Box] Point + (.lo b)) + +(defn show [p Point] () + (print (.x p)) (print " ") (println (.y p))) + +(defn main [] i32 + ;; ── A let binding copies ──────────────────────────────────────── + (let [a (Point {.x 1 .y 2}) + b a] + (set (.x b) 99) + (show a) ; 1 2 — a must not have moved + (show b)) ; 99 2 + + ;; ── A parameter copies ────────────────────────────────────────── + (let [a (Point {.x 1 .y 2}) + c (bump a)] + (show a) ; 1 2 + (show c)) ; 101 2 + + ;; ── A nested struct copies with its container ─────────────────── + (let [bx (Box {.lo (Point {.x 1 .y 1}) .hi (Point {.x 9 .y 9}) .n 3}) + cy bx] + (set (.x (.lo cy)) 42) + (set (.n cy) 7) + (print (.x (.lo bx))) (print " ") (println (.n bx)) ; 1 3 + (print (.x (.lo cy))) (print " ") (println (.n cy))) ; 42 7 + + ;; ── A field read is a copy, not a view ────────────────────────── + (let [bx (Box {.lo (Point {.x 1 .y 1}) .hi (Point {.x 9 .y 9}) .n 3}) + p (origin-of bx)] + (set (.x p) 55) + (print (.x (.lo bx))) (print " ") (println (.x p))) ; 1 55 + + ;; ── A global copies both ways ─────────────────────────────────── + (set gp (Point {.x 4 .y 5})) + (let [g gp] + (set (.x g) 0) + (show gp) ; 4 5 + (show g)) ; 0 5 + + ;; ── A fixed array is a value too ──────────────────────────────── + (let [xs [1 2 3] + ys xs] + (set (at ys 0) 77) + (print (at xs 0)) (print " ") (println (at ys 0))) ; 1 77 + + ;; ── An array of structs copies its elements ───────────────────── + ;; An element read is a value too, so mutating what came out of one must + ;; reach neither array. A shallow copy of the outer array would leave both + ;; naming the same element object, and this would print 8 8 8. + (let [ps [(Point {.x 1 .y 1}) (Point {.x 2 .y 2})] + qs ps + e (at qs 0)] + (set (.x e) 8) + (print (.x (at ps 0))) (print " ") + (print (.x (at qs 0))) (print " ") + (println (.x e))) ; 1 1 8 + 0) diff --git a/spike/js/survey.sh b/spike/js/survey.sh new file mode 100755 index 0000000..839a564 --- /dev/null +++ b/spike/js/survey.sh @@ -0,0 +1,158 @@ +#!/usr/bin/env bash +# Does the JS dialect agree with LLVM, or refuse in its own words? +# +# Shaped after spike/x86/survey.sh and for the same reason: the only honest +# test of a backend is what the program prints and what it exits with. Every +# program in test/programs is built both ways -- native through LLVM, and one +# .js run by node -- and stdout, stderr and the exit status are all diffed. +# +# The difference from the x86 sweep is what a refusal means. That backend is +# *behind*: every node it refuses is one it will lower eventually, so a +# refusal there is a regression and the strict mode fails on one. This is a +# *dialect*: docs/DISCUSS.md item 5 decided that object mapping leaves the +# memory model behind, so a program using pointers, allocators, a Map, a Pool, +# the FFI or conditions is refused permanently and correctly. A refusal here +# is therefore an expected outcome and not a failure -- what fails is a +# DIFFER, which is a wrong answer, and a CRASH, which is a program the backend +# emitted and node would not run. +# +# Five outcomes: +# +# MATCH built both ways, same stdout, same stderr, same exit status +# DIFFER built both ways, and disagreed +# REFUSED Js.Unsupported -- named by the backend, with a location (exit 3) +# CRASH emitted JS that node refused to run, or that threw +# SKIP no main, does not compile at all, or does not terminate +# +# Over test/programs, and over spike/js's own probes, which are here for the +# paths the corpus does not walk -- p1-int-semantics.flan in particular is the +# evidence for the wrapping, division and shift decisions in lib/js.ml's +# header, and it is in the corpus rather than run by hand so that the evidence +# is the sweep. +# +# Usage: spike/js/survey.sh [name-substring ...] +set -u +orig=$(pwd) +here=$(cd "$(dirname "$0")" && pwd) +root=$(cd "$here/../.." && pwd) +cd "$root" || exit 1 + +# FLAN is how the dune @js alias hands this script a compiler dune has already +# built; building it here would be a second dune inside the first one's lock. +# See spike/x86/survey.sh, which says the same thing at more length. +if [ -n "${FLAN:-}" ]; then + case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac +else + dune build --root . bin/main.exe 2>&1 | head -30 + flan=$root/_build/default/bin/main.exe +fi +test -x "$flan" || { echo "build failed"; exit 1; } + +# node is the host. Guarded rather than assumed: this sweep is opt-in and a +# machine without node should say so and stop, not report zero of everything. +node=${NODE:-node} +if ! command -v "$node" > /dev/null 2>&1; then + echo "js survey: no $node on PATH, nothing run" + exit 0 +fi + +corpus=${SURVEY_CORPUS:-$root} +out=$(mktemp -d); trap 'rm -rf "$out"' EXIT + +# The two that run until something stops them, excluded by name for the reason +# the x86 sweep excludes them: a timeout cannot tell them from a hang. +forever="dev-loop dev-watch" + +TIMEOUT=${TIMEOUT:-20} + +declare -a match=() differ=() refused=() crash=() skip=() + +for src in "$corpus"/test/programs/*.flan "$corpus"/spike/js/*.flan; do + name=$(basename "$src" .flan) + if [ $# -gt 0 ]; then + want=0 + for pat in "$@"; do case "$name" in *"$pat"*) want=1;; esac; done + [ $want = 1 ] || continue + fi + case " $forever " in *" $name "*) skip+=("$name:runs-forever"); continue;; esac + + # 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" \ + >"$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") + else + skip+=("$name:does-not-compile") + fi + continue + fi + + "$flan" build "$src" --target=js -o "$out/$name.js" \ + >"$out/$name.js.err" 2>&1 + rc=$? + if [ $rc = 3 ]; then + why=$(head -1 "$out/$name.js.err" | sed 's/^js: //' | sed 's/^[^ ]*flan:[0-9]*:[0-9]*: //') + refused+=("$name:$why") + continue + fi + if [ $rc != 0 ]; then + crash+=("$name:compiler:$(head -1 "$out/$name.js.err")") + continue + fi + + ( cd "$out" && timeout "$TIMEOUT" "$out/$name.llvm" \ + >"$out/$name.llvm.out" 2>"$out/$name.llvm.diag" ) + a=$? + ( cd "$out" && timeout "$TIMEOUT" "$node" "$out/$name.js" \ + >"$out/$name.js.out" 2>"$out/$name.js.diag" ) + b=$? + # node's own failure -- a SyntaxError, a ReferenceError, a thrown Error -- + # is not a disagreement about a value. It is a backend that emitted + # something it should have refused, and it gets its own bucket so that the + # two are never confused in the counts. + if grep -q "^[A-Za-z]*Error:\|node:internal" "$out/$name.js.diag" 2>/dev/null; then + crash+=("$name:node:$(grep -m1 "^[A-Za-z]*Error:" "$out/$name.js.diag" | head -c 120)") + continue + fi + if [ "$a" = "$b" ] && cmp -s "$out/$name.llvm.out" "$out/$name.js.out" \ + && cmp -s "$out/$name.llvm.diag" "$out/$name.js.diag"; then + match+=("$name") + else + differ+=("$name:llvm=$a/js=$b") + if [ "${SURVEY_SHOW:-}" = 1 ]; then + echo "--- $name: llvm exit $a, js exit $b" + diff "$out/$name.llvm.out" "$out/$name.js.out" | head -20 + diff "$out/$name.llvm.diag" "$out/$name.js.diag" | head -20 + fi + fi +done + +echo +echo "MATCH ${#match[@]}" +echo "DIFFER ${#differ[@]}" +[ "${#differ[@]}" = 0 ] || printf ' %s\n' "${differ[@]}" +echo "REFUSED ${#refused[@]}" +if [ "${#refused[@]}" != 0 ] && [ "${SURVEY_QUIET:-}" != 1 ]; then + printf '%s\n' "${refused[@]}" | sed 's/^[^:]*://' | cut -c1-60 | sort | uniq -c \ + | sort -rn | sed 's/^/ /' +fi +echo "CRASH ${#crash[@]}" +[ "${#crash[@]}" = 0 ] || printf ' %s\n' "${crash[@]}" +echo "SKIP ${#skip[@]}" +if [ "${#skip[@]}" != 0 ] && [ "${SURVEY_QUIET:-}" != 1 ]; then + printf '%s\n' "${skip[@]}" | sed 's/^[^:]*://' | sort | uniq -c \ + | sed 's/^/ /' +fi + +# Strict mode, for the @js alias. A refusal is *not* a failure here -- see the +# header -- so only a wrong answer and a program node could not run are. +if [ "${SURVEY_STRICT:-}" = 1 ]; then + if [ "${#differ[@]}" != 0 ] || [ "${#crash[@]}" != 0 ]; then + echo + echo "js survey FAILED: ${#differ[@]} differ, ${#crash[@]} crash" + exit 1 + fi + echo + echo "js survey ok: ${#match[@]} match, ${#refused[@]} refused by name" +fi