1543 lines
64 KiB
OCaml
1543 lines
64 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.
|
|
|
|
{1 Where this stops, and what the next lane picks up}
|
|
|
|
[spike/js/survey.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77
|
|
refused by name, 0 that node would not run, over the corpus and this
|
|
file's own two probes. What the refusals say about the order to work in:
|
|
|
|
- {b [Vec], and with it the type-erased container runtime.} The largest
|
|
single bucket after the FFI. A [Vec] reaches this file as
|
|
[Prim (Rt "flan_vec_push", ...)] over an [AddrOf] and an [Allocator],
|
|
so it needs two things that are refused on purpose today: a {e named
|
|
table} of [flan_vec_*] symbols answered over a JS array, and a narrow
|
|
hole in [AddrOf] for the arguments those take. Both refusals are
|
|
load-bearing and neither should be widened further than that. A [Vec] is
|
|
move-only and owns its storage, so a JS array aliases correctly and
|
|
needs none of the copying above.
|
|
- {b The dev loop.} docs/DISCUSS.md item 5's unexpected upside: evaluating
|
|
new code is the one thing JavaScript makes easy, and wasm cannot have
|
|
this at all. [Build.executable] refuses [--dev] here in its own words
|
|
and that refusal is where the lane starts.
|
|
- {b Interop}, which is what the whole target is for: a [declare-c]
|
|
binding has no meaning here, but a [declare-js] would, and 14 of the 77
|
|
refusals are the agent package's C.
|
|
- {b Conditions} are a lane and not a stub. [fdefers] is dropped below on
|
|
the grounds that nothing can start a transfer; the first thing that can
|
|
makes that note wrong, and it says so where it is. *)
|
|
|
|
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 }; }
|
|
// Uint8Array.from rather than a view onto the Buffer: node pools small
|
|
// Buffers inside one ArrayBuffer, so a view would let a write through one
|
|
// string literal's slice reach the bytes of another. Native puts a literal in
|
|
// .rodata, where a write is a fault; this is the nearest thing to that which
|
|
// costs nothing.
|
|
function $str(s) { const b = Buffer.from(s, "utf8"); const a = Uint8Array.from(b); return $view(a, 0, a.length); }
|
|
function $bytes(xs) { const a = Uint8Array.from(xs); return $view(a, 0, a.length); }
|
|
function $buf(s) {
|
|
const a = s.a;
|
|
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;
|
|
datas : (string, Tast.data) Hashtbl.t; (* the tagged sums, defdata *)
|
|
cunions : (string, unit) Hashtbl.t; (* C's untagged unions, refused *)
|
|
checks : bool;
|
|
mutable strs : (string * string) list; (* literal -> its const name *)
|
|
mutable nstr : int;
|
|
mutable copies : string list; (* struct names needing a $copy *)
|
|
mutable tags : string list; (* union names needing a $tag *)
|
|
}
|
|
|
|
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.datas n ->
|
|
if not (List.mem n m.copies) then m.copies <- n :: m.copies;
|
|
Some (Printf.sprintf "%s$copy(%s)" (ident n) v)
|
|
| Types.Array (_, e) -> (
|
|
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
|
|
(* [v] is named once, through the parameter: spelling it twice would
|
|
evaluate the argument twice, and the argument may be a checked index
|
|
whose own subexpression has an effect. *)
|
|
| Some c ->
|
|
Some
|
|
(Printf.sprintf
|
|
"((o) => (o === null ? null : { v: ((x) => %s)(o.v) }))(%s)" c v))
|
|
| _ -> None
|
|
|
|
(* A value that was just built is already private; cloning it would be a copy
|
|
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.
|
|
|
|
[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
|
|
| 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
|
|
| _ ->
|
|
(* 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.cunions n ->
|
|
at loc
|
|
"%s is an untagged union, which is not in the JS dialect — its members \
|
|
share one run of bytes and two properties of an object cannot. A \
|
|
defdata carries its case and does map"
|
|
n
|
|
| Types.Named n when Hashtbl.mem m.structs n ->
|
|
let s = Hashtbl.find m.structs n in
|
|
Printf.sprintf "{ %s }"
|
|
(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.datas n ->
|
|
(* Declaration order from zero is the tag, so an all-bytes-zero union is
|
|
the first case with a zeroed payload. Tast.case_index says so. *)
|
|
let u = Hashtbl.find m.datas 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 ─────────────────────────────────────────── *)
|
|
|
|
(* C's untagged union, which arrives as a [structure] whose every field sits
|
|
at offset zero. Two fields sharing one run of bytes is a layout, and an
|
|
object has none here — so it is named rather than met as "not a struct". *)
|
|
let refuse_cunion m loc n =
|
|
if Hashtbl.mem m.cunions n then
|
|
at loc
|
|
"%s is an untagged union, which is not in the JS dialect — its members \
|
|
share one run of bytes and two properties of an object cannot. A \
|
|
defdata carries its case and does map"
|
|
n
|
|
|
|
let struct_of m loc (t : Types.t) =
|
|
match t with
|
|
| Types.Named n when Hashtbl.mem m.structs n -> Hashtbl.find m.structs n
|
|
| Types.Named n ->
|
|
refuse_cunion m loc n;
|
|
at loc "a field of %s, which is not a struct" (Types.to_string t)
|
|
| t -> at loc "a field of %s, which is not a struct" (Types.to_string t)
|
|
|
|
let elem_ty loc (t : Types.t) =
|
|
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))
|
|
(* [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.datas n ->
|
|
if i <> 0 then
|
|
at e.Tast.loc "field %d of the union %s, which has only a tag" i n;
|
|
if not (List.mem n f.md.tags) then f.md.tags <- n :: f.md.tags;
|
|
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
|
|
| Types.Named n -> n
|
|
| t -> at e.Tast.loc "case field of %s" (Types.to_string t)
|
|
in
|
|
let u = Hashtbl.find f.md.datas n in
|
|
(match Tast.case_index u case with
|
|
| Some (_, c) ->
|
|
Printf.sprintf "%s.%s" (spill f x)
|
|
(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.datas 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
|
|
(* 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 i.Tast.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 i (value f i)
|
|
| i :: rest ->
|
|
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
|
|
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
|
|
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
|
|
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
|
|
(* 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
|
|
| 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 i.Tast.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 i.Tast.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.datas 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.datas 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;
|
|
(* [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;
|
|
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);
|
|
(* 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 ", "
|
|
(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. *)
|
|
(* 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.datas 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
|
|
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.datas 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;
|
|
datas = Hashtbl.create 8; cunions = Hashtbl.create 4; checks;
|
|
strs = []; nstr = 0; copies = []; tags = [] }
|
|
in
|
|
List.iter
|
|
(fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
|
|
p.Tast.structs;
|
|
List.iter
|
|
(fun (u : Tast.data) -> Hashtbl.replace m.datas u.Tast.dname u)
|
|
p.Tast.datas;
|
|
(* C's untagged unions, which arrive as [structure] values whose every field
|
|
is at offset zero. That is a layout, and a layout is the one thing an
|
|
object has none of here: two fields sharing storage cannot be two
|
|
properties. Registered so the refusal can name the type rather than
|
|
failing as "not a struct". *)
|
|
List.iter
|
|
(fun (u : Tast.structure) -> Hashtbl.replace m.cunions u.Tast.sname ())
|
|
p.Tast.unions;
|
|
if p.Tast.externs <> [] then begin
|
|
let e = List.hd p.Tast.externs in
|
|
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))
|
|
^ String.concat "" (List.map (tag_fn m) (List.sort compare m.tags))
|
|
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
|
|
(* [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(%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
|
|
^ (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
|