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

The sweep is the evidence: 24 match, 0 differ, 71 refused by name

Browse Source 
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.
This commit is contained in:
Joseph Ferano 2026-09-17 21:59:25 +07:00
parent dfb02ee26a
commit dfe0296479
4 changed files with 473 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
lib/js.ml
View File

@ -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

106
spike/js/p1-int-semantics.flan Normal file
View File

@ -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)

87
spike/js/p2-value-copies.flan Normal file
View File

@ -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)

158
spike/js/survey.sh Executable file
View File

@ -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