Joseph Ferano
63d9b87b7a
The transfer channel was the only thing between 41 programs and the corpus. It is there now: a guard after every Flan call, a landing pad per restart-case, handler-bind and with-allocator, a transfer exit per function that runs its fdefers, and check_at and check_slice, which could not exist until the guard did. Measured by what the programs print and what they exit with, never by reading bytes. spike/x86/survey.sh builds every program in test/programs both ways and diffs stdout and the exit status; it did not exist, so it is here too, and it is the progress meter. before 41 MATCH 1 DIFFER 41 refused by name after 83 MATCH 0 DIFFER 0 refused by name The one DIFFER was bounds.flan, and it was the honest answer to "--x86 is silently a --no-bounds-checks build". It is not one any more: check_at and check_slice signal through the channel exactly as emit.ml's do, so a bounds violation signals, a restart-case catches it, and an unhandled one exits 134 on both backends. The transitional refusal that would have said so retired before it was written. check_no_transfer is not removed, it is narrowed to the one place the argument still holds: a global's initialiser runs from flan..init-globals, before main and before anything can handle anything, so a transfer out of it has nowhere to go. Four bugs, and three of them are the shape item 16 predicted -- code that reads correctly and answers wrong, found by output and not by objdump: - The body fell through into the transfer exit, so every fdefer ran twice on a normal return. emit.ml cannot have this bug: its ret terminates the block. - A Vec crossed to the runtime as the address of a *copy*, so pushes grew the copy and an in-bounds (at v 1) signalled against a length of zero. - ucomis sets CF, ZF and PF together for a NaN, so sete answered true for (= x x) and the prelude's NaN test never fired: (/ 0.0 0.0) formatted as -9223372036854775808. Flan's comparisons are LLVM's ordered ones, so < and <= swap and =, != take a setnp beside them. - A union read field 0 through the struct table and was refused by name rather than laid out as a tag and a payload. And one that could not have been found later: emit_globals_init stored a null *into* the channel slot rather than a cell address into it, which is a null pointer for every callee to write through. Harmless while nothing could transfer; a fault the first time a guard loaded through it.
2424 lines
103 KiB
OCaml
2424 lines
103 KiB
OCaml
(** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one.
|
|
|
|
Grown out of [spike/backend/x86.ml], which proved the shape. What is new
|
|
here is everything the spike enumerated and did not do: aggregates, floats,
|
|
globals, string literals, the transfer channel, and a whole program rather
|
|
than one function.
|
|
|
|
{1 The internal calling convention}
|
|
|
|
The spike's report (DISCUSS.md item 15) called the internal convention the
|
|
sharpest obstacle, because LLVM's answer for a first-class struct is an
|
|
implementation detail discoverable only by disassembly — a 24-byte struct
|
|
comes back in [rax]:[rdx]:[rcx], and [rcx] is a register SysV never uses
|
|
for a return value.
|
|
|
|
That obstacle does not exist here, and the reason is worth stating because
|
|
it is the whole licence for this module: {b a dev build is compiled
|
|
entirely by this backend and a release build entirely by LLVM, and the two
|
|
never meet in one process.} A dev build's [.ll] is not emitted at all when
|
|
this backend runs. So the convention is ours to pick, and we pick the
|
|
simplest one that exists:
|
|
|
|
- {b Scalars} — integers, [bool], pointers, enums, handles, allocators,
|
|
function pointers — go in SysV's integer registers [rdi rsi rdx rcx r8
|
|
r9], then right-to-left on the stack. [bool] is one byte, zero-extended.
|
|
- {b Floats} go in [xmm0]-[xmm7], then on the stack.
|
|
- {b Every aggregate goes by pointer.} An argument is a pointer to a copy
|
|
the caller made; a return is a hidden [sret] pointer in the {e first}
|
|
integer register, with everything else shifted along, and the same
|
|
pointer comes back in [rax]. Nothing is classified, nothing is split
|
|
across register classes, and there is no eightbyte rule.
|
|
- {b The transfer channel} is the last argument of all, a pointer, in the
|
|
integer sequence — [emit.ml]'s [signature] rule, unchanged.
|
|
|
|
{b Where this must match SysV exactly, it does}, and that is the C
|
|
boundary: [flan_rt.c], [flan_dev.c], the generated FFI shim. [check.ml]
|
|
rejects an aggregate in a [declare] signature and the shim flattens every
|
|
struct, so a string or slice crosses as [ptr]+[len] and no Flan-emitted
|
|
call ever hands C an aggregate. There is therefore no aggregate classifier
|
|
in this file, and per item 15 there does not need to be one.
|
|
|
|
{1 The frame, and why the spike's worst bug cannot happen here}
|
|
|
|
The spike found its one real bug in a call written inside a binary
|
|
operator: the evaluator spilled the left operand with [push], so [rsp] was
|
|
8 out at the call and a C callee doing an aligned spill returned garbage.
|
|
It fixed that with a depth counter.
|
|
|
|
This module does not have a depth counter, because it does not push.
|
|
{b Every intermediate value is a frame temporary}, bump-allocated below
|
|
[rbp] with a high-water mark, and the outgoing-argument area is reserved
|
|
once in the prologue. [rsp] is written exactly twice — in the prologue and
|
|
by [leave] — so [rsp % 16 == 0] at every call site is a property of one
|
|
rounded [sub] rather than an invariant every case has to maintain. The bug
|
|
class is removed rather than guarded against.
|
|
|
|
That costs instructions and no correctness. A debug build does not
|
|
optimise; this is the trade the brief asks for.
|
|
|
|
{1 Layout}
|
|
|
|
[Emit.lay] / [lay_fields] / [payload_lay], reused rather than rewritten.
|
|
They are acceptance-tested against LLVM's own [getelementptr], so there is
|
|
one layout calculator in this compiler and this backend is a caller of it.
|
|
|
|
{1 The container}
|
|
|
|
Output is an assembly file: [.byte] blobs for the instructions, with the
|
|
few fields that need a relocation written as assembler expressions
|
|
([call sym], [.long lbl - . - 4]). Byte offsets stay exactly known, which
|
|
is what the introspection this backend exists for will need; what we give
|
|
up is writing ELF ourselves, which is several hundred lines that produce
|
|
no Flan progress and in which a bug looks exactly like an encoding bug.
|
|
Reversible: the encoder below hands out bytes, and who packages them is a
|
|
separate question. *)
|
|
|
|
exception Unsupported of string
|
|
|
|
let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt
|
|
|
|
(* ── The byte buffer ─────────────────────────────────────────────────── *)
|
|
|
|
(* Raw bytes accumulate in [pend] and are flushed as one [.byte] directive;
|
|
anything the assembler has to resolve goes out as a directive with a known
|
|
size, so [n] is the exact offset of the next byte either way. *)
|
|
type buf = { out : Buffer.t; mutable pend : int list; mutable n : int }
|
|
|
|
let create () = { out = Buffer.create 4096; pend = []; n = 0 }
|
|
|
|
let flush b =
|
|
if b.pend <> [] then begin
|
|
Buffer.add_string b.out "\t.byte ";
|
|
Buffer.add_string b.out
|
|
(String.concat "," (List.rev_map (Printf.sprintf "0x%02x") b.pend));
|
|
Buffer.add_char b.out '\n';
|
|
b.pend <- []
|
|
end
|
|
|
|
let u8 b x =
|
|
b.pend <- (x land 0xff) :: b.pend;
|
|
b.n <- b.n + 1
|
|
|
|
let u32 b n = for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done
|
|
|
|
let i32 b (n : int) =
|
|
if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n;
|
|
u32 b n
|
|
|
|
let u64 b (n : int64) =
|
|
for i = 0 to 7 do
|
|
u8 b
|
|
(Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL))
|
|
done
|
|
|
|
let dir b s size =
|
|
flush b;
|
|
Buffer.add_string b.out ("\t" ^ s ^ "\n");
|
|
b.n <- b.n + size
|
|
|
|
let text b s = flush b; Buffer.add_string b.out s
|
|
let lbl b l = flush b; Buffer.add_string b.out (l ^ ":\n")
|
|
|
|
(* ── Registers ───────────────────────────────────────────────────────── *)
|
|
|
|
(* The encoding numbering, not the ABI's: these three bits are what modrm
|
|
wants, which is why rsp is 4 and rbp is 5. *)
|
|
let rax = 0 and rcx = 1 and rdx = 2
|
|
let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7
|
|
let r8 = 8 and r9 = 9 and r11 = 11
|
|
|
|
let xmm0 = 0
|
|
|
|
let int_args = [| rdi; rsi; rdx; rcx; r8; r9 |]
|
|
let n_int_args = 6
|
|
let n_sse_args = 8
|
|
|
|
(* REX. [force] is for the 8-bit forms, where without a REX byte registers 4-7
|
|
name ah/ch/dh/bh rather than spl/bpl/sil/dil — a store of a bool from rsi
|
|
would otherwise write the wrong half of rdx. *)
|
|
let rex ?(force = false) b ~w ~r ~x ~m =
|
|
let v =
|
|
(if w then 8 else 0)
|
|
lor (if r >= 8 then 4 else 0)
|
|
lor (if x >= 8 then 2 else 0)
|
|
lor (if m >= 8 then 1 else 0)
|
|
in
|
|
if v <> 0 || force then u8 b (0x40 lor v)
|
|
|
|
let modrm_r b ~r ~m = u8 b (0xc0 lor ((r land 7) lsl 3) lor (m land 7))
|
|
|
|
(* [base + disp32], always disp32: a frame outgrows 128 bytes and a disp8 that
|
|
silently wraps is precisely the bug this would not find. r12 and rsp need a
|
|
SIB byte because 4 in the r/m field means "SIB follows". *)
|
|
let modrm_m b ~r ~base ~disp =
|
|
u8 b (0x80 lor ((r land 7) lsl 3) lor (base land 7));
|
|
if base land 7 = 4 then u8 b 0x24;
|
|
i32 b disp
|
|
|
|
(* [rip + disp32], where the displacement is a relocation the assembler fills
|
|
in. modrm mod=00 r/m=101 is the rip-relative form. *)
|
|
let modrm_rip b ~r ~sym ~addend =
|
|
u8 b (((r land 7) lsl 3) lor 5);
|
|
dir b
|
|
(Printf.sprintf ".long %s%s - . - 4" sym
|
|
(if addend = 0 then "" else Printf.sprintf "+%d" addend))
|
|
4
|
|
|
|
(* ── Instructions ────────────────────────────────────────────────────── *)
|
|
|
|
type mem = Frame of int | Reg of int * int | Sym of string * int
|
|
|
|
let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) =
|
|
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
|
|
List.iter (u8 b) pfx;
|
|
(match mm with
|
|
| Sym _ -> rex b ~w ~r ~x:0 ~m:0
|
|
| _ -> rex b ~w ~r ~x:0 ~m:base);
|
|
List.iter (u8 b) op;
|
|
match mm with
|
|
| Frame d -> modrm_m b ~r ~base:rbp ~disp:d
|
|
| Reg (g, d) -> modrm_m b ~r ~base:g ~disp:d
|
|
| Sym (s, a) -> modrm_rip b ~r ~sym:s ~addend:a
|
|
|
|
let mov_rr b ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b 0x89; modrm_r b ~r:src ~m:dst
|
|
|
|
let movabs b ~dst (n : int64) =
|
|
rex b ~w:true ~r:0 ~x:0 ~m:dst;
|
|
u8 b (0xb8 lor (dst land 7));
|
|
u64 b n
|
|
|
|
let lea b ~dst ~(mm : mem) = mem_op b ~r:dst ~op:[ 0x8d ] ~w:true ~pfx:[] ~mm
|
|
|
|
(* An integer load of [size] bytes, widened to the full 64-bit register the
|
|
way the operand's own signedness says. Everything downstream then works in
|
|
64 bits and narrows only at a store, which is what makes one set of
|
|
arithmetic encodings cover eight integer types. *)
|
|
let load_int b ~dst ~mm ~size ~signed =
|
|
match size, signed with
|
|
| 8, _ -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:true ~pfx:[] ~mm
|
|
| 4, false -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:false ~pfx:[] ~mm
|
|
| 4, true -> mem_op b ~r:dst ~op:[ 0x63 ] ~w:true ~pfx:[] ~mm
|
|
| 2, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb7 ] ~w:true ~pfx:[] ~mm
|
|
| 2, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbf ] ~w:true ~pfx:[] ~mm
|
|
| 1, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb6 ] ~w:true ~pfx:[] ~mm
|
|
| 1, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbe ] ~w:true ~pfx:[] ~mm
|
|
| n, _ -> unsupported "integer load of %d bytes" n
|
|
|
|
let store_int b ~src ~mm ~size =
|
|
match size with
|
|
| 8 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:true ~pfx:[] ~mm
|
|
| 4 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[] ~mm
|
|
| 2 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[ 0x66 ] ~mm
|
|
| 1 ->
|
|
(* The one place a REX byte is needed for its own sake. *)
|
|
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
|
|
rex ~force:(src >= 4) b ~w:false ~r:src ~x:0 ~m:base;
|
|
u8 b 0x88;
|
|
(match mm with
|
|
| Frame d -> modrm_m b ~r:src ~base:rbp ~disp:d
|
|
| Reg (g, d) -> modrm_m b ~r:src ~base:g ~disp:d
|
|
| Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a)
|
|
| n -> unsupported "integer store of %d bytes" n
|
|
|
|
let alu_rr b ~op ~dst ~src =
|
|
rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b op; modrm_r b ~r:src ~m:dst
|
|
|
|
let add_rr b ~dst ~src = alu_rr b ~op:0x01 ~dst ~src
|
|
let sub_rr b ~dst ~src = alu_rr b ~op:0x29 ~dst ~src
|
|
let and_rr b ~dst ~src = alu_rr b ~op:0x21 ~dst ~src
|
|
let or_rr b ~dst ~src = alu_rr b ~op:0x09 ~dst ~src
|
|
let xor_rr b ~dst ~src = alu_rr b ~op:0x31 ~dst ~src
|
|
let cmp_rr b ~a ~c = alu_rr b ~op:0x39 ~dst:a ~src:c
|
|
|
|
let imul_rr b ~dst ~src =
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xaf; modrm_r b ~r:dst ~m:src
|
|
|
|
let grp1_imm b ~ext ~dst n =
|
|
rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0x81; modrm_r b ~r:ext ~m:dst; i32 b n
|
|
|
|
let add_imm b ~dst n = grp1_imm b ~ext:0 ~dst n
|
|
let sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n
|
|
let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n
|
|
|
|
let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst
|
|
let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst
|
|
let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a
|
|
|
|
(* cqo then idiv, or xor rdx,rdx then div: the sign of the operands decides
|
|
which pair, and getting that wrong is a wrong answer rather than a fault. *)
|
|
let cqo b = u8 b 0x48; u8 b 0x99
|
|
let idiv_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:7 ~m:src
|
|
let div_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:6 ~m:src
|
|
|
|
(* Shifts by cl. The count is masked to the operand width by the hardware,
|
|
which is the rule the language already defines (item 15's audit). *)
|
|
let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
|
|
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
|
|
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
|
|
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
|
|
|
|
let setcc b ~cc ~dst =
|
|
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
|
|
u8 b 0x0f; u8 b (0x90 lor cc); modrm_r b ~r:0 ~m:dst
|
|
|
|
let movzx8 b ~dst ~src =
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xb6; modrm_r b ~r:dst ~m:src
|
|
|
|
let jmp_lbl b l = u8 b 0xe9; dir b (Printf.sprintf ".long %s - . - 4" l) 4
|
|
let jcc_lbl b ~cc l = u8 b 0x0f; u8 b (0x80 lor cc); dir b (Printf.sprintf ".long %s - . - 4" l) 4
|
|
|
|
let call_sym b s = flush b; dir b (Printf.sprintf "call %s" s) 5
|
|
let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm_r b ~r:2 ~m:r
|
|
let leave b = u8 b 0xc9
|
|
let ret b = u8 b 0xc3
|
|
let ud2 b = u8 b 0x0f; u8 b 0x0b
|
|
let push_r b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7))
|
|
|
|
(* rep movsb: rdi, rsi, rcx. Nothing is ever live in a register across a
|
|
statement here, so the crudest block copy in the instruction set is also
|
|
the correct one, and a struct assignment *is* the copy spec-memory.md
|
|
requires. *)
|
|
let rep_movsb b = u8 b 0xf3; u8 b 0xa4
|
|
let rep_stosb b = u8 b 0xf3; u8 b 0xaa
|
|
|
|
(* ── SSE ─────────────────────────────────────────────────────────────── *)
|
|
|
|
let sse_rm b ~pfx ~op ~r ~mm = mem_op b ~r ~op:[ 0x0f; op ] ~w:false ~pfx:[ pfx ] ~mm
|
|
let sse_rr b ~pfx ~op ~r ~m =
|
|
u8 b pfx; rex b ~w:false ~r ~x:0 ~m; u8 b 0x0f; u8 b op; modrm_r b ~r ~m
|
|
|
|
let movsd_load b ~dst ~mm = sse_rm b ~pfx:0xf2 ~op:0x10 ~r:dst ~mm
|
|
let movsd_store b ~src ~mm = sse_rm b ~pfx:0xf2 ~op:0x11 ~r:src ~mm
|
|
let movss_load b ~dst ~mm = sse_rm b ~pfx:0xf3 ~op:0x10 ~r:dst ~mm
|
|
let movss_store b ~src ~mm = sse_rm b ~pfx:0xf3 ~op:0x11 ~r:src ~mm
|
|
|
|
let fload b ~dst ~mm ~f64 = if f64 then movsd_load b ~dst ~mm else movss_load b ~dst ~mm
|
|
let fstore b ~src ~mm ~f64 = if f64 then movsd_store b ~src ~mm else movss_store b ~src ~mm
|
|
|
|
let farith b ~op ~f64 ~dst ~src = sse_rr b ~pfx:(if f64 then 0xf2 else 0xf3) ~op ~r:dst ~m:src
|
|
let ucomis b ~f64 ~a ~c =
|
|
if f64 then u8 b 0x66;
|
|
rex b ~w:false ~r:a ~x:0 ~m:c; u8 b 0x0f; u8 b 0x2e; modrm_r b ~r:a ~m:c
|
|
|
|
(* Conversions. REX.W selects the 64-bit integer side in each direction. *)
|
|
let cvtsi2f b ~f64 ~dst ~src =
|
|
u8 b (if f64 then 0xf2 else 0xf3);
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2a; modrm_r b ~r:dst ~m:src
|
|
|
|
let cvttf2si b ~f64 ~dst ~src =
|
|
u8 b (if f64 then 0xf2 else 0xf3);
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2c; modrm_r b ~r:dst ~m:src
|
|
|
|
let cvtsd2ss b ~dst ~src = sse_rr b ~pfx:0xf2 ~op:0x5a ~r:dst ~m:src
|
|
let cvtss2sd b ~dst ~src = sse_rr b ~pfx:0xf3 ~op:0x5a ~r:dst ~m:src
|
|
let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modrm_r b ~r:dst ~m:dst
|
|
|
|
(* ── Types ───────────────────────────────────────────────────────────── *)
|
|
|
|
(* [Emit.m] carries the struct and union tables [Emit.lay] reads. Built here
|
|
rather than imported so that this module adds no line to [emit.ml]: the
|
|
record has no signature hiding it and every field it needs is inert. *)
|
|
let layout_ctx ~checks (p : Tast.program) : Emit.m =
|
|
let structs = Hashtbl.create 16 and unions = Hashtbl.create 16 in
|
|
List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
|
|
p.Tast.structs;
|
|
List.iter (fun (u : Tast.union) -> Hashtbl.replace unions u.Tast.uname u)
|
|
p.Tast.unions;
|
|
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; unions;
|
|
globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks;
|
|
dev = false; known = (fun _ -> true); dbg = None; sanitize = false;
|
|
nstr = 0; nfi = 0 }
|
|
|
|
let sizeof md t = fst (Emit.lay md t)
|
|
let alignof md t = snd (Emit.lay md t)
|
|
|
|
(* The one classification this backend makes, and it has two answers rather
|
|
than SysV's eight. *)
|
|
let is_agg (t : Types.t) =
|
|
match t with
|
|
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _
|
|
| Types.Alloc | Types.Handle _ | Types.Fn _ -> false
|
|
| Types.Unit | Types.Never -> false
|
|
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
|
|
| Types.Pool _ | Types.Option _ | Types.Named _ -> true
|
|
| Types.Var v -> unsupported "type variable %s" v
|
|
|
|
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
|
|
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false
|
|
let f64_of (t : Types.t) = match t with Types.Float Types.F32 -> false | _ -> true
|
|
|
|
(* Signedness for a load and for a comparison. A pointer, a handle and an enum
|
|
are each unsigned machine words; [bool] is a zero-extended byte. *)
|
|
let signed_of (t : Types.t) =
|
|
match t with
|
|
| Types.Int k -> Types.signed k
|
|
| Types.Enum _ -> true
|
|
| _ -> false
|
|
|
|
(* ── Mangling ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The same names [emit.ml] gives, so a build made here links against the same
|
|
runtime and a disassembly reads with the same symbols. A Flan name can hold
|
|
characters an assembler will not take bare, so every symbol is quoted. *)
|
|
let asm_sym s = "\"" ^ s ^ "\""
|
|
let fsym n = asm_sym ("flan." ^ n)
|
|
let gsym n = asm_sym ("flan." ^ n)
|
|
|
|
(* ── Function context ────────────────────────────────────────────────── *)
|
|
|
|
type fnctx = {
|
|
b : buf;
|
|
md : Emit.m;
|
|
fnname : string;
|
|
(* The label the epilogue sits on. Every [return] and every fallthrough from
|
|
the body jumps here, so the frame is torn down in exactly one place. *)
|
|
mutable retlbl : string;
|
|
fret : Types.t;
|
|
slots : int array; (* rbp-relative offset of each Tast slot *)
|
|
mutable xfer_off : int; (* the incoming transfer channel pointer *)
|
|
mutable sret_off : int; (* where the hidden return pointer was put *)
|
|
mutable retval : int; (* the scalar return value's temporary *)
|
|
mutable frame : int; (* bytes currently allocated below rbp *)
|
|
mutable maxframe : int;
|
|
mutable outgoing : int; (* bytes the widest call needs for stack args *)
|
|
(* One entry per [While] we are inside, innermost first: the label a [break]
|
|
jumps to and the label a [continue] jumps to, which is the latch and not
|
|
the head. *)
|
|
mutable loops : (string * string) list;
|
|
(* The innermost landing pad a transfer found after a call should jump to,
|
|
with a flag saying whether anything ever aimed at it: a pad nobody jumps
|
|
to must not be emitted, because its code would then be reached by falling
|
|
into it. Empty means the function's own transfer exit, [xfer_lbl]. *)
|
|
mutable pads : (string * bool ref) list;
|
|
(* The function's own transfer exit — spec-conditions.md §5 and §6. A
|
|
transfer that reached the top of this function without a restart-case to
|
|
catch it leaves the way a [return] does, which is what reuses the epilogue
|
|
and the defers for free. [unwound] says whether anything can reach it. *)
|
|
mutable xfer_lbl : string;
|
|
mutable unwound : bool;
|
|
(* Collected while lowering: string literals and float constants both need a
|
|
labelled constant in .rodata, and both are discovered mid-expression. *)
|
|
rodata : Buffer.t;
|
|
externs : (string, string) Hashtbl.t;
|
|
fns : (string, unit) Hashtbl.t;
|
|
}
|
|
|
|
(* Module-wide rather than per-function. Two functions each holding an [if]
|
|
would otherwise both emit [.Lif1] into the same [.s] and the assembler would
|
|
refuse the file — a failure that only appears once a *program* is lowered
|
|
and never once a single function is, which is exactly the class of thing the
|
|
spike could not have found. *)
|
|
let uniq = ref 0
|
|
|
|
let new_label _f tag = incr uniq; Printf.sprintf ".L%s%d" tag !uniq
|
|
|
|
(* Bump-allocate a frame temporary and answer its rbp-relative offset. The
|
|
offset is negative, so the running total is rounded *up* to the alignment;
|
|
rbp is 16-aligned, so that is the alignment the value actually gets. *)
|
|
let alloc f size align =
|
|
let a = if align <= 1 then 1 else align in
|
|
f.frame <- f.frame + (if size <= 0 then 1 else size);
|
|
f.frame <- (f.frame + a - 1) / a * a;
|
|
if f.frame > f.maxframe then f.maxframe <- f.frame;
|
|
-f.frame
|
|
|
|
let tmp f (t : Types.t) = alloc f (max 1 (sizeof f.md t)) (alignof f.md t)
|
|
let ptmp f = alloc f 8 8
|
|
|
|
(* Temporaries are reclaimed at the end of the expression that made them; the
|
|
destination is allocated by the caller and therefore outlives the reset. *)
|
|
let scoped f g =
|
|
let save = f.frame in
|
|
let r = g () in
|
|
f.frame <- save;
|
|
r
|
|
|
|
(* ── Moving values ───────────────────────────────────────────────────── *)
|
|
|
|
(* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else
|
|
is its own width, widened on load. *)
|
|
let load_scalar f ~reg ~off (t : Types.t) =
|
|
if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t)
|
|
else
|
|
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
|
|
load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t)
|
|
|
|
let store_scalar f ~reg ~off (t : Types.t) =
|
|
if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t)
|
|
else
|
|
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
|
|
store_int f.b ~src:reg ~mm:(Frame off) ~size
|
|
|
|
(* Through a pointer rather than a frame offset: the same two, with the
|
|
address already in a register. *)
|
|
let load_scalar_at f ~reg ~base ~disp (t : Types.t) =
|
|
if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
|
|
else
|
|
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
|
|
load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t)
|
|
|
|
let store_scalar_at f ~reg ~base ~disp (t : Types.t) =
|
|
if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
|
|
else
|
|
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
|
|
store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size
|
|
|
|
(* n bytes from the address in rsi to the address in rdi. *)
|
|
let blockcopy f n =
|
|
if n > 0 then begin
|
|
movabs f.b ~dst:rcx (Int64.of_int n);
|
|
rep_movsb f.b
|
|
end
|
|
|
|
let copy_frames f ~dst ~src n =
|
|
if n > 0 then begin
|
|
lea f.b ~dst:rdi ~mm:(Frame dst);
|
|
lea f.b ~dst:rsi ~mm:(Frame src);
|
|
blockcopy f n
|
|
end
|
|
|
|
let zero_frame f ~dst n =
|
|
if n > 0 then begin
|
|
lea f.b ~dst:rdi ~mm:(Frame dst);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
movabs f.b ~dst:rcx (Int64.of_int n);
|
|
rep_stosb f.b
|
|
end
|
|
|
|
(* ── Constants in .rodata ────────────────────────────────────────────── *)
|
|
|
|
let rodata_label _f = incr uniq; Printf.sprintf ".Lk%d" !uniq
|
|
|
|
let escape_bytes s =
|
|
String.concat ","
|
|
(List.map (fun c -> Printf.sprintf "0x%02x" (Char.code c))
|
|
(List.init (String.length s) (String.get s)))
|
|
|
|
let string_const f s =
|
|
let l = rodata_label f in
|
|
Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l);
|
|
if String.length s > 0 then
|
|
Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s));
|
|
(* A trailing NUL nobody reads through the length, so that a pointer handed
|
|
to C by a shim is still a C string if anything ever treats it as one. *)
|
|
Buffer.add_string f.rodata "\t.byte 0x00\n";
|
|
l
|
|
|
|
let float_const f (x : float) ~f64 =
|
|
let l = rodata_label f in
|
|
if f64 then
|
|
Buffer.add_string f.rodata
|
|
(Printf.sprintf "\t.align 8\n%s:\n\t.quad 0x%Lx\n" l (Int64.bits_of_float x))
|
|
else
|
|
Buffer.add_string f.rodata
|
|
(Printf.sprintf "\t.align 4\n%s:\n\t.long 0x%lx\n" l (Int32.bits_of_float x));
|
|
l
|
|
|
|
(* ── Locations ───────────────────────────────────────────────────────── *)
|
|
|
|
(* Where a value lives. Every value in this backend lives in memory, so the
|
|
three cases are the three ways an address is formed and not three kinds of
|
|
value: a frame offset, a rip-relative global, and a pointer already computed
|
|
into a frame temporary. Adding a field offset to any of them is arithmetic
|
|
on the displacement rather than an instruction. *)
|
|
type loc =
|
|
| Lf of int (* rbp + d *)
|
|
| Lg of string * int (* rip-relative symbol + d *)
|
|
| Lp of int * int (* [rbp + p] is a pointer; + d *)
|
|
|
|
let shift l d =
|
|
match l with
|
|
| Lf o -> Lf (o + d)
|
|
| Lg (s, a) -> Lg (s, a + d)
|
|
| Lp (p, a) -> Lp (p, a + d)
|
|
|
|
(* [scratch] is only touched by the [Lp] case, and every caller passes r11 —
|
|
which is why r11 is never a value register anywhere below. *)
|
|
let lmem f (l : loc) ~scratch : mem =
|
|
match l with
|
|
| Lf o -> Frame o
|
|
| Lg (s, a) -> Sym (s, a)
|
|
| Lp (p, a) ->
|
|
load_int f.b ~dst:scratch ~mm:(Frame p) ~size:8 ~signed:false;
|
|
Reg (scratch, a)
|
|
|
|
let addr_into f ~reg (l : loc) =
|
|
match l with
|
|
| Lf o -> lea f.b ~dst:reg ~mm:(Frame o)
|
|
| Lg (s, a) -> lea f.b ~dst:reg ~mm:(Sym (s, a))
|
|
| Lp (p, a) ->
|
|
load_int f.b ~dst:reg ~mm:(Frame p) ~size:8 ~signed:false;
|
|
if a <> 0 then add_imm f.b ~dst:reg a
|
|
|
|
let scalar_size f (t : Types.t) =
|
|
match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t)
|
|
|
|
let load_loc f ~reg (l : loc) (t : Types.t) =
|
|
let mm = lmem f l ~scratch:r11 in
|
|
if is_float t then fload f.b ~dst:reg ~mm ~f64:(f64_of t)
|
|
else load_int f.b ~dst:reg ~mm ~size:(scalar_size f t) ~signed:(signed_of t)
|
|
|
|
let store_loc f ~reg (l : loc) (t : Types.t) =
|
|
let mm = lmem f l ~scratch:r11 in
|
|
if is_float t then fstore f.b ~src:reg ~mm ~f64:(f64_of t)
|
|
else store_int f.b ~src:reg ~mm ~size:(scalar_size f t)
|
|
|
|
(* An aggregate move. [rep movsb] rather than a sized loop for the reason the
|
|
header gives: nothing is live in a register across a statement, so the
|
|
crudest block copy in the instruction set is also the correct one. *)
|
|
let copy_loc f ~(dst : loc) ~(src : loc) n =
|
|
if n > 0 then begin
|
|
addr_into f ~reg:rdi dst;
|
|
addr_into f ~reg:rsi src;
|
|
blockcopy f n
|
|
end
|
|
|
|
let zero_loc f (dst : loc) n =
|
|
if n > 0 then begin
|
|
addr_into f ~reg:rdi dst;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
movabs f.b ~dst:rcx (Int64.of_int n);
|
|
rep_stosb f.b
|
|
end
|
|
|
|
(* Move a value of any type from one location to another: a block copy for an
|
|
aggregate, a load and a store for a scalar, and nothing at all for Unit. *)
|
|
let move f ~(dst : loc) ~(src : loc) (t : Types.t) =
|
|
if not (is_void t) then
|
|
if is_agg t then copy_loc f ~dst ~src (sizeof f.md t)
|
|
else begin
|
|
let r = if is_float t then xmm0 else rax in
|
|
load_loc f ~reg:r src t;
|
|
store_loc f ~reg:r dst t
|
|
end
|
|
|
|
let imm_into f ~reg (n : int64) = movabs f.b ~dst:reg n
|
|
|
|
(* ── Struct layout, through [Emit] ───────────────────────────────────── *)
|
|
|
|
let union_payload_off f (u : Tast.union) =
|
|
let size, align = Emit.payload_lay f.md u in
|
|
if size = 0 then 0
|
|
else
|
|
let _, _, offs =
|
|
Emit.lay_fields f.md
|
|
[ Types.Int Types.I32;
|
|
Types.Array (Int64.of_int (size / align),
|
|
Types.Int (Emit.int_kind (align * 8))) ]
|
|
in
|
|
List.nth offs 1
|
|
|
|
let field_offsets f (sn : string) =
|
|
match Hashtbl.find_opt f.md.Emit.structs sn with
|
|
| Some (s : Tast.structure) ->
|
|
let _, _, offs =
|
|
Emit.lay_fields f.md
|
|
(List.map (fun (fl : Tast.field) -> fl.Tast.fty) s.Tast.fields)
|
|
in
|
|
offs
|
|
| None ->
|
|
(* A union is a struct too, at this level: [emit.ml] lays it out as a tag
|
|
and a payload blob, and the structural printer reads the tag as field 0
|
|
without unwrapping the value. *)
|
|
(match Hashtbl.find_opt f.md.Emit.unions sn with
|
|
| Some (u : Tast.union) -> [ 0; union_payload_off f u ]
|
|
| None -> unsupported "no struct %s" sn)
|
|
|
|
(* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay]
|
|
measures it as — so the payload's offset is whatever [lay_fields] puts the
|
|
second one at, and not a rule spelled a second time here. A union whose
|
|
cases are all payload-less is a bare tag and has no second field. *)
|
|
|
|
let union_of f n =
|
|
match Hashtbl.find_opt f.md.Emit.unions n with
|
|
| Some u -> u
|
|
| None -> unsupported "no union %s" n
|
|
|
|
(* The offsets of one case's fields inside the payload blob. The single place
|
|
in this backend that knows how a payload is read, so [match]'s binds,
|
|
[CaseField] and [MakeCase] cannot come to different conclusions about it. *)
|
|
let case_offsets f (c : Tast.variant) =
|
|
let _, _, offs =
|
|
Emit.lay_fields f.md
|
|
(List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields)
|
|
in
|
|
offs
|
|
|
|
(* An Option is { i8 tag, T }, the same two fields [Emit.lay] measures it as. *)
|
|
let option_lay f (t : Types.t) =
|
|
let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I8; t ] in
|
|
match offs with [ a; b ] -> a, b | _ -> unsupported "option layout"
|
|
|
|
(* ── Condition codes ─────────────────────────────────────────────────── *)
|
|
|
|
let cc_e = 4 and cc_ne = 5
|
|
let cc_b = 2 and cc_ae = 3 and cc_be = 6 and cc_a = 7
|
|
let cc_l = 12 and cc_ge = 13 and cc_le = 14 and cc_g = 15
|
|
|
|
let int_cc ~signed (p : Tast.prim) =
|
|
match p, signed with
|
|
| Tast.Eq, _ -> cc_e
|
|
| Tast.Ne, _ -> cc_ne
|
|
| Tast.Lt, true -> cc_l | Tast.Lt, false -> cc_b
|
|
| Tast.Le, true -> cc_le | Tast.Le, false -> cc_be
|
|
| Tast.Gt, true -> cc_g | Tast.Gt, false -> cc_a
|
|
| Tast.Ge, true -> cc_ge | Tast.Ge, false -> cc_ae
|
|
| _ -> unsupported "not a comparison"
|
|
|
|
(* Parity, which on [ucomis] means "unordered": one of the operands was a NaN.
|
|
Nothing else in this file reads it. *)
|
|
let cc_np = 11
|
|
|
|
(* [ucomis] sets the flags the *unsigned* codes read, whichever way the
|
|
operands are signed, so a float comparison never uses l/g — and it sets
|
|
CF, ZF and PF all at once when either operand is a NaN.
|
|
|
|
That last part is why this is not simply the unsigned table. Every
|
|
comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq,
|
|
one, olt, ...), which answers false for a NaN, and [setb] after an
|
|
unordered compare answers true. So [<] and [<=] swap their operands and ask
|
|
for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be
|
|
spelled by one code at all and take a second [setnp] beside them.
|
|
|
|
[(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is
|
|
the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as
|
|
-9223372036854775808. *)
|
|
let float_swaps (p : Tast.prim) =
|
|
match p with Tast.Lt | Tast.Le -> true | _ -> false
|
|
|
|
let float_cc (p : Tast.prim) =
|
|
match p with
|
|
| Tast.Eq -> cc_e | Tast.Ne -> cc_ne
|
|
| Tast.Lt -> cc_a | Tast.Le -> cc_ae
|
|
| Tast.Gt -> cc_a | Tast.Ge -> cc_ae
|
|
| _ -> unsupported "not a comparison"
|
|
|
|
let float_ordered (p : Tast.prim) =
|
|
match p with Tast.Eq | Tast.Ne -> true | _ -> false
|
|
|
|
let is_cmp (p : Tast.prim) =
|
|
match p with
|
|
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true
|
|
| _ -> false
|
|
|
|
(* ── The transfer channel, spec-conditions.md §6 ──────────────── *)
|
|
|
|
(* One indirection more than [emit.ml] has, and it is the whole trap in this
|
|
file. There [%xfer] is an alloca, so the target is one [load] away. Here
|
|
[xfer_off] is a frame slot *holding the caller's pointer*, so reading the
|
|
target is two loads — slot, then through it — and clearing the channel is a
|
|
store *through* the pointer and never a store to [xfer_off]. Getting that
|
|
wrong produces assembly that reads perfectly and a program that never sees
|
|
a transfer, which is exactly the failure item 15 warns about. *)
|
|
|
|
let chan_into f ~reg = load_int f.b ~dst:reg ~mm:(Frame f.xfer_off) ~size:8 ~signed:false
|
|
|
|
(* The transfer target, or null. *)
|
|
let xfer_load f ~reg =
|
|
chan_into f ~reg;
|
|
load_int f.b ~dst:reg ~mm:(Reg (reg, 0)) ~size:8 ~signed:false
|
|
|
|
(* [reg] into the channel. [scratch] must not be [reg]. *)
|
|
let xfer_store f ~reg ~scratch =
|
|
chan_into f ~reg:scratch;
|
|
store_int f.b ~src:reg ~mm:(Reg (scratch, 0)) ~size:8
|
|
|
|
let xfer_clear f =
|
|
chan_into f ~reg:r11;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
store_int f.b ~src:rax ~mm:(Reg (r11, 0)) ~size:8
|
|
|
|
(* Where a transfer found after a call goes: the innermost restart-case,
|
|
handler-bind or with-allocator pad we are inside, or the function's own
|
|
transfer exit. Naming one marks it reached — nothing emits a pad that is
|
|
only ever fallen into. *)
|
|
let current_pad f =
|
|
match f.pads with
|
|
| (p, used) :: _ -> used := true; p
|
|
| [] -> f.unwound <- true; f.xfer_lbl
|
|
|
|
(* The check after a call, which is the whole of §6's lowering at a call site:
|
|
two loads, a test and a branch. Only [r11] is touched, so it may be emitted
|
|
between the call and the store of the value in [rax] — which is where it
|
|
goes, because a transfer means the value is meaningless.
|
|
|
|
A foreign call gets none: a transfer cannot cross a C frame, so there is
|
|
nothing a guard there could find. The exceptions are the runtime entry
|
|
points that take the channel themselves and signal through it. *)
|
|
let guard f =
|
|
xfer_load f ~reg:r11;
|
|
test_rr f.b ~a:r11 ~c:r11;
|
|
jcc_lbl f.b ~cc:cc_ne (current_pad f)
|
|
|
|
(* Run [g] with a fresh pad on top of the stack, and answer the pad's label
|
|
beside whether anything aimed at it. *)
|
|
let with_pad f tag g =
|
|
let pad = new_label f tag and used = ref false in
|
|
f.pads <- (pad, used) :: f.pads;
|
|
let r = g () in
|
|
f.pads <- List.tl f.pads;
|
|
(pad, used, r)
|
|
|
|
(* ── The runtime's two dynamic stacks ────────────────────────────────── *)
|
|
|
|
(* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the
|
|
same rules the runtime's own structs get, and the same [Emit.lay] applies to
|
|
everything else. Both live as frame temporaries of the function that
|
|
establishes them, which is the point: the *address* of a frame is the
|
|
identity a transfer carries, so re-entering the same restart-case gets a
|
|
different one and a module loaded later cannot collide with it. *)
|
|
|
|
(* { ptr prev, i32 type_id, ptr fn } *)
|
|
let h_size = 24
|
|
let h_type = 8
|
|
let h_fn = 16
|
|
|
|
(* { ptr prev, i32 name_id, ptr name, i64 namelen, ptr args,
|
|
i32 arity, i32 sig_id, i32 armed, ptr sig, i64 siglen } *)
|
|
let r_size = 72
|
|
let r_name_id = 8
|
|
let r_name = 16
|
|
let r_namelen = 24
|
|
let r_args = 32
|
|
let r_arity = 40
|
|
let r_sig_id = 44
|
|
let r_armed = 48
|
|
let r_sig = 56
|
|
let r_siglen = 64
|
|
|
|
(* ── The calling convention, as the header states it ─────────────────── *)
|
|
|
|
(* One argument as it will actually be handed over. [Aptr] is an aggregate,
|
|
which always crosses as the address of a copy the caller made; [Alen] is the
|
|
second word of a slice being exploded for a C callee. *)
|
|
type arg =
|
|
| Aint of loc * Types.t
|
|
| Aflt of loc * Types.t
|
|
| Aptr of loc
|
|
| Alen of loc
|
|
|
|
(* The C boundary, and the one place this backend must match SysV rather than
|
|
pick. [check.ml] rejects an aggregate in a [declare] signature and the shim
|
|
flattens every struct, so the only aggregates that reach here are the ones
|
|
[emit.ml]'s own shim rules already spell out: a slice as ptr+len, and a
|
|
move-only container by address. *)
|
|
let classify_c (l : loc) (t : Types.t) =
|
|
match t with
|
|
| Types.String | Types.Slice _ -> [ Aint (l, Types.Ptr Types.Unit); Alen l ]
|
|
| Types.Unit | Types.Never -> []
|
|
| Types.Vec _ | Types.Map _ | Types.Pool _ -> [ Aptr l ]
|
|
| _ when is_agg t ->
|
|
unsupported "aggregate %s across the C boundary" (Types.to_string t)
|
|
| _ when is_float t -> [ Aflt (l, t) ]
|
|
| _ -> [ Aint (l, t) ]
|
|
|
|
(* Hand the arguments over. Everything has already been evaluated into frame
|
|
temporaries, so loading the registers cannot disturb anything: every load
|
|
below reads from rbp, and rbp does not move. Answers how many SSE registers
|
|
were used, which is what [al] has to say to a variadic callee. *)
|
|
let emit_args f (args : arg list) =
|
|
let ints = ref 0 and sses = ref 0 and stack = ref 0 in
|
|
let placed =
|
|
List.map
|
|
(fun a ->
|
|
match a with
|
|
| Aflt _ when !sses < n_sse_args -> incr sses; `Sse (!sses - 1, a)
|
|
| Aflt _ -> let k = !stack in stack := k + 8; `Stack (k, a)
|
|
| _ when !ints < n_int_args -> incr ints; `Int (!ints - 1, a)
|
|
| _ -> let k = !stack in stack := k + 8; `Stack (k, a))
|
|
args
|
|
in
|
|
if !stack > f.outgoing then f.outgoing <- !stack;
|
|
let into ~reg a =
|
|
match a with
|
|
| Aint (l, t) -> load_loc f ~reg l t
|
|
| Aflt (l, t) -> fload f.b ~dst:reg ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t)
|
|
| Aptr l -> addr_into f ~reg l
|
|
| Alen l ->
|
|
load_int f.b ~dst:reg ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8
|
|
~signed:true
|
|
in
|
|
(* The stack half first, because it uses rax as its courier and a register
|
|
argument must not already be sitting in rax while that happens. *)
|
|
List.iter
|
|
(function
|
|
| `Stack (k, a) ->
|
|
(match a with
|
|
| Aflt (l, t) ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t);
|
|
fstore f.b ~src:xmm0 ~mm:(Reg (rsp, k)) ~f64:(f64_of t)
|
|
| _ ->
|
|
into ~reg:rax a;
|
|
store_int f.b ~src:rax ~mm:(Reg (rsp, k)) ~size:8)
|
|
| _ -> ())
|
|
placed;
|
|
List.iter
|
|
(function
|
|
| `Int (i, a) -> into ~reg:int_args.(i) a
|
|
| `Sse (i, a) -> into ~reg:i a
|
|
| `Stack _ -> ())
|
|
placed;
|
|
!sses
|
|
|
|
(* ── Lowering ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The destination handed to an expression whose value is thrown away.
|
|
|
|
It is one allocated value and it is compared by identity, because it is not
|
|
an address and must never be used as one: rbp+0 is the saved rbp and rbp+8
|
|
is the return address, so a 16-byte slice stored "into the sink" overwrites
|
|
both and the function returns into whatever the first two words of the
|
|
value happened to be. That is not hypothetical — it is how [edn.flan]
|
|
failed, by jumping into .rodata several statements after the real mistake,
|
|
and the mistake was a form of non-void type written in statement position.
|
|
|
|
So [lower] refuses the sink for anything that has a value, and spends a
|
|
frame temporary on it instead. The temporary is reclaimed at once; the
|
|
point is that the store has somewhere legal to go. *)
|
|
let sink = Lf 0
|
|
|
|
let rec lower f (e : Tast.expr) (dst : loc) : unit =
|
|
if dst == sink && not (is_void e.Tast.ty) then
|
|
scoped f (fun () ->
|
|
let o = tmp f e.Tast.ty in
|
|
lower f e (Lf o))
|
|
else lower_at f e dst
|
|
|
|
and lower_at f (e : Tast.expr) (dst : loc) : unit =
|
|
let t = e.Tast.ty in
|
|
match e.Tast.e with
|
|
| Tast.Int (n, _) -> imm_into f ~reg:rax n; store_loc f ~reg:rax dst t
|
|
| Tast.Bool b ->
|
|
imm_into f ~reg:rax (if b then 1L else 0L);
|
|
store_loc f ~reg:rax dst Types.Bool
|
|
| Tast.Float (x, k) ->
|
|
let f64 = (k = Types.F64) in
|
|
let l = float_const f x ~f64 in
|
|
fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
|
|
| Tast.Str s ->
|
|
(* A string and a [u8] slice are the same two words, which is why [Bytes]
|
|
below is a non-instruction. *)
|
|
let l = string_const f s in
|
|
lea f.b ~dst:rax ~mm:(Sym (l, 0));
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
|
imm_into f ~reg:rax (Int64.of_int (String.length s));
|
|
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
|
|
| Tast.Unit -> ()
|
|
| Tast.Zero ty -> zero_value f dst ty
|
|
| Tast.None_ -> zero_value f dst t
|
|
(* Reading an uninitialised value gives whatever the slot held: stable
|
|
garbage rather than LLVM's [poison]. The one construct where the two
|
|
backends are meant to differ — DISCUSS.md item 15, question 4. *)
|
|
| Tast.Uninit _ -> ()
|
|
| Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
|
|
let src = lvalue f e in
|
|
move f ~dst ~src t
|
|
| Tast.Addr p ->
|
|
let l = place f p in
|
|
addr_into f ~reg:rax l;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
(* Not the indirection cell: this backend owns the whole build and nothing
|
|
is redefined into it, so a function's address is its symbol. When it
|
|
stops being true, [Fnval] is the case that grows a load. *)
|
|
| Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n) ->
|
|
lea f.b ~dst:rax ~mm:(Sym (fsym n, 0));
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
| Tast.FnAddr (Tast.Rtfn n) ->
|
|
lea f.b ~dst:rax ~mm:(Sym (n, 0));
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
| Tast.Prim (p, args) -> prim f e p args dst
|
|
| Tast.Call (name, args) ->
|
|
(match Hashtbl.find_opt f.externs name with
|
|
| Some sym -> call_c f ~sym ~args ~rty:t dst
|
|
| None -> call_flan f ~target:(`Sym (fsym name)) ~args ~rty:t dst)
|
|
| Tast.CallPtr (callee, args) ->
|
|
let c = eval f callee in
|
|
call_flan f ~target:(`Loc c) ~args ~rty:t dst
|
|
| Tast.Do body -> block f body dst t
|
|
| Tast.Let (bs, body) ->
|
|
List.iter
|
|
(fun (slot, (v : Tast.expr)) ->
|
|
scoped f (fun () -> lower f v (Lf f.slots.(slot))))
|
|
bs;
|
|
block f body dst t
|
|
| Tast.If (c, a, b) ->
|
|
let lelse = new_label f "else" and lend = new_label f "endif" in
|
|
scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool);
|
|
test_rr f.b ~a:rax ~c:rax;
|
|
jcc_lbl f.b ~cc:cc_e lelse;
|
|
scoped f (fun () -> lower f a dst);
|
|
jmp_lbl f.b lend;
|
|
lbl f.b lelse;
|
|
scoped f (fun () -> lower f b dst);
|
|
lbl f.b lend
|
|
| Tast.While (c, body, latch) ->
|
|
let lhead = new_label f "head" and llatch = new_label f "latch"
|
|
and lend = new_label f "endw" in
|
|
lbl f.b lhead;
|
|
scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool);
|
|
test_rr f.b ~a:rax ~c:rax;
|
|
jcc_lbl f.b ~cc:cc_e lend;
|
|
f.loops <- (lend, llatch) :: f.loops;
|
|
List.iter (fun s -> scoped f (fun () -> lower f s sink)) body;
|
|
lbl f.b llatch;
|
|
List.iter (fun s -> scoped f (fun () -> lower f s sink)) latch;
|
|
f.loops <- List.tl f.loops;
|
|
jmp_lbl f.b lhead;
|
|
lbl f.b lend
|
|
| Tast.Return v ->
|
|
(match v with
|
|
| Some x when not (is_void x.Tast.ty) && not (is_void f.fret) ->
|
|
scoped f (fun () -> lower f x (ret_loc f))
|
|
| Some x -> scoped f (fun () -> lower f x sink)
|
|
| None -> ());
|
|
jmp_lbl f.b f.retlbl
|
|
| Tast.Break n ->
|
|
(match List.nth_opt f.loops n with
|
|
| Some (lend, _) -> jmp_lbl f.b lend
|
|
| None -> unsupported "break %d outside a loop" n)
|
|
| Tast.Continue n ->
|
|
(match List.nth_opt f.loops n with
|
|
| Some (_, llatch) -> jmp_lbl f.b llatch
|
|
| None -> unsupported "continue %d outside a loop" n)
|
|
| Tast.Set (p, v) ->
|
|
let l = place f p in
|
|
scoped f (fun () -> lower f v l)
|
|
| Tast.Make (sn, xs) ->
|
|
let offs = field_offsets f sn in
|
|
List.iteri
|
|
(fun i (x : Tast.expr) ->
|
|
scoped f (fun () -> lower f x (shift dst (List.nth offs i))))
|
|
xs
|
|
| Tast.Arr xs ->
|
|
let elem =
|
|
match t with
|
|
| Types.Array (_, el) -> el
|
|
| _ -> unsupported "array literal of %s" (Types.to_string t)
|
|
in
|
|
let sz = sizeof f.md elem in
|
|
List.iteri
|
|
(fun i (x : Tast.expr) ->
|
|
scoped f (fun () -> lower f x (shift dst (i * sz))))
|
|
xs
|
|
| Tast.Some_ x ->
|
|
let payload =
|
|
match t with
|
|
| Types.Option el -> el
|
|
| _ -> unsupported "some of %s" (Types.to_string t)
|
|
in
|
|
let ot, ov = option_lay f payload in
|
|
imm_into f ~reg:rax 1L;
|
|
store_int f.b ~src:rax ~mm:(lmem f (shift dst ot) ~scratch:r11) ~size:1;
|
|
scoped f (fun () -> lower f x (shift dst ov))
|
|
| Tast.UnwrapSome x ->
|
|
(* An early return and not an expression that can fail: with a [None] the
|
|
enclosing function returns [None] at once. *)
|
|
let payload =
|
|
match x.Tast.ty with
|
|
| Types.Option el -> el
|
|
| _ -> unsupported "unwrap of %s" (Types.to_string x.Tast.ty)
|
|
in
|
|
let src = eval f x in
|
|
let ot, ov = option_lay f payload in
|
|
load_int f.b ~dst:rax ~mm:(lmem f (shift src ot) ~scratch:r11) ~size:1
|
|
~signed:false;
|
|
let lsome = new_label f "some" in
|
|
test_rr f.b ~a:rax ~c:rax;
|
|
jcc_lbl f.b ~cc:cc_ne lsome;
|
|
if not (is_void f.fret) then zero_value f (ret_loc f) f.fret;
|
|
jmp_lbl f.b f.retlbl;
|
|
lbl f.b lsome;
|
|
move f ~dst ~src:(shift src ov) payload
|
|
| Tast.MakeCase (uname, case, fields) ->
|
|
let u = union_of f uname in
|
|
let i, c =
|
|
match Tast.case_index u case with
|
|
| Some (i, c) -> i, c
|
|
| None -> unsupported "no case %s of %s" case uname
|
|
in
|
|
(* Zeroed first: an omitted field is ZII and the payload blob is wider
|
|
than this case, so the bytes past its last field have to be something
|
|
rather than whatever the frame held. *)
|
|
zero_loc f dst (sizeof f.md t);
|
|
imm_into f ~reg:rax (Int64.of_int i);
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:4;
|
|
let poff = union_payload_off f u in
|
|
let offs = case_offsets f c in
|
|
List.iteri
|
|
(fun k (x : Tast.expr) ->
|
|
scoped f (fun () -> lower f x (shift dst (poff + List.nth offs k))))
|
|
fields
|
|
| Tast.CaseField (target, case, i) ->
|
|
move f ~dst ~src:(case_field f target case i) t
|
|
| Tast.Match (scrut, arms) -> emit_match f scrut arms dst t
|
|
(* The condition crosses as a pointer: a handler runs while the signalling
|
|
frame is still alive, so there is nothing to copy and nothing to own. *)
|
|
| Tast.Signal (Tast.Ssignal, id, c) ->
|
|
scoped f (fun () ->
|
|
let l = lvalue f c in
|
|
addr_into f ~reg:rsi l;
|
|
imm_into f ~reg:rdi (Int64.of_int id);
|
|
chan_into f ~reg:rdx;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_signal";
|
|
guard f)
|
|
(* §2's diverging variant. [flan_error] does not return unless a handler
|
|
transferred, so the guard is the only way out and the fall-through is
|
|
[ud2] — where [emit.ml] writes [unreachable]. *)
|
|
| Tast.Signal (Tast.Serror, id, c) ->
|
|
scoped f (fun () ->
|
|
let l = lvalue f c in
|
|
addr_into f ~reg:rsi l;
|
|
imm_into f ~reg:rdi (Int64.of_int id);
|
|
chan_into f ~reg:rdx;
|
|
let name =
|
|
match c.Tast.ty with Types.Named n -> n | _ -> "a condition" in
|
|
str_args f ~preg:rcx ~nreg:r8 name;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_error";
|
|
guard f;
|
|
ud2 f.b)
|
|
| Tast.Handled (frames, body) -> emit_handled f frames body dst t
|
|
| Tast.RestartCase (clauses, body) -> emit_restart_case f clauses body dst t
|
|
| Tast.WithAlloc (a, body) -> emit_with_alloc f a body dst t
|
|
| Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) ->
|
|
emit_invoke_restart f id name args sg sg_id rloc
|
|
|
|
(* ── Conditions ──────────────────────────────────────────────────────── *)
|
|
|
|
(* A string constant handed to the runtime as ptr+len, in two registers. *)
|
|
and str_args f ~preg ~nreg s =
|
|
let l = string_const f s in
|
|
lea f.b ~dst:preg ~mm:(Sym (l, 0));
|
|
imm_into f ~reg:nreg (Int64.of_int (String.length s))
|
|
|
|
(* One of the runtime's [_Noreturn] refusals. Everything is already in its
|
|
register; this is the call and the [ud2] that says the fall-through is not
|
|
a path. *)
|
|
and die f sym =
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b sym;
|
|
ud2 f.b
|
|
|
|
(* (handler-bind ((C f) ...) BODY...) — §2. Two stores and a push per frame,
|
|
and the frames live on this function's own stack. Popping is by frame and
|
|
not by count, which is right even if something below got the stack out of
|
|
step.
|
|
|
|
The body may not [return] — the checker rejects that — so the pop below and
|
|
the pop in the pad are between them the only paths out. *)
|
|
and emit_handled f frames body dst t =
|
|
let slots =
|
|
List.map
|
|
(fun (h : Tast.hframe) ->
|
|
let slot = alloc f h_size 8 in
|
|
imm_into f ~reg:rax (Int64.of_int h.Tast.htype);
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + h_type)) ~size:4;
|
|
(* The clause's body address, deliberately, and not a cell load: a
|
|
handler frame is not a redefinable top-level value — nothing can
|
|
name it and it lives only for this body. *)
|
|
lea f.b ~dst:rax ~mm:(Sym (fsym h.Tast.hfn, 0));
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + h_fn)) ~size:8;
|
|
lea f.b ~dst:rdi ~mm:(Frame slot);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_handler_push";
|
|
slot)
|
|
frames
|
|
in
|
|
(* Innermost first, which is the order they were pushed in reverse. *)
|
|
let pop () =
|
|
List.iter
|
|
(fun slot ->
|
|
lea f.b ~dst:rdi ~mm:(Frame slot);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_handler_pop")
|
|
(List.rev slots)
|
|
in
|
|
let ld = new_label f "endhandled" in
|
|
let pad, used, () = with_pad f "hxfer" (fun () -> block f body dst t) in
|
|
pop ();
|
|
jmp_lbl f.b ld;
|
|
(* A transfer passing through: these frames are on this function's stack and
|
|
must come off before it goes any further. Nothing here calls Flan, so the
|
|
channel can stay as it is. *)
|
|
if !used then begin
|
|
lbl f.b pad;
|
|
pop ();
|
|
jmp_lbl f.b (current_pad f)
|
|
end;
|
|
lbl f.b ld
|
|
|
|
(* (with-allocator A BODY...) — spec-memory.md's "Allocators". Save, run,
|
|
restore, and restore *again at the pad*: a body that errors, or one a
|
|
handler transfers out of, leaves through [current_pad], and a context
|
|
allocator left pointing into a region nobody outside the body has heard of
|
|
would be wrong in the break loop — which is exactly where someone is about
|
|
to allocate to render a condition. *)
|
|
and emit_with_alloc f (a : Tast.expr) body dst t =
|
|
let prev = ptmp f in
|
|
scoped f (fun () ->
|
|
let av = eval f a in
|
|
load_loc f ~reg:rdi av a.Tast.ty);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_context_set";
|
|
store_int f.b ~src:rax ~mm:(Frame prev) ~size:8;
|
|
let restore () =
|
|
load_int f.b ~dst:rdi ~mm:(Frame prev) ~size:8 ~signed:false;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_context_restore"
|
|
in
|
|
let ld = new_label f "endwith" in
|
|
let pad, used, () = with_pad f "wxfer" (fun () -> block f body dst t) in
|
|
restore ();
|
|
jmp_lbl f.b ld;
|
|
if !used then begin
|
|
lbl f.b pad;
|
|
restore ();
|
|
jmp_lbl f.b (current_pad f)
|
|
end;
|
|
lbl f.b ld
|
|
|
|
(* A clause's parameters as one record: what the invoker stores into and what
|
|
the clause loads out of. The two ends never see each other, so the layout is
|
|
agreed by the signature hash they compare first — same types in the same
|
|
order is the same record, and both sides ask [Emit.lay_fields], which is the
|
|
one layout calculator in this compiler. *)
|
|
and args_layout f (tys : Types.t list) =
|
|
let size, align, offs = Emit.lay_fields f.md tys in
|
|
(max 1 size), (max 1 align), offs
|
|
|
|
(* (restart-case BODY (name [p T] BODY-1) ...) — §3, §4 and §6 together.
|
|
|
|
One frame per clause, so the frame a transfer names says which clause to
|
|
run. §4's "innermost offering the name" falls out of the runtime's stack
|
|
walk, and re-entering a restart-case works because each activation allocates
|
|
its own frames.
|
|
|
|
§5's defers between here and the invoke have already run: each function on
|
|
the way out ran its own at its transfer exit before returning. What is left
|
|
is to take these frames off, copy §3's parameters out of the buffer the
|
|
invoker filled, and start the clause. *)
|
|
and emit_restart_case f clauses body dst t =
|
|
(* Everything the pad reads is allocated here, before any [scoped] the body
|
|
or a clause runs. The frame allocator is a bump pointer that reclaims at
|
|
the end of each statement, so a slot allocated inside the body would be
|
|
handed out again to the clause that has to read it — and the read would
|
|
be of whatever the clause's own temporaries put there. *)
|
|
let tgt = ptmp f in
|
|
let bufp = ptmp f in
|
|
let frames =
|
|
List.map
|
|
(fun (c : Tast.rclause) ->
|
|
let slot = alloc f r_size 8 in
|
|
let args =
|
|
if c.Tast.rparams = [] then None
|
|
else begin
|
|
let size, align, offs =
|
|
args_layout f (List.map snd c.Tast.rparams) in
|
|
Some (alloc f size align, offs)
|
|
end
|
|
in
|
|
(c, slot, args))
|
|
clauses
|
|
in
|
|
List.iter
|
|
(fun ((c : Tast.rclause), slot, args) ->
|
|
imm_into f ~reg:rax (Int64.of_int c.Tast.rname_id);
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_name_id)) ~size:4;
|
|
(* The name itself, beside the hash. A hash is all that matching needs,
|
|
but a break loop has to *show* someone their choices, and nothing at
|
|
run time can turn a hash back into a name. *)
|
|
str_args f ~preg:rax ~nreg:rcx c.Tast.rname;
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_name)) ~size:8;
|
|
store_int f.b ~src:rcx ~mm:(Frame (slot + r_namelen)) ~size:8;
|
|
(* §3's signature, which every frame carries whether it takes
|
|
parameters or not: a clause taking none has to be able to refuse
|
|
arguments as loudly as one taking two of the wrong type. *)
|
|
imm_into f ~reg:rax (Int64.of_int (List.length c.Tast.rparams));
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_arity)) ~size:4;
|
|
imm_into f ~reg:rax (Int64.of_int c.Tast.rsig_id);
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_sig_id)) ~size:4;
|
|
str_args f ~preg:rax ~nreg:rcx c.Tast.rsig;
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_sig)) ~size:8;
|
|
store_int f.b ~src:rcx ~mm:(Frame (slot + r_siglen)) ~size:8;
|
|
(match args with
|
|
| None -> ()
|
|
| Some (buf, _) ->
|
|
lea f.b ~dst:rax ~mm:(Frame buf);
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_args)) ~size:8;
|
|
(* Nothing has filled it in yet. Whoever aims a transfer at this
|
|
frame without going through an [invoke-restart] — the break loop,
|
|
today — leaves this zero, and the clause refuses rather than
|
|
running on values no one supplied. *)
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
store_int f.b ~src:rax ~mm:(Frame (slot + r_armed)) ~size:4);
|
|
lea f.b ~dst:rdi ~mm:(Frame slot);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_restart_push")
|
|
frames;
|
|
let pop () =
|
|
List.iter
|
|
(fun (_, slot, _) ->
|
|
lea f.b ~dst:rdi ~mm:(Frame slot);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_restart_pop")
|
|
(List.rev frames)
|
|
in
|
|
let ld = new_label f "endrestart" in
|
|
let pad, used, () = with_pad f "rxfer" (fun () -> lower f body dst) in
|
|
pop ();
|
|
jmp_lbl f.b ld;
|
|
if !used then begin
|
|
lbl f.b pad;
|
|
xfer_load f ~reg:rax;
|
|
store_int f.b ~src:rax ~mm:(Frame tgt) ~size:8;
|
|
(* Cleared before a clause runs, and put back if this transfer turns out to
|
|
be aimed further out. A clause body is ordinary code and its calls are
|
|
guarded like any other; it must not start with the channel still set. *)
|
|
xfer_clear f;
|
|
pop ();
|
|
List.iter
|
|
(fun ((c : Tast.rclause), slot, args) ->
|
|
let next = new_label f "outer" in
|
|
load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false;
|
|
lea f.b ~dst:rcx ~mm:(Frame slot);
|
|
cmp_rr f.b ~a:rax ~c:rcx;
|
|
jcc_lbl f.b ~cc:cc_ne next;
|
|
(match args with
|
|
| None -> ()
|
|
| Some (buf, offs) ->
|
|
(* Aimed here by something that supplied no arguments. There is no
|
|
such path from an [invoke-restart], so this is a break loop
|
|
taking a restart it cannot yet fill in — refused with the
|
|
reason. *)
|
|
load_int f.b ~dst:rax ~mm:(Frame (slot + r_armed)) ~size:4
|
|
~signed:true;
|
|
let armed = new_label f "armed" in
|
|
test_rr f.b ~a:rax ~c:rax;
|
|
jcc_lbl f.b ~cc:cc_ne armed;
|
|
let l0 = List.hd c.Tast.rbody in
|
|
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string l0.Tast.loc);
|
|
str_args f ~preg:rdx ~nreg:rcx c.Tast.rname;
|
|
str_args f ~preg:r8 ~nreg:r9 c.Tast.rsig;
|
|
die f "flan_restart_unarmed";
|
|
lbl f.b armed;
|
|
(* The frame is still addressable — it is a temporary of *this*
|
|
function — and the buffer is whatever the invoker left there. *)
|
|
lea f.b ~dst:rax ~mm:(Frame buf);
|
|
store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8;
|
|
List.iteri
|
|
(fun i (slot_i, ty) ->
|
|
move f ~dst:(Lf f.slots.(slot_i))
|
|
~src:(Lp (bufp, List.nth offs i)) ty)
|
|
c.Tast.rparams);
|
|
scoped f (fun () -> block f c.Tast.rbody dst t);
|
|
jmp_lbl f.b ld;
|
|
lbl f.b next)
|
|
frames;
|
|
(* Aimed further out than any of these. Back into the channel it goes. *)
|
|
load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false;
|
|
xfer_store f ~reg:rax ~scratch:r11;
|
|
jmp_lbl f.b (current_pad f)
|
|
end;
|
|
lbl f.b ld
|
|
|
|
(* §4's lookup, then the transfer itself: the frame that was found goes into
|
|
the channel and this function leaves through its landing pad. Type [Never],
|
|
so nothing follows. *)
|
|
and emit_invoke_restart f id name (args : Tast.expr list) sg sg_id rloc =
|
|
(* The arguments first, each into a frame temporary of its own, because the
|
|
lookup and its two failure paths clobber every register. *)
|
|
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
|
|
let t = ptmp f in
|
|
let bufp = ptmp f in
|
|
imm_into f ~reg:rdi (Int64.of_int id);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_find_restart";
|
|
store_int f.b ~src:rax ~mm:(Frame t) ~size:8;
|
|
(* No frame offers the name. That is a runtime error at the invoke site —
|
|
not an unwind past everything — because there is nowhere to resume. *)
|
|
let found = new_label f "found" in
|
|
test_rr f.b ~a:rax ~c:rax;
|
|
jcc_lbl f.b ~cc:cc_ne found;
|
|
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc);
|
|
str_args f ~preg:rdx ~nreg:rcx name;
|
|
die f "flan_restart_fail";
|
|
lbl f.b found;
|
|
(* §3's run-time check. A restart is found by name on a dynamic stack, so
|
|
what it takes is not knowable here: the frame carries its parameter count
|
|
and the hash of how they are spelled, and both are compared. The count is
|
|
not redundant with the hash — it is what makes a 32-bit collision between
|
|
two different signatures harmless in practice — and it is the cheaper
|
|
half. *)
|
|
let ok = new_label f "sigok" and bad = new_label f "signo" in
|
|
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:rax ~mm:(Reg (r11, r_arity)) ~size:4 ~signed:false;
|
|
cmp_imm f.b ~dst:rax (List.length args);
|
|
jcc_lbl f.b ~cc:cc_ne bad;
|
|
(* The hash is a full 32 bits and a [cmp] takes a signed imm32, so it goes
|
|
through a register rather than through the immediate. *)
|
|
load_int f.b ~dst:rax ~mm:(Reg (r11, r_sig_id)) ~size:4 ~signed:false;
|
|
imm_into f ~reg:rcx (Int64.of_int (sg_id land 0xffffffff));
|
|
cmp_rr f.b ~a:rax ~c:rcx;
|
|
jcc_lbl f.b ~cc:cc_e ok;
|
|
lbl f.b bad;
|
|
(* Eight arguments, so two go on the stack — which is what [outgoing] is
|
|
for. What the frame says it takes is read off the frame, because only the
|
|
frame knows; what was given is this call site's own spelling. *)
|
|
if f.outgoing < 16 then f.outgoing <- 16;
|
|
str_args f ~preg:rax ~nreg:r11 sg;
|
|
store_int f.b ~src:rax ~mm:(Reg (rsp, 0)) ~size:8;
|
|
store_int f.b ~src:r11 ~mm:(Reg (rsp, 8)) ~size:8;
|
|
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:r8 ~mm:(Reg (r11, r_sig)) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:r9 ~mm:(Reg (r11, r_siglen)) ~size:8 ~signed:true;
|
|
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc);
|
|
str_args f ~preg:rdx ~nreg:rcx name;
|
|
die f "flan_restart_args_fail";
|
|
lbl f.b ok;
|
|
(* Into the buffer the target frame owns, field by field: this frame is about
|
|
to go, and the clause runs after it has. The layout is the one the
|
|
signature just agreed on. *)
|
|
if vals <> [] then begin
|
|
let _, _, offs = args_layout f (List.map snd vals) in
|
|
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:rax ~mm:(Reg (r11, r_args)) ~size:8 ~signed:false;
|
|
store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8;
|
|
List.iteri
|
|
(fun i (l, ty) -> move f ~dst:(Lp (bufp, List.nth offs i)) ~src:l ty)
|
|
vals;
|
|
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
|
|
imm_into f ~reg:rax 1L;
|
|
store_int f.b ~src:rax ~mm:(Reg (r11, r_armed)) ~size:4
|
|
end;
|
|
load_int f.b ~dst:rax ~mm:(Frame t) ~size:8 ~signed:false;
|
|
xfer_store f ~reg:rax ~scratch:r11;
|
|
jmp_lbl f.b (current_pad f)
|
|
|
|
and zero_value f (dst : loc) (ty : Types.t) =
|
|
if is_agg ty then zero_loc f dst (sizeof f.md ty)
|
|
else if not (is_void ty) then
|
|
if is_float ty then begin
|
|
xorps f.b ~dst:xmm0;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of ty)
|
|
end else begin
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
store_loc f ~reg:rax dst ty
|
|
end
|
|
|
|
(* A statement list. Everything but the last form is evaluated for effect; the
|
|
last one is the value. *)
|
|
and block f body dst t =
|
|
let rec go = function
|
|
| [] -> ()
|
|
| [ (last : Tast.expr) ] ->
|
|
if is_void t || is_void last.Tast.ty then
|
|
scoped f (fun () -> lower f last sink)
|
|
else scoped f (fun () -> lower f last dst)
|
|
| s :: rest -> scoped f (fun () -> lower f s sink); go rest
|
|
in
|
|
go body
|
|
|
|
(* The address of something that denotes a location. Nothing is copied. *)
|
|
and lvalue f (e : Tast.expr) : loc =
|
|
match e.Tast.e with
|
|
| Tast.Local i -> Lf f.slots.(i)
|
|
| Tast.Global n -> Lg (gsym n, 0)
|
|
| Tast.Deref x -> let p = eval f x in Lp (off_of p, 0)
|
|
| Tast.Field (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
|
|
(* [(at a i)] denotes a location, and the source writes through it:
|
|
[(set (.x (at pts 0)) 1.5)] has to reach the array and not a copy of one
|
|
of its elements. [emit.ml] gets this from [addr]'s own [At] case; without
|
|
it here the store lands in a temporary and the program is quietly
|
|
wrong. *)
|
|
| Tast.Prim (Tast.At, a :: is) when is <> [] ->
|
|
elements f (lvalue f a) a.Tast.ty is
|
|
| Tast.CaseField (target, case, i) -> case_field f target case i
|
|
| _ -> eval f e
|
|
|
|
(* The address of one field of one case of a union value. Only ever reached
|
|
under an arm that proved the tag — [match] is the only thing that proves
|
|
it — or from the structural printer, which compares the same tag first. *)
|
|
and case_field f (target : Tast.expr) case i =
|
|
let uname =
|
|
match target.Tast.ty with
|
|
| Types.Named n -> n
|
|
| ty -> unsupported "case field of %s" (Types.to_string ty)
|
|
in
|
|
let u = union_of f uname in
|
|
let c =
|
|
match Tast.case_index u case with
|
|
| Some (_, c) -> c
|
|
| None -> unsupported "no case %s of %s" case uname
|
|
in
|
|
shift (lvalue f target) (union_payload_off f u + List.nth (case_offsets f c) i)
|
|
|
|
(* [match]. The two subjects are the same shape and are read differently: an
|
|
[Option] is an i8 tag and a payload at a known offset, a declared union is
|
|
an i32 tag and a blob the arm's case reinterprets. Everything past the tag
|
|
and the binds is shared, which is the arrangement [emit.ml] settled on for
|
|
the same reason. *)
|
|
and emit_match f (scrut : Tast.expr) (arms : Tast.arm list) dst t =
|
|
let base = lvalue f scrut in
|
|
let tag_size, tag_of, bind_at =
|
|
match scrut.Tast.ty with
|
|
| Types.Named n when Hashtbl.mem f.md.Emit.unions n ->
|
|
let u = union_of f n in
|
|
let poff = union_payload_off f u in
|
|
( 4,
|
|
(fun case ->
|
|
match Tast.case_index u case with
|
|
| Some (i, _) -> i
|
|
| None -> unsupported "no case %s of %s" case n),
|
|
fun case k ->
|
|
match Tast.case_index u case with
|
|
| Some (_, c) ->
|
|
shift base (poff + List.nth (case_offsets f c) k),
|
|
(List.nth c.Tast.vfields k).Tast.fty
|
|
| None -> unsupported "no case %s of %s" case n )
|
|
| Types.Option el ->
|
|
(* [lay_fields] puts the i8 tag at 0, so [base] is the tag's address the
|
|
way it is for a union. *)
|
|
let _, ov = option_lay f el in
|
|
( 1,
|
|
(fun case -> if String.equal case "Some" then 1 else 0),
|
|
fun _case _k -> shift base ov, el )
|
|
| ty -> unsupported "match on %s" (Types.to_string ty)
|
|
in
|
|
let lend = new_label f "endmatch" in
|
|
let rec go = function
|
|
| [] ->
|
|
(* The checker proved exhaustiveness, so nothing reaches here. A trap
|
|
rather than a fallthrough: [ud2] is a defined SIGILL at the
|
|
instruction that fell through, which is the cheap half of item 15's
|
|
question 4. *)
|
|
ud2 f.b
|
|
| (a : Tast.arm) :: rest ->
|
|
let lnext = new_label f "arm" in
|
|
(match a.Tast.acase with
|
|
| None -> ()
|
|
| Some case ->
|
|
load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:tag_size
|
|
~signed:false;
|
|
cmp_imm f.b ~dst:rax (tag_of case);
|
|
jcc_lbl f.b ~cc:cc_ne lnext);
|
|
List.iteri
|
|
(fun k slot ->
|
|
let src, fty =
|
|
bind_at (match a.Tast.acase with Some c -> c | None -> "") k
|
|
in
|
|
move f ~dst:(Lf f.slots.(slot)) ~src fty)
|
|
a.Tast.binds;
|
|
block f a.Tast.abody dst t;
|
|
jmp_lbl f.b lend;
|
|
if a.Tast.acase <> None then (lbl f.b lnext; go rest)
|
|
in
|
|
go arms;
|
|
lbl f.b lend
|
|
|
|
and field_loc f (base : loc) (ty : Types.t) i =
|
|
match ty with
|
|
| Types.Named sn -> shift base (List.nth (field_offsets f sn) i)
|
|
| Types.Ptr (Types.Named sn) ->
|
|
shift (Lp (off_of base, 0)) (List.nth (field_offsets f sn) i)
|
|
| Types.String | Types.Slice _ -> shift base (if i = 0 then 0 else 8)
|
|
| Types.Option el -> let ot, ov = option_lay f el in
|
|
shift base (if i = 0 then ot else ov)
|
|
| _ -> unsupported "field of %s" (Types.to_string ty)
|
|
|
|
and off_of (l : loc) =
|
|
match l with
|
|
| Lf o -> o
|
|
| _ -> unsupported "a pointer value must be a frame temporary"
|
|
|
|
and place f (p : Tast.place) : loc =
|
|
match p with
|
|
| Tast.Plocal i -> Lf f.slots.(i)
|
|
| Tast.Pglobal n -> Lg (gsym n, 0)
|
|
| Tast.Pderef x -> let q = eval f x in Lp (off_of q, 0)
|
|
| Tast.Pfield (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
|
|
(* [(at grid r c)] is one node with two indices, not two nodes: an array of
|
|
arrays is contiguous, so the second index walks into the element the
|
|
first one landed on. *)
|
|
| Tast.Pindex (x, is) -> elements f (lvalue f x) x.Tast.ty is
|
|
|
|
(* One element of an array, a slice or a pointer. No bounds check: the check
|
|
[emit.ml] emits signals, and signalling is the row of item 15's table with
|
|
no plan here yet — so this backend is the [--no-bounds-checks] shape of the
|
|
program and says so. *)
|
|
and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc =
|
|
match is with
|
|
| [] -> base
|
|
| i :: rest ->
|
|
let elem =
|
|
match ty with
|
|
| Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el
|
|
| Types.String -> Types.Int Types.U8
|
|
| t -> unsupported "index into %s" (Types.to_string t)
|
|
in
|
|
elements f (element f base ty i) elem rest
|
|
|
|
(* ── Bounds checks ───────────────────────────────────────────────────── *)
|
|
|
|
(* [emit.ml]'s [check_at] and [check_slice], which could not exist here until
|
|
the guard did: the runtime's bounds error *signals*, so the call is an
|
|
ordinary one that returns when a handler or the break loop transferred, and
|
|
what makes it a check rather than a call is the guard after it. The
|
|
fall-through past the guard is what is unreachable — nothing answered, so
|
|
the runtime already died inside the call — and [ud2] is where [emit.ml]
|
|
writes [unreachable].
|
|
|
|
That is also the answer to "does a bounds trap run defers": an answered one
|
|
does, because it leaves through the innermost pad; an unanswered one still
|
|
does not, because it is a die inside C. Identical on both backends. *)
|
|
and bounds_call f sym (loc : Loc.t) (extra : int list) =
|
|
let s = Loc.to_string loc in
|
|
str_args f ~preg:rdi ~nreg:rsi s;
|
|
let regs = [| rdx; rcx; r8; r9 |] in
|
|
List.iteri
|
|
(fun k off ->
|
|
load_int f.b ~dst:regs.(k) ~mm:(Frame off) ~size:8 ~signed:true)
|
|
extra;
|
|
chan_into f ~reg:regs.(List.length extra);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b sym;
|
|
guard f;
|
|
ud2 f.b
|
|
|
|
(* The length an index is checked against, or [None] for the forms [emit.ml]
|
|
does not check either: a raw pointer, which has no length, and a string,
|
|
which its [element_addr] does not index at all. *)
|
|
and index_len _f (base : loc) (ty : Types.t) =
|
|
match ty with
|
|
| Types.Array (n, _) -> Some (`Const n)
|
|
| Types.Slice _ -> Some (`At (shift base 8))
|
|
| _ -> None
|
|
|
|
and load_len f = function
|
|
| `Const n -> imm_into f ~reg:rcx n
|
|
| `At l -> load_int f.b ~dst:rcx ~mm:(lmem f l ~scratch:r11) ~size:8 ~signed:true
|
|
|
|
(* [at] is strict: the last valid index is len - 1, and one unsigned compare
|
|
catches a negative index as well as an oversized one. *)
|
|
and check_at f (base : loc) (ty : Types.t) (i : Tast.expr) (iv : loc) =
|
|
if f.md.Emit.checks then
|
|
match index_len f base ty with
|
|
| None -> ()
|
|
| Some len ->
|
|
scoped f (fun () ->
|
|
let a = ptmp f and b = ptmp f in
|
|
load_loc f ~reg:rax iv i.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
|
|
load_len f len;
|
|
store_int f.b ~src:rcx ~mm:(Frame b) ~size:8;
|
|
cmp_rr f.b ~a:rax ~c:rcx;
|
|
let ok = new_label f "inb" in
|
|
jcc_lbl f.b ~cc:cc_b ok;
|
|
bounds_call f "flan_bounds_error" i.Tast.loc [ a; b ];
|
|
lbl f.b ok)
|
|
|
|
(* [slice] is not strict: a slice ending at len — or an empty one at lo = len —
|
|
is legal. [lo <= hi] is not redundant with [hi <= len], because a reversed
|
|
range would otherwise yield hi - lo as a huge unsigned length, which is a
|
|
worse hole than the missing check. *)
|
|
and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr)
|
|
(llo : loc) (hi : Tast.expr) (lhi : loc) =
|
|
if f.md.Emit.checks then
|
|
let len =
|
|
match ty with
|
|
| Types.Array (n, _) -> Some (`Const n)
|
|
| Types.Slice _ | Types.String -> Some (`At (shift base 8))
|
|
| _ -> None
|
|
in
|
|
match len with
|
|
| None -> ()
|
|
| Some len ->
|
|
scoped f (fun () ->
|
|
let a = ptmp f and b = ptmp f and c = ptmp f in
|
|
load_loc f ~reg:rax llo lo.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
|
|
load_loc f ~reg:rdx lhi hi.Tast.ty;
|
|
store_int f.b ~src:rdx ~mm:(Frame b) ~size:8;
|
|
load_len f len;
|
|
store_int f.b ~src:rcx ~mm:(Frame c) ~size:8;
|
|
let ok = new_label f "inb" and bad = new_label f "oob" in
|
|
cmp_rr f.b ~a:rax ~c:rdx;
|
|
jcc_lbl f.b ~cc:cc_a bad;
|
|
cmp_rr f.b ~a:rdx ~c:rcx;
|
|
jcc_lbl f.b ~cc:cc_be ok;
|
|
lbl f.b bad;
|
|
bounds_call f "flan_slice_error" loc [ a; b; c ];
|
|
lbl f.b ok)
|
|
|
|
and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc =
|
|
let elem =
|
|
match ty with
|
|
| Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el
|
|
| Types.String -> Types.Int Types.U8
|
|
| t -> unsupported "index into %s" (Types.to_string t)
|
|
in
|
|
let iv = eval f i in
|
|
check_at f base ty i iv;
|
|
(match ty with
|
|
| Types.Array _ -> addr_into f ~reg:rax base
|
|
| _ ->
|
|
(* A slice's data pointer is its first word; a raw pointer is itself. *)
|
|
load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:8 ~signed:false);
|
|
load_loc f ~reg:rcx iv i.Tast.ty;
|
|
let sz = max 1 (sizeof f.md elem) in
|
|
if sz <> 1 then begin
|
|
imm_into f ~reg:rdx (Int64.of_int sz);
|
|
imul_rr f.b ~dst:rcx ~src:rdx
|
|
end;
|
|
add_rr f.b ~dst:rax ~src:rcx;
|
|
let p = ptmp f in
|
|
store_int f.b ~src:rax ~mm:(Frame p) ~size:8;
|
|
Lp (p, 0)
|
|
|
|
(* Evaluate into a fresh temporary and answer where it landed. Always a copy,
|
|
never the slot itself: [emit.ml] loads an operand where the operand is
|
|
written, left-to-right evaluation is *required* and not a preference (item
|
|
15, question 4), and a later argument that assigns to the same slot must
|
|
not be able to change what an earlier one already saw. *)
|
|
and eval f (e : Tast.expr) : loc =
|
|
if is_void e.Tast.ty then (lower f e sink; sink)
|
|
else begin
|
|
let o = tmp f e.Tast.ty in
|
|
lower f e (Lf o);
|
|
Lf o
|
|
end
|
|
|
|
and ret_loc f = if is_agg f.fret then Lp (f.sret_off, 0) else Lf f.retval
|
|
|
|
(* ── Calls ───────────────────────────────────────────────────────────── *)
|
|
|
|
(* Flan calling Flan. The convention is the header's, entire: scalars in the
|
|
integer or SSE sequence, every aggregate by pointer, a hidden [sret] in the
|
|
first integer register when the result is an aggregate, and the transfer
|
|
channel last of all. *)
|
|
and call_flan f ~target ~args ~rty dst =
|
|
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
|
|
let callee =
|
|
match target with `Sym s -> `Sym s | `Loc l -> `Loc (off_of l)
|
|
in
|
|
let sret = (not (is_void rty)) && is_agg rty in
|
|
let head = if sret then [ Aptr dst ] else [] in
|
|
let body =
|
|
List.concat_map
|
|
(fun (l, ty) ->
|
|
if is_void ty then []
|
|
else if is_agg ty then [ Aptr l ]
|
|
else if is_float ty then [ Aflt (l, ty) ]
|
|
else [ Aint (l, ty) ])
|
|
vals
|
|
in
|
|
(* The channel is this frame's own: a callee that transfers writes through
|
|
the pointer we were handed, so one cell serves the whole chain. *)
|
|
let chan = [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] in
|
|
ignore (emit_args f (head @ body @ chan));
|
|
(match callee with
|
|
| `Sym s -> call_sym f.b s
|
|
| `Loc o ->
|
|
load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false;
|
|
call_r f.b r11);
|
|
(* §6 at a call site, and it is every call site: a callee that transferred
|
|
wrote a frame address through the channel, and the value in [rax] means
|
|
nothing. The guard touches only [r11], so it goes between the call and
|
|
the store rather than after it. A call by pointer is guarded by the same
|
|
guard — a transfer is carried by the channel whether the callee was
|
|
reached by name or by address. *)
|
|
guard f;
|
|
if (not (is_void rty)) && not sret then
|
|
store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty
|
|
|
|
(* Flan calling C. SysV exactly, because this is the boundary where it has to
|
|
be — and the only aggregates that get here are the ones the shim rules
|
|
already flatten. *)
|
|
and call_c f ~sym ~args ~rty dst =
|
|
call_native f ~sym:(asm_sym sym) ~args ~rty dst
|
|
|
|
(* The two runtime entry points whose bounds check signals. They are the only
|
|
[Rt] symbols that can transfer, so they are the only ones that take the
|
|
channel and the only ones guarded — everything else in this family is
|
|
arithmetic over a container header and cannot reach a handler. A Vec is
|
|
checked inside the runtime rather than in emitted code (BUILT.md), so this
|
|
is where [(at v i)] gets what [(at arr i)] gets from [check_at]. *)
|
|
and rt_signals sym =
|
|
String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice"
|
|
|
|
and call_rt f ~sym ~args ~rty dst =
|
|
call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst
|
|
|
|
and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
|
|
(* A Vec, a Map and a Pool are move-only and cross to the runtime as their
|
|
*address*, which is what lets an operation mutate the caller's container
|
|
in place. [eval] would hand over the address of a copy, and the runtime
|
|
would grow that and leave the caller's header at length zero — which is
|
|
how [bounds-condition.flan] failed, as an in-bounds (at v 1) signalling
|
|
against a length of 0. Every other aggregate is read-only across this
|
|
boundary, so a copy there is harmless. *)
|
|
let vals =
|
|
List.map
|
|
(fun (a : Tast.expr) ->
|
|
(match a.Tast.ty with
|
|
| Types.Vec _ | Types.Map _ | Types.Pool _ -> lvalue f a
|
|
| _ -> eval f a), a.Tast.ty)
|
|
args
|
|
in
|
|
let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in
|
|
let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] else flat in
|
|
let nsse = emit_args f flat in
|
|
(* [al] is how many SSE registers were used, which a variadic callee reads.
|
|
Harmless on a fixed one, and a [declare] does not say which it is. *)
|
|
imm_into f ~reg:rax (Int64.of_int nsse);
|
|
call_sym f.b sym;
|
|
if chan then guard f;
|
|
if not (is_void rty) then begin
|
|
if is_agg rty then unsupported "aggregate return from %s" sym;
|
|
store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty
|
|
end
|
|
|
|
(* ── Primitives ──────────────────────────────────────────────────────── *)
|
|
|
|
and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
|
|
let t = e.Tast.ty in
|
|
match p, args with
|
|
| (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem
|
|
| Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ a; b ] ->
|
|
let la = eval f a in
|
|
let lb = eval f b in
|
|
if is_float t then begin
|
|
let f64 = f64_of t in
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64;
|
|
fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64;
|
|
let op =
|
|
match p with
|
|
| Tast.Add -> 0x58 | Tast.Sub -> 0x5c
|
|
| Tast.Mul -> 0x59 | Tast.Div -> 0x5e
|
|
| _ -> unsupported "that operator on %s" (Types.to_string t)
|
|
in
|
|
farith f.b ~op ~f64 ~dst:xmm0 ~src:1;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
|
|
end else begin
|
|
let signed = signed_of t in
|
|
load_loc f ~reg:rax la a.Tast.ty;
|
|
load_loc f ~reg:rcx lb b.Tast.ty;
|
|
(match p with
|
|
| Tast.Add -> add_rr f.b ~dst:rax ~src:rcx
|
|
| Tast.Sub -> sub_rr f.b ~dst:rax ~src:rcx
|
|
| Tast.Mul -> imul_rr f.b ~dst:rax ~src:rcx
|
|
| Tast.BitAnd -> and_rr f.b ~dst:rax ~src:rcx
|
|
| Tast.BitOr -> or_rr f.b ~dst:rax ~src:rcx
|
|
| Tast.BitXor -> xor_rr f.b ~dst:rax ~src:rcx
|
|
(* The count is masked to the operand width by the hardware, which is
|
|
the rule the language already defines. *)
|
|
| Tast.Shl -> shl_cl f.b ~dst:rax
|
|
| Tast.Shr -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax
|
|
| Tast.Div | Tast.Rem ->
|
|
if signed then (cqo f.b; idiv_r f.b ~src:rcx)
|
|
else (xor_rr f.b ~dst:rdx ~src:rdx; div_r f.b ~src:rcx);
|
|
if p = Tast.Rem then mov_rr f.b ~dst:rax ~src:rdx
|
|
| _ -> unsupported "arithmetic");
|
|
store_loc f ~reg:rax dst t
|
|
end
|
|
| _, [ a; b ] when is_cmp p ->
|
|
let la = eval f a in
|
|
let lb = eval f b in
|
|
if is_float a.Tast.ty then begin
|
|
let f64 = f64_of a.Tast.ty in
|
|
let x, y = if float_swaps p then lb, la else la, lb in
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f x ~scratch:r11) ~f64;
|
|
fload f.b ~dst:1 ~mm:(lmem f y ~scratch:r11) ~f64;
|
|
ucomis f.b ~f64 ~a:xmm0 ~c:1;
|
|
setcc f.b ~cc:(float_cc p) ~dst:rax;
|
|
if float_ordered p then begin
|
|
movzx8 f.b ~dst:rax ~src:rax;
|
|
setcc f.b ~cc:cc_np ~dst:rcx;
|
|
movzx8 f.b ~dst:rcx ~src:rcx;
|
|
and_rr f.b ~dst:rax ~src:rcx
|
|
end
|
|
end else begin
|
|
load_loc f ~reg:rax la a.Tast.ty;
|
|
load_loc f ~reg:rcx lb b.Tast.ty;
|
|
cmp_rr f.b ~a:rax ~c:rcx;
|
|
setcc f.b ~cc:(int_cc ~signed:(signed_of a.Tast.ty) p) ~dst:rax
|
|
end;
|
|
movzx8 f.b ~dst:rax ~src:rax;
|
|
store_loc f ~reg:rax dst Types.Bool
|
|
| Tast.Not, [ a ] ->
|
|
let la = eval f a in
|
|
if Types.equal a.Tast.ty Types.Bool then begin
|
|
load_loc f ~reg:rax la Types.Bool;
|
|
grp1_imm f.b ~ext:6 ~dst:rax 1
|
|
end else begin
|
|
load_loc f ~reg:rax la a.Tast.ty;
|
|
not_r f.b ~dst:rax
|
|
end;
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.Len, [ a ] ->
|
|
(match a.Tast.ty with
|
|
| Types.Array (n, _) -> imm_into f ~reg:rax n
|
|
| Types.String | Types.Slice _ ->
|
|
let l = lvalue f a in
|
|
load_int f.b ~dst:rax ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8
|
|
~signed:true
|
|
| ty -> unsupported "len of %s" (Types.to_string ty));
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.At, a :: is when is <> [] ->
|
|
let l = elements f (lvalue f a) a.Tast.ty is in
|
|
move f ~dst ~src:l t
|
|
| Tast.Slice, [ a; lo; hi ] ->
|
|
let elem =
|
|
match a.Tast.ty with
|
|
| Types.Array (_, el) | Types.Slice el -> el
|
|
| Types.String -> Types.Int Types.U8
|
|
| ty -> unsupported "slice of %s" (Types.to_string ty)
|
|
in
|
|
let base = lvalue f a in
|
|
let llo = eval f lo in
|
|
let lhi = eval f hi in
|
|
(* The source is read once, and the check goes between reading it and the
|
|
arithmetic: the length it is checked against must be the one the
|
|
arithmetic uses. *)
|
|
check_slice f base a.Tast.ty e.Tast.loc lo llo hi lhi;
|
|
(match a.Tast.ty with
|
|
| Types.Array _ -> addr_into f ~reg:rax base
|
|
| _ ->
|
|
load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:8
|
|
~signed:false);
|
|
load_loc f ~reg:rcx llo lo.Tast.ty;
|
|
let sz = max 1 (sizeof f.md elem) in
|
|
if sz <> 1 then begin
|
|
imm_into f ~reg:rdx (Int64.of_int sz);
|
|
imul_rr f.b ~dst:rcx ~src:rdx
|
|
end;
|
|
add_rr f.b ~dst:rax ~src:rcx;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
|
load_loc f ~reg:rax lhi hi.Tast.ty;
|
|
load_loc f ~reg:rcx llo lo.Tast.ty;
|
|
sub_rr f.b ~dst:rax ~src:rcx;
|
|
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
|
|
(* string and [u8] are the same two words, so both directions are views and
|
|
not copies — the same non-instruction [emit.ml] emits. *)
|
|
| (Tast.Bytes | Tast.StrOfBytes), [ a ] -> lower f a dst
|
|
| Tast.I64ToBytes, [ a ] -> shim_out f "flan_i64_to_bytes" a dst
|
|
| Tast.U64ToBytes, [ a ] -> shim_out f "flan_u64_to_bytes" a dst
|
|
| Tast.F64ToBytes, [ a ] -> shim_out f "flan_f64_to_bytes" a dst
|
|
| Tast.EscapeBytes, [ a ] ->
|
|
let l = eval f a in
|
|
slice_in_out f "flan_escape_bytes" l dst
|
|
| Tast.BytesToI64, [ a ] ->
|
|
call_rt f ~sym:"flan_bytes_to_i64" ~args:[ a ] ~rty:t dst
|
|
| Tast.BytesToF64, [ a ] ->
|
|
call_rt f ~sym:"flan_bytes_to_f64" ~args:[ a ] ~rty:t dst
|
|
| Tast.WriteStdout, [ a ] ->
|
|
call_rt f ~sym:"flan_write_stdout" ~args:[ a ] ~rty:Types.Unit sink
|
|
| Tast.Exit, [ a ] ->
|
|
call_rt f ~sym:"flan_exit" ~args:[ a ] ~rty:Types.Unit sink;
|
|
ud2 f.b
|
|
| Tast.Argv, [] ->
|
|
addr_into f ~reg:rdi dst;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_argv"
|
|
| Tast.SizeOf ty, [] ->
|
|
imm_into f ~reg:rax (Int64.of_int (sizeof f.md ty));
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.AlignOf ty, [] ->
|
|
imm_into f ~reg:rax (Int64.of_int (alignof f.md ty));
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.AddrOf, [ a ] ->
|
|
let l = lvalue f a in
|
|
addr_into f ~reg:rax l;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
| Tast.Rt sym, _ -> call_rt f ~sym ~args ~rty:t dst
|
|
| Tast.Cast target, [ a ] -> cast f a target dst
|
|
| _ -> unsupported "primitive with %d arguments" (List.length args)
|
|
|
|
(* [void shim(T, flan_slice *out)] — a scalar in, a slice written through a
|
|
hidden out pointer. The three number printers, and nothing else. *)
|
|
and shim_out f sym (a : Tast.expr) dst =
|
|
let l = eval f a in
|
|
if is_float a.Tast.ty then begin
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of a.Tast.ty);
|
|
addr_into f ~reg:rdi dst;
|
|
imm_into f ~reg:rax 1L
|
|
end else begin
|
|
load_loc f ~reg:rdi l a.Tast.ty;
|
|
addr_into f ~reg:rsi dst;
|
|
imm_into f ~reg:rax 0L
|
|
end;
|
|
call_sym f.b sym
|
|
|
|
(* [void shim(ptr, i64, flan_slice *out)] — a slice in, a slice out. *)
|
|
and slice_in_out f sym (src : loc) dst =
|
|
load_int f.b ~dst:rdi ~mm:(lmem f src ~scratch:r11) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:rsi ~mm:(lmem f (shift src 8) ~scratch:r11) ~size:8
|
|
~signed:true;
|
|
addr_into f ~reg:rdx dst;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b sym
|
|
|
|
(* Every conversion, and there are only four shapes of them. Integer to
|
|
integer is already the load and store rules: a load widens the way the
|
|
source's own signedness says, and a store narrows to the destination's
|
|
width, so one pair covers all sixty-four pairings. *)
|
|
and cast f (a : Tast.expr) (target : Types.t) dst =
|
|
let concrete (t : Types.t) =
|
|
match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
|
|
in
|
|
let src_t = concrete a.Tast.ty and dst_t = concrete target in
|
|
let l = eval f a in
|
|
match is_float src_t, is_float dst_t with
|
|
| false, false ->
|
|
load_loc f ~reg:rax l src_t;
|
|
store_loc f ~reg:rax dst dst_t
|
|
| true, true ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
|
|
if f64_of src_t && not (f64_of dst_t) then cvtsd2ss f.b ~dst:xmm0 ~src:xmm0
|
|
else if (not (f64_of src_t)) && f64_of dst_t then
|
|
cvtss2sd f.b ~dst:xmm0 ~src:xmm0;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
|
|
| false, true ->
|
|
load_loc f ~reg:rax l src_t;
|
|
cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
|
|
| true, false ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
|
|
cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0;
|
|
store_loc f ~reg:rax dst dst_t
|
|
|
|
(* ── A function ──────────────────────────────────────────────────────── *)
|
|
|
|
(* The frame is rounded to 16 and reserves the outgoing-argument area in the
|
|
same [sub]. [push rbp] takes entry's [rsp ≡ 8 (mod 16)] to [rsp ≡ 0], so
|
|
[rbp ≡ 0] and — because [rsp] is written exactly here and by [leave] —
|
|
[rsp ≡ 0] at every call site in the body. That is the whole licence for
|
|
having no depth counter, and it is one rounded subtraction rather than an
|
|
invariant every case has to maintain. *)
|
|
let frame_bytes f = ((f.maxframe + f.outgoing + 15) / 16) * 16
|
|
|
|
(* Where each argument arrives, in the order the header lays down: a hidden
|
|
[sret] first when the result is an aggregate, then the parameters, then the
|
|
transfer channel. Answers one entry per incoming value — a register number,
|
|
or a positive [rbp] displacement for the ones that came on the stack. *)
|
|
type incoming = Ireg of int | Isse of int | Istk of int
|
|
|
|
let incoming_of ~sret (params : Types.t list) =
|
|
let ints = ref 0 and sses = ref 0 and stk = ref 0 in
|
|
let next_int () =
|
|
if !ints < n_int_args then (incr ints; Ireg int_args.(!ints - 1))
|
|
else (let k = !stk in stk := k + 8; Istk (16 + k))
|
|
in
|
|
let next_sse () =
|
|
if !sses < n_sse_args then (incr sses; Isse (!sses - 1))
|
|
else (let k = !stk in stk := k + 8; Istk (16 + k))
|
|
in
|
|
let sret_at = if sret then Some (next_int ()) else None in
|
|
let ps =
|
|
List.map
|
|
(fun ty ->
|
|
if is_void ty then Istk (-1)
|
|
else if is_agg ty then next_int ()
|
|
else if is_float ty then next_sse ()
|
|
else next_int ())
|
|
params
|
|
in
|
|
sret_at, ps, next_int ()
|
|
|
|
let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
|
|
let b = create () in
|
|
let nslots = Array.length fn.Tast.slots in
|
|
let f =
|
|
{ b; md; fnname = fn.Tast.name; retlbl = "";
|
|
fret = fn.Tast.ret; slots = Array.make nslots 0;
|
|
xfer_off = 0; sret_off = 0; retval = 0;
|
|
frame = 0; maxframe = 0; outgoing = 0;
|
|
loops = []; pads = []; xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 64; externs; fns }
|
|
in
|
|
(* The header's own frame model: every slot and every temporary is
|
|
bump-allocated below rbp, and the high-water mark is what the prologue
|
|
subtracts. Nothing is ever pushed. *)
|
|
Array.iteri (fun i ty -> f.slots.(i) <- tmp f ty) fn.Tast.slots;
|
|
let sret = (not (is_void fn.Tast.ret)) && is_agg fn.Tast.ret in
|
|
f.xfer_off <- ptmp f;
|
|
if sret then f.sret_off <- ptmp f;
|
|
if (not sret) && not (is_void fn.Tast.ret) then f.retval <- tmp f fn.Tast.ret;
|
|
f.retlbl <- new_label f "ret";
|
|
f.xfer_lbl <- new_label f "xfer";
|
|
let sret_at, param_at, xfer_at = incoming_of ~sret fn.Tast.params in
|
|
(* An aggregate parameter arrives as a pointer to the caller's copy and has
|
|
to be copied into its slot before anything else runs — and [rep movsb]
|
|
eats rdi, rsi and rcx, which is where three of the other parameters still
|
|
are. So every incoming register is spilled first and the copies happen
|
|
afterwards, out of frame temporaries. *)
|
|
let spills =
|
|
List.map2
|
|
(fun ty at ->
|
|
match at with
|
|
| Ireg _ when is_agg ty -> Some (ptmp f)
|
|
| _ -> None)
|
|
fn.Tast.params param_at
|
|
in
|
|
(* The body. Lowered into its own buffer, because the prologue's [sub] needs
|
|
a frame size only the body can decide, and every relocation this backend
|
|
emits is an assembler expression — so nothing has to be patched. *)
|
|
let last = ref None in
|
|
let rec go = function
|
|
| [] -> ()
|
|
| [ (e : Tast.expr) ] -> last := Some e; go []
|
|
| e :: rest -> scoped f (fun () -> lower f e sink); go rest
|
|
in
|
|
go fn.Tast.body;
|
|
(match !last with
|
|
| Some e when (not (is_void fn.Tast.ret)) && not (is_void e.Tast.ty) ->
|
|
scoped f (fun () -> lower f e (ret_loc f))
|
|
| Some e -> scoped f (fun () -> lower f e sink)
|
|
| None -> ());
|
|
(* The transfer exit, spec-conditions.md §5 and §6. A transfer that reached
|
|
the top of this function without a restart-case to catch it leaves the
|
|
same way a [return] does — which is what reuses the existing return path,
|
|
and with it the defers, for free. The value returned is meaningless: the
|
|
caller's guard sees the channel set and never looks at it.
|
|
|
|
Emitted here, *before* the prologue buffer is made, because [frame_bytes]
|
|
is read when the prologue is built and everything below allocates
|
|
temporaries and makes calls that move the high-water mark. *)
|
|
if f.unwound then begin
|
|
(* The body falls through to the epilogue, so it has to be sent there
|
|
explicitly before this: otherwise the last statement runs straight into
|
|
the transfer exit and the defers run a second time. [emit.ml] cannot
|
|
have this bug — its [ret] terminates the block. *)
|
|
jmp_lbl f.b f.retlbl;
|
|
lbl f.b f.xfer_lbl;
|
|
if fn.Tast.fdefers <> [] then begin
|
|
(* The channel is cleared while the defers run and put back after. A
|
|
defer makes ordinary calls and each one is guarded; with the channel
|
|
still set the first of them would branch straight back here. *)
|
|
let saved = ptmp f in
|
|
xfer_load f ~reg:rax;
|
|
store_int f.b ~src:rax ~mm:(Frame saved) ~size:8;
|
|
xfer_clear f;
|
|
let cleanup = new_label f "cleanup" and used = ref false in
|
|
f.pads <- [ (cleanup, used) ];
|
|
List.iter (fun e -> scoped f (fun () -> lower f e sink)) fn.Tast.fdefers;
|
|
f.pads <- [];
|
|
load_int f.b ~dst:rax ~mm:(Frame saved) ~size:8 ~signed:false;
|
|
xfer_store f ~reg:rax ~scratch:r11;
|
|
jmp_lbl f.b f.retlbl;
|
|
(* A defer that starts a *second* transfer while the first is unwinding.
|
|
§6's per-frame slot nests, but nothing here does: the first
|
|
transfer's target is in hand and the defers are half run. Refused
|
|
loudly rather than resolved to one of them. *)
|
|
if !used then begin
|
|
lbl f.b cleanup;
|
|
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string fn.Tast.floc);
|
|
die f "flan_transfer_fail"
|
|
end
|
|
end
|
|
else jmp_lbl f.b f.retlbl
|
|
end
|
|
else if fn.Tast.fdefers <> [] then
|
|
(* Nothing in this function can transfer, so the second exit has no path
|
|
to it and the defers on it are dead. Left as a refusal rather than
|
|
quietly dropped: if that reasoning is ever wrong, this says so. *)
|
|
unsupported "%s has defers on a transfer path nothing reaches"
|
|
fn.Tast.name;
|
|
|
|
(* The prologue, now that the frame size is known. *)
|
|
let pb = create () in
|
|
push_r pb rbp;
|
|
mov_rr pb ~dst:rbp ~src:rsp;
|
|
let n = frame_bytes f in
|
|
if n > 0 then sub_imm pb ~dst:rsp n;
|
|
(match sret_at with
|
|
| Some (Ireg r) -> store_int pb ~src:r ~mm:(Frame f.sret_off) ~size:8
|
|
| Some (Istk d) ->
|
|
load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
|
|
store_int pb ~src:rax ~mm:(Frame f.sret_off) ~size:8
|
|
| _ -> ());
|
|
List.iteri
|
|
(fun i ty ->
|
|
let at = List.nth param_at i and sp = List.nth spills i in
|
|
let slot = f.slots.(i) in
|
|
match at, sp with
|
|
| Ireg r, Some p -> store_int pb ~src:r ~mm:(Frame p) ~size:8
|
|
| Ireg r, None ->
|
|
if is_void ty then ()
|
|
else store_int pb ~src:r ~mm:(Frame slot)
|
|
~size:(match ty with Types.Bool -> 1
|
|
| _ -> max 1 (fst (Emit.lay md ty)))
|
|
| Isse i', _ ->
|
|
fstore pb ~src:i' ~mm:(Frame slot) ~f64:(f64_of ty)
|
|
| Istk d, _ ->
|
|
if is_agg ty then begin
|
|
(* The caller put a pointer there, not the aggregate. *)
|
|
load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
|
|
store_int pb ~src:rax ~mm:(Frame (match sp with Some p -> p | None -> slot))
|
|
~size:8
|
|
end else if not (is_void ty) then begin
|
|
load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:(signed_of ty);
|
|
store_int pb ~src:rax ~mm:(Frame slot)
|
|
~size:(match ty with Types.Bool -> 1
|
|
| _ -> max 1 (fst (Emit.lay md ty)))
|
|
end)
|
|
fn.Tast.params;
|
|
(match xfer_at with
|
|
| Ireg r -> store_int pb ~src:r ~mm:(Frame f.xfer_off) ~size:8
|
|
| Istk d ->
|
|
load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
|
|
store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8
|
|
| Isse _ -> unsupported "the channel in an SSE register");
|
|
(* And now the aggregate copies, with every incoming register safely in the
|
|
frame. A struct parameter *is* a copy — spec-memory.md's assignment rule,
|
|
made by the caller and taken again here so the callee owns it. *)
|
|
List.iteri
|
|
(fun i ty ->
|
|
match List.nth spills i with
|
|
| Some p ->
|
|
lea pb ~dst:rdi ~mm:(Frame f.slots.(i));
|
|
load_int pb ~dst:rsi ~mm:(Frame p) ~size:8 ~signed:false;
|
|
movabs pb ~dst:rcx (Int64.of_int (fst (Emit.lay md ty)));
|
|
rep_movsb pb
|
|
| None -> ())
|
|
fn.Tast.params;
|
|
|
|
(* The epilogue, in exactly one place. *)
|
|
lbl f.b f.retlbl;
|
|
if sret then load_int f.b ~dst:rax ~mm:(Frame f.sret_off) ~size:8 ~signed:false
|
|
else if not (is_void fn.Tast.ret) then
|
|
load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax)
|
|
~off:f.retval fn.Tast.ret;
|
|
leave f.b;
|
|
ret f.b;
|
|
flush pb;
|
|
flush f.b;
|
|
let sym = fsym fn.Tast.name in
|
|
let out = Buffer.create 1024 in
|
|
Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym);
|
|
Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym);
|
|
Buffer.add_string out (sym ^ ":\n");
|
|
Buffer.add_string out (Buffer.contents pb.out);
|
|
Buffer.add_string out (Buffer.contents f.b.out);
|
|
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
|
|
Buffer.contents out, Buffer.contents f.rodata
|
|
|
|
(* ── C's main ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The same four shapes [emit.ml]'s [emit_main] adapts to, and the same order:
|
|
the runtime is initialised while argc and argv are still in the registers
|
|
the loader put them in, the program's own end of the transfer channel is a
|
|
null cell on this frame, and the exit goes through [flan_exit] because
|
|
stdout is a FILE* and something has to flush it. *)
|
|
let emit_main (md : Emit.m) (fn : Tast.fn) =
|
|
let b = create () in
|
|
push_r b rbp;
|
|
mov_rr b ~dst:rbp ~src:rsp;
|
|
sub_imm b ~dst:rsp 48;
|
|
(* [al] is zero at every call this backend makes, variadic or not — see
|
|
[call_native]. Setting it here too costs two bytes and keeps the rule
|
|
without an exception, which is worth more than the two bytes. *)
|
|
xor_rr b ~dst:rax ~src:rax;
|
|
call_sym b "flan_rt_init";
|
|
let xfer = -8 and argv = -32 in
|
|
xor_rr b ~dst:rax ~src:rax;
|
|
store_int b ~src:rax ~mm:(Frame xfer) ~size:8;
|
|
(match fn.Tast.params with
|
|
| [] -> lea b ~dst:rdi ~mm:(Frame xfer)
|
|
| [ _ ] ->
|
|
lea b ~dst:rdi ~mm:(Frame argv);
|
|
xor_rr b ~dst:rax ~src:rax;
|
|
call_sym b "flan_argv";
|
|
lea b ~dst:rdi ~mm:(Frame argv);
|
|
lea b ~dst:rsi ~mm:(Frame xfer)
|
|
| _ -> unsupported "main takes at most one parameter");
|
|
call_sym b (fsym "main");
|
|
if Types.equal fn.Tast.ret (Types.Int Types.I32) then
|
|
mov_rr b ~dst:rdi ~src:rax
|
|
else xor_rr b ~dst:rdi ~src:rdi;
|
|
xor_rr b ~dst:rax ~src:rax;
|
|
call_sym b "flan_exit";
|
|
ud2 b;
|
|
flush b;
|
|
ignore md;
|
|
let out = Buffer.create 256 in
|
|
Buffer.add_string out "\t.globl\tmain\n\t.type\tmain, @function\nmain:\n";
|
|
Buffer.add_string out (Buffer.contents b.out);
|
|
Buffer.add_string out "\t.size\tmain, . - main\n\n";
|
|
Buffer.contents out
|
|
|
|
(* ── Globals ─────────────────────────────────────────────────────────── *)
|
|
|
|
(* Every global is a zeroed object and an initialiser that runs before [main]
|
|
does. [emit.ml] folds the initialiser into an LLVM constant instead, which
|
|
it can because it has a constant folder for the IR's own syntax; running the
|
|
same expression as code costs a few instructions once and needs no second
|
|
evaluator that could disagree with the first about what a struct literal
|
|
means. *)
|
|
let emit_globals_data (md : Emit.m) (globals : Tast.global list) =
|
|
let out = Buffer.create 256 in
|
|
Buffer.add_string out "\t.bss\n";
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
let size, align = Emit.lay md g.Tast.gty in
|
|
let sym = gsym g.Tast.gname in
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.globl\t%s\n\t.align\t%d\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, %d\n%s:\n\t.zero\t%d\n"
|
|
sym align sym sym (max 1 size) sym (max 1 size)))
|
|
globals;
|
|
Buffer.contents out
|
|
|
|
let init_sym = "\"flan..init-globals\""
|
|
|
|
let emit_globals_init (md : Emit.m) ~externs ~fns (globals : Tast.global list) =
|
|
let b = create () in
|
|
let f =
|
|
{ b; md; fnname = "<globals>"; retlbl = new_label () "ginit";
|
|
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
|
|
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
|
|
xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 64; externs; fns }
|
|
in
|
|
(* Two slots, not one: [xfer_off] holds the *pointer* every call passes on,
|
|
and [cell] is what it points at. Storing a null into [xfer_off] itself —
|
|
which is what this did while nothing could transfer — hands every callee
|
|
a null channel to write through. No caller gives this function one, so it
|
|
owns the cell. *)
|
|
let cell = ptmp f in
|
|
f.xfer_off <- ptmp f;
|
|
f.xfer_lbl <- new_label f "gxfer";
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0))))
|
|
globals;
|
|
(* Nothing establishes a handler or a restart before this runs, so a
|
|
transfer out of an initialiser has nowhere to go and cannot arise: a
|
|
bounds failure here finds no handler and dies inside the runtime. The
|
|
exit still exists because a guard names it. *)
|
|
if f.unwound then begin
|
|
jmp_lbl f.b f.retlbl; lbl f.b f.xfer_lbl; jmp_lbl f.b f.retlbl
|
|
end;
|
|
let pb = create () in
|
|
push_r pb rbp;
|
|
mov_rr pb ~dst:rbp ~src:rsp;
|
|
let n = frame_bytes f in
|
|
if n > 0 then sub_imm pb ~dst:rsp n;
|
|
(* No caller hands this one a channel, so it gets a null cell of its own and
|
|
passes that cell's address on. *)
|
|
xor_rr pb ~dst:rax ~src:rax;
|
|
store_int pb ~src:rax ~mm:(Frame cell) ~size:8;
|
|
lea pb ~dst:rax ~mm:(Frame cell);
|
|
store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8;
|
|
lbl f.b f.retlbl;
|
|
leave f.b;
|
|
ret f.b;
|
|
flush pb; flush f.b;
|
|
let out = Buffer.create 512 in
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.type\t%s, @function\n%s:\n" init_sym init_sym);
|
|
Buffer.add_string out (Buffer.contents pb.out);
|
|
Buffer.add_string out (Buffer.contents f.b.out);
|
|
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" init_sym init_sym);
|
|
Buffer.contents out, Buffer.contents f.rodata
|
|
|
|
(* ── The program ─────────────────────────────────────────────────────── *)
|
|
|
|
(* What is left of the precondition that used to stand in for conditions.
|
|
|
|
It was a whole-program argument: this backend emitted no guard after a call,
|
|
which is sound exactly when nothing in the reachable set can ever *write*
|
|
the channel, so the build refused by name the moment it found something that
|
|
could. Every call site is guarded now and the argument has retired — except
|
|
in one place, which is why the walk is still here.
|
|
|
|
A global's initialiser runs from [flan..init-globals], before [main] and
|
|
before anything has established a handler or a restart. It owns its own
|
|
channel cell because no caller hands it one, so a transfer out of an
|
|
initialiser has nowhere to go: its exit would return to the loader. Refused
|
|
by name rather than compiled into a return into ld.so. *)
|
|
let check_no_transfer (p : Tast.program) =
|
|
let bad what =
|
|
unsupported "%s in a global's initialiser: it runs before main, before \
|
|
anything can handle it, and a transfer out of it has nowhere \
|
|
to go" what
|
|
in
|
|
let rec ex (e : Tast.expr) =
|
|
(match e.Tast.e with
|
|
| Tast.Signal _ -> bad "signal"
|
|
| Tast.InvokeRestart _ -> bad "invoke-restart"
|
|
| Tast.RestartCase _ -> bad "restart-case"
|
|
| Tast.Handled _ -> bad "handler-bind"
|
|
| _ -> ());
|
|
iter_sub ex e
|
|
and iter_sub g (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Prim (_, xs) | Tast.Call (_, xs) | Tast.Arr xs | Tast.Do xs
|
|
| Tast.Make (_, xs) | Tast.MakeCase (_, _, xs) -> List.iter g xs
|
|
| Tast.CallPtr (a, xs) -> g a; List.iter g xs
|
|
| Tast.Handled (_, xs) -> List.iter g xs
|
|
| Tast.Let (bs, body) -> List.iter (fun (_, x) -> g x) bs; List.iter g body
|
|
| Tast.If (a, b, c) -> g a; g b; g c
|
|
| Tast.While (a, b, l) -> g a; List.iter g b; List.iter g l
|
|
| Tast.Return (Some x) | Tast.Some_ x | Tast.Deref x | Tast.UnwrapSome x
|
|
| Tast.Field (x, _) | Tast.CaseField (x, _, _) | Tast.Signal (_, _, x) -> g x
|
|
| Tast.Set (pl, x) -> place_ g pl; g x
|
|
| Tast.Addr pl -> place_ g pl
|
|
| Tast.Match (x, arms) ->
|
|
g x; List.iter (fun (a : Tast.arm) -> List.iter g a.Tast.abody) arms
|
|
| Tast.RestartCase (cs, x) ->
|
|
List.iter (fun (c : Tast.rclause) -> List.iter g c.Tast.rbody) cs; g x
|
|
| Tast.WithAlloc (a, body) -> g a; List.iter g body
|
|
| Tast.InvokeRestart (_, _, xs, _, _, _) -> List.iter g xs
|
|
| _ -> ()
|
|
and place_ g (pl : Tast.place) =
|
|
match pl with
|
|
| Tast.Pfield (x, _) | Tast.Pderef x -> g x
|
|
| Tast.Pindex (x, ys) -> g x; List.iter g ys
|
|
| _ -> ()
|
|
in
|
|
List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals
|
|
|
|
(* A whole program as one assembly file. *)
|
|
let program ~checks (p : Tast.program) : string =
|
|
check_no_transfer p;
|
|
let md = layout_ctx ~checks p in
|
|
let externs = Hashtbl.create 16 in
|
|
List.iter
|
|
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
|
|
p.Tast.externs;
|
|
let fns = Hashtbl.create 64 in
|
|
List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fns fn.Tast.name ()) p.Tast.fns;
|
|
let text = Buffer.create 65536 and rodata = Buffer.create 4096 in
|
|
Buffer.add_string text
|
|
"# Generated by flan's x86-64 backend (the dev one). The instructions are\n\
|
|
# .byte blobs so that every byte offset stays exactly known; the few\n\
|
|
# fields that need a relocation are assembler expressions.\n\
|
|
\t.text\n\n";
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
let t, r = emit_fn md ~externs ~fns fn in
|
|
Buffer.add_string text t;
|
|
Buffer.add_string rodata r)
|
|
p.Tast.fns;
|
|
let ginit, gr = emit_globals_init md ~externs ~fns p.Tast.globals in
|
|
Buffer.add_string text ginit;
|
|
Buffer.add_string rodata gr;
|
|
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
|
| Some fn -> Buffer.add_string text (emit_main md fn)
|
|
| None -> unsupported "no main");
|
|
let out = Buffer.create 65536 in
|
|
Buffer.add_buffer out text;
|
|
(* The globals' initialiser runs before main, through the same constructor
|
|
slot [emit.ml] uses to arm the allocation registry. *)
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.section\t.init_array,\"aw\",@init_array\n\t.align\t8\n\
|
|
\t.quad\t%s\n\n" init_sym);
|
|
Buffer.add_string out (emit_globals_data md p.Tast.globals);
|
|
Buffer.add_string out "\n\t.section\t.rodata\n";
|
|
Buffer.add_buffer out rodata;
|
|
Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
|
|
Buffer.contents out
|