Joseph Ferano
3e68089cde
The type itself, the ABI its operations call into, and the one decision the feature could not avoid: (defn f [x y]) is one parameter or two, and which one depends on whether y names a type. Parse does not decide it. That lookup is the one its defn comment records being removed for being wrong twice in one day -- the set of type names is incomplete at parse time by construction, and macros generating definitions is what widened the failure. So the vector is carried undecided, as Ast.pitems, and paired in Check, after every file is loaded, every macro expanded and every header imported. The set is complete there. It is not complete across time, and the comment says so: a defstruct written later changes a signature with no edit to the function. The return slot stays mandatory and dyn is written out in it. The ambiguity there has no syntactic resolution at all -- a capitalised head in a list is both a type application and a struct literal -- so the third state the parameters needed does not exist for the return type, and ret = None goes on meaning Unit. What the feature costs, and what is taken back: a slot with no type used to be a syntax error, so a mistyped type now reads as an extra parameter with no diagnostic. A name within one edit of a type's gets the resolver's own did-you-mean, and an unknown capitalised name is reported as the unknown type it is -- not one parameter in the corpus is capitalised. A lowercase name resembling no type is the feature working, and is the residual. The x86 backend refuses dyn by name; both callers already name --llvm, and the daemon takes that backend by default, so this is the first thing a user of dyn sees. The JS dialect refuses it too, for the opposite reason -- every value there is already dynamic and what is missing is only the lowering. runtime/flan_dyn.h is the fixed ABI. flan_dyn_stub.c stands in until the real collector lands and says in its header that it verifies nothing about roots.
1549 lines
65 KiB
OCaml
1549 lines
65 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],
|
|
[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"
|
|
(* The irony is not lost: JavaScript is the one target where a dyn value
|
|
needs no boxing at all, because every value there is already one. What is
|
|
missing is not the representation but the lowering — dyn ops are calls
|
|
into runtime/flan_dyn.h, and this dialect has no such runtime. It is a
|
|
lane, not a difficulty. *)
|
|
| Types.Dyn ->
|
|
at loc
|
|
"dyn is not in the JS dialect yet — every JavaScript value is already \
|
|
dynamic, so this is a matter of lowering the dyn operations onto the \
|
|
host's own, and that work has not been done"
|
|
| 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. A constant initialiser is a value this IR can spell, and it
|
|
is the only kind that gets here: the language runs a computed one from a
|
|
function [main] calls at startup, and this dialect has grown no equivalent
|
|
— so one is refused below rather than silently started as zero. The
|
|
ordering question the startup path answers is therefore not one this file
|
|
has. *)
|
|
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 computed, and the JS dialect has no \
|
|
init-at-startup path to run it from"
|
|
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
|