Joseph Ferano
dfb02ee26a
lib/js.ml lowers the same checked Tast the other two backends take to one CommonJS file, by object mapping rather than linear memory: docs/DISCUSS.md item 5 settled that fork before this was written, and item 5's consequence is the whole shape of the file. Object mapping means the host's collector owns every value, so there is no (Ptr T), no free, no arena and no allocator, and a program that uses one is refused by name with a location rather than compiled badly. flan build --target=js leaves Build.executable through its own two lines, before anything that assumes a clang: there is no object to compile and no linker to run. --dev, --debug, --sanitize and --x86 are refused there rather than swallowed. Js.Unsupported exits 3 beside X86.Unsupported, so a sweep can count refused-by-name apart from did-not-compile. What runs end to end: integer and float arithmetic with the normalisation each width needs, let, if, while with break and continue, calls, function values, structs, fixed arrays, slices, unions, options, match, and println through the same structural printer the other backends walk. Value semantics is the trap the object mapping sets and the reason the header carries a section on it. A Flan struct and a fixed array copy on assignment and a JS object does not, so every site emit.ml memcpys emits a generated Point$copy here. Fable's JS backend faces the same question for F# structs and answers it the other way -- it inserts no clone, and its Rust backend does -- so the divergence is deliberate and the survey pins it.
1395 lines
56 KiB
OCaml
1395 lines
56 KiB
OCaml
(** Tast -> JavaScript, by object mapping. A dialect, not a third target.
|
|
|
|
docs/DISCUSS.md item 5 settled the design fork before any of this was
|
|
written, and the settlement is the whole shape of this file: {b a Flan
|
|
struct becomes a plain JS object and a [Vec] becomes a JS array.} The
|
|
alternative — an [ArrayBuffer] standing in for linear memory, with typed
|
|
array reads and writes — is asm.js, which is what wasm exists to replace,
|
|
and it is precisely wrong for a backend whose reason to exist is calling
|
|
JS libraries. Games go to wasm. This is for web apps.
|
|
|
|
{1 What this is a dialect of}
|
|
|
|
Object mapping means the host's garbage collector owns every value, and
|
|
that is not a detail that can be papered over: {b the memory model does not
|
|
come along.} There are no addresses in JavaScript, so there is no
|
|
[(Ptr T)], no [free], no arena, no allocator and no [with-allocator]. A
|
|
program that uses them is not a program this backend compiles badly — it is
|
|
a program this backend {e refuses}, by name and with a location, which is
|
|
the house rule at [check.ml:14] applied at the one place that can see the
|
|
target. Nothing here approximates.
|
|
|
|
The refusals are in [refuse_ty] and in the [unsupported] calls through the
|
|
walk below. Each one names the feature and says which property of the
|
|
object mapping excludes it, because "js: unsupported" is a bug report
|
|
addressed to nobody.
|
|
|
|
{1 The mapping, in one table}
|
|
|
|
- [i8 i16 i32 u8 u16 u32], an enum, a [bool], [f32], [f64] — a JS number
|
|
(a boolean for [bool]). Every arithmetic result is normalised back into
|
|
the type's range at the site that produced it: see {!section:ints}.
|
|
- [i64] and [u64] — a [BigInt]. A double holds 53 bits exactly and these
|
|
types hold 64, so there is no honest alternative; it is slower and it is
|
|
right, and a wrong number silently is the outcome this repository refuses
|
|
everywhere else.
|
|
- A struct — a plain object, [{x: 1, y: 2}], keyed by the field's own name.
|
|
Readable output is a goal, and this is most of it.
|
|
- [[n T]], a fixed array — a JS array, or a [Uint8Array] when [T] is [u8].
|
|
- [[T]], a slice, and [string] — [{a, o, n}]: the backing store, an offset
|
|
into it and a length. A slice is a non-owning view in Flan and this is a
|
|
non-owning view here: writing through one writes the original, and a
|
|
copy of a slice shares its storage, both of which are what the other two
|
|
backends do with a (ptr, len) pair.
|
|
- A union — [{case: "Name", field: ...}]. [(Option T)] — [null] for
|
|
[None] and [{v: x}] for [Some], so that [(Some 0)] and [None] are not the
|
|
same value, which [0]-as-falsy would make them.
|
|
- [(Fn [..] R)] — a JS function. Function {e values} come along; they carry
|
|
no capture in Flan either.
|
|
|
|
{b [string] and [[u8]] are the same representation, and that is not a
|
|
shortcut.} [Tast.Bytes] and [Tast.StrOfBytes] are documented there as
|
|
non-instructions — in both existing backends a [string] {e is} a (ptr, len)
|
|
pair over bytes, and the two prims reinterpret rather than convert. Making
|
|
[string] a JS string would make [(len s)] count UTF-16 code units where
|
|
every other backend counts bytes, and the prelude is byte-oriented
|
|
throughout ([rune-count], [valid-utf8?], [decode-rune] all take [[u8]]).
|
|
So the JS string appears in exactly one place: the argument of
|
|
[$str(...)], where a literal is spelled, and it is UTF-8 encoded on the
|
|
way in. Decoding happens at [write-stdout] and nowhere else.
|
|
|
|
The backing store of a [u8] sequence is a [Uint8Array] rather than an
|
|
[Array] — the brief's "honest mapping" — and it buys more than honesty:
|
|
a [Uint8Array] masks on store, so [u8] wrapping is the store itself, and
|
|
it is the type a JS library that wants bytes already accepts.
|
|
|
|
{1:copies Value semantics, which is the trap}
|
|
|
|
A Flan struct and a fixed array are {e values}: binding, passing,
|
|
returning or storing one copies it, which is what [emit.ml] spends a
|
|
memcpy on at every one of those sites. A JS object assigns by reference.
|
|
Left alone, [(let [b a] ...)] on a struct would alias where the LLVM build
|
|
copied, and a mutation after the copy would diverge — silently, and only
|
|
in a program that actually mutates a copy.
|
|
|
|
So every site where [emit.ml] copies, this emits a clone: a [let] binding,
|
|
a [set], a call argument, a [return], a field or element store, a struct
|
|
or array literal's parts, and a [match] arm's binds. A generated
|
|
[Point$copy] per struct does it, recursively, because a field may be a
|
|
struct or an array of them. The clone is skipped where the value is
|
|
already fresh — a literal, a call's result, a new slice — which is what
|
|
keeps the output readable rather than a wall of [$copy].
|
|
|
|
A [Vec] is move-only in Flan and owns its storage, so a JS array is the
|
|
right thing for it and aliasing is the right behaviour: the trap is only
|
|
where Flan copies. Slices are views and copy as views, by the same rule.
|
|
|
|
{1:ints Integer semantics}
|
|
|
|
The known hard part, and the one place a silent wrong number is reachable.
|
|
The rule is that {b every value of type [T] is, at rest, always in [T]'s
|
|
range}, so comparisons, printing and equality need no normalisation of
|
|
their own and only the arithmetic sites do:
|
|
|
|
- 32 bits — [| 0] for the signed kinds, [>>> 0] for the unsigned ones, and
|
|
[Math.imul] for a multiply, which is exact modulo 2^32 where [a * b] is
|
|
not.
|
|
- 8 and 16 bits — [<< 24 >> 24], [<< 16 >> 16], [& 0xff], [& 0xffff].
|
|
- 64 bits — [BigInt.asIntN(64, ...)] and [BigInt.asUintN(64, ...)].
|
|
- A shift's count is masked to the operand's width, mirroring [emit.ml]'s
|
|
shift arm, which masks because LLVM makes an over-wide shift poison. The
|
|
mechanism is different — JS already masks a 32-bit shift and does not
|
|
mask an 8-bit one, because it has no 8-bit shift — so the mask is
|
|
written out rather than relied on.
|
|
- A divide truncates toward zero ([Math.trunc], not [| 0], which is only
|
|
the same below 2^31), and a remainder follows C, which JS's [%] already
|
|
does.
|
|
- [f32] rounds through [Math.fround] after every operation, because a JS
|
|
number is a double and a [float] is not.
|
|
|
|
A divide by zero, [INT_MIN / -1] and a float-to-integer cast out of range
|
|
all produce the same message and the same exit status [flan_rt.c] does —
|
|
[ArithError]'s unhandled sentence, verbatim, and 134. Without that,
|
|
[(/ x 0)] in JS is [Infinity], and [Infinity | 0] is [0]: a wrong number,
|
|
silently, which is the worst outcome available.
|
|
|
|
{1 What is refused, and why each}
|
|
|
|
Pointers and [deref], [free], allocators and [with-allocator], [Map],
|
|
[Pool] and [(Handle T)], [declare-c] and the FFI, [embed], conditions and
|
|
restarts ([signal], [handler-bind], [restart-case], [invoke-restart]), and
|
|
the type-erased container runtime's own entry points. The first group has
|
|
no counterpart in a garbage-collected object graph; the FFI and [embed]
|
|
are a host boundary this backend does not have; conditions are a stack
|
|
walk over a transfer channel and are a lane of their own, not a stub.
|
|
|
|
{1 Output}
|
|
|
|
One CommonJS file, with a small runtime at the top and the program under
|
|
it, ending in [process.exit(main())]. [require] rather than [import] so
|
|
that a bare [node out.js] runs it with no [package.json] to arrange.
|
|
Output goes through [fs.writeSync(1, ...)] rather than
|
|
[process.stdout.write], because node's stdout is asynchronous and a
|
|
[process.exit] after a write on it truncates the output — which would
|
|
look exactly like a codegen bug. *)
|
|
|
|
exception Unsupported of string
|
|
|
|
let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt
|
|
|
|
let at loc fmt =
|
|
Printf.ksprintf
|
|
(fun s -> raise (Unsupported (Loc.to_string loc ^ ": " ^ s)))
|
|
fmt
|
|
|
|
(* ── Names ──────────────────────────────────────────────────────────
|
|
|
|
A Flan name is not a JS identifier: [rand-u32], [bytes=?], [append!] and
|
|
[fn/sort-bytes!/0] are all ordinary. The rule below is injective, which is
|
|
what matters — two Flan names must never land on one JS name — and readable
|
|
second: [-] is the common case and becomes [_], so [rand-u32] reads as
|
|
[rand_u32], and an underscore that was actually written becomes [$_] so
|
|
that the two cannot collide. Everything else becomes [$] and two hex
|
|
digits. Nothing the rule produces starts with [$], which is how every
|
|
identifier this file invents for itself stays out of the way. *)
|
|
|
|
let reserved =
|
|
[ "break"; "case"; "catch"; "class"; "const"; "continue"; "debugger";
|
|
"default"; "delete"; "do"; "else"; "export"; "extends"; "finally"; "for";
|
|
"function"; "if"; "import"; "in"; "instanceof"; "new"; "return"; "super";
|
|
"switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while";
|
|
"with"; "yield"; "let"; "static"; "enum"; "await"; "implements";
|
|
"package"; "protected"; "interface"; "private"; "public"; "null"; "true";
|
|
"false"; "arguments"; "eval"; "undefined"; "NaN"; "Infinity" ]
|
|
|
|
let ident name =
|
|
let b = Buffer.create (String.length name + 4) in
|
|
String.iter
|
|
(fun c ->
|
|
match c with
|
|
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> Buffer.add_char b c
|
|
| '-' -> Buffer.add_char b '_'
|
|
| '_' -> Buffer.add_string b "$_"
|
|
| c -> Buffer.add_string b (Printf.sprintf "$%02x" (Char.code c)))
|
|
name;
|
|
let s = Buffer.contents b in
|
|
let s =
|
|
match s.[0] with '0' .. '9' -> "_" ^ s | _ -> s | exception _ -> "_empty"
|
|
in
|
|
if List.mem s reserved then s ^ "_" else s
|
|
|
|
(* A field or a case name reaches the output as a property. The same rule, so
|
|
that a struct with fields [x] and [x-y] keeps them apart, and so that
|
|
[v.pos_x] reads as the field the source spelled. *)
|
|
let prop name = ident name
|
|
|
|
let fname n = ident n
|
|
let gvar n = "g_" ^ ident n
|
|
|
|
(* ── Types: what the mapping admits ─────────────────────────────────── *)
|
|
|
|
let rec refuse_ty loc (t : Types.t) =
|
|
match t with
|
|
| Types.Int _ | Types.Float _ | Types.Bool | Types.String | Types.Unit
|
|
| Types.Never | Types.Named _ | Types.Enum _ -> ()
|
|
| Types.Slice t | Types.Array (_, t) | Types.Option t -> refuse_ty loc t
|
|
| Types.Vec t -> refuse_ty loc t
|
|
| Types.Fn (ps, r) -> List.iter (refuse_ty loc) ps; refuse_ty loc r
|
|
| Types.Ptr _ ->
|
|
at loc
|
|
"(Ptr T) is not in the JS dialect — JavaScript has no addresses, so a \
|
|
pointer has nothing to be. Pass the value, or a (Vec T) for storage \
|
|
that is shared"
|
|
| Types.Alloc ->
|
|
at loc
|
|
"Allocator is not in the JS dialect — the host's collector owns every \
|
|
value here, so there is no allocation to direct"
|
|
| Types.Map (_, _) ->
|
|
at loc
|
|
"(Map K V) is not in the JS dialect yet — Odin's open-addressed map is a \
|
|
type-erased runtime over raw bytes and the JS answer is a Map keyed by \
|
|
a structural key, which is its own lane"
|
|
| Types.Pool _ ->
|
|
at loc
|
|
"(Pool T) is not in the JS dialect — a pool hands out slot indices into \
|
|
storage it owns, which is the memory model this dialect leaves behind"
|
|
| Types.Handle _ ->
|
|
at loc
|
|
"(Handle T) is not in the JS dialect — a handle is an index into a Pool, \
|
|
and there is no Pool here"
|
|
| Types.Var n ->
|
|
at loc "a type variable (%s) reached the backend, which cannot happen" n
|
|
|
|
(* Aggregates in the sense that matters here: the types whose assignment
|
|
copies in Flan and would alias in JS. A slice is deliberately not one —
|
|
it is a view, and a copy of a view shares storage in every backend. *)
|
|
let rec is_agg (t : Types.t) =
|
|
match t with
|
|
| Types.Named _ | Types.Array _ -> true
|
|
| Types.Option t -> is_agg t
|
|
| _ -> false
|
|
|
|
let _ = is_agg
|
|
|
|
(* ── The emitted runtime ────────────────────────────────────────────
|
|
|
|
Small, and every line of it is either a representation decision from the
|
|
header or a message that has to agree with runtime/flan_rt.c character for
|
|
character. The survey diffs stderr, so a reworded sentence here is a
|
|
DIFFER. *)
|
|
|
|
let runtime =
|
|
{js|"use strict";
|
|
// The Flan runtime for the JS dialect. See lib/js.ml for what maps to what.
|
|
const $fs = require("fs");
|
|
|
|
// A slice, a string and a [u8] are one shape: a backing store, an offset and
|
|
// 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); }
|
|
function $bytes(xs) { const a = Uint8Array.from(xs); return $view(a, 0, a.length); }
|
|
function $buf(s) {
|
|
const a = s.a;
|
|
return a instanceof Uint8Array ? a.subarray(s.o, s.o + s.n)
|
|
: Uint8Array.from(a.slice(s.o, s.o + s.n));
|
|
}
|
|
function $out(s) { if (s.n > 0) $fs.writeSync(1, $buf(s)); }
|
|
|
|
// Exit 134 is abort()'s status without abort()'s signal, and stdout is
|
|
// written synchronously above, so the message lands after the output that
|
|
// led to it exactly as flan_rt.c's fflush(stdout) arranges.
|
|
function $die(msg) { $fs.writeSync(2, msg); process.exit(134); }
|
|
function $bounds(loc, i, n) {
|
|
$die(loc + ": index " + i + " is out of bounds for length " + n + "\n");
|
|
}
|
|
function $slicefail(loc, lo, hi, n) {
|
|
$die(loc + ": slice [" + lo + " " + hi + ") is out of bounds for length " + n + "\n");
|
|
}
|
|
function $divzero(loc, a) { $die(loc + ": divide by zero: (/ " + a + " 0)\n"); }
|
|
function $remzero(loc, a) { $die(loc + ": remainder by zero: (% " + a + " 0)\n"); }
|
|
function $divovf(loc, op, a, b) {
|
|
$die(loc + ": (" + op + " " + a + " " + b + ") overflows: the quotient is one past the largest value the type holds, and this is the only pair of operands for which that is true\n");
|
|
}
|
|
function $castrange(loc, lo, hi) {
|
|
$die(loc + ": this value does not fit the integer type it is cast to, which holds [" + lo + " " + hi + "]\n");
|
|
}
|
|
|
|
// Checked indexing and slicing. The comparison is the unsigned one flan_rt.c
|
|
// makes: a negative index is a huge length there and out of bounds here.
|
|
function $at(s, i, loc) {
|
|
if (i < 0 || i >= s.n) $bounds(loc, i, s.n);
|
|
return s.a[s.o + i];
|
|
}
|
|
function $set(s, i, v, loc) {
|
|
if (i < 0 || i >= s.n) $bounds(loc, i, s.n);
|
|
s.a[s.o + i] = v;
|
|
}
|
|
function $slice(s, lo, hi, loc) {
|
|
if (lo > hi || hi > s.n || lo < 0) $slicefail(loc, lo, hi, s.n);
|
|
return $view(s.a, s.o + lo, hi - lo);
|
|
}
|
|
// A fixed array is its own store; indexing one is the same check without a view.
|
|
function $aat(a, i, loc) {
|
|
if (i < 0 || i >= a.length) $bounds(loc, i, a.length);
|
|
return a[i];
|
|
}
|
|
function $aset(a, i, v, loc) {
|
|
if (i < 0 || i >= a.length) $bounds(loc, i, a.length);
|
|
a[i] = v;
|
|
}
|
|
function $aslice(a, lo, hi, loc) {
|
|
if (lo > hi || hi > a.length || lo < 0) $slicefail(loc, lo, hi, a.length);
|
|
return $view(a, lo, hi - lo);
|
|
}
|
|
|
|
// %lld and %llu. A BigInt prints its digits and nothing else, which is what
|
|
// the two shims in flan_rt.c do.
|
|
function $i64s(x) { return $str(String(x)); }
|
|
// C's "%g": six significant digits, exponent form outside [1e-4, 1e6), and
|
|
// trailing zeros stripped. Written out because String(x) is none of those.
|
|
function $g(x) {
|
|
if (Number.isNaN(x)) return "nan";
|
|
if (!Number.isFinite(x)) return x > 0 ? "inf" : "-inf";
|
|
if (x === 0) return Object.is(x, -0) ? "-0" : "0";
|
|
const e = Number(x.toExponential(5).split("e")[1]);
|
|
if (e < -4 || e >= 6) {
|
|
let m = x.toExponential(5).split("e")[0];
|
|
if (m.indexOf(".") >= 0) m = m.replace(/0+$/, "").replace(/\.$/, "");
|
|
const s = e < 0 ? "-" : "+";
|
|
const a = Math.abs(e);
|
|
return m + "e" + s + (a < 10 ? "0" + a : String(a));
|
|
}
|
|
let t = x.toFixed(Math.max(0, 5 - e));
|
|
if (t.indexOf(".") >= 0) t = t.replace(/0+$/, "").replace(/\.$/, "");
|
|
return t;
|
|
}
|
|
function $f64s(x) { return $str($g(x)); }
|
|
|
|
// strtoll and strtod over the leading text, which is what the C shims do:
|
|
// no digits is 0, and strtoll saturates at the ends of the type.
|
|
function $tobytesi64(s) {
|
|
const t = Buffer.from($buf(s)).toString("latin1");
|
|
const m = /^[ \t\n\r\f\v]*[+-]?[0-9]+/.exec(t);
|
|
if (!m) return 0n;
|
|
let v = BigInt(m[0].replace(/^[ \t\n\r\f\v]*/, ""));
|
|
const lo = -(2n ** 63n), hi = 2n ** 63n - 1n;
|
|
return v < lo ? lo : v > hi ? hi : v;
|
|
}
|
|
function $tobytesf64(s) {
|
|
const t = Buffer.from($buf(s)).toString("latin1");
|
|
const m = /^[ \t\n\r\f\v]*[+-]?(?:[0-9]*\.?[0-9]+(?:[eE][+-]?[0-9]+)?|[0-9]+\.)/.exec(t);
|
|
return m ? parseFloat(m[0]) : 0;
|
|
}
|
|
|
|
// The escape table of flan_escape_bytes, including its 1024-byte buffer and
|
|
// its ellipsis, because a printed structure must read the same on both.
|
|
function $esc(s) {
|
|
const p = $buf(s);
|
|
const o = [34];
|
|
let cut = 0;
|
|
for (let i = 0; i < p.length; i++) {
|
|
if (o.length + 5 + 4 >= 1024) { cut = 1; break; }
|
|
const c = p[i];
|
|
if (c === 34) { o.push(92, 34); }
|
|
else if (c === 92) { o.push(92, 92); }
|
|
else if (c === 10) { o.push(92, 110); }
|
|
else if (c === 9) { o.push(92, 116); }
|
|
else if (c === 13) { o.push(92, 114); }
|
|
else if (c < 0x20) {
|
|
const h = "\\x" + c.toString(16).padStart(2, "0");
|
|
for (let k = 0; k < h.length; k++) o.push(h.charCodeAt(k));
|
|
} else o.push(c);
|
|
}
|
|
if (cut) o.push(46, 46, 46);
|
|
o.push(34);
|
|
return $bytes(o);
|
|
}
|
|
|
|
function $argv() {
|
|
const xs = process.argv.slice(1).map($str);
|
|
return $view(xs, 0, xs.length);
|
|
}
|
|
|js}
|
|
|
|
(* ── The module state ───────────────────────────────────────────────── *)
|
|
|
|
type m = {
|
|
out : Buffer.t; (* the program text *)
|
|
structs : (string, Tast.structure) Hashtbl.t;
|
|
unions : (string, Tast.union) Hashtbl.t;
|
|
checks : bool;
|
|
mutable strs : (string * string) list; (* literal -> its const name *)
|
|
mutable nstr : int;
|
|
mutable copies : string list; (* struct names needing a $copy *)
|
|
}
|
|
|
|
type f = {
|
|
md : m;
|
|
b : Buffer.t;
|
|
mutable ind : int;
|
|
mutable n : int; (* temporaries *)
|
|
names : string array; (* slot index -> JS name *)
|
|
slots : Types.t array;
|
|
ret : Types.t;
|
|
mutable loops : (string * string) list; (* break label, continue label *)
|
|
}
|
|
|
|
let line f fmt =
|
|
Printf.ksprintf
|
|
(fun s ->
|
|
Buffer.add_string f.b (String.make (f.ind * 2) ' ');
|
|
Buffer.add_string f.b s;
|
|
Buffer.add_char f.b '\n')
|
|
fmt
|
|
|
|
let fresh f = f.n <- f.n + 1; Printf.sprintf "t%d" f.n
|
|
|
|
(* A JS string literal for a run of bytes. Printable ASCII stays readable;
|
|
anything else goes out as numbers, because the output file's own encoding
|
|
must not decide what a byte literal meant. *)
|
|
let js_string s =
|
|
let b = Buffer.create (String.length s + 2) in
|
|
Buffer.add_char b '"';
|
|
String.iter
|
|
(fun c ->
|
|
match c with
|
|
| '"' -> Buffer.add_string b "\\\""
|
|
| '\\' -> Buffer.add_string b "\\\\"
|
|
| '\n' -> Buffer.add_string b "\\n"
|
|
| '\t' -> Buffer.add_string b "\\t"
|
|
| '\r' -> Buffer.add_string b "\\r"
|
|
| c when Char.code c >= 0x20 && Char.code c < 0x7f -> Buffer.add_char b c
|
|
| c -> Buffer.add_string b (Printf.sprintf "\\u%04x" (Char.code c)))
|
|
s;
|
|
Buffer.add_char b '"';
|
|
Buffer.contents b
|
|
|
|
let printable s =
|
|
let ok = ref true in
|
|
String.iter
|
|
(fun c -> if Char.code c < 0x20 || Char.code c >= 0x7f then ok := false)
|
|
s;
|
|
!ok
|
|
|
|
(* Literals are interned: one const per distinct text, built once at load, so
|
|
that a string in a loop is not re-encoded per iteration and so that the
|
|
identity of a literal is stable the way a .rodata address is. *)
|
|
let string_const m s =
|
|
match List.assoc_opt s m.strs with
|
|
| Some n -> n
|
|
| None ->
|
|
let n = Printf.sprintf "$s%d" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
m.strs <- (s, n) :: m.strs;
|
|
n
|
|
|
|
let locstr loc = js_string (Loc.to_string loc)
|
|
|
|
(* ── Copying a value ────────────────────────────────────────────────
|
|
|
|
See the header's "Value semantics" section. [copy_of] is the JS expression
|
|
that produces a private copy of [v] at type [t], and [None] means the type
|
|
copies by assignment already. *)
|
|
|
|
let rec copy_of m (t : Types.t) v =
|
|
match t with
|
|
| 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 ->
|
|
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) -> (
|
|
match copy_of m e "x" with
|
|
| None -> Some (Printf.sprintf "%s.slice()" v)
|
|
| Some c -> Some (Printf.sprintf "%s.map((x) => %s)" v c))
|
|
| Types.Option e -> (
|
|
match copy_of m e "x" with
|
|
| None -> None
|
|
| Some c ->
|
|
Some (Printf.sprintf "(%s === null ? null : { v: ((x) => %s)(%s.v) })" v c v))
|
|
| _ -> None
|
|
|
|
(* A value that was just built is already private; cloning it would be a copy
|
|
of a copy. Everything else may be a second name for storage someone else
|
|
holds. A call's result is fresh because [return] clones on the way out. *)
|
|
let rec fresh_value (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Make _ | Tast.Arr _ | Tast.Zero _ | Tast.Uninit _ | Tast.Call _
|
|
| Tast.CallPtr _ | Tast.MakeCase _ | Tast.Int _ | Tast.Float _
|
|
| Tast.Bool _ | Tast.Str _ | Tast.Unit | Tast.None_ -> true
|
|
| Tast.Some_ v -> fresh_value v
|
|
| Tast.Prim (Tast.Rt _, _) -> true
|
|
| _ -> false
|
|
|
|
(* ── Integer normalisation ──────────────────────────────────────────── *)
|
|
|
|
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. *)
|
|
let norm (k : Types.ikind) s =
|
|
match k with
|
|
| Types.I64 -> Printf.sprintf "BigInt.asIntN(64, %s)" s
|
|
| Types.U64 -> Printf.sprintf "BigInt.asUintN(64, %s)" s
|
|
| Types.I32 -> Printf.sprintf "(%s | 0)" s
|
|
| Types.U32 -> Printf.sprintf "(%s >>> 0)" s
|
|
| Types.I16 -> Printf.sprintf "((%s) << 16 >> 16)" s
|
|
| Types.U16 -> Printf.sprintf "((%s) & 0xffff)" s
|
|
| Types.I8 -> Printf.sprintf "((%s) << 24 >> 24)" s
|
|
| Types.U8 -> Printf.sprintf "((%s) & 0xff)" s
|
|
|
|
let fround (k : Types.fkind) s =
|
|
match k with Types.F32 -> Printf.sprintf "Math.fround(%s)" s | Types.F64 -> s
|
|
|
|
(* The literal spelling of an integer of a given kind: a BigInt gets its [n]. *)
|
|
let int_lit k (v : int64) =
|
|
match k with
|
|
| Types.I64 -> Printf.sprintf "%Ldn" v
|
|
| Types.U64 ->
|
|
if Int64.compare v 0L >= 0 then Printf.sprintf "%Ldn" v
|
|
else Printf.sprintf "%sn" (Printf.sprintf "%Lu" v)
|
|
| Types.U32 | Types.U16 | Types.U8 ->
|
|
Printf.sprintf "%Ld" (Int64.logand v (Int64.of_int 0xffffffff))
|
|
| _ -> Printf.sprintf "%Ld" v
|
|
|
|
let float_lit (x : float) =
|
|
if Float.is_integer x && Float.abs x < 1e21 then Printf.sprintf "%.1f" x
|
|
else if Float.is_nan x then "NaN"
|
|
else if x = Float.infinity then "Infinity"
|
|
else if x = Float.neg_infinity then "-Infinity"
|
|
else
|
|
(* Shortest round-tripping decimal. OCaml's %.17g always round-trips; the
|
|
shorter spellings are tried first so the output stays readable. *)
|
|
let rec go p =
|
|
if p > 17 then Printf.sprintf "%.17g" x
|
|
else
|
|
let s = Printf.sprintf "%.*g" p x in
|
|
if float_of_string s = x then s else go (p + 1)
|
|
in
|
|
go 1
|
|
|
|
(* ── Zero of a type, which is ZII settled here ──────────────────────── *)
|
|
|
|
let rec zero m loc (t : Types.t) =
|
|
refuse_ty loc t;
|
|
match t with
|
|
| Types.Int k -> if big k then "0n" else "0"
|
|
| Types.Float _ -> "0.0"
|
|
| Types.Bool -> "false"
|
|
| Types.Enum _ -> "0"
|
|
| Types.Unit -> "undefined"
|
|
| Types.String | Types.Slice _ -> "$view([], 0, 0)"
|
|
| Types.Option _ -> "null"
|
|
| Types.Array (n, e) ->
|
|
(match e with
|
|
| Types.Int Types.U8 -> Printf.sprintf "new Uint8Array(%Ld)" n
|
|
| _ ->
|
|
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
|
|
Printf.sprintf "{ %s }"
|
|
(String.concat ", "
|
|
(List.map
|
|
(fun (fl : Tast.field) ->
|
|
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 ->
|
|
(* 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
|
|
(match u.Tast.cases with
|
|
| [] -> at loc "union %s has no cases" n
|
|
| c :: _ ->
|
|
Printf.sprintf "{ case: %s%s }" (js_string c.Tast.vname)
|
|
(String.concat ""
|
|
(List.map
|
|
(fun (fl : Tast.field) ->
|
|
Printf.sprintf ", %s: %s" (prop fl.Tast.fname)
|
|
(zero m loc fl.Tast.fty))
|
|
c.Tast.vfields)))
|
|
| Types.Fn _ -> "null"
|
|
| Types.Vec _ -> "[]"
|
|
| t -> at loc "no zero value for %s in the JS dialect" (Types.to_string t)
|
|
|
|
(* ── Places and expressions ─────────────────────────────────────────── *)
|
|
|
|
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
|
|
| t -> at loc "a field of %s, which is not a struct" (Types.to_string t)
|
|
|
|
let elem_ty loc (t : Types.t) =
|
|
match t with
|
|
| Types.Slice e | Types.Array (_, e) -> e
|
|
| Types.String -> Types.Int Types.U8
|
|
| t -> at loc "indexing %s is not in the JS dialect" (Types.to_string t)
|
|
|
|
let is_bytes (t : Types.t) =
|
|
match t with
|
|
| Types.String -> true
|
|
| Types.Slice (Types.Int Types.U8) | Types.Array (_, Types.Int Types.U8) ->
|
|
true
|
|
| _ -> false
|
|
|
|
let rec value f (e : Tast.expr) : string =
|
|
refuse_ty e.Tast.loc e.Tast.ty;
|
|
match e.Tast.e with
|
|
| Tast.Int (v, k) ->
|
|
(match e.Tast.ty with
|
|
| Types.Enum _ -> Printf.sprintf "%Ld" v
|
|
| _ -> int_lit k v)
|
|
| Tast.Float (x, _) -> float_lit x
|
|
| Tast.Bool b -> if b then "true" else "false"
|
|
| Tast.Str s ->
|
|
let n = string_const f.md s in
|
|
n
|
|
| Tast.Unit -> "undefined"
|
|
| Tast.Zero t -> zero f.md e.Tast.loc t
|
|
(* [uninit] is the opt-out from zeroing. There is no uninitialised memory
|
|
here to opt out of, so it is the zero — which is more than the program
|
|
asked for and never less. *)
|
|
| Tast.Uninit t -> zero f.md e.Tast.loc t
|
|
| Tast.Local i -> f.names.(i)
|
|
| Tast.Global n -> gvar n
|
|
| Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n) -> fname n
|
|
| Tast.FnAddr (Tast.Rtfn n) ->
|
|
at e.Tast.loc
|
|
"the runtime entry point %s has no JS counterpart — it is C in \
|
|
flan_rt.c, and this dialect has no C"
|
|
n
|
|
| Tast.Prim (p, args) -> prim f e p args
|
|
| Tast.Call (n, args) ->
|
|
Printf.sprintf "%s(%s)" (fname n) (String.concat ", " (call_args f args))
|
|
| 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)
|
|
| Tast.CaseField (x, case, i) ->
|
|
let n =
|
|
match x.Tast.ty with
|
|
| 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
|
|
(match Tast.case_index u case with
|
|
| Some (_, c) ->
|
|
Printf.sprintf "%s.%s" (spill f x)
|
|
(prop (List.nth c.Tast.vfields i).Tast.fname)
|
|
| None -> at e.Tast.loc "no case %s of %s" case n)
|
|
| Tast.Make (n, parts) ->
|
|
let s = Hashtbl.find f.md.structs n in
|
|
let vs = List.map (fun p -> bind_value f p) parts in
|
|
Printf.sprintf "{ %s }"
|
|
(String.concat ", "
|
|
(List.map2
|
|
(fun (fl : Tast.field) v ->
|
|
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
|
|
(match Tast.case_index u case with
|
|
| None -> at e.Tast.loc "no case %s of %s" case n
|
|
| Some (_, c) ->
|
|
let vs = List.map (fun p -> bind_value f p) parts in
|
|
Printf.sprintf "{ case: %s%s }" (js_string case)
|
|
(String.concat ""
|
|
(List.map2
|
|
(fun (fl : Tast.field) v ->
|
|
Printf.sprintf ", %s: %s" (prop fl.Tast.fname) v)
|
|
c.Tast.vfields vs)))
|
|
| Tast.Arr parts ->
|
|
let vs = List.map (fun p -> bind_value f p) parts in
|
|
(match e.Tast.ty with
|
|
| Types.Array (_, Types.Int Types.U8) ->
|
|
Printf.sprintf "Uint8Array.of(%s)" (String.concat ", " vs)
|
|
| _ -> Printf.sprintf "[%s]" (String.concat ", " vs))
|
|
| Tast.Some_ v -> Printf.sprintf "{ v: %s }" (bind_value f v)
|
|
| Tast.None_ -> "null"
|
|
| Tast.Addr _ | Tast.Deref _ ->
|
|
at e.Tast.loc
|
|
"an address is not in the JS dialect — JavaScript has no addresses, so \
|
|
(addr-of x) and a deref have nothing to name"
|
|
| Tast.Signal _ ->
|
|
at e.Tast.loc
|
|
"signalling a condition is not in the JS dialect yet — the handler \
|
|
stack and the transfer channel are a lane of their own"
|
|
| Tast.Handled _ ->
|
|
at e.Tast.loc
|
|
"handler-bind is not in the JS dialect yet — the handler stack and the \
|
|
transfer channel are a lane of their own"
|
|
| Tast.RestartCase _ ->
|
|
at e.Tast.loc
|
|
"restart-case is not in the JS dialect yet — a restart is a frame on a \
|
|
stack this backend does not build"
|
|
| Tast.InvokeRestart _ ->
|
|
at e.Tast.loc
|
|
"invoke-restart is not in the JS dialect yet — a restart is a frame on \
|
|
a stack this backend does not build"
|
|
| Tast.WithAlloc _ ->
|
|
at e.Tast.loc
|
|
"with-allocator is not in the JS dialect — the host's collector owns \
|
|
every value here, so there is no allocator to rebind"
|
|
(* Everything below is statement-shaped: it needs a temporary to be a value.
|
|
[stmt] writes into the name this hands it. *)
|
|
| Tast.Do _ | Tast.Let _ | Tast.If _ | Tast.While _ | Tast.Match _
|
|
| Tast.UnwrapSome _ | Tast.Set _ | Tast.Return _ | Tast.Break _
|
|
| Tast.Continue _ ->
|
|
if Types.equal e.Tast.ty Types.Unit || Types.equal e.Tast.ty Types.Never
|
|
then begin
|
|
stmt f None e;
|
|
"undefined"
|
|
end
|
|
else begin
|
|
let t = fresh f in
|
|
line f "let %s;" t;
|
|
stmt f (Some t) e;
|
|
t
|
|
end
|
|
|
|
(* An expression whose JS text has no side effect and no evaluation order to
|
|
respect. Used to decide whether an operand has to go through a temporary
|
|
before the next one is compiled. *)
|
|
and simple (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit
|
|
| Tast.Local _ | Tast.Global _ | Tast.None_ | Tast.FnAddr _ -> true
|
|
| Tast.Field (x, _) | Tast.CaseField (x, _, _) -> simple x
|
|
| _ -> false
|
|
|
|
(* Evaluate into a name if the expression is not already one. *)
|
|
and spill f (e : Tast.expr) =
|
|
if simple e then value f e
|
|
else begin
|
|
let t = fresh f in
|
|
line f "const %s = %s;" t (value f e);
|
|
t
|
|
end
|
|
|
|
(* A list of expressions, left to right, with the order preserved: once one of
|
|
them has to emit a statement, every operand before it is already in a
|
|
temporary, so nothing is re-ordered. *)
|
|
and evals f (es : Tast.expr list) =
|
|
let rec go acc = function
|
|
| [] -> List.rev acc
|
|
| [ last ] -> List.rev (value f last :: acc)
|
|
| e :: rest ->
|
|
let v = if simple e then value f e else spill f e in
|
|
go (v :: acc) rest
|
|
in
|
|
go [] es
|
|
|
|
(* A value about to be bound to something that outlives the expression. See
|
|
the header's "Value semantics". *)
|
|
and bind_value f (e : Tast.expr) =
|
|
let v = value f e in
|
|
if fresh_value e then v
|
|
else match copy_of f.md e.Tast.ty v with Some c -> c | None -> v
|
|
|
|
and call_args f (args : Tast.expr list) =
|
|
let vs = evals f args in
|
|
List.map2
|
|
(fun (a : Tast.expr) v ->
|
|
if fresh_value a then v
|
|
else match copy_of f.md a.Tast.ty v with Some c -> c | None -> v)
|
|
args vs
|
|
|
|
(* ── Primitives ─────────────────────────────────────────────────────── *)
|
|
|
|
and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
|
let loc = e.Tast.loc in
|
|
match (p, args) with
|
|
| (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
|
|
arith f e p x y
|
|
| (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
|
|
let op =
|
|
match p with
|
|
| Tast.Eq -> "===" | Tast.Ne -> "!==" | Tast.Lt -> "<"
|
|
| Tast.Le -> "<=" | Tast.Gt -> ">" | _ -> ">="
|
|
in
|
|
(match evals f [ x; y ] with
|
|
| [ a; b ] -> Printf.sprintf "(%s %s %s)" a op b
|
|
| _ -> assert false)
|
|
| Tast.Not, [ x ] -> Printf.sprintf "(!%s)" (value f x)
|
|
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ]
|
|
-> bitwise f e p x y
|
|
| Tast.Len, [ x ] -> (
|
|
match x.Tast.ty with
|
|
| Types.Array (n, _) -> Printf.sprintf "%Ld" n
|
|
| Types.String | Types.Slice _ -> Printf.sprintf "%s.n" (spill f x)
|
|
| t -> at loc "(len %s) is not in the JS dialect" (Types.to_string t))
|
|
| Tast.At, target :: idx -> index f loc target idx
|
|
| Tast.Slice, [ target; lo; hi ] -> (
|
|
match evals f [ target; lo; hi ] with
|
|
| [ t; a; b ] ->
|
|
let fn = match target.Tast.ty with
|
|
| Types.Array _ -> "$aslice" | _ -> "$slice"
|
|
in
|
|
Printf.sprintf "%s(%s, %s, %s, %s)" fn t a b (locstr loc)
|
|
| _ -> assert false)
|
|
| Tast.SliceFromPtr, _ ->
|
|
at loc
|
|
"(slice-from-ptr p n) is not in the JS dialect — it makes a slice out of \
|
|
an address, and JavaScript has no addresses"
|
|
(* [Bytes] and [StrOfBytes] are reinterprets in every backend: a string is a
|
|
run of bytes here as it is there. See the header. *)
|
|
| (Tast.Bytes | Tast.StrOfBytes), [ x ] -> value f x
|
|
| Tast.BytesToF64, [ x ] -> Printf.sprintf "$tobytesf64(%s)" (value f x)
|
|
| Tast.BytesToI64, [ x ] -> Printf.sprintf "$tobytesi64(%s)" (value f x)
|
|
| Tast.F64ToBytes, [ x ] -> Printf.sprintf "$f64s(%s)" (value f x)
|
|
| (Tast.I64ToBytes | Tast.U64ToBytes), [ x ] ->
|
|
Printf.sprintf "$i64s(%s)" (value f x)
|
|
| Tast.EscapeBytes, [ x ] -> Printf.sprintf "$esc(%s)" (value f x)
|
|
| Tast.WriteStdout, [ x ] -> Printf.sprintf "$out(%s)" (value f x)
|
|
| Tast.Exit, [ x ] ->
|
|
Printf.sprintf "process.exit(Number(%s))" (value f x)
|
|
| Tast.Argv, [] -> "$argv()"
|
|
| Tast.Cast t, [ x ] -> cast f loc t x
|
|
| Tast.AddrOf, _ ->
|
|
at loc
|
|
"(addr-of x) is not in the JS dialect — JavaScript has no addresses"
|
|
| (Tast.SizeOf _ | Tast.AlignOf _), _ ->
|
|
at loc
|
|
"a size or an alignment is not in the JS dialect — an object has no \
|
|
layout here, which is the whole point of the object mapping"
|
|
| Tast.Rt sym, _ ->
|
|
at loc
|
|
"%s is the type-erased container runtime, which is C in flan_rt.c — the \
|
|
JS dialect has no counterpart for it yet"
|
|
sym
|
|
| _ -> at loc "this primitive is not in the JS dialect yet"
|
|
|
|
(* [(at grid y x)] is one node with a list of indices, innermost last. Each
|
|
step but the last goes through a temporary, because the element it names is
|
|
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 =
|
|
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)
|
|
else
|
|
match bty with
|
|
| Types.Array _ -> Printf.sprintf "%s[%s]" base iv
|
|
| _ -> Printf.sprintf "%s.a[%s.o + %s]" base base iv
|
|
in
|
|
let rec go base bty = function
|
|
| [] -> base
|
|
| [ i ] -> step base bty (value f i)
|
|
| i :: rest ->
|
|
let one = step base bty (value f i) in
|
|
let t = fresh f in
|
|
line f "const %s = %s;" t one;
|
|
go t (elem_ty loc bty) rest
|
|
in
|
|
go tv target.Tast.ty idxs
|
|
|
|
and arith f (e : Tast.expr) p x y =
|
|
let loc = e.Tast.loc in
|
|
let a, b =
|
|
match evals f [ x; y ] with [ a; b ] -> (a, b) | _ -> assert false
|
|
in
|
|
match e.Tast.ty with
|
|
| Types.Float k ->
|
|
let op =
|
|
match p with
|
|
| Tast.Add -> "+" | Tast.Sub -> "-" | Tast.Mul -> "*"
|
|
| Tast.Div -> "/" | _ -> "%"
|
|
in
|
|
fround k (Printf.sprintf "(%s %s %s)" a op b)
|
|
| Types.Int k ->
|
|
(match p with
|
|
| Tast.Add -> norm k (Printf.sprintf "%s + %s" a b)
|
|
| Tast.Sub -> norm k (Printf.sprintf "%s - %s" a b)
|
|
| Tast.Mul ->
|
|
if big k then norm k (Printf.sprintf "%s * %s" a b)
|
|
else
|
|
(* Math.imul is exact modulo 2^32 where a * b loses the low bits
|
|
once the product passes 2^53. Every kind below 32 bits is exact
|
|
in it too, since the mask that follows only keeps low bits. *)
|
|
norm k (Printf.sprintf "Math.imul(%s, %s)" a b)
|
|
| Tast.Div | Tast.Rem ->
|
|
let is_rem = p = Tast.Rem in
|
|
check_div f loc k ~is_rem a b;
|
|
if is_rem then norm k (Printf.sprintf "%s %% %s" a b)
|
|
else if big k then norm k (Printf.sprintf "%s / %s" a b)
|
|
else norm k (Printf.sprintf "Math.trunc(%s / %s)" a b)
|
|
| _ -> assert false)
|
|
| t -> at loc "arithmetic on %s" (Types.to_string t)
|
|
|
|
(* The two tests emit.ml's [check_div] emits, with the same elisions: a
|
|
literal divisor that cannot be zero needs no zero test, and one that cannot
|
|
be -1 needs no overflow test. The sentences are flan_rt.c's, verbatim,
|
|
because the survey diffs stderr. *)
|
|
and check_div f loc (k : Types.ikind) ~is_rem a b =
|
|
if f.md.checks then begin
|
|
let zero_lit = if big k then "0n" else "0" in
|
|
let neg1 = if big k then "-1n" else "-1" in
|
|
let need_zero = not (b = zero_lit) in
|
|
let need_ovf = Types.signed k && b <> zero_lit in
|
|
if need_zero then
|
|
line f "if (%s === %s) $%s(%s, %s);" b zero_lit
|
|
(if is_rem then "remzero" else "divzero")
|
|
(locstr loc) a;
|
|
if need_ovf then begin
|
|
let lo =
|
|
let bits = Types.bits k in
|
|
if bits = 64 then "-9223372036854775808n"
|
|
else Printf.sprintf "%d" (-(1 lsl (bits - 1)))
|
|
in
|
|
line f "if (%s === %s && %s === %s) $divovf(%s, %s, %s, %s);" a lo b neg1
|
|
(locstr loc)
|
|
(js_string (if is_rem then "%" else "/"))
|
|
a b
|
|
end
|
|
end
|
|
|
|
and bitwise f (e : Tast.expr) p x y =
|
|
let a, b =
|
|
match evals f [ x; y ] with [ a; b ] -> (a, b) | _ -> assert false
|
|
in
|
|
let k =
|
|
match x.Tast.ty with
|
|
| Types.Int k -> k
|
|
| t -> at e.Tast.loc "a bitwise operation on %s" (Types.to_string t)
|
|
in
|
|
(* The count is masked to the operand's width, mirroring emit.ml's shift
|
|
arm. JS masks a 32-bit shift itself and has no 8- or 16-bit shift at
|
|
all, so the mask is written rather than relied on. *)
|
|
let b =
|
|
match p with
|
|
| Tast.Shl | Tast.Shr ->
|
|
if big k then Printf.sprintf "(%s & %dn)" b (Types.bits k - 1)
|
|
else Printf.sprintf "(%s & %d)" b (Types.bits k - 1)
|
|
| _ -> b
|
|
in
|
|
match p with
|
|
| Tast.BitAnd -> norm k (Printf.sprintf "%s & %s" a b)
|
|
| Tast.BitOr -> norm k (Printf.sprintf "%s | %s" a b)
|
|
| Tast.BitXor -> norm k (Printf.sprintf "%s ^ %s" a b)
|
|
| Tast.Shl -> norm k (Printf.sprintf "%s << %s" a b)
|
|
| Tast.Shr ->
|
|
if big k then norm k (Printf.sprintf "%s >> %s" a b)
|
|
else if Types.signed k then norm k (Printf.sprintf "%s >> %s" a b)
|
|
else
|
|
(* An unsigned value below 32 bits is already a non-negative number, so
|
|
>> and >>> agree on it; at 32 bits only >>> does. *)
|
|
norm k (Printf.sprintf "%s >>> %s" a b)
|
|
| _ -> assert false
|
|
|
|
and cast f loc (t : Types.t) (x : Tast.expr) =
|
|
refuse_ty loc t;
|
|
let src = x.Tast.ty in
|
|
let v = value f x in
|
|
match (src, t) with
|
|
| Types.Int a, Types.Int b when a = b -> v
|
|
| (Types.Enum _ | Types.Int _), (Types.Enum _ | Types.Int _) ->
|
|
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)
|
|
| 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
|
|
fround k (if sbig then Printf.sprintf "Number(%s)" v else v)
|
|
| Types.Float _, Types.Int k ->
|
|
let t0 = fresh f in
|
|
line f "const %s = %s;" t0 v;
|
|
if f.md.checks then begin
|
|
let bits = Types.bits k in
|
|
let lo, hi =
|
|
if Types.signed k then
|
|
( Printf.sprintf "-%s" (two_pow (bits - 1)),
|
|
Printf.sprintf "%s" (two_pow (bits - 1)) )
|
|
else ("0", two_pow bits)
|
|
in
|
|
let ilo, ihi =
|
|
if Types.signed k then
|
|
(Printf.sprintf "-%s" (two_pow (bits - 1)),
|
|
Printf.sprintf "%s" (dec_sub1 (two_pow (bits - 1))))
|
|
else ("0", dec_sub1 (two_pow bits))
|
|
in
|
|
line f "if (!(%s >= %s && %s < %s)) $castrange(%s, %s, %s);" t0 lo t0 hi
|
|
(locstr loc) ilo ihi
|
|
end;
|
|
if big k then norm k (Printf.sprintf "BigInt(Math.trunc(%s))" t0)
|
|
else norm k (Printf.sprintf "Math.trunc(%s)" t0)
|
|
| Types.Bool, Types.Int k -> norm k (Printf.sprintf "(%s ? 1 : 0)" v)
|
|
| a, b ->
|
|
at loc "a cast from %s to %s is not in the JS dialect"
|
|
(Types.to_string a) (Types.to_string b)
|
|
|
|
(* 2^n as a decimal literal, exact for every n a machine integer can need. *)
|
|
and two_pow n =
|
|
let rec go acc i = if i = 0 then acc else go (mul2 acc) (i - 1) in
|
|
go "1" n
|
|
|
|
and mul2 s =
|
|
let n = String.length s in
|
|
let out = Bytes.make (n + 1) '0' in
|
|
let carry = ref 0 in
|
|
for i = n - 1 downto 0 do
|
|
let d = (Char.code s.[i] - 48) * 2 + !carry in
|
|
Bytes.set out (i + 1) (Char.chr (48 + (d mod 10)));
|
|
carry := d / 10
|
|
done;
|
|
Bytes.set out 0 (Char.chr (48 + !carry));
|
|
let s = Bytes.to_string out in
|
|
if s.[0] = '0' then String.sub s 1 n else s
|
|
|
|
and dec_sub1 s =
|
|
let b = Bytes.of_string s in
|
|
let rec go i =
|
|
if i < 0 then ()
|
|
else if Bytes.get b i = '0' then (Bytes.set b i '9'; go (i - 1))
|
|
else Bytes.set b i (Char.chr (Char.code (Bytes.get b i) - 1))
|
|
in
|
|
go (Bytes.length b - 1);
|
|
let s = Bytes.to_string b in
|
|
if String.length s > 1 && s.[0] = '0' then String.sub s 1 (String.length s - 1)
|
|
else s
|
|
|
|
(* ── Statements ─────────────────────────────────────────────────────── *)
|
|
|
|
and assign f dest v =
|
|
match dest with None -> line f "%s;" v | Some d -> line f "%s = %s;" d v
|
|
|
|
and stmt f dest (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Do body -> block f dest body
|
|
| Tast.Let (binds, body) ->
|
|
List.iter
|
|
(fun (slot, v) ->
|
|
let x = bind_value f v in
|
|
line f "%s = %s;" f.names.(slot) x)
|
|
binds;
|
|
block f dest body
|
|
| Tast.If (c, a, b) ->
|
|
let cv = value f c in
|
|
line f "if (%s) {" cv;
|
|
f.ind <- f.ind + 1;
|
|
stmt f dest a;
|
|
f.ind <- f.ind - 1;
|
|
line f "} else {";
|
|
f.ind <- f.ind + 1;
|
|
stmt f dest b;
|
|
f.ind <- f.ind - 1;
|
|
line f "}"
|
|
| Tast.While (c, body, latch) ->
|
|
let d = List.length f.loops in
|
|
let lb = Printf.sprintf "$b%d" d and lc = Printf.sprintf "$c%d" d in
|
|
line f "%s: for (;;) {" lb;
|
|
f.ind <- f.ind + 1;
|
|
let cv = value f c in
|
|
line f "if (!(%s)) break %s;" cv lb;
|
|
(* The body is a labelled block and the latch is after it, so a continue
|
|
runs the latch — emit.ml's reason for the latch existing at all: a
|
|
[dotimes] step written in the body would be skipped by a continue and
|
|
the loop would never advance. *)
|
|
line f "%s: {" lc;
|
|
f.ind <- f.ind + 1;
|
|
f.loops <- (lb, lc) :: f.loops;
|
|
List.iter (fun x -> stmt f None x) body;
|
|
f.loops <- List.tl f.loops;
|
|
f.ind <- f.ind - 1;
|
|
line f "}";
|
|
List.iter (fun x -> stmt f None x) latch;
|
|
f.ind <- f.ind - 1;
|
|
line f "}";
|
|
(match dest with Some d -> line f "%s = undefined;" d | None -> ())
|
|
| Tast.Break n ->
|
|
let lb, _ = List.nth f.loops n in
|
|
line f "break %s;" lb
|
|
| Tast.Continue n ->
|
|
let _, lc = List.nth f.loops n in
|
|
line f "break %s;" lc
|
|
| Tast.Return None ->
|
|
if Types.equal f.ret Types.Unit then line f "return;"
|
|
else line f "return %s;" (zero f.md e.Tast.loc f.ret)
|
|
| Tast.Return (Some v) ->
|
|
if Types.equal f.ret Types.Unit then begin
|
|
ignore (value f v);
|
|
line f "return;"
|
|
end
|
|
else line f "return %s;" (bind_value f v)
|
|
| Tast.Set (p, v) -> set f e.Tast.loc p v
|
|
| Tast.Match (s, arms) -> emit_match f dest s arms
|
|
| Tast.UnwrapSome v ->
|
|
let ov = spill f v in
|
|
line f "if (%s === null) return null;" ov;
|
|
assign f dest (Printf.sprintf "%s.v" ov)
|
|
| _ -> assign f dest (value f e)
|
|
|
|
and block f dest (body : Tast.expr list) =
|
|
match body with
|
|
| [] -> (match dest with Some d -> line f "%s = undefined;" d | None -> ())
|
|
| [ last ] -> stmt f dest last
|
|
| x :: rest ->
|
|
stmt f None x;
|
|
block f dest rest
|
|
|
|
and set f loc (p : Tast.place) (v : Tast.expr) =
|
|
match p with
|
|
| Tast.Plocal i -> line f "%s = %s;" f.names.(i) (bind_value f v)
|
|
| Tast.Pglobal n -> line f "%s = %s;" (gvar n) (bind_value f v)
|
|
| Tast.Pfield (x, i) ->
|
|
let s = struct_of f.md loc x.Tast.ty in
|
|
let fl = List.nth s.Tast.fields i in
|
|
let t = spill f x in
|
|
line f "%s.%s = %s;" t (prop fl.Tast.fname) (bind_value f v)
|
|
| Tast.Pindex (x, idxs) ->
|
|
(* Every index but the last names the container the next one indexes, so
|
|
the walk down is [index]'s and only the final store is written here. *)
|
|
let tv = spill f x in
|
|
let rec walk base (bty : Types.t) = function
|
|
| [] -> assert false
|
|
| [ i ] ->
|
|
let iv = value f i in
|
|
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)
|
|
else (
|
|
match bty with
|
|
| Types.Array _ -> line f "%s[%s] = %s;" base iv rhs
|
|
| _ -> line f "%s.a[%s.o + %s] = %s;" base base iv rhs)
|
|
| i :: rest ->
|
|
let iv = value f i in
|
|
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)
|
|
else
|
|
match bty with
|
|
| Types.Array _ -> Printf.sprintf "%s[%s]" base iv
|
|
| _ -> Printf.sprintf "%s.a[%s.o + %s]" base base iv
|
|
in
|
|
let t = fresh f in
|
|
line f "const %s = %s;" t one;
|
|
walk t (elem_ty loc bty) rest
|
|
in
|
|
walk tv x.Tast.ty idxs
|
|
| Tast.Pderef _ ->
|
|
at loc
|
|
"a store through a pointer is not in the JS dialect — JavaScript has no \
|
|
addresses"
|
|
|
|
and emit_match f dest (s : Tast.expr) (arms : Tast.arm list) =
|
|
let sv = spill f s in
|
|
let opt = match s.Tast.ty with Types.Option _ -> true | _ -> false in
|
|
let payload =
|
|
match s.Tast.ty with Types.Option t -> Some t | _ -> None
|
|
in
|
|
let uname =
|
|
match s.Tast.ty with
|
|
| Types.Named n when Hashtbl.mem f.md.unions n -> Some n
|
|
| Types.Option _ -> None
|
|
| t -> at s.Tast.loc "match on %s" (Types.to_string t)
|
|
in
|
|
let first = ref true in
|
|
let closed = ref false in
|
|
List.iter
|
|
(fun (a : Tast.arm) ->
|
|
if not !closed then begin
|
|
(match a.Tast.acase with
|
|
| None ->
|
|
if !first then line f "{" else line f "} else {";
|
|
closed := true
|
|
| Some c ->
|
|
let test =
|
|
if opt then
|
|
if String.equal c "Some" then
|
|
Printf.sprintf "%s !== null" sv
|
|
else Printf.sprintf "%s === null" sv
|
|
else Printf.sprintf "%s.case === %s" sv (js_string c)
|
|
in
|
|
if !first then line f "if (%s) {" test
|
|
else line f "} else if (%s) {" test);
|
|
first := false;
|
|
f.ind <- f.ind + 1;
|
|
(* The binds, in field order. Each one copies, for the reason in the
|
|
header: a bound field is a value in Flan. *)
|
|
List.iteri
|
|
(fun i slot ->
|
|
let name = f.names.(slot) in
|
|
match (opt, a.Tast.acase, uname) with
|
|
| true, _, _ ->
|
|
let t = Option.get payload in
|
|
let v = Printf.sprintf "%s.v" sv in
|
|
let v =
|
|
match copy_of f.md t v with Some c -> c | None -> v
|
|
in
|
|
line f "%s = %s;" name v
|
|
| false, Some c, Some n ->
|
|
let u = Hashtbl.find f.md.unions n in
|
|
(match Tast.case_index u c with
|
|
| Some (_, cs) ->
|
|
let fl = List.nth cs.Tast.vfields i in
|
|
let v =
|
|
Printf.sprintf "%s.%s" sv (prop fl.Tast.fname)
|
|
in
|
|
let v =
|
|
match copy_of f.md fl.Tast.fty v with
|
|
| Some cc -> cc
|
|
| None -> v
|
|
in
|
|
line f "%s = %s;" name v
|
|
| None -> at s.Tast.loc "no case %s" c)
|
|
| _ -> at s.Tast.loc "a default arm cannot bind fields")
|
|
a.Tast.binds;
|
|
block f dest a.Tast.abody;
|
|
f.ind <- f.ind - 1
|
|
end)
|
|
arms;
|
|
if not !first then begin
|
|
if not !closed then
|
|
(* The checker proved exhaustiveness, so the fall-through is
|
|
unreachable; it is written out so that a wrong proof is a message and
|
|
not a silently-undefined value. *)
|
|
line f "} else { throw new Error(\"unreachable match\"); }"
|
|
else line f "}"
|
|
end
|
|
|
|
(* ── A function ─────────────────────────────────────────────────────── *)
|
|
|
|
(* Slot names come from [snames] where the source wrote one, which is most of
|
|
what makes the output readable. A name used by two different slots gets its
|
|
index appended, so the mapping stays injective. *)
|
|
let slot_names (fn : Tast.fn) =
|
|
let n = Array.length fn.Tast.slots in
|
|
let seen = Hashtbl.create 16 in
|
|
Array.iteri
|
|
(fun i s ->
|
|
match s with
|
|
| Some s when i < n ->
|
|
Hashtbl.replace seen s (1 + try Hashtbl.find seen s with Not_found -> 0)
|
|
| _ -> ())
|
|
fn.Tast.snames;
|
|
Array.init n (fun i ->
|
|
match fn.Tast.snames.(i) with
|
|
| Some s when Hashtbl.find seen s = 1 -> ident s
|
|
| Some s -> Printf.sprintf "%s$%d" (ident s) i
|
|
| None -> Printf.sprintf "t$%d" i)
|
|
|
|
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";
|
|
let names = slot_names fn in
|
|
let f =
|
|
{ md = m; b = Buffer.create 512; ind = 1; n = 0; names;
|
|
slots = fn.Tast.slots; ret = fn.Tast.ret; loops = [] }
|
|
in
|
|
let nparams = List.length fn.Tast.params in
|
|
(* Every slot that is not a parameter is declared once at the top, which is
|
|
what the frame is: the checker already numbered them and they do not
|
|
nest. *)
|
|
let locals =
|
|
Array.to_list (Array.sub names nparams (Array.length names - nparams))
|
|
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;
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "\nfunction %s(%s) {\n%s}\n" (fname fn.Tast.name)
|
|
(String.concat ", "
|
|
(List.mapi (fun i _ -> names.(i)) fn.Tast.params))
|
|
(Buffer.contents f.b))
|
|
|
|
(* ── A whole program ────────────────────────────────────────────────── *)
|
|
|
|
(* 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. *)
|
|
let copy_fn m name =
|
|
let field_copy (fl : Tast.field) =
|
|
let v = Printf.sprintf "v.%s" (prop fl.Tast.fname) in
|
|
let v = match copy_of m fl.Tast.fty v with Some c -> c | None -> v in
|
|
Printf.sprintf "%s: %s" (prop fl.Tast.fname) v
|
|
in
|
|
if Hashtbl.mem m.structs name then
|
|
let s = Hashtbl.find m.structs name in
|
|
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 arm (c : Tast.variant) =
|
|
Printf.sprintf
|
|
" if (v.case === %s) return { case: v.case%s };\n"
|
|
(js_string c.Tast.vname)
|
|
(String.concat ""
|
|
(List.map
|
|
(fun (fl : Tast.field) -> ", " ^ field_copy fl)
|
|
c.Tast.vfields))
|
|
in
|
|
Printf.sprintf "function %s$copy(v) {\n%s return { case: v.case };\n}\n"
|
|
(ident name)
|
|
(String.concat "" (List.map arm u.Tast.cases))
|
|
|
|
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 = [] }
|
|
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)
|
|
p.Tast.unions;
|
|
if p.Tast.externs <> [] then begin
|
|
let e = List.hd p.Tast.externs in
|
|
unsupported
|
|
"%s is a (declare-c ...) binding, and the JS dialect has no C boundary \
|
|
— the FFI crosses through a generated C shim, which has nowhere to be \
|
|
here"
|
|
e.Tast.ename
|
|
end;
|
|
if p.Tast.cshim <> [] then
|
|
unsupported
|
|
"this program generates a C shim, and the JS dialect has no C boundary";
|
|
(* Globals first: an initialiser is a compile-time constant in this IR, so
|
|
there is no ordering question and no init-at-startup path. *)
|
|
let gbuf = Buffer.create 256 in
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
refuse_ty g.Tast.ginit.Tast.loc g.Tast.gty;
|
|
let f =
|
|
{ md = m; b = Buffer.create 64; ind = 0; n = 0; names = [||];
|
|
slots = [||]; ret = g.Tast.gty; loops = [] }
|
|
in
|
|
let v = value f g.Tast.ginit in
|
|
if Buffer.length f.b > 0 then
|
|
at g.Tast.ginit.Tast.loc
|
|
"the initialiser of %s is not a constant, which this IR does not \
|
|
produce"
|
|
g.Tast.gname;
|
|
Buffer.add_string gbuf
|
|
(Printf.sprintf "%s %s = %s;\n"
|
|
(if g.Tast.gconst then "const" else "let")
|
|
(gvar g.Tast.gname) v))
|
|
p.Tast.globals;
|
|
List.iter (fun fn -> func m fn) p.Tast.fns;
|
|
(* The copies are discovered while walking, so they are written after it and
|
|
hoisted above by JS's own function hoisting. *)
|
|
let copies =
|
|
String.concat "" (List.map (copy_fn m) (List.sort compare m.copies))
|
|
in
|
|
let strs =
|
|
String.concat ""
|
|
(List.map
|
|
(fun (s, n) ->
|
|
if printable s then
|
|
Printf.sprintf "const %s = $str(%s);\n" n (js_string s)
|
|
else
|
|
Printf.sprintf "const %s = $bytes([%s]);\n" n
|
|
(String.concat ", "
|
|
(List.map (fun c -> string_of_int (Char.code c))
|
|
(List.init (String.length s) (String.get s)))))
|
|
(List.rev m.strs))
|
|
in
|
|
let has_main =
|
|
List.exists (fun (fn : Tast.fn) -> String.equal fn.Tast.name "main")
|
|
p.Tast.fns
|
|
in
|
|
let tail =
|
|
if has_main then
|
|
let mainfn =
|
|
List.find (fun (fn : Tast.fn) -> String.equal fn.Tast.name "main")
|
|
p.Tast.fns
|
|
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")
|
|
else ""
|
|
in
|
|
runtime ^ "\n// ── string literals ──\n" ^ strs
|
|
^ (if copies = "" then "" else "\n// ── value-semantics copies ──\n" ^ copies)
|
|
^ (if Buffer.length gbuf = 0 then ""
|
|
else "\n// ── globals ──\n" ^ Buffer.contents gbuf)
|
|
^ Buffer.contents m.out ^ tail
|