Joseph Ferano
bdecd2b8f2
Another lane landed (slice-from-ptr p n) while this backend was not looking,
and it arrived as two refusals rather than one: slice-from-ptr.flan and
bounds.flan both stopped building through --x86. Neither is a new obstacle —
a Slice _ is {ptr, i64} here exactly as it is in emit.ml, so the form is one
store of the pointer and one of the length and no new representation at all.
The half worth writing down is the check. There is nothing to compare the
length against — only the caller knows how many elements live behind that
pointer — so what is checked is that the promise is not absurd, and that test
is *signed*. check_slice's own compares are unsigned, and a negative i32
sign-extended to 64 bits is a huge unsigned value that an unsigned "hi <= len"
waves through; the result would be a slice about 2^64 long that reads as a
pass and faults somewhere else entirely.
Nothing in the corpus walks that path: every length in slice-from-ptr.flan is
a literal, and a negative literal is refused by check.ml before any code is
emitted. So spike/x86/p7-slice-from-ptr.flan takes the length as a parameter
and runs it through a restart-case, which puts the condition's low/high/length
on stdout and compares them against the LLVM build.
2468 lines
105 KiB
OCaml
2468 lines
105 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
|
|
(* (slice-from-ptr p n): the two words a slice already is, with the pointer
|
|
the caller handed over and the length the caller promised. A [Slice _] is
|
|
{ptr, i64} here exactly as it is in [emit.ml], so there is no new
|
|
representation to build — one store of the pointer and one of the length.
|
|
|
|
The check is the *length itself* and not a range, because nothing here
|
|
knows how many elements live behind that pointer; only the caller does.
|
|
So what is checked is the half that can be — that the promise is not
|
|
absurd — and it is a *signed* test, which matters: [check_slice]'s
|
|
compares are unsigned, and a negative i32 sign-extended to 64 bits is a
|
|
huge unsigned value that [jbe] waves straight through.
|
|
|
|
It reuses [flan_slice_error] for [emit.ml]'s reason: the violated
|
|
condition is 0 <= n, which has the shape of a reversed slice, so the range
|
|
is reported as [0 n) against a length of 0. *)
|
|
| Tast.SliceFromPtr, [ p; n ] ->
|
|
let lp = eval f p in
|
|
let ln = eval f n in
|
|
if f.md.Emit.checks then
|
|
scoped f (fun () ->
|
|
let a = ptmp f and b = ptmp f and c = ptmp f in
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
|
|
store_int f.b ~src:rax ~mm:(Frame c) ~size:8;
|
|
load_loc f ~reg:rax ln n.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(Frame b) ~size:8;
|
|
cmp_imm f.b ~dst:rax 0;
|
|
let ok = new_label f "inb" in
|
|
jcc_lbl f.b ~cc:cc_ge ok;
|
|
bounds_call f "flan_slice_error" e.Tast.loc [ a; b; c ];
|
|
lbl f.b ok);
|
|
load_loc f ~reg:rax lp p.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
|
load_loc f ~reg:rax ln n.Tast.ty;
|
|
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. *)
|
|
let zero_return () =
|
|
if not (is_void fn.Tast.ret) then zero_value f (ret_loc f) fn.Tast.ret
|
|
in
|
|
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;
|
|
(* [emit.ml] leaves here with [ret zeroinitializer]. The value is
|
|
meaningless to a caller — its guard sees the channel set and never looks
|
|
at it — but [main] is a caller with no guard, and what it finds in [rax]
|
|
is the process exit status. Zero rather than whatever the return
|
|
temporary held. *)
|
|
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;
|
|
zero_return ();
|
|
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 begin zero_return (); jmp_lbl f.b f.retlbl end
|
|
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
|