Joseph Ferano
786656dfee
The corpus sweep found it, and it found it the way item 15 said this work fails: array-ctor.flan crashed, and the assembly around the crash read correctly. (set (.x (at pts 0)) 1.5) went through lvalue, lvalue had no case for At, and the fallback evaluates — so the store landed in a copy of the element and the array kept its zeros. emit.ml has this as addr's own At case. One line here, and the program matches the LLVM build. Two more programs beside the fizz: one for the internal calling convention the fizz does not touch at all — a struct argument, a struct return through the hidden pointer, f32 in the SSE half, eight integer arguments so two go on the stack, and a slice by pointer — and one for the rest of the core: a global with an initialiser, recursion, break, continue, the bitwise family, unsigned shifts and the conversions both ways. Both agree with LLVM. al is now zero at every call this backend makes, including the three in main that were reaching flan_rt_init, flan_argv and flan_exit without it. Inert on a fixed callee; the point is that there is no exception to the rule to remember.
1595 lines
67 KiB
OCaml
1595 lines
67 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 (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 = false;
|
|
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.
|
|
Empty means the function's own transfer exit. *)
|
|
mutable pads : string list;
|
|
(* 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 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 -> unsupported "no struct %s" sn
|
|
|
|
(* 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"
|
|
|
|
(* [ucomis] sets the flags the *unsigned* codes read, whichever way the
|
|
operands are signed, so a float comparison never uses l/g. *)
|
|
let float_cc (p : Tast.prim) =
|
|
match p with
|
|
| Tast.Eq -> cc_e | Tast.Ne -> cc_ne
|
|
| Tast.Lt -> cc_b | Tast.Le -> cc_be
|
|
| Tast.Gt -> cc_a | Tast.Ge -> cc_ae
|
|
| _ -> unsupported "not a comparison"
|
|
|
|
let is_cmp (p : Tast.prim) =
|
|
match p with
|
|
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true
|
|
| _ -> false
|
|
|
|
(* ── 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 a void expression is handed and never reads. rbp+0 is the
|
|
saved rbp; nothing below stores through a destination it was told was
|
|
void, so the address is a name and not a target. *)
|
|
let sink = Lf 0
|
|
|
|
let rec lower 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.Match _ | Tast.MakeCase _ | Tast.CaseField _ ->
|
|
unsupported "union values, in %s" f.fnname
|
|
| Tast.Signal _ | Tast.Handled _ | Tast.RestartCase _
|
|
| Tast.InvokeRestart _ | Tast.WithAlloc _ ->
|
|
unsupported "conditions, in %s" f.fnname
|
|
|
|
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; i ]) -> element f (lvalue f a) a.Tast.ty i
|
|
| _ -> eval f e
|
|
|
|
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
|
|
| Tast.Pindex (x, [ i ]) -> element f (lvalue f x) x.Tast.ty i
|
|
| Tast.Pindex _ -> unsupported "multi-dimensional index"
|
|
|
|
(* 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 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
|
|
(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);
|
|
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
|
|
|
|
and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~args ~rty dst
|
|
|
|
and call_native f ~sym ~(args : Tast.expr list) ~rty dst =
|
|
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
|
|
let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals 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 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
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64;
|
|
fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64;
|
|
ucomis f.b ~f64 ~a:xmm0 ~c:1;
|
|
setcc f.b ~cc:(float_cc p) ~dst:rax
|
|
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; i ] ->
|
|
let l = element f (lvalue f a) a.Tast.ty i 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
|
|
(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 = []; 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";
|
|
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 is not built, and nothing can reach it: no node in this
|
|
program signals or invokes a restart (checked before any of this runs), so
|
|
[fdefers] has no second path to run on. *)
|
|
if fn.Tast.fdefers <> [] then
|
|
unsupported "%s has defers on the transfer path" 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 = [];
|
|
rodata = Buffer.create 64; externs; fns }
|
|
in
|
|
f.xfer_off <- ptmp f;
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0))))
|
|
globals;
|
|
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 one of its own. *)
|
|
xor_rr pb ~dst:rax ~src:rax;
|
|
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 ─────────────────────────────────────────────────────── *)
|
|
|
|
(* The guard that makes the missing transfer guard sound. [emit.ml] emits a
|
|
check of the channel after every call; this backend emits none, and the
|
|
reason it may is a whole-program one: if nothing in the reachable set can
|
|
ever *write* the channel, no call can ever come back with it set. That is a
|
|
property of the program and not of the backend, so it is checked here rather
|
|
than assumed — and when it fails the build stops with the node that broke
|
|
it rather than running with a guard that is not there. *)
|
|
let check_no_transfer (p : Tast.program) =
|
|
let bad what = unsupported "%s needs the transfer channel, which this \
|
|
backend does not emit a guard for" 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"
|
|
| Tast.WithAlloc _ -> bad "with-allocator"
|
|
| Tast.Prim (Tast.Rt s, _)
|
|
when String.equal s "flan_vec_at" || String.equal s "flan_vec_as_slice" ->
|
|
bad ("(" ^ s ^ ")")
|
|
| _ -> ());
|
|
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 (fn : Tast.fn) -> List.iter ex fn.Tast.body; List.iter ex fn.Tast.fdefers)
|
|
p.Tast.fns;
|
|
List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals
|
|
|
|
(* A whole program as one assembly file. *)
|
|
let program (p : Tast.program) : string =
|
|
check_no_transfer p;
|
|
let md = layout_ctx 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
|