4519 lines
207 KiB
OCaml
4519 lines
207 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 (docs/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 The licence has an edge now, and it is the indirection cells below.} A
|
|
cell is a mutable global an out-of-process redefinition can store into, and
|
|
the module doing the storing is built by [Emit.redefinition], which is
|
|
LLVM. The two conventions agree on scalars and disagree on every
|
|
aggregate, so an LLVM-built module dlopened into a build made here would be
|
|
correct exactly until a redefined function took or returned a struct.
|
|
Nothing in the toolchain does that today — [flan reload] and [flan dev]
|
|
build host and module through LLVM together — and the answer when
|
|
something does is a redefinition emitter {e here}, not a classifier.
|
|
|
|
- {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;
|
|
(* ── Annotation ──
|
|
A comment waiting for the bytes it is about, newest last, each with the
|
|
serial that says who queued it. Nothing here reaches the object: the
|
|
assembler discards a comment, and splitting one [.byte] directive into
|
|
two is the same bytes in the same order. What it buys is a listing whose
|
|
runs of machine code are each headed by the Flan form that produced them.
|
|
|
|
Queued rather than written, because the point of the comment is to sit
|
|
above bytes and a form that emits none must not leave its heading on the
|
|
next form's. So [annote] queues, the first byte written afterwards flushes
|
|
the queue, and [unannote] withdraws whatever its own form queued and never
|
|
spent. *)
|
|
mutable ann : (int * string) list;
|
|
(* How far to indent a run of bytes, which is the nesting depth of the form
|
|
that is emitting it. An argument's bytes step in and the call's step back
|
|
out, so the shape of the expression is visible in the left margin without
|
|
reading a single comment. *)
|
|
mutable ind : string;
|
|
}
|
|
|
|
let create () =
|
|
{ out = Buffer.create 4096; pend = []; n = 0; ann = []; ind = "" }
|
|
|
|
let flush b =
|
|
if b.pend <> [] then begin
|
|
Buffer.add_string b.out ("\t" ^ b.ind ^ ".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
|
|
|
|
(* The serial of the highest-numbered comment that has actually been written.
|
|
[unannote] compares against it to tell "my heading is still waiting and
|
|
should be withdrawn" from "my heading was spent on bytes I emitted". Module
|
|
scope because the serials are, and they are because a function's prologue
|
|
and its body are two buffers. *)
|
|
let annser = ref 0
|
|
let annmax = ref 0
|
|
|
|
(* Bytes are about to be written, so anything queued is about them. *)
|
|
let ann_due b =
|
|
if b.ann <> [] then begin
|
|
flush b;
|
|
List.iter
|
|
(fun (s, line) ->
|
|
Buffer.add_string b.out line;
|
|
Buffer.add_char b.out '\n';
|
|
if s > !annmax then annmax := s)
|
|
b.ann;
|
|
b.ann <- []
|
|
end
|
|
|
|
let u8 b x =
|
|
if b.ann <> [] then ann_due b;
|
|
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
|
|
|
|
(* A relocation, a label and raw text all count as "bytes about to be written"
|
|
for the queue's purpose: each is part of the run its form produced, and a
|
|
heading has to arrive before the label its form's code begins at. *)
|
|
let dir b s size =
|
|
ann_due b;
|
|
flush b;
|
|
Buffer.add_string b.out ("\t" ^ b.ind ^ s ^ "\n");
|
|
b.n <- b.n + size
|
|
|
|
let text b s = ann_due b; flush b; Buffer.add_string b.out s
|
|
let lbl b l = ann_due b; flush b; Buffer.add_string b.out (l ^ ":\n")
|
|
|
|
(* The margin a run of bytes is written at. Changing it flushes, because
|
|
[flush] writes the margin as it stands when the line is written and the
|
|
bytes pending at that moment were accumulated under the old one — without
|
|
this, the tail of an outer form comes out at the indentation its last
|
|
argument had. *)
|
|
let set_ind b s = if b.ind <> s then begin flush b; b.ind <- s end
|
|
|
|
(* Queue one comment line. [pre] is written as given — the callers below spell
|
|
their own leading tab and hash — and the serial comes back so that the form
|
|
that queued it can withdraw it if it turns out to have emitted nothing. *)
|
|
let annote b line =
|
|
incr annser;
|
|
b.ann <- b.ann @ [ (!annser, line) ];
|
|
!annser
|
|
|
|
(* Drop every heading queued at or after [s] and still unspent. Answers whether
|
|
[s] itself was spent, which is the only thing a caller wants to know. *)
|
|
let unannote b s =
|
|
if b.ann <> [] then b.ann <- List.filter (fun (k, _) -> k < s) b.ann;
|
|
!annmax >= s
|
|
|
|
(* ── 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
|
|
|
|
(* For the listing only — nothing encodes through this. In the same order the
|
|
numbering above is in, which is the modrm one and not the alphabetical one a
|
|
reader might expect. *)
|
|
let rname = [| "rax"; "rcx"; "rdx"; "rbx"; "rsp"; "rbp"; "rsi"; "rdi";
|
|
"r8"; "r9"; "r10"; "r11"; "r12"; "r13"; "r14"; "r15" |]
|
|
|
|
let regname r = if r >= 0 && r < 16 then rname.(r) else Printf.sprintf "r?%d" r
|
|
|
|
(* 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
|
|
|
|
(* The same field, against a symbol this object does not define. A [PC32]
|
|
relocation against an undefined symbol cannot be used in a shared object --
|
|
[ld] refuses the link outright -- so the address is read out of the GOT
|
|
instead and the loader binds the slot to whatever the host has.
|
|
|
|
[@GOTPCREL] is already pc-relative, so the [- .] the plain form needs is
|
|
wrong here: written with it, [as] produces an addend of -8 and the load
|
|
reads the wrong slot. [-4] alone is what [llc -relocation-model=pic]
|
|
produces for the same instruction, checked against it. There is no addend
|
|
either: the GOT holds the symbol's address and nothing else, so a field
|
|
offset is added after the load, which is what [Lgot] below does. *)
|
|
let modrm_got b ~r ~sym =
|
|
u8 b (((r land 7) lsl 3) lor 5);
|
|
dir b (Printf.sprintf ".long %s@GOTPCREL - 4" sym) 4
|
|
|
|
(* ── Instructions ────────────────────────────────────────────────────── *)
|
|
|
|
type mem =
|
|
| Frame of int
|
|
| Reg of int * int
|
|
| Sym of string * int
|
|
| Got of string (* the GOT slot holding [sym]'s address *)
|
|
|
|
let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) =
|
|
let base =
|
|
match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ | Got _ -> 0
|
|
in
|
|
List.iter (u8 b) pfx;
|
|
(match mm with
|
|
| Sym _ | Got _ -> 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
|
|
| Got s -> modrm_got b ~r ~sym:s
|
|
|
|
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 _ | Got _ -> 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
|
|
| Got s -> modrm_got b ~r:src ~sym:s)
|
|
| 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 and_imm b ~dst n = grp1_imm b ~ext:4 ~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, always 64 bits wide, because every integer in this backend is
|
|
computed in a full register and narrowed only on the way to memory. The
|
|
hardware masks the count to 63 for a 64-bit shift and to 31 for a 32-bit
|
|
one, and to nothing narrower than that — there is no 8- or 16-bit masking
|
|
rule to inherit. So the width the count is masked to is a property of the
|
|
*instruction* emitted, not of the language's type, and since the instruction
|
|
is always the 64-bit one the caller has to mask the count itself for every
|
|
width below 64. See the shift arm in [prim_to]. *)
|
|
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 data type 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 ~dev (p : Tast.program) : Emit.m =
|
|
let structs = Hashtbl.create 16 and datas = Hashtbl.create 16 in
|
|
let 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.data) -> Hashtbl.replace datas u.Tast.dname u)
|
|
p.Tast.datas;
|
|
List.iter (fun (u : Tast.structure) -> Hashtbl.replace unions u.Tast.sname u)
|
|
p.Tast.unions;
|
|
(* The globals table is filled and not left empty, which it was for as long
|
|
as nothing here asked a question about a name. [Reach.ref_fingerprint]
|
|
does: it hashes the set of *globals* a body names, and with an empty table
|
|
no name is a global, so every frame descriptor would carry the hash of the
|
|
empty set while the daemon recomputes it against the real one. The frames
|
|
would then all read as superseded and the break loop would refuse the
|
|
locals of a body nobody had touched. *)
|
|
let globals = Hashtbl.create 16 in
|
|
List.iter (fun (g : Tast.global) -> Hashtbl.replace globals g.Tast.gname g.Tast.gty)
|
|
p.Tast.globals;
|
|
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions;
|
|
globals; externs = Hashtbl.create 1; checks;
|
|
dev; 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.Fn _ -> false
|
|
| Types.Unit | Types.Never -> false
|
|
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
|
|
| 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)
|
|
|
|
(* The indirection cell: a mutable global holding the address of the function
|
|
that is currently this name's body. Spelled exactly as [Emit.cellname]
|
|
spells it, because that is the whole point of having one here — a
|
|
redefinition module is still built by LLVM, and it binds
|
|
[@"flan.cell.<n>" = external global ptr] against whatever built the host.
|
|
Byte-for-byte or the link fails and the piece served nothing. *)
|
|
let csym n = asm_sym ("flan.cell." ^ n)
|
|
|
|
(* The marker that says which backend built an image, and it is the whole of
|
|
the answer to the one way these two backends can be mixed and be wrong.
|
|
[emit.ml] and this file agree on every scalar and disagree on every
|
|
aggregate — this file passes a struct by pointer with a hidden [sret] and
|
|
LLVM classifies per SysV — so a redefinition module from one backend
|
|
dlopened into a host from the other links, loads, and then dies at the first
|
|
call into a redefined function that takes or returns a struct. That was
|
|
measured as SIGSEGV; see HANDOFF-x86-aggregates.md.
|
|
|
|
A dev build defines its own marker and a redefinition module emits a data
|
|
relocation against the marker it was itself built for. A matched pair binds
|
|
it and notices nothing. A crossed pair has no such symbol to bind, and the
|
|
loader refuses the module at [dlopen] — before a single instruction of the
|
|
new body runs, and with the missing symbol naming the backend in the
|
|
message. That is the property: the mismatch is caught by the loader rather
|
|
than by the processor, at load rather than at a call.
|
|
|
|
[Emit.abi_marker] is the same string for the LLVM half. The two must stay
|
|
distinct and neither may ever be defined by both backends, or the refusal
|
|
quietly stops refusing. *)
|
|
let abi_marker = "flan.abi.x86"
|
|
|
|
(* ── Debug information ───────────────────────────────────────────────── *)
|
|
|
|
(* DWARF, written out as bytes, for the same reason the instructions are — and
|
|
the reason is worth stating first because it is the one thing about this
|
|
backend that makes debug information cost more here than it does anywhere
|
|
else.
|
|
|
|
{b [.loc] does not work against an assembly file that has no instructions
|
|
in it.} GAS builds its line table from [dwarf2_emit_insn], which runs only
|
|
when an instruction is assembled, and this file assembles none: everything
|
|
is a [.byte] blob. A pending [.loc] therefore sits until the *next* [.loc]
|
|
and is flushed at whatever the location counter has reached by then, so
|
|
every row comes out one statement late and the last statement of every
|
|
function gets no row at all. Measured on GAS 2.44 and reproduced with
|
|
labels interposed, which do not help. So [.debug_line] is emitted here as
|
|
data, which is in any case the only spelling consistent with the rest of
|
|
the file.
|
|
|
|
DWARF 4 rather than 5. Version 4's file and directory tables are
|
|
NUL-terminated strings and a terminator byte where 5 form-codes them, and
|
|
nothing above needs a version 5 feature. A compile unit declares its own
|
|
version, so a v4 unit sitting beside the v5 ones clang gives the runtime's
|
|
C is not a conflict — each is read on its own terms.
|
|
|
|
What is described is deliberately shallow: the compile unit, one subprogram
|
|
per function, and the line table. {b No locals and no types.} [emit.ml]
|
|
writes a [!DILocalVariable] per slot because every slot there is an
|
|
[alloca] that [llvm.dbg.declare] can point at and LLVM computes the frame
|
|
offset; here a slot is a bump-allocated frame temporary whose offset this
|
|
file knows but whose *lifetime* it does not model — [scoped] reclaims
|
|
temporaries and a later expression reuses the bytes. Naming an offset that
|
|
holds something else half the time is worse than naming nothing, so this
|
|
emits nothing rather than a confident wrong answer. That is the same call
|
|
[build.ml] makes about wasm32's member offsets. *)
|
|
|
|
(* One row of the line table: the label whose address it is, and the position
|
|
it names. Addresses are labels rather than numbers because the assembler
|
|
places the function and this file does not. *)
|
|
type dwrow = { rlbl : string; rfile : int; rline : int; rcol : int }
|
|
|
|
type dwsub = {
|
|
sname : string; (* what a debugger calls the frame *)
|
|
ssym : string; (* the symbol the linker sees *)
|
|
sfile : int;
|
|
sline : int;
|
|
send : string; (* a label one past the function's last byte *)
|
|
mutable srows : dwrow list; (* newest first *)
|
|
}
|
|
|
|
type dwarf = {
|
|
dfiles : (string, int) Hashtbl.t;
|
|
mutable dpaths : string list; (* newest first *)
|
|
mutable dsubs : dwsub list; (* newest first *)
|
|
mutable dcur : dwsub option; (* the function being lowered *)
|
|
mutable dlast : (int * int * int) option; (* the last row's position *)
|
|
(* [buf.n] as it stood when the last row was made. [lower] recurses, so an
|
|
outer form and the inner one that emits the first byte of it both ask for
|
|
a row at the same address; without this the table carries a run of rows
|
|
that a debugger resolves by taking the last, which is the innermost form
|
|
rather than the statement. Keeping the first is both smaller and the
|
|
better answer. Reset to -1 per function, because the body's byte counter
|
|
starts again at 0 and the entry row is at the prologue's 0. *)
|
|
mutable dlastn : int;
|
|
}
|
|
|
|
let new_dwarf () =
|
|
{ dfiles = Hashtbl.create 8; dpaths = []; dsubs = []; dcur = None;
|
|
dlast = None; dlastn = -1 }
|
|
|
|
(* File indices are 1-based and handed out in first-seen order, which is the
|
|
order the file table is written in below. A program spans more than one
|
|
file whenever the prelude or a macro contributed a form, and the checker's
|
|
own invented nodes carry [Loc.unknown], whose file is [<unknown>] — that
|
|
one never reaches here, because a row with line 0 is attributed to the
|
|
enclosing function's file instead. *)
|
|
let dwfile dw path =
|
|
match Hashtbl.find_opt dw.dfiles path with
|
|
| Some n -> n
|
|
| None ->
|
|
let n = List.length dw.dpaths + 1 in
|
|
Hashtbl.replace dw.dfiles path n;
|
|
dw.dpaths <- path :: dw.dpaths;
|
|
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 *)
|
|
(* The shadow-stack record this function pushes, in a dev build: three words
|
|
at [rbp+dframe], holding the previous head, the static description, and
|
|
the slot table. [None] in a release build, where there is no record and
|
|
the epilogue below restores nothing. *)
|
|
mutable dframe : int option;
|
|
(* Where a dev build records each named slot's address, so that a stopped
|
|
frame's locals can be read: one word per Tast slot at [rbp+dslotv]. [None]
|
|
in a release build and in a function with no named slot at all — the same
|
|
gate [emit.ml] applies, and for a reason that is LLVM's rather than ours
|
|
(an alloca whose address escapes stops being promotable). Keeping the gate
|
|
anyway is what makes the two backends' frames answer identically, which is
|
|
the only thing the break loop can check. *)
|
|
mutable dslotv : int option;
|
|
(* [fn.snames], carried so [bind_slot] can ask whether a slot has a name to
|
|
show without the whole [Tast.fn] being threaded to every binding site. *)
|
|
snames : string option array;
|
|
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;
|
|
(* True of a symbol this object does not define. Always false for a whole
|
|
program, which defines everything it names bar the runtime, and where
|
|
every reference is therefore pc-relative exactly as before. A redefinition
|
|
module answers true for the host's cells, globals and bodies, and those
|
|
go through the GOT -- see [modrm_got]. *)
|
|
ext : string -> bool;
|
|
(* [Some slot] of a symbol that does not exist anywhere: a function or a
|
|
global the host was never built with, introduced by a redefinition module
|
|
while the process was running. There is no symbol to bind to and ELF has
|
|
no way to grow one, so the address is looked up by string at install time
|
|
and parked in [slot], which is this module's own object. Always [None] for
|
|
a whole program, where [known] is true of everything -- so the
|
|
whole-program path emits byte-identical output and the survey goes on
|
|
being a structural check on all of this. [ext] and this are two questions
|
|
and not one: [ext] says "the host's, reach it through the GOT", this says
|
|
"nobody's yet, reach it through a slot I filled". *)
|
|
slot : string -> string option;
|
|
(* The line table under construction, in a [--debug] build. [None] is every
|
|
other build, and then [dwline] below is the only thing that looks at it
|
|
and does nothing — so a release build's output is byte-identical to what
|
|
it was before debug information existed. *)
|
|
dw : dwarf option;
|
|
(* True when this listing is meant to be read by a person rather than handed
|
|
to clang — see [program]'s [annotate]. Every annotation in this file is
|
|
behind it, so that a build's assembly is character-for-character what it
|
|
was before any of this existed and [survey.sh] goes on comparing the same
|
|
text it always compared. *)
|
|
ann : bool;
|
|
(* How deeply nested the form being lowered is, which is what the left margin
|
|
of the listing shows. *)
|
|
mutable adepth : int;
|
|
(* The last heading written, so that a macro that expands to forty forms at
|
|
one call site does not print that call site forty times. *)
|
|
mutable alast : string;
|
|
}
|
|
|
|
(* 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
|
|
|
|
(* A line-table row at the point the output has reached, unless the last row
|
|
already named this position. [lower] calls this for every expression, so
|
|
the dedup is what keeps a statement made of a dozen nodes on one line from
|
|
costing a dozen rows; the column is part of the key, so two forms on one
|
|
line are still told apart.
|
|
|
|
Line 0 is [Loc.unknown] — a node the checker invented rather than one
|
|
anyone wrote. It is attributed to the enclosing function's own line, for
|
|
[emit.ml]'s reason at its [at_loc]: a zero line in DWARF means "no line",
|
|
and a debugger given one steps over the whole construct. *)
|
|
let dwline f (loc : Loc.t) =
|
|
match f.dw with
|
|
| None -> ()
|
|
| Some dw ->
|
|
(match dw.dcur with
|
|
| None -> ()
|
|
| Some s ->
|
|
let file, line, col =
|
|
if loc.Loc.line = 0 then (s.sfile, s.sline, 1)
|
|
else (dwfile dw loc.Loc.file, loc.Loc.line, loc.Loc.col)
|
|
in
|
|
if dw.dlast <> Some (file, line, col) && f.b.n > dw.dlastn then begin
|
|
let l = new_label f "dl" in
|
|
lbl f.b l;
|
|
dw.dlast <- Some (file, line, col);
|
|
dw.dlastn <- f.b.n;
|
|
s.srows <-
|
|
{ rlbl = l; rfile = file; rline = line; rcol = col } :: s.srows
|
|
end)
|
|
|
|
(* ── Annotation ──────────────────────────────────────────────────────── *)
|
|
|
|
(* Everything below writes comments and nothing else, and all of it is behind
|
|
[f.ann]. The reason it is worth the code is the one the frame model makes
|
|
unavoidable: every intermediate value in this backend lives in a frame
|
|
temporary, so a listing is a wall of [-0x48(%rbp)] and there is no way to
|
|
tell which of those is the loop counter and which is where the left operand
|
|
of an [imul] was parked. LLVM's output names its values and this file's
|
|
cannot, so the names have to be written down beside it instead.
|
|
|
|
A comment costs nothing in the object — the assembler discards it — so what
|
|
it buys is paid for entirely in the size of the [.s], which nothing but a
|
|
reader ever looks at. *)
|
|
|
|
(* One bookkeeping line: something the compiler put there that no form in the
|
|
source asked for, named once so that a reader who meets it again recognises
|
|
it. The post-call guard and the bounds-check triple are the two that matter
|
|
most, because they are the two a reader counts instructions in and wonders
|
|
about. *)
|
|
(* Wrapped rather than written as given, and whitespace collapsed on the way:
|
|
the callers below spell their text across several source lines, and an
|
|
assembly comment that runs to two hundred columns is one nobody reads. *)
|
|
let wrap ~pre ~width s =
|
|
let words =
|
|
List.filter (fun w -> w <> "")
|
|
(String.split_on_char ' '
|
|
(String.map (fun c -> if c = '\n' || c = '\t' then ' ' else c) s))
|
|
in
|
|
let lines = ref [] and cur = Buffer.create 80 in
|
|
let emit () =
|
|
if Buffer.length cur > 0 then begin
|
|
lines := (pre ^ Buffer.contents cur) :: !lines;
|
|
Buffer.clear cur
|
|
end
|
|
in
|
|
List.iter
|
|
(fun w ->
|
|
if Buffer.length cur > 0
|
|
&& String.length pre + Buffer.length cur + 1 + String.length w > width
|
|
then emit ();
|
|
if Buffer.length cur > 0 then Buffer.add_char cur ' ';
|
|
Buffer.add_string cur w)
|
|
words;
|
|
emit ();
|
|
List.rev !lines
|
|
|
|
let note f s =
|
|
if f.ann then
|
|
List.iter
|
|
(fun l -> ignore (annote f.b l))
|
|
(wrap ~pre:(Printf.sprintf "\t%s# " f.b.ind) ~width:78 s)
|
|
|
|
(* The same, on a buffer rather than a function context: the prologue is built
|
|
into its own buffer before [f.b] is finished with. *)
|
|
let bnote ann b s =
|
|
if ann then
|
|
List.iter (fun l -> ignore (annote b l)) (wrap ~pre:"\t# " ~width:78 s)
|
|
|
|
(* The heading for one Flan form, queued against whatever bytes it goes on to
|
|
emit. Three things are deliberately not annotated.
|
|
|
|
A form the checker invented carries [Loc.unknown], and there is no source
|
|
text to quote for it; it inherits the heading of the form that contains it,
|
|
which is where it came from and therefore the true answer.
|
|
|
|
An atom — a literal, a local, a global — is skipped because annotating it
|
|
would steal its parent's heading. A multiply of a local by a literal lowers
|
|
as a load, a load and an [imul]: if the two operands each queued a heading
|
|
of their own, the heading standing above the [imul] would name the literal,
|
|
and the one line a reader of this file most wants to be right would be
|
|
wrong. Skipping the atoms leaves the multiply queued until the first byte
|
|
and spanning the whole run, which is the answer.
|
|
|
|
And a form at the same source position as the last heading written is
|
|
skipped, which is what keeps a macro from printing its call site once per
|
|
form of its expansion. *)
|
|
let atomic (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Int _ | Tast.Bool _ | Tast.Float _ | Tast.Str _ | Tast.Unit
|
|
| Tast.Zero _ | Tast.None_ | Tast.Uninit _ | Tast.Local _ | Tast.Global _
|
|
| Tast.FnAddr _ -> true
|
|
| _ -> false
|
|
|
|
let annot f (e : Tast.expr) =
|
|
if (not f.ann) || atomic e || e.Tast.loc.Loc.line = 0 then None
|
|
else
|
|
let loc = e.Tast.loc in
|
|
let where = Printf.sprintf "%s:%d:%d" (Filename.basename loc.Loc.file)
|
|
loc.Loc.line loc.Loc.col in
|
|
match Loc.snippet loc with
|
|
| None -> None
|
|
| Some src ->
|
|
let src =
|
|
match loc.Loc.macro with
|
|
| Some m -> Printf.sprintf "%s [from the macro %s]" src m
|
|
| None -> src
|
|
in
|
|
let key = where ^ " " ^ src in
|
|
if key = f.alast then None
|
|
else begin
|
|
f.alast <- key;
|
|
set_ind f.b (String.make (2 * min 12 f.adepth) ' ');
|
|
let head = Printf.sprintf "\t%s# %s" f.b.ind src in
|
|
let pad = max 1 (62 - String.length head) in
|
|
Some (annote f.b (head ^ String.make pad ' ' ^ where))
|
|
end
|
|
|
|
(* 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
|
|
note f (Printf.sprintf
|
|
"rep movsb: %d bytes from rsi to rdi. An aggregate is copied rather than \
|
|
aliased — spec-memory.md's assignment rule" n);
|
|
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
|
|
note f (Printf.sprintf "rep stosb: %d bytes of zero, which is what this backend \
|
|
spells a zero value as" n);
|
|
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)))
|
|
|
|
(* Counted, on the same field [emit.ml] counts it on and for the same one
|
|
reason: it is the test [redefinition] applies before it lets an expression
|
|
thunk's module say it may be unloaded. A string literal is emitted into this
|
|
module's image and the expression may store it anywhere it likes, so a
|
|
module holding one keeps its mapping. A float constant is a label in the
|
|
same section and is deliberately not counted -- it is loaded, never
|
|
retained. *)
|
|
let string_const f s =
|
|
f.md.Emit.nstr <- f.md.Emit.nstr + 1;
|
|
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
|
|
|
|
(* ── The shadow stack's descriptors ──────────────────────────────────── *)
|
|
|
|
(* One [flan_fninfo] (runtime/flan_dev.c) per function in a dev build: the
|
|
name and the location as bytes and lengths, how many slots the frame has,
|
|
and the two fingerprints the daemon compares a frame against. Static data —
|
|
nothing about a function changes between two calls to it — so the record a
|
|
call pushes is three words and points at this.
|
|
|
|
Not through [string_const], and that is the whole reason this has its own
|
|
emitter rather than borrowing that one. [string_const] bumps [md.nstr],
|
|
which is the test [redefinition] applies before it lets an expression
|
|
thunk's module say nothing points into it: a literal in the image may be
|
|
held by the program afterwards, so a module with one keeps its mapping. A
|
|
descriptor is not held — the frames naming it were popped on the way out and
|
|
the break loop copies the bytes it shows. Counting these there would stop
|
|
every C-x C-e module from ever being unloaded, which is [emit.ml]'s [m.nfi]
|
|
comment and the same trap on this side.
|
|
|
|
The bytes carry no NUL and are not meant to: every reader takes the length
|
|
beside the pointer. *)
|
|
let fi_bytes 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));
|
|
l, String.length s
|
|
|
|
(* [.data.rel.ro] and not [.rodata], which every other constant here goes in.
|
|
This is the only constant this backend emits that holds an *address*, and an
|
|
address in a shared object is a relocation the loader applies at load time —
|
|
so the section has to be one the loader may write. A redefinition module is
|
|
exactly such an object. The section is switched back afterwards because the
|
|
caller's buffer is emitted inside [.rodata] and everything after this in it
|
|
belongs there. *)
|
|
let fninfo f (fn : Tast.fn) ~nslots =
|
|
let nlbl, nlen = fi_bytes f fn.Tast.name in
|
|
let llbl, llen = fi_bytes f (Loc.to_string fn.Tast.floc) in
|
|
let l = rodata_label f in
|
|
Buffer.add_string f.rodata
|
|
(Printf.sprintf
|
|
"\t.section\t.data.rel.ro,\"aw\"\n\t.align 8\n%s:\n\
|
|
\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\
|
|
\t.long\t%d\n\t.long\t%d\n\t.long\t%d\n\t.long\t0\n\
|
|
\t.section\t.rodata\n"
|
|
l nlbl nlen llbl llen nslots (Emit.slot_fingerprint fn)
|
|
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem f.md.Emit.globals) fn));
|
|
l
|
|
|
|
(* The store that says "this slot is bound now", and it is the address rather
|
|
than a flag for [emit.ml]'s reason: the reader needs the address anyway, so
|
|
one store carries both facts, and a slot the control flow has not reached
|
|
reads as null rather than as a plausible value at an address nobody wrote.
|
|
|
|
rax is free at every site that calls this — each one has just finished
|
|
moving a value into the slot, and nothing in this backend is live in a
|
|
register across a statement. *)
|
|
let bind_slot f i =
|
|
match f.dslotv with
|
|
| None -> ()
|
|
| Some sv ->
|
|
if i < Array.length f.snames && f.snames.(i) <> None then begin
|
|
lea f.b ~dst:rax ~mm:(Frame f.slots.(i));
|
|
store_int f.b ~src:rax ~mm:(Frame (sv + (8 * i))) ~size:8
|
|
end
|
|
|
|
(* ── 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 *)
|
|
| Lgot of string * int (* a symbol this object does not define; + d *)
|
|
(* A name that did not exist when the host was built, so there is no symbol
|
|
anywhere to bind to. The address lives in a slot this module defines and
|
|
[flan_reload_install] fills by asking the runtime's registry for it by
|
|
string. The slot is this object's own, so naming it is pc-relative and
|
|
never goes through the GOT; reading it is the one extra load, which is
|
|
exactly [Lgot]'s shape with [Sym] where it has [Got]. *)
|
|
| Lslot of string * int (* a module-local slot holds the address; + 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)
|
|
| Lgot (s, a) -> Lgot (s, a + d)
|
|
| Lslot (s, a) -> Lslot (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)
|
|
(* The GOT slot holds the address, so this is one load more than [Lg] and
|
|
exactly the [Lp] shape afterwards -- the displacement is arithmetic on a
|
|
register base, never on the relocation. *)
|
|
| Lgot (s, a) ->
|
|
load_int f.b ~dst:scratch ~mm:(Got s) ~size:8 ~signed:false;
|
|
Reg (scratch, a)
|
|
| Lslot (s, a) ->
|
|
load_int f.b ~dst:scratch ~mm:(Sym (s, 0)) ~size:8 ~signed:false;
|
|
Reg (scratch, 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))
|
|
| Lgot (s, a) ->
|
|
load_int f.b ~dst:reg ~mm:(Got s) ~size:8 ~signed:false;
|
|
if a <> 0 then add_imm f.b ~dst:reg a
|
|
| Lslot (s, a) ->
|
|
load_int f.b ~dst:reg ~mm:(Sym (s, 0)) ~size:8 ~signed:false;
|
|
if a <> 0 then add_imm f.b ~dst:reg 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
|
|
|
|
(* The spellings of "name a symbol", each picking the pc-relative form
|
|
for a symbol this object defines and the GOT form for one it does not. *)
|
|
let sym_loc f s =
|
|
match f.slot s with
|
|
| Some sl -> Lslot (sl, 0)
|
|
| None -> if f.ext s then Lgot (s, 0) else Lg (s, 0)
|
|
|
|
(* [lea] of a symbol is an address; out of the GOT the address is already
|
|
there, so the [lea] becomes a load. *)
|
|
let addr_sym f ~dst s =
|
|
if f.ext s then load_int f.b ~dst ~mm:(Got s) ~size:8 ~signed:false
|
|
else lea f.b ~dst ~mm:(Sym (s, 0))
|
|
|
|
(* Read what a global holds, as opposed to where it is -- an indirection cell
|
|
is the only caller. Out of the GOT that is two loads, not one: the slot
|
|
holds the cell's *address*. Collapsing them was this lane's one real bug,
|
|
and it looked exactly right in the disassembly: [mov r11, cell@GOTPCREL(%rip)]
|
|
beside [call *%r11] reads as "call through the cell" and in fact calls the
|
|
cell. docs/DISCUSS.md item 15 said this is how hand-encoding fails. *)
|
|
let load_sym f ~dst s =
|
|
match f.slot s with
|
|
(* The slot holds the cell's address, just as the GOT entry below does, so
|
|
this is the same two loads with one relocation swapped. Which is the point
|
|
of spelling a run-time-new name this way: every site that reaches a cell
|
|
already double-loads, and none of them had to learn a third case. *)
|
|
| Some sl ->
|
|
load_int f.b ~dst ~mm:(Sym (sl, 0)) ~size:8 ~signed:false;
|
|
load_int f.b ~dst ~mm:(Reg (dst, 0)) ~size:8 ~signed:false
|
|
| None ->
|
|
if f.ext s then begin
|
|
load_int f.b ~dst ~mm:(Got s) ~size:8 ~signed:false;
|
|
load_int f.b ~dst ~mm:(Reg (dst, 0)) ~size:8 ~signed:false
|
|
end
|
|
else load_int f.b ~dst ~mm:(Sym (s, 0)) ~size:8 ~signed:false
|
|
|
|
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 data_payload_off f (u : Tast.data) =
|
|
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 data type 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.datas sn with
|
|
| Some (u : Tast.data) -> [ 0; data_payload_off f u ]
|
|
| None ->
|
|
(* And a union is a struct at this level too, with the one difference
|
|
that makes it a union: every member starts where the union starts,
|
|
so the offsets are zeros and the member's own type is what the load
|
|
or the store reads the bytes as. One list per member and not a
|
|
single zero, because the caller indexes it by member. *)
|
|
match Hashtbl.find_opt f.md.Emit.unions sn with
|
|
| Some (u : Tast.structure) -> List.map (fun _ -> 0) u.Tast.fields
|
|
| None -> unsupported "no struct %s" sn)
|
|
|
|
(* A data type 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 data type whose
|
|
cases are all payload-less is a bare tag and has no second field. *)
|
|
|
|
let data_of f n =
|
|
match Hashtbl.find_opt f.md.Emit.datas n with
|
|
| Some u -> u
|
|
| None -> unsupported "no data type %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 =
|
|
note f
|
|
"The transfer guard, after every call to Flan code: load this frame's channel, load \
|
|
through it, test, and branch if it is set — a callee that transferred left a \
|
|
target there and the value in rax means nothing.";
|
|
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 _ -> [ 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 =
|
|
(* The one hook the line table needs, and it is here rather than at
|
|
statement granularity on purpose: the same recursion that lowers a nested
|
|
call lowers its arguments, and a row per expression is what makes a
|
|
backtrace through an argument name the argument rather than the call. It
|
|
is inert in every build but a [--debug] one. *)
|
|
dwline f e.Tast.loc;
|
|
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 if not f.ann then lower_at f e dst
|
|
else begin
|
|
(* The second hook, and it hangs off the same recursion for the same
|
|
reason: a heading queued here spans exactly the bytes this form and
|
|
everything inside it emit, so the listing nests the way the source
|
|
does. Withdrawn again if the form emitted nothing — a [defer] that is
|
|
hoisted, a [Unit] in statement position — because a heading left
|
|
standing would be read as belonging to whatever came next. *)
|
|
let prev = f.alast in
|
|
(* Captured before [annot], which moves the margin as a side effect of
|
|
queueing a heading: restoring what it moved is the point. *)
|
|
let d = f.adepth and ind = f.b.ind in
|
|
let s = annot f e in
|
|
f.adepth <- d + 1;
|
|
lower_at f e dst;
|
|
f.adepth <- d;
|
|
set_ind f.b ind;
|
|
match s with
|
|
| Some s -> if not (unannote f.b s) then f.alast <- prev
|
|
| None -> ()
|
|
end
|
|
|
|
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 — docs/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
|
|
(* The symbol itself, not a load from it: a function's address is a
|
|
link-time constant, and this is the spelling a lifted handler clause is
|
|
reached by. [emit.ml] says the same of [Flanfn]. *)
|
|
| Tast.FnAddr (Tast.Flanfn n) ->
|
|
addr_sym f ~dst:rax (fsym n);
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
(* A function value someone wrote, which is the one [FnAddr] that is not the
|
|
symbol. In a release build there is nothing to redefine and it is the
|
|
symbol after all; in a dev build it is the cell's contents, so that a
|
|
value taken after a redefinition is the new body. What that does not give
|
|
— and [emit.ml] names it rather than papering over it with a trampoline —
|
|
is a value taken *before* a redefinition and called after it. Once the
|
|
address is in a slot there is nothing left to re-resolve. *)
|
|
| Tast.FnAddr (Tast.Fnval n) ->
|
|
if f.md.Emit.dev then
|
|
load_sym f ~dst:rax (csym n)
|
|
else addr_sym f ~dst:rax (fsym n);
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
| Tast.FnAddr (Tast.Rtfn n) ->
|
|
addr_sym f ~dst:rax n;
|
|
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 ->
|
|
(* A dev build calls through the cell so that a redefinition reaches
|
|
every existing call site; a release build names the symbol. *)
|
|
call_flan f
|
|
~target:(if f.md.Emit.dev then `Cell (csym name) else `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)));
|
|
bind_slot f 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 (dname, case, fields) ->
|
|
let u = data_of f dname in
|
|
let i, c =
|
|
match Tast.case_index u case with
|
|
| Some (i, c) -> i, c
|
|
| None -> unsupported "no case %s of %s" case dname
|
|
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 = data_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. *)
|
|
addr_sym f ~dst:rax (fsym h.Tast.hfn);
|
|
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;
|
|
bind_slot f slot_i)
|
|
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 -> sym_loc f (gsym n)
|
|
| 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 data type 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 dname =
|
|
match target.Tast.ty with
|
|
| Types.Named n -> n
|
|
| ty -> unsupported "case field of %s" (Types.to_string ty)
|
|
in
|
|
let u = data_of f dname in
|
|
let c =
|
|
match Tast.case_index u case with
|
|
| Some (_, c) -> c
|
|
| None -> unsupported "no case %s of %s" case dname
|
|
in
|
|
shift (lvalue f target) (data_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 data type 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.datas n ->
|
|
let u = data_of f n in
|
|
let poff = data_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 data type. *)
|
|
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;
|
|
bind_slot f slot)
|
|
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 -> sym_loc f (gsym n)
|
|
| 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) =
|
|
note f (Printf.sprintf
|
|
"Out of bounds: the location string, the operands, and this frame's channel, \
|
|
then %s, which signals" sym);
|
|
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;
|
|
note f
|
|
"ud2, where emit.ml writes unreachable. Nothing answered the signal, so the runtime \
|
|
already died inside that call and nothing falls through to here.";
|
|
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 () ->
|
|
note f
|
|
"The bounds check. One unsigned compare catches a negative index as well as an \
|
|
oversized one, and the not-taken branch is the whole of the fast path.";
|
|
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. Two compares, and only one of them is a bounds check.
|
|
|
|
[hi <= len] is the bounds check. It asks whether the caller's range fits
|
|
inside the thing being sliced, which is a question about a length this
|
|
backend has to go and load, and [--no-bounds-checks] exists to stop asking
|
|
it — the release decision, taken by someone who accepts undefined behaviour
|
|
if their indices are wrong.
|
|
|
|
[lo <= hi] is a different claim and survives the flag. The two words stored
|
|
at the bottom of this case are a slice, and the second is a *count*: the
|
|
`sub` in the caller computes hi - lo, and everything downstream — the len
|
|
primitive, a re-slice, flan_write_stdout, any C this is handed to — reads
|
|
it as a non-negative number of elements. A reversed range does not build an
|
|
out-of-range slice, it builds a value that is not a slice: (slice s 2 1)
|
|
stores -1, and -1 read as a count is 18446744073709551615. There is no
|
|
build in which that is the intended behaviour, so there is no flag that
|
|
turns the compare off. flan_vec_as_slice validates its own [l > h]
|
|
unconditionally in plain C and always has; this is the same rule, arriving
|
|
late on the emitted path.
|
|
|
|
Hence the shape below. All three frame temporaries are stored before either
|
|
compare and outside the flag, because [bounds_call] reads all three and the
|
|
third is the length the message prints — gate the store along with the
|
|
compare and an unchecked build traps with the right range beside a garbage
|
|
length, which is a wrong answer that builds, links and passes every test
|
|
that reads the IR rather than the text. *)
|
|
and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr)
|
|
(llo : loc) (hi : Tast.expr) (lhi : loc) =
|
|
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" in
|
|
cmp_rr f.b ~a:rax ~c:rdx;
|
|
if f.md.Emit.checks then begin
|
|
let bad = new_label f "oob" in
|
|
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
|
|
end else
|
|
jcc_lbl f.b ~cc:cc_be ok;
|
|
bounds_call f "flan_slice_error" loc [ a; b; c ];
|
|
lbl f.b ok)
|
|
|
|
(* [emit.ml]'s [check_div] and [check_cast], item 3 of docs/handoffs/HANDOFF-x86-rt.md's
|
|
list, and the one item on it that was blocked on a language decision rather
|
|
than on code. That decision is in docs/handoffs/HANDOFF-arith.md: a divide or remainder by
|
|
zero, the one division that overflows, and a float to integer cast whose
|
|
value does not fit all signal ArithError, exactly as a bad index signals
|
|
BoundsError.
|
|
|
|
Why it could not be left to the hardware, which is the temptation here and
|
|
is what this backend did until now. `idiv` raises SIGFPE on both the zero
|
|
and the overflow case, and a SIGFPE cannot be caught and resumed — so there
|
|
is no version of this that tests afterwards, and nothing that dies with a
|
|
location. The other backend calls the same three situations undefined and
|
|
folds them to whatever it likes. Neither is a behaviour a program can be
|
|
written against, and the two disagreed, which is what a survey diff would
|
|
eventually have found the hard way.
|
|
|
|
These reuse [bounds_call] unchanged: it spells the whole shape — the
|
|
location string into rdi/rsi, the extra arguments out of frame temporaries
|
|
into rdx/rcx/r8/r9, the channel after them, the guard, and the [ud2] that
|
|
stands where [emit.ml] writes [unreachable]. flan_arith_error takes three
|
|
extras, so the channel lands in r9 and the register file is exactly full. *)
|
|
|
|
(* The codes are [emit.ml]'s, read from there rather than copied: they are an
|
|
agreement with flan_arith_fail in the runtime, and an agreement kept in two
|
|
places is an agreement that drifts. *)
|
|
|
|
(* rax holds the dividend and rcx the divisor, both already widened to 64 bits
|
|
by [load_loc] according to their own signedness — which is what lets the
|
|
overflow test compare against the *narrow* type's most negative value in a
|
|
64-bit register and mean it.
|
|
|
|
Two tests and two ways out rather than [emit.ml]'s single branch with a
|
|
[select], because there is no [select] here and a second compare on the cold
|
|
path is free. The ordinary path still pays one compare and one
|
|
not-taken branch, which is the same as over there.
|
|
|
|
Both tests are dropped when a literal divisor cannot trigger them. That is
|
|
not a micro-optimisation: (/ x 2) is the common case and would otherwise
|
|
carry a compare and a branch forever. *)
|
|
and check_div f (loc : Loc.t) ~is_rem (k : Types.ikind) ~lit =
|
|
if f.md.Emit.checks then begin
|
|
let need_zero = match lit with Some n -> Int64.equal n 0L | None -> true in
|
|
let need_ovf =
|
|
Types.signed k
|
|
&& (match lit with Some n -> Int64.equal n (-1L) | None -> true)
|
|
in
|
|
if need_zero || need_ovf then
|
|
scoped f (fun () ->
|
|
note f
|
|
(Printf.sprintf
|
|
"The arithmetic guard: %s%s%s, and the failure path signals through \
|
|
flan_arith_fail"
|
|
(if need_zero then "a zero divisor" else "")
|
|
(if need_zero && need_ovf then " and " else "")
|
|
(if need_ovf then "the one overflowing division" else ""));
|
|
let so = ptmp f and sa = ptmp f and sb = ptmp f in
|
|
store_int f.b ~src:rax ~mm:(Frame sa) ~size:8;
|
|
store_int f.b ~src:rcx ~mm:(Frame sb) ~size:8;
|
|
let ok = new_label f "arith" and bad = new_label f "arithbad" in
|
|
let zcode = if is_rem then Emit.arith_rem_zero else Emit.arith_div_zero in
|
|
let ocode = if is_rem then Emit.arith_rem_overflow else Emit.arith_div_overflow in
|
|
if need_zero then begin
|
|
let nz = new_label f "arithnz" in
|
|
cmp_imm f.b ~dst:rcx 0;
|
|
jcc_lbl f.b ~cc:cc_ne nz;
|
|
imm_into f ~reg:rdx (Int64.of_int zcode);
|
|
store_int f.b ~src:rdx ~mm:(Frame so) ~size:8;
|
|
jmp_lbl f.b bad;
|
|
lbl f.b nz
|
|
end;
|
|
if need_ovf then begin
|
|
cmp_imm f.b ~dst:rcx (-1);
|
|
jcc_lbl f.b ~cc:cc_ne ok;
|
|
(* Through r11 rather than as an immediate: the most negative i64
|
|
does not fit the imm32 [cmp_imm] encodes, and one spelling for
|
|
every width beats a special case for the one that does not. *)
|
|
imm_into f ~reg:r11 (Int64.neg (Int64.shift_left 1L (Types.bits k - 1)));
|
|
cmp_rr f.b ~a:rax ~c:r11;
|
|
jcc_lbl f.b ~cc:cc_ne ok;
|
|
imm_into f ~reg:rdx (Int64.of_int ocode);
|
|
store_int f.b ~src:rdx ~mm:(Frame so) ~size:8
|
|
end
|
|
else jmp_lbl f.b ok;
|
|
lbl f.b bad;
|
|
bounds_call f "flan_arith_error" loc [ so; sa; sb ];
|
|
lbl f.b ok;
|
|
(* rdx is the high half of the dividend and [cqo] is what fills it, so
|
|
whatever the overflow test left there does not survive; rax and rcx
|
|
are untouched on this path and do not need reloading. *)
|
|
())
|
|
end
|
|
|
|
(* A float to integer cast whose value does not fit. xmm0 holds the value, in
|
|
the *source's* precision, and the bounds are compared in that same precision
|
|
rather than widened to a double first the way [emit.ml] does it: both bounds
|
|
are powers of two, so both are exact in an f32 as well as in an f64, and the
|
|
two tests therefore answer identically. Doing it here saves a conversion and
|
|
a second live xmm register.
|
|
|
|
The direction of each compare is chosen so that a NaN fails both. [ucomis]
|
|
sets CF, ZF and PF together when either operand is unordered, so the test
|
|
for the low end is written as "jump to the failure when below", which a NaN
|
|
takes, and the test for the high end swaps its operands and asks the same
|
|
question the other way round. A NaN cast to an integer is exactly as
|
|
undefined as 1e300 is and has no business walking through the guard. *)
|
|
and check_cast f (loc : Loc.t) (src : Types.fkind) (k : Types.ikind) =
|
|
if f.md.Emit.checks then begin
|
|
note f
|
|
"The range check on a float-to-integer cast. Two compares, written in the \
|
|
directions that make a NaN fail both of them.";
|
|
let f64 = (src = Types.F64) in
|
|
let n = Types.bits k in
|
|
let signed = Types.signed k in
|
|
let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in
|
|
let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in
|
|
let lo_i = if signed then Int64.neg (Int64.shift_left 1L (n - 1)) else 0L in
|
|
let hi_i =
|
|
if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L
|
|
else if n = 64 then -1L
|
|
else Int64.sub (Int64.shift_left 1L n) 1L
|
|
in
|
|
let klo = float_const f lo_f ~f64 and khi = float_const f hi_f ~f64 in
|
|
scoped f (fun () ->
|
|
let so = ptmp f and sa = ptmp f and sb = ptmp f in
|
|
let ok = new_label f "fits" and bad = new_label f "nofit" in
|
|
fload f.b ~dst:1 ~mm:(Sym (klo, 0)) ~f64;
|
|
ucomis f.b ~f64 ~a:xmm0 ~c:1;
|
|
jcc_lbl f.b ~cc:cc_b bad;
|
|
fload f.b ~dst:1 ~mm:(Sym (khi, 0)) ~f64;
|
|
(* The operands the other way round, so that the code asked for is one a
|
|
NaN answers false to: this is "hi > v" and not "v < hi". *)
|
|
ucomis f.b ~f64 ~a:1 ~c:xmm0;
|
|
jcc_lbl f.b ~cc:cc_a ok;
|
|
lbl f.b bad;
|
|
imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_range);
|
|
store_int f.b ~src:rax ~mm:(Frame so) ~size:8;
|
|
imm_into f ~reg:rax lo_i;
|
|
store_int f.b ~src:rax ~mm:(Frame sa) ~size:8;
|
|
imm_into f ~reg:rax hi_i;
|
|
store_int f.b ~src:rax ~mm:(Frame sb) ~size:8;
|
|
bounds_call f "flan_arith_error" loc [ so; sa; sb ];
|
|
lbl f.b ok)
|
|
end
|
|
|
|
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 | `Cell s -> `Cell 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));
|
|
(* The cell is loaded *after* the arguments, and [emit.ml] has the same as a
|
|
load-bearing comment: a redefinition that lands between two calls still
|
|
must not land in the middle of one. [r11] is scratch and no argument
|
|
register, so this cannot disturb what [emit_args] just placed. [CallPtr]
|
|
is deliberately the other way round — the callee there is written first
|
|
and there is no cell to keep out of an argument list. *)
|
|
(match callee with
|
|
| `Sym s -> call_sym f.b s
|
|
| `Cell s ->
|
|
note f
|
|
"The indirection cell. A dev build calls through it rather than to the symbol, so \
|
|
that a redefinition installed while the process runs is reached by the next \
|
|
call.";
|
|
load_sym f ~dst:r11 s;
|
|
call_r f.b r11
|
|
| `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 (docs/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 and a Map 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 _ -> 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
|
|
(* Unreachable, and it is worth saying why rather than leaving it reading
|
|
like a gap in the backend. Nothing that crosses this boundary returns an
|
|
aggregate, by two rules that both live in [check.ml]:
|
|
|
|
- every aggregate-valued runtime result comes back through an
|
|
*out-pointer* the checker allocates, so the Flan-level return type is
|
|
[Unit] or a scalar. [flan_vec_as_slice] is the one that looks like a
|
|
counter-example and is not: [check.ml] builds it as [rt loc
|
|
Types.Unit] and [flan_rt.c] writes the two words through [void *out].
|
|
Every other [rt] builder in the file answers [Unit], an [Int], a
|
|
[Ptr] or an [Alloc].
|
|
- [crossable], which admits [String] and [Slice _] only as "a
|
|
parameter" and refuses an aggregate return from a [declare] outright.
|
|
|
|
So this is a guard against those two rules changing, and not a feature
|
|
waiting to be written. If one ever does change, the work it names is
|
|
*SysV classification* and not the internal convention in the header: C
|
|
returns a 16-byte slice in rax:rdx, and there is no classifier in this
|
|
file. Refusing is the honest answer until there is. *)
|
|
if is_agg rty then
|
|
unsupported
|
|
"%s returns %s by value, which needs SysV return classification this \
|
|
backend does not have" sym (Types.to_string rty);
|
|
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 language masks a computed count to the operand's width minus one
|
|
and says so out loud (NEXT.md's sharp edges); [emit] writes that mask
|
|
into the IR at 2041. The hardware would do it too if the shift were
|
|
the operand's width, but [shift_cl] is 64 bits wide whatever the type
|
|
says, so what the silicon masks to is 63 and not 31, 15 or 7. Without
|
|
the [and] a count of 32 on an i32 shifts the sign-extended value out
|
|
of the low half and stores zero, where the rule — and LLVM — say the
|
|
count is 0 and the value comes back unchanged. One extra [and] on the
|
|
count register buys the agreement; 64-bit shifts skip it because
|
|
there the hardware's mask is already the rule's. A literal out of
|
|
range never reaches here: [check] rejects it as a typo. *)
|
|
| Tast.Shl | Tast.Shr ->
|
|
(match t with
|
|
| Types.Int k when Types.bits k < 64 ->
|
|
and_imm f.b ~dst:rcx (Types.bits k - 1)
|
|
| _ -> ());
|
|
(match p with
|
|
| Tast.Shl -> shl_cl f.b ~dst:rax
|
|
| _ -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax)
|
|
| Tast.Div | Tast.Rem ->
|
|
(* The guard goes *before* the instruction, which is the whole of why
|
|
it has to be emitted at all: `idiv` raises SIGFPE on both the zero
|
|
and the overflow case and a SIGFPE cannot be caught and resumed.
|
|
Integers only — this arm is already inside the non-float half —
|
|
because IEEE x / 0.0 is an infinity and is a defined answer. *)
|
|
(match t with
|
|
| Types.Int k ->
|
|
let lit =
|
|
match b.Tast.e with Tast.Int (n, _) -> Some n | _ -> None
|
|
in
|
|
check_div f e.Tast.loc ~is_rem:(p = Tast.Rem) k ~lit
|
|
| _ -> ());
|
|
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.
|
|
|
|
It is not behind [f.md.Emit.checks], and the reason is the one
|
|
[check_slice] above spells out at length. [--no-bounds-checks] drops a
|
|
comparison against a known length; this comparison has no length to be
|
|
against — the paragraph above says as much — so the flag has nothing here
|
|
to drop. The word being stored into the second half of [dst] is the
|
|
slice's count, and a count that is negative is not a slice with the
|
|
bounds check taken off, it is not a slice. So the test runs in every
|
|
build, exactly as [lo <= hi] does. *)
|
|
| Tast.SliceFromPtr, [ p; n ] ->
|
|
let lp = eval f p in
|
|
let ln = eval f n in
|
|
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
|
|
(* [b] is the caller's buffer, a frame slot the checker gave this call site.
|
|
See check.ml's [to_bytes]: a backend temporary here would be reclaimed at
|
|
the end of this expression and the slice outlives it. *)
|
|
| Tast.I64ToBytes, [ a; b ] -> shim_out f "flan_i64_to_bytes" a b dst
|
|
| Tast.U64ToBytes, [ a; b ] -> shim_out f "flan_u64_to_bytes" a b dst
|
|
| Tast.F64ToBytes, [ a; b ] -> shim_out f "flan_f64_to_bytes" a b 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
|
|
(* The allocation registry's notes are the one runtime family a release
|
|
build drops on the floor, and [emit.ml:1918] drops it with this same
|
|
guard — the checker builds a [Tast.Rt] it does not know is unwanted,
|
|
because it does not know whether this is a dev build and does not have
|
|
to. [emit.ml] is careful to drop it before the arguments are walked, so
|
|
that taking the address of the container being described does not leave
|
|
an escaped alloca for mem2reg to refuse; here the arguments are not
|
|
touched until [call_rt], so answering [()] is already early enough. The
|
|
test is [emit.ml]'s byte for byte, strict [>] included: bare
|
|
[flan_dev_reg_note] is the runtime's own entry point and is never a
|
|
[Tast.Rt]; what [check.ml] builds is the [_vec] and [_map]
|
|
wrappers, each of which is longer than the prefix. The node's type is
|
|
[Unit], so there is nothing to store and [dst] is untouched. *)
|
|
| Tast.Rt sym, _
|
|
when (not f.md.Emit.dev)
|
|
&& String.length sym > 17
|
|
&& String.equal (String.sub sym 0 17) "flan_dev_reg_note" -> ()
|
|
| 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, uint8_t *buf, flan_slice *out)] — a scalar in, text rendered
|
|
into the caller's buffer, and a slice over it written through a hidden out
|
|
pointer. The three number printers, and nothing else.
|
|
Both operands are evaluated before any argument register is loaded:
|
|
evaluating one is arbitrary code and would otherwise overwrite the other. *)
|
|
and shim_out f sym (a : Tast.expr) (buf : Tast.expr) dst =
|
|
let l = eval f a in
|
|
let lb = eval f buf 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);
|
|
load_loc f ~reg:rdi lb buf.Tast.ty;
|
|
addr_into f ~reg:rsi dst;
|
|
imm_into f ~reg:rax 1L
|
|
end else begin
|
|
load_loc f ~reg:rdi l a.Tast.ty;
|
|
load_loc f ~reg:rsi lb buf.Tast.ty;
|
|
addr_into f ~reg:rdx 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);
|
|
(* [cvttsd2si] answers a fixed "integer indefinite" for a value out of
|
|
range, which is a number rather than an answer — and the other backend
|
|
calls the same cast undefined and will fold it to anything. So the
|
|
value is tested against the destination's range first. *)
|
|
(match src_t, dst_t with
|
|
| Types.Float sk, Types.Int k -> check_cast f a.Tast.loc sk k
|
|
| _ -> ());
|
|
cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0;
|
|
store_loc f ~reg:rax dst dst_t
|
|
|
|
(* ── Call frame information ──────────────────────────────────────────── *)
|
|
|
|
(* The whole frame model, in five directives.
|
|
|
|
[.cfi] is the one thing the assembler gets right against a file with no
|
|
instructions in it, and it is worth saying so beside the debug-information
|
|
section above, which is about the thing it gets wrong: CFI advances are
|
|
computed from frag positions, where the line table's are computed from
|
|
having assembled an instruction. Measured — a [.byte]-only function comes
|
|
out of [readelf --debug-dump=frames] with exact advances.
|
|
|
|
The content is a constant because of the header's own claim that [rsp] is
|
|
written exactly twice. On entry the CFA is [rsp+8]; [push rbp] makes it
|
|
[rsp+16] and puts the saved [rbp] at [cfa-16]; [mov rsp, rbp] moves the
|
|
rule onto [rbp], where it stays for the whole body, because the only other
|
|
write to [rsp] is the [leave]. After that [rsp] is [rbp+8] again and the
|
|
CFA is [rsp+8]. Register 6 is [rbp] and 7 is [rsp] in DWARF's numbering;
|
|
the return address is column 16 and the CIE already says it is at
|
|
[cfa-8].
|
|
|
|
Emitted only in a [--debug] build, so that a release build's assembly stays
|
|
byte-for-byte what it was. That is a conservative call rather than a
|
|
principled one: this description is correct in every build, and a release
|
|
build is where an unwind through a crash would most want it. What stops it
|
|
from being unconditional today is only that nothing measures the [.eh_frame]
|
|
it would add. *)
|
|
let cfi_after_push b = text b "\t.cfi_def_cfa_offset 16\n\t.cfi_offset 6, -16\n"
|
|
let cfi_after_mov b = text b "\t.cfi_def_cfa_register 6\n"
|
|
let cfi_after_leave b = text b "\t.cfi_def_cfa 7, 8\n"
|
|
|
|
(* ── 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 ()
|
|
|
|
(* ── The frame map ───────────────────────────────────────────────────── *)
|
|
|
|
(* What a listing out of this backend needs most, and the one thing no amount
|
|
of disassembly recovers. LLVM's output names its values; this file's names
|
|
nothing, because every value it has lives in a frame temporary and a
|
|
temporary has no name to print. So the key goes above the function: which
|
|
displacement is which parameter, which is which named local, where the
|
|
compiler's own three live, and where the nameless temporaries begin.
|
|
|
|
Everything here is read out of state [emit_fn] already keeps. Nothing is
|
|
recomputed and nothing is guessed, which is why this cannot drift from the
|
|
code it describes: [f.slots] *is* what the prologue stores through.
|
|
|
|
The one thing deliberately not described is any individual temporary.
|
|
[scoped] reclaims them and a later statement reuses the bytes, so naming an
|
|
offset that holds something else half the time is worse than saying where
|
|
the region starts — which is the same call the DWARF above makes about
|
|
locals, and for the same reason. *)
|
|
let where_from = function
|
|
| Ireg r -> Printf.sprintf "from %s" (regname r)
|
|
| Isse i -> Printf.sprintf "from xmm%d" i
|
|
| Istk d -> Printf.sprintf "from the caller's stack, at rbp+0x%x" d
|
|
|
|
let frame_map (md : Emit.m) (fn : Tast.fn) ~slots ~fixed ~total ~outgoing
|
|
~xfer_off ~sret_off ~retval ~dframe ~dslotv ~sret ~sret_at ~param_at
|
|
~xfer_at =
|
|
let b = Buffer.create 1024 in
|
|
let line s = Buffer.add_string b (if s = "" then "#\n" else "# " ^ s ^ "\n") in
|
|
(* The prose paragraphs wrap; the table below does not, because its columns
|
|
are the point of it. *)
|
|
let para s = List.iter (fun l -> Buffer.add_string b (l ^ "\n"))
|
|
(wrap ~pre:"# " ~width:76 s) in
|
|
let bar = "# " ^ String.concat "" (List.init 68 (fun _ -> "\xe2\x94\x80")) in
|
|
Buffer.add_string b (bar ^ "\n");
|
|
(* The [defn] as it was written, which is the whole line and not the span:
|
|
[floc] points at the name, and a reader wants the parameter list too. A
|
|
function the checker lifted out of a [handler-bind] clause has no line of
|
|
its own to show and says so. *)
|
|
let decl =
|
|
match Loc.source_line fn.Tast.floc with
|
|
| Some l -> Some (String.trim l)
|
|
| None -> None
|
|
in
|
|
line
|
|
(Printf.sprintf "%s%s" (fsym fn.Tast.name)
|
|
(match decl with
|
|
| Some d when String.length d > 0 ->
|
|
Printf.sprintf " %s %s"
|
|
(if String.length d > 56 then String.sub d 0 55 ^ "…" else d)
|
|
(Loc.to_string fn.Tast.floc)
|
|
| _ ->
|
|
(match fn.Tast.fparent with
|
|
| Some parent ->
|
|
Printf.sprintf
|
|
" a clause lifted out of %s, which no one wrote as a \
|
|
function" parent
|
|
| None -> " " ^ Loc.to_string fn.Tast.floc)));
|
|
(* A function out of the prelude, or out of any file this process cannot open
|
|
again, gets a frame map and no form headings at all: [Loc.snippet] has
|
|
nothing to quote and says so rather than printing a column of bare
|
|
positions. Worth saying once per function, because the absence is
|
|
otherwise read as a bug in the annotation. *)
|
|
if decl = None then
|
|
para
|
|
"The source this was compiled from is not readable from here, so the \
|
|
byte runs below carry no form headings — only this map.";
|
|
line "";
|
|
(* The convention, stated where the function is rather than only in this
|
|
file's header, because the header is not what a reader of a listing has
|
|
in front of them. *)
|
|
let nparams = List.length fn.Tast.params in
|
|
let args =
|
|
List.mapi
|
|
(fun i at ->
|
|
let nm = match fn.Tast.snames.(i) with Some n -> n | None -> "_" in
|
|
Printf.sprintf "%s %s" nm (where_from at))
|
|
param_at
|
|
in
|
|
para
|
|
(if nparams = 0 then "Takes nothing."
|
|
else "Arguments: " ^ String.concat ", " args ^ ".");
|
|
(match sret_at with
|
|
| Some at ->
|
|
para (Printf.sprintf
|
|
"The result is an aggregate, so it comes back through a hidden sret pointer \
|
|
the caller allocated (%s) and hands that same pointer back in rax. Every \
|
|
aggregate goes by pointer here; nothing is classified and there is no \
|
|
eightbyte rule."
|
|
(where_from at))
|
|
| None ->
|
|
if is_void fn.Tast.ret then line "Returns nothing."
|
|
else
|
|
line (Printf.sprintf "Returns %s in %s."
|
|
(Types.to_string fn.Tast.ret)
|
|
(if is_float fn.Tast.ret then "xmm0" else "rax")));
|
|
para (Printf.sprintf
|
|
"The transfer channel arrives last of all, %s. It is a pointer to the cell a \
|
|
callee writes its target into, and reading it is what every guard below \
|
|
does."
|
|
(where_from xfer_at));
|
|
line "";
|
|
para (Printf.sprintf
|
|
"The frame is 0x%x bytes below rbp. %s" total
|
|
(if outgoing > 0 then
|
|
Printf.sprintf
|
|
"The lowest 0x%x of them are the outgoing argument area, reserved once \
|
|
here and written by whichever call in this function passes the most on \
|
|
the stack." outgoing
|
|
else "No call in it passes an argument on the stack."));
|
|
line "";
|
|
let row off name ty what =
|
|
line (Printf.sprintf " %-8s %-14s %-10s %s"
|
|
(Printf.sprintf "-0x%x" (-off)) name ty what)
|
|
in
|
|
Array.iteri
|
|
(fun i ty ->
|
|
if not (is_void ty) then begin
|
|
let name =
|
|
match fn.Tast.snames.(i) with Some n -> n | None -> "<anon>"
|
|
in
|
|
let what =
|
|
if i < nparams then
|
|
Printf.sprintf "parameter %d, %s" (i + 1)
|
|
(where_from (List.nth param_at i))
|
|
else if fn.Tast.snames.(i) = None then
|
|
"a slot the compiler made, not one anyone named"
|
|
else "a local"
|
|
in
|
|
let what =
|
|
if is_agg ty then
|
|
what ^ Printf.sprintf " — %d bytes, copied in" (sizeof md ty)
|
|
else what
|
|
in
|
|
row slots.(i) name (Types.to_string ty) what
|
|
end)
|
|
fn.Tast.slots;
|
|
row xfer_off "<chan>" "ptr" "the transfer channel this frame passes on";
|
|
if sret then
|
|
row sret_off "<sret>" "ptr"
|
|
"the caller's sret pointer, kept for the epilogue";
|
|
if (not sret) && not (is_void fn.Tast.ret) then
|
|
row retval "<ret>" (Types.to_string fn.Tast.ret)
|
|
"the return value the epilogue loads";
|
|
(* Present in a dev build and absent from a release one, and the map says
|
|
which build this is by saying nothing when there is nothing there. *)
|
|
(match dframe with
|
|
| Some off ->
|
|
row off "<frame>" "ptr[3]"
|
|
"the shadow-stack record: the previous head, the description, the slots"
|
|
| None -> ());
|
|
(match dslotv with
|
|
| Some off ->
|
|
row off "<slots>" "ptr[]"
|
|
"one address per slot, null until the binding that fills it has run"
|
|
| None -> ());
|
|
para (Printf.sprintf
|
|
"Everything below -0x%x is a temporary. They are bump-allocated and reclaimed \
|
|
at the end of the form that made them, so a later form reuses the bytes and \
|
|
no one offset down there means one thing for long." fixed);
|
|
Buffer.add_string b (bar ^ "\n");
|
|
Buffer.contents b
|
|
|
|
let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
|
|
?(slot = fun _ -> None) ?(hidden = false) ?(ann = false) ?dw (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;
|
|
dframe = None; dslotv = None; snames = fn.Tast.snames;
|
|
frame = 0; maxframe = 0; outgoing = 0;
|
|
loops = []; pads = []; xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 64; externs; fns; ext; slot; dw;
|
|
ann; adepth = 0; alast = "" }
|
|
in
|
|
(* The subprogram this function's rows hang off. Its first row is the
|
|
function symbol itself, at the line the [defn] was written on, so the
|
|
entry has a position before the prologue has run; every row after it
|
|
comes out of [dwline] as the body is lowered. [dlast] is not primed with
|
|
it, which is deliberate — the first form of the body sits at a different
|
|
column even when it is on the same line, so it gets a row of its own, and
|
|
two rows are what let a debugger put a breakpoint after the prologue
|
|
rather than on it. *)
|
|
let cfi = match dw with None -> false | Some _ -> true in
|
|
let sub =
|
|
match dw with
|
|
| None -> None
|
|
| Some d ->
|
|
let line =
|
|
if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line
|
|
in
|
|
let file = dwfile d fn.Tast.floc.Loc.file in
|
|
let s =
|
|
{ sname = fn.Tast.name; ssym = fsym fn.Tast.name; sfile = file;
|
|
sline = line; send = new_label f "fe";
|
|
srows = [ { rlbl = fsym fn.Tast.name; rfile = file; rline = line;
|
|
rcol = 1 } ] }
|
|
in
|
|
d.dcur <- Some s;
|
|
d.dlast <- None;
|
|
d.dlastn <- -1;
|
|
d.dsubs <- s :: d.dsubs;
|
|
Some s
|
|
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;
|
|
(* The shadow stack's storage, in a dev build and nowhere else: three words
|
|
for the record and one per slot for the table. Allocated here, beside the
|
|
channel and the return temporary, so that they sit above [fixed] and the
|
|
frame map has somewhere to name them; and allocated outside every [scoped]
|
|
so nothing below reuses the bytes.
|
|
|
|
Only a function with at least one *named* slot gets a table, which is the
|
|
gate [emit.ml] applies. There it buys an optimisation — an alloca whose
|
|
address escapes is one mem2reg cannot promote — and nothing here promotes
|
|
anything, so on this side it buys only the stores. It is kept because the
|
|
two backends have to answer a stopped frame identically: a function whose
|
|
every slot the compiler invented reports no slots on LLVM, and a listing
|
|
that differed by backend is the one thing the break loop cannot check. *)
|
|
if md.Emit.dev then begin
|
|
if nslots > 0 && Array.exists (fun n -> n <> None) fn.Tast.snames then
|
|
f.dslotv <- Some (alloc f (8 * nslots) 8);
|
|
f.dframe <- Some (alloc f 24 8)
|
|
end;
|
|
f.retlbl <- new_label f "ret";
|
|
f.xfer_lbl <- new_label f "xfer";
|
|
(* Where the named part of the frame ends and the nameless part begins. Read
|
|
here rather than from [maxframe] afterwards, because [maxframe] is the
|
|
high-water mark of the temporaries and this is the boundary below which
|
|
they start. It is the frame map's last line. *)
|
|
let fixed = f.frame in
|
|
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 shadow stack's push, and the pop is in the epilogue. plan.org has had
|
|
*Frames: shadow stack* in the dev column since the beginning; [emit.ml]
|
|
builds the same four words on the LLVM side and this is the x86 one, down
|
|
to which fields are written and when, so that a break loop cannot tell
|
|
which backend it stopped.
|
|
|
|
Inline rather than a call, for [emit.ml]'s reason: this is on every call in
|
|
a dev build, and a call made to record a call would be most of what it
|
|
costs. What it does cost here is a handful of stores — the table's zeroing,
|
|
three words of record, one head store, and one [lea]+store per named
|
|
parameter.
|
|
|
|
Emitted into the body buffer rather than the prologue's, and that is not a
|
|
detail: the prologue is where the incoming registers still hold the
|
|
arguments, and every instruction below clobbers rax. The body buffer's
|
|
first byte is the first point at which they are all safely in the frame.
|
|
|
|
One push per [emit_fn] and no more. [emit_main], [emit_globals_init] and
|
|
[flan_reload_install] build their context by hand and push nothing, which
|
|
is what [emit.ml] does too: they are C's frames, not the program's, and a
|
|
backtrace that named them would be naming the runtime. *)
|
|
(match f.dframe with
|
|
| None -> ()
|
|
| Some fr ->
|
|
if ann then set_ind f.b "";
|
|
note f
|
|
"The shadow stack's push — runtime/flan_dev.c. Dev builds only, and it is what \
|
|
lets a stopped program say where it is. The pop is the first thing in the \
|
|
epilogue, so a transfer out of this frame pops it too.";
|
|
(* Every entry, not only the named ones: "null means not bound" has to
|
|
hold at every index, or a reader has to know which indices it may
|
|
trust, and that is a second thing to keep in step. *)
|
|
(match f.dslotv with
|
|
| Some sv -> zero_frame f ~dst:sv (8 * nslots)
|
|
| None -> ());
|
|
let head = sym_loc f "flan_frame_head" in
|
|
load_int f.b ~dst:rax ~mm:(lmem f head ~scratch:r11) ~size:8 ~signed:false;
|
|
store_int f.b ~src:rax ~mm:(Frame fr) ~size:8;
|
|
addr_into f ~reg:rax (Lg (fninfo f fn ~nslots:(if f.dslotv = None then 0 else nslots), 0));
|
|
store_int f.b ~src:rax ~mm:(Frame (fr + 8)) ~size:8;
|
|
(match f.dslotv with
|
|
| Some sv -> lea f.b ~dst:rax ~mm:(Frame sv)
|
|
| None -> xor_rr f.b ~dst:rax ~src:rax);
|
|
store_int f.b ~src:rax ~mm:(Frame (fr + 16)) ~size:8;
|
|
lea f.b ~dst:rax ~mm:(Frame fr);
|
|
store_int f.b ~src:rax ~mm:(lmem f head ~scratch:r11) ~size:8;
|
|
(* The parameters are bound before the body starts, so they are recorded
|
|
here rather than at a binding site there is none of. *)
|
|
List.iteri (fun i _ -> bind_slot f i) fn.Tast.params);
|
|
(* 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;
|
|
if ann then set_ind f.b "";
|
|
note f
|
|
"The transfer exit — spec-conditions.md §5. A transfer that found no restart-case \
|
|
in this frame leaves the way a return does, which is what runs the defers.";
|
|
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;
|
|
(* And if [f.unwound] is false there is nothing to emit: the defers on the
|
|
transfer exit are dead because no path names that exit. This used to be a
|
|
refusal, on the theory that a function with a defer and no transfer exit
|
|
was a sign the reasoning had gone wrong. It is not — it is every leaf
|
|
function with a defer, and [spike/x86/p9-dead-defers.flan] is ten lines
|
|
of it. [emit.ml]'s [emit_fn] writes the whole exit under the same
|
|
[if f.unwound], and so drops them too.
|
|
|
|
What makes the drop safe is that [unwound] is not an approximation.
|
|
Every site that can leave a transfer in the channel and keep going either
|
|
emits [guard] — [Signal], [bounds_call], the two [rt_signals] entry
|
|
points, and every call by name or by pointer — or jumps to [current_pad]
|
|
outright, which is [invoke-restart] and the three re-propagating pads. So
|
|
[unwound] is false exactly when no transfer can arrive. A function whose
|
|
every call sits inside a [restart-case] is not a counterexample: the
|
|
guard sets that pad's [used], the pad is emitted, and its tail
|
|
re-propagates through [current_pad] with the pad stack already popped. *)
|
|
|
|
(* The prologue, now that the frame size is known. *)
|
|
let pb = create () in
|
|
bnote ann pb
|
|
"The prologue: save rbp, take the frame in one sub, and spill every incoming \
|
|
register into its slot. rsp is written here and by leave and nowhere else, so rsp \
|
|
% 16 == 0 at every call site below is a property of that one rounded sub rather \
|
|
than an invariant each case has to keep.";
|
|
push_r pb rbp;
|
|
if cfi then cfi_after_push pb;
|
|
mov_rr pb ~dst:rbp ~src:rsp;
|
|
if cfi then cfi_after_mov pb;
|
|
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. *)
|
|
if ann then set_ind f.b "";
|
|
note f
|
|
"The epilogue, and every return and every transfer out of this frame arrives here, \
|
|
so the frame is torn down once.";
|
|
lbl f.b f.retlbl;
|
|
(* The shadow stack's pop, and it is one store because this backend has one
|
|
epilogue: a [return], the fall through the body's tail, and the transfer
|
|
exit all arrive at this label, so the head is restored on the unwinding
|
|
path as well as on the normal one. [emit.ml] needs the same restore at
|
|
five separate [ret]s and routes them through its [ret] for exactly that
|
|
reason — a pop written only on the normal path leaves a dead frame behind
|
|
every handled condition, and the next backtrace is a lie.
|
|
|
|
Before the return value is loaded, because it is loaded into rax. *)
|
|
(match f.dframe with
|
|
| None -> ()
|
|
| Some fr ->
|
|
load_int f.b ~dst:rax ~mm:(Frame fr) ~size:8 ~signed:false;
|
|
store_int f.b ~src:rax
|
|
~mm:(lmem f (sym_loc f "flan_frame_head") ~scratch:r11) ~size:8);
|
|
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;
|
|
if cfi then cfi_after_leave f.b;
|
|
ret f.b;
|
|
flush pb;
|
|
flush f.b;
|
|
let sym = fsym fn.Tast.name in
|
|
let out = Buffer.create 1024 in
|
|
if ann then
|
|
Buffer.add_string out
|
|
(frame_map md fn ~slots:f.slots ~fixed ~total:(frame_bytes f)
|
|
~outgoing:f.outgoing ~xfer_off:f.xfer_off ~sret_off:f.sret_off
|
|
~retval:f.retval ~dframe:f.dframe ~dslotv:f.dslotv ~sret ~sret_at
|
|
~param_at ~xfer_at);
|
|
Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym);
|
|
(* [emit.ml:2072] says this is load-bearing and it is: default visibility in
|
|
a shared object is interposable, and that applies to taking the address
|
|
too, so a plain reference from inside a redefinition module would resolve
|
|
to the *host's* copy and the module would install the very body it is
|
|
replacing. Only a module's own bodies are hidden; a whole program emits
|
|
none. *)
|
|
if hidden then Buffer.add_string out (Printf.sprintf "\t.hidden\t%s\n" sym);
|
|
Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym);
|
|
Buffer.add_string out (sym ^ ":\n");
|
|
if cfi then Buffer.add_string out "\t.cfi_startproc\n";
|
|
Buffer.add_string out (Buffer.contents pb.out);
|
|
Buffer.add_string out (Buffer.contents f.b.out);
|
|
(* One past the last byte, which is what [DW_AT_high_pc] and the line
|
|
table's closing [DW_LNE_end_sequence] both want. [.size]'s [. - sym] says
|
|
the same thing but is an expression rather than a symbol, and
|
|
[DW_FORM_addr] takes a symbol. *)
|
|
(match sub with
|
|
| Some s -> Buffer.add_string out (s.send ^ ":\n")
|
|
| None -> ());
|
|
(match dw with Some d -> d.dcur <- None | None -> ());
|
|
if cfi then Buffer.add_string out "\t.cfi_endproc\n";
|
|
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
|
|
Buffer.contents out, Buffer.contents f.rodata
|
|
|
|
(* Two functions, because the two halves run at different times and have to.
|
|
|
|
[data_sym] is the constant image: the values [emit.ml] writes into the
|
|
object and this backend has no folder for, so it writes them as stores. They
|
|
are data, they depend on nothing, and they have to be there even in a build
|
|
with no [main] — a C host that brings its own entry point still finds the
|
|
globals it was linked against — so this one stays a .init_array
|
|
constructor. That is the only thing .init_array is still used for here, and
|
|
it is the honest use of it: it is standing in for the other backend's
|
|
object image, not for a program.
|
|
|
|
[init_sym] is the computed initialisers, and it is called from [main]. It
|
|
carries the same name as [emit.ml]'s startup function because it is the
|
|
same function, and it moved out of .init_array for the reason given there:
|
|
the runtime has to be up before an initialiser runs, or a global computed
|
|
from [args] would answer differently on the two backends, and a rule that
|
|
holds on one backend and not the other is not a rule.
|
|
|
|
What used to be here beside them is the walk that refused a [signal] or a
|
|
restart inside an initialiser. It is [Check.no_transfer_in_init] now: it was
|
|
this backend's rule only while this was the only backend that ran
|
|
initialisers, and a refusal that is about the language belongs where both
|
|
backends meet it. *)
|
|
let data_sym = "\"flan..init-data\""
|
|
let init_sym = "\"flan..init-globals\""
|
|
|
|
(* ── 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 ?(cfi = false) ?(ann = false) ?(startup = false) (md : Emit.m)
|
|
(fn : Tast.fn) =
|
|
let b = create () in
|
|
bnote ann b
|
|
"C's main, which is the whole of the adapter between the loader and a Flan program. \
|
|
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, so flan.main is called exactly the way every other Flan function \
|
|
is; and the exit goes through flan_exit rather than ret, because stdout is a FILE* \
|
|
and something has to flush it. The ud2 at the end is unreachable — flan_exit does \
|
|
not return.";
|
|
push_r b rbp;
|
|
if cfi then cfi_after_push b;
|
|
mov_rr b ~dst:rbp ~src:rsp;
|
|
if cfi then cfi_after_mov b;
|
|
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";
|
|
(* The computed globals, after the runtime is up and before a line of the
|
|
program's own code — [emit.ml]'s [emit_startup] says why this is a call
|
|
from here rather than a second constructor. It takes no channel: no caller
|
|
can hand it one, so it owns a null cell of its own. *)
|
|
if startup then call_sym b init_sym;
|
|
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";
|
|
(* No [.cfi_def_cfa 7, 8] to close with, because this one has no epilogue:
|
|
it leaves through [flan_exit] and the [ud2] after that is unreachable.
|
|
The rbp rule therefore holds to the last byte, which is what a backtrace
|
|
out of anything [main] called needs. *)
|
|
if cfi then Buffer.add_string out "\t.cfi_startproc\n";
|
|
Buffer.add_string out (Buffer.contents b.out);
|
|
if cfi then Buffer.add_string out "\t.cfi_endproc\n";
|
|
Buffer.add_string out "\t.size\tmain, . - main\n\n";
|
|
Buffer.contents out
|
|
|
|
(* ── Globals ─────────────────────────────────────────────────────────── *)
|
|
|
|
(* Every global is a zeroed object and a store that fills it in. [emit.ml]
|
|
folds a constant 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 emit_globals_init ?(cfi = false) ?(ann = false) ~sym (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;
|
|
dframe = None; dslotv = None; snames = [||];
|
|
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
|
|
xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 64; externs; fns; ext = (fun _ -> false);
|
|
slot = (fun _ -> None); dw = None; ann; adepth = 0; alast = "" }
|
|
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 has established a handler or a restart by the time either of
|
|
these runs — one of them is a constructor and the other is the first call
|
|
[main] makes — so a transfer out of an initialiser has nowhere to go and
|
|
the checker refuses one by name. 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;
|
|
if cfi then cfi_after_push pb;
|
|
mov_rr pb ~dst:rbp ~src:rsp;
|
|
if cfi then cfi_after_mov pb;
|
|
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;
|
|
if cfi then cfi_after_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" sym sym);
|
|
if cfi then Buffer.add_string out "\t.cfi_startproc\n";
|
|
Buffer.add_string out (Buffer.contents pb.out);
|
|
Buffer.add_string out (Buffer.contents f.b.out);
|
|
if cfi then Buffer.add_string out "\t.cfi_endproc\n";
|
|
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
|
|
Buffer.contents out, Buffer.contents f.rodata
|
|
|
|
(* ── The program ─────────────────────────────────────────────────────── *)
|
|
|
|
(* One cell per function, initialised to the body this build compiled, and
|
|
[.globl] so that a redefinition module can bind to it. Nothing has been
|
|
redefined yet when the program starts, so a dev build begins by behaving
|
|
exactly like a release one — the indirection is the only difference, and
|
|
that is what makes the whole corpus a test of it.
|
|
|
|
[.data] and not [.bss]: the initialiser is a relocation against the body,
|
|
not a zero. Default visibility, because interposition is the point here;
|
|
only a redefined *body* is hidden, and this backend emits none.
|
|
|
|
What is not here is [Emit.cellptr] — the second, deeper spelling for a name
|
|
the host was never built with. It cannot arise in a whole-program build,
|
|
where [known] is true of everything, and it belongs with the redefinition
|
|
module that would introduce such a name. *)
|
|
let emit_cells (p : Tast.program) =
|
|
let out = Buffer.create 256 in
|
|
Buffer.add_string out "\t.data\n";
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
let c = csym fn.Tast.name in
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.globl\t%s\n\t.align\t8\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, 8\n%s:\n\t.quad\t%s\n"
|
|
c c c c (fsym fn.Tast.name)))
|
|
p.Tast.fns;
|
|
Buffer.contents out
|
|
|
|
(* ── The DWARF sections ──────────────────────────────────────────────── *)
|
|
|
|
(* A path inside an assembler string literal. Flan source paths contain
|
|
neither of these two characters in practice, but a path is user input and
|
|
a stray backslash would end the directive rather than the string. *)
|
|
let asm_str s =
|
|
let b = Buffer.create (String.length s + 8) in
|
|
String.iter
|
|
(fun c ->
|
|
if c = '"' || c = '\\' then Buffer.add_char b '\\';
|
|
Buffer.add_char b c)
|
|
s;
|
|
Buffer.contents b
|
|
|
|
(* Absolute, because the file table below gives every entry directory index 0
|
|
and a debugger then reads the name as written. [emit.ml]'s [dfile] splits
|
|
the same absolute path into a [!DIFile]'s filename and directory; DWARF is
|
|
happy with either and one string is fewer moving parts. *)
|
|
let abspath p =
|
|
if Filename.is_relative p then Filename.concat (Sys.getcwd ()) p else p
|
|
|
|
(* [DW_LNE_set_address] on a label: the escape opcode, a length of 9, the
|
|
sub-opcode, and eight bytes of address the assembler relocates.
|
|
|
|
Every row gets one of these rather than a [DW_LNS_advance_pc] with a
|
|
computed delta, and the reason is that a delta would be a difference of two
|
|
labels inside a [.uleb128], which asks the assembler to resolve a value
|
|
whose size affects the values after it. That does work, but it is exactly
|
|
the kind of thing whose failure looks like a DWARF bug. Rows are eleven
|
|
bytes each here and that is a debug build's business. *)
|
|
let dw_set_address b lbl =
|
|
Buffer.add_string b (Printf.sprintf "\t.byte\t0, 9, 2\n\t.quad\t%s\n" lbl)
|
|
|
|
(* The line-number program: one sequence per function, closed with an
|
|
end_sequence at the label one past its last byte. The registers are reset
|
|
at the head of every sequence, which is why [line] starts at 1 and [file]
|
|
at 1 in each. Rows within a sequence must be address-ordered, and they are
|
|
for free: [dwline] appends them in the order the bytes are emitted. *)
|
|
let dw_line_program (dw : dwarf) =
|
|
let b = Buffer.create 4096 in
|
|
List.iter
|
|
(fun s ->
|
|
let line = ref 1 and file = ref 1 and col = ref 0 in
|
|
List.iter
|
|
(fun r ->
|
|
dw_set_address b r.rlbl;
|
|
if r.rfile <> !file then begin
|
|
Buffer.add_string b
|
|
(Printf.sprintf "\t.byte\t4\n\t.uleb128 %d\n" r.rfile);
|
|
file := r.rfile
|
|
end;
|
|
if r.rcol <> !col then begin
|
|
Buffer.add_string b
|
|
(Printf.sprintf "\t.byte\t5\n\t.uleb128 %d\n" r.rcol);
|
|
col := r.rcol
|
|
end;
|
|
if r.rline <> !line then begin
|
|
Buffer.add_string b
|
|
(Printf.sprintf "\t.byte\t3\n\t.sleb128 %d\n" (r.rline - !line));
|
|
line := r.rline
|
|
end;
|
|
Buffer.add_string b "\t.byte\t1\n")
|
|
(List.rev s.srows);
|
|
dw_set_address b s.send;
|
|
Buffer.add_string b "\t.byte\t0, 1, 1\n")
|
|
(List.rev dw.dsubs);
|
|
Buffer.contents b
|
|
|
|
(* The three sections. [tbeg] and [tend] bracket everything this object puts
|
|
in [.text] — the compile unit claims that whole range, including the C
|
|
[main] shim and the globals' initialiser, neither of which has any rows.
|
|
That is honest: they are code this unit produced, and a debugger that finds
|
|
no line for an address inside them says so. *)
|
|
let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend =
|
|
let out = Buffer.create 8192 in
|
|
(* The compile unit's directory, and the directory table the file entries
|
|
index into. [emit.ml]'s [dfile] splits every path into a basename and a
|
|
directory the same way, and the reason to match it is what a debugger
|
|
prints: a frame reads [debug.flan:19] rather than the eighty characters
|
|
of an absolute path. Directory index 0 is the compile unit's own
|
|
directory, so a file sitting beside the one that named the unit -- which
|
|
is most of them -- costs no entry at all. *)
|
|
let cudir = Filename.dirname (abspath cufile) in
|
|
let dirs = ref [] in
|
|
let dirix d =
|
|
if String.equal d cudir then 0
|
|
else
|
|
match List.assoc_opt d !dirs with
|
|
| Some n -> n
|
|
| None ->
|
|
let n = List.length !dirs + 1 in
|
|
dirs := !dirs @ [ (d, n) ];
|
|
n
|
|
in
|
|
let files =
|
|
List.map
|
|
(fun p ->
|
|
let a = abspath p in
|
|
(Filename.basename a, dirix (Filename.dirname a)))
|
|
(List.rev dw.dpaths)
|
|
in
|
|
Buffer.add_string out
|
|
"\n# Debug information. Written out as data rather than left to the\n\
|
|
# assembler's .loc, which cannot work here: GAS builds its line table\n\
|
|
# when it assembles an instruction, and this file assembles none.\n";
|
|
(* .debug_abbrev. Two abbreviations, because two shapes of DIE are all that
|
|
is described. *)
|
|
Buffer.add_string out
|
|
"\t.section\t.debug_abbrev,\"\",@progbits\n\
|
|
.Ldwabbrev:\n\
|
|
\t.uleb128 1\n\
|
|
\t.uleb128 0x11\t\t# DW_TAG_compile_unit\n\
|
|
\t.byte\t1\t\t# has children\n\
|
|
\t.uleb128 0x25\n\t.uleb128 0x08\t# DW_AT_producer DW_FORM_string\n\
|
|
\t.uleb128 0x13\n\t.uleb128 0x05\t# DW_AT_language DW_FORM_data2\n\
|
|
\t.uleb128 0x03\n\t.uleb128 0x08\t# DW_AT_name DW_FORM_string\n\
|
|
\t.uleb128 0x1b\n\t.uleb128 0x08\t# DW_AT_comp_dir DW_FORM_string\n\
|
|
\t.uleb128 0x11\n\t.uleb128 0x01\t# DW_AT_low_pc DW_FORM_addr\n\
|
|
\t.uleb128 0x12\n\t.uleb128 0x07\t# DW_AT_high_pc DW_FORM_data8\n\
|
|
\t.uleb128 0x10\n\t.uleb128 0x17\t# DW_AT_stmt_list DW_FORM_sec_offset\n\
|
|
\t.byte\t0, 0\n\
|
|
\t.uleb128 2\n\
|
|
\t.uleb128 0x2e\t\t# DW_TAG_subprogram\n\
|
|
\t.byte\t0\t\t# no children\n\
|
|
\t.uleb128 0x3f\n\t.uleb128 0x19\t# DW_AT_external DW_FORM_flag_present\n\
|
|
\t.uleb128 0x03\n\t.uleb128 0x08\t# DW_AT_name DW_FORM_string\n\
|
|
\t.uleb128 0x6e\n\t.uleb128 0x08\t# DW_AT_linkage_name DW_FORM_string\n\
|
|
\t.uleb128 0x3a\n\t.uleb128 0x0f\t# DW_AT_decl_file DW_FORM_udata\n\
|
|
\t.uleb128 0x3b\n\t.uleb128 0x0f\t# DW_AT_decl_line DW_FORM_udata\n\
|
|
\t.uleb128 0x11\n\t.uleb128 0x01\t# DW_AT_low_pc DW_FORM_addr\n\
|
|
\t.uleb128 0x12\n\t.uleb128 0x07\t# DW_AT_high_pc DW_FORM_data8\n\
|
|
\t.byte\t0, 0\n\
|
|
\t.byte\t0\n";
|
|
(* .debug_info. DW_LANG_C99 for [emit.ml]'s reason: it is less a claim about
|
|
the source language than the truth about the data model, and it is what
|
|
makes a debugger's own struct printing correct against this layout. *)
|
|
Buffer.add_string out
|
|
(Printf.sprintf
|
|
"\t.section\t.debug_info,\"\",@progbits\n\
|
|
.Ldwinfo:\n\
|
|
\t.long\t.Ldwinfo_end - .Ldwinfo_ver\n\
|
|
.Ldwinfo_ver:\n\
|
|
\t.short\t4\n\
|
|
\t.long\t.Ldwabbrev\n\
|
|
\t.byte\t8\n\
|
|
\t.uleb128 1\n\
|
|
\t.asciz\t\"flan (x86-64)\"\n\
|
|
\t.short\t0x000c\t\t# DW_LANG_C99\n\
|
|
\t.asciz\t\"%s\"\n\
|
|
\t.asciz\t\"%s\"\n\
|
|
\t.quad\t%s\n\
|
|
\t.quad\t%s - %s\n\
|
|
\t.long\t.Ldwline\n"
|
|
(asm_str (Filename.basename (abspath cufile)))
|
|
(asm_str cudir)
|
|
tbeg tend tbeg);
|
|
List.iter
|
|
(fun s ->
|
|
Buffer.add_string out
|
|
(Printf.sprintf
|
|
"\t.uleb128 2\n\t.asciz\t\"%s\"\n\t.asciz\t\"%s\"\n\
|
|
\t.uleb128 %d\n\t.uleb128 %d\n\t.quad\t%s\n\t.quad\t%s - %s\n"
|
|
(asm_str s.sname)
|
|
(asm_str ("flan." ^ s.sname))
|
|
s.sfile s.sline s.ssym s.send s.ssym))
|
|
(List.rev dw.dsubs);
|
|
Buffer.add_string out "\t.byte\t0\n.Ldwinfo_end:\n";
|
|
(* .debug_line. The standard opcode lengths are the standard ones; changing
|
|
them would change nothing, since every row below is spelled out of the
|
|
three opcodes this emitter uses and never out of a special opcode. *)
|
|
Buffer.add_string out
|
|
"\t.section\t.debug_line,\"\",@progbits\n\
|
|
.Ldwline:\n\
|
|
\t.long\t.Ldwline_end - .Ldwline_ver\n\
|
|
.Ldwline_ver:\n\
|
|
\t.short\t4\n\
|
|
\t.long\t.Ldwline_prog - .Ldwline_hdr\n\
|
|
.Ldwline_hdr:\n\
|
|
\t.byte\t1\t\t# minimum_instruction_length\n\
|
|
\t.byte\t1\t\t# maximum_operations_per_instruction\n\
|
|
\t.byte\t1\t\t# default_is_stmt\n\
|
|
\t.byte\t0xfb\t\t# line_base = -5\n\
|
|
\t.byte\t14\t\t# line_range\n\
|
|
\t.byte\t13\t\t# opcode_base\n\
|
|
\t.byte\t0,1,1,1,1,0,0,0,1,0,0,1\n";
|
|
List.iter
|
|
(fun (d, _) ->
|
|
Buffer.add_string out (Printf.sprintf "\t.asciz\t\"%s\"\n" (asm_str d)))
|
|
!dirs;
|
|
Buffer.add_string out "\t.byte\t0\t\t# end of the directory table\n";
|
|
List.iter
|
|
(fun (name, dir) ->
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.asciz\t\"%s\"\n\t.uleb128 %d\n\t.uleb128 0\n\
|
|
\t.uleb128 0\n"
|
|
(asm_str name) dir))
|
|
files;
|
|
Buffer.add_string out "\t.byte\t0\n.Ldwline_prog:\n";
|
|
Buffer.add_string out (dw_line_program dw);
|
|
Buffer.add_string out ".Ldwline_end:\n";
|
|
Buffer.contents out
|
|
|
|
(* A whole program as one assembly file. *)
|
|
let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
|
|
(p : Tast.program) : string =
|
|
let md = layout_ctx ~checks ~dev 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 dw = if debug then Some (new_dwarf ()) else None in
|
|
(* The file every diagnostic in this unit is really about: the first
|
|
function anyone actually wrote. [emit.ml]'s [new_dbg] picks it the same
|
|
way and for the same reason -- the prelude contributes functions too, and
|
|
naming the prelude as the compile unit would be true and useless. *)
|
|
let cufile =
|
|
match
|
|
List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
|
|
with
|
|
| Some f -> f.Tast.floc.Loc.file
|
|
| None -> "<unknown>"
|
|
in
|
|
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";
|
|
(* The legend, and the reason it is here rather than repeated: four of the
|
|
five things below are emitted at hundreds of sites, and a comment that
|
|
explains the transfer guard at every call site is noise by the third one.
|
|
Each is named where it appears and explained once, here. *)
|
|
if annotate then
|
|
Buffer.add_string text
|
|
"#\n\
|
|
# Annotated, because `flan emit --x86` exists to be read. Every comment\n\
|
|
# here is discarded by the assembler; the bytes are what a build emits,\n\
|
|
# unchanged and in the same order.\n\
|
|
#\n\
|
|
# How to read it\n\
|
|
#\n\
|
|
# Above each function is a frame map. Every value in this backend\n\
|
|
# lives in a frame slot, so -0x20(%rbp) is the whole vocabulary of the\n\
|
|
# listing and the map is its key: which displacement is which\n\
|
|
# parameter, which is which named local, where the compiler's own\n\
|
|
# three sit, and below which offset everything is an unnamed\n\
|
|
# temporary that later forms reuse.\n\
|
|
#\n\
|
|
# Inside a function, each run of bytes is headed by the Flan form that\n\
|
|
# produced it, with the file:line:col it was written at. Headings and\n\
|
|
# byte runs are indented by how deeply the form nests, so an\n\
|
|
# argument's code steps in and the call's steps back out.\n\
|
|
#\n\
|
|
# Literals, locals and globals are not headed: they would steal the\n\
|
|
# heading of the form that contains them, and the operand loads\n\
|
|
# belong under the operator.\n\
|
|
#\n\
|
|
# The five things the compiler adds that no form asked for\n\
|
|
#\n\
|
|
# The transfer guard. After every call to Flan code: load this\n\
|
|
# frame's channel pointer, load through it, test, and branch if it is\n\
|
|
# set. A callee that transferred wrote a frame address there and the\n\
|
|
# value in rax means nothing, so the branch goes to the innermost\n\
|
|
# restart-case, handler-bind or with-allocator landing pad, or to the\n\
|
|
# function's own transfer exit. Four instructions, touching only r11,\n\
|
|
# which is why it fits between the call and the store of the result.\n\
|
|
# spec-conditions.md §6.\n\
|
|
#\n\
|
|
# The bounds check. A compare and a not-taken branch on the fast\n\
|
|
# path; the slow path passes a location string, the index and the\n\
|
|
# length, and this frame's channel, to a runtime entry point that\n\
|
|
# signals. Because it signals rather than aborting, it is an ordinary\n\
|
|
# call with a guard after it, and the ud2 past the guard is where\n\
|
|
# nothing answered.\n\
|
|
#\n\
|
|
# The arithmetic guard, the same shape: a zero divisor, the one\n\
|
|
# overflowing division, and the range check on a float-to-integer\n\
|
|
# cast.\n\
|
|
#\n\
|
|
# rep movsb. An aggregate is copied and never aliased, so a struct\n\
|
|
# argument, a struct return and a struct assignment are each a block\n\
|
|
# copy. spec-memory.md's assignment rule.\n\
|
|
#\n\
|
|
# The indirection cell, in a --dev build only. A call by name loads\n\
|
|
# the cell first and calls through it, so that a redefinition\n\
|
|
# installed while the process runs is reached by the next call.\n\
|
|
#\n\
|
|
# What is not here are mnemonics. The bytes are a blob so that every\n\
|
|
# offset stays exactly known, and spike/x86/dump.sh puts objdump's\n\
|
|
# disassembly of this same object beside this file: that one says what,\n\
|
|
# and this one says why.\n";
|
|
(* A numbered [.file] is what stops clang's integrated assembler from
|
|
generating a compile unit of its *own* over this file -- one that names
|
|
the .s, and whose rows land at the [call] mnemonics, which are the only
|
|
real instructions here. Those addresses are inside the functions this
|
|
unit already describes, so two units would claim them. Measured: with the
|
|
directive, the assembler emits an empty line table and nothing else.
|
|
Harmless in a release build, where it is simply never emitted. *)
|
|
if debug then
|
|
Buffer.add_string text
|
|
(Printf.sprintf "\t.file\t1 \"%s\"\n" (asm_str (abspath cufile)));
|
|
(* The label the compile unit's range starts at, and it is emitted only in a
|
|
debug build so that a release build's assembly is byte-for-byte what it
|
|
was before any of this existed. *)
|
|
Buffer.add_string text
|
|
(if debug then "\t.text\n.Ldwtext:\n\n" else "\t.text\n\n");
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
let t, r = emit_fn md ~externs ~fns ~ann:annotate ?dw fn in
|
|
Buffer.add_string text t;
|
|
Buffer.add_string rodata r)
|
|
p.Tast.fns;
|
|
(* The constant image, then the computed initialisers, each into its own
|
|
function: see the two symbols' own note. The split is total —
|
|
[Tast.const_init] is what [emit.ml] asks to decide which globals it can
|
|
write into the object — so every global is written exactly once. *)
|
|
let constants, computed =
|
|
List.partition
|
|
(fun (g : Tast.global) -> Tast.const_init g.Tast.ginit)
|
|
p.Tast.globals
|
|
in
|
|
let ginit, gr =
|
|
emit_globals_init ~cfi:debug ~ann:annotate ~sym:data_sym md ~externs ~fns
|
|
constants
|
|
in
|
|
Buffer.add_string text ginit;
|
|
Buffer.add_string rodata gr;
|
|
let startup = computed <> [] in
|
|
if startup then begin
|
|
let t, r =
|
|
emit_globals_init ~cfi:debug ~ann:annotate ~sym:init_sym md ~externs ~fns
|
|
computed
|
|
in
|
|
Buffer.add_string text t;
|
|
Buffer.add_string rodata r
|
|
end;
|
|
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
|
| Some fn ->
|
|
Buffer.add_string text (emit_main ~cfi:debug ~ann:annotate ~startup md fn)
|
|
(* No [main] is not an error, and [emit.ml] treats it the same way: a
|
|
program can be linked against a C host that brings its own entry point,
|
|
which is what [reload_host.c] is. Refusing here made a --x86 host for the
|
|
reload tests impossible to build. *)
|
|
| None -> ());
|
|
(* The end of everything this object puts in .text, and therefore the end of
|
|
the compile unit's range. It has to be written while .text is still the
|
|
current section, which is why it is here and not beside the sections
|
|
below. *)
|
|
if debug then Buffer.add_string text ".Ldwtext_end:\n";
|
|
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. *)
|
|
(* [flan_dev_reg_enable] arms the allocation registry, and a dev build is the
|
|
only build that has one. A constructor rather than a line in [main] for
|
|
[emit.ml]'s reason, which that file now states in its weaker and truer
|
|
form: arming has to precede the first allocation, and a constructor is the
|
|
only slot that precedes every one of them whatever the entry point is. It
|
|
is ordered before [data_sym] here because that one allocates too, and
|
|
before [init_sym] by construction: that one is called from [main], which
|
|
every constructor precedes.
|
|
Leaving it out was the one visible difference between a `--x86 --dev`
|
|
build and an LLVM one over the whole corpus: [registry.flan] asks
|
|
[(live? ...)] and got four zeroes. *)
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.section\t.init_array,\"aw\",@init_array\n\t.align\t8\n%s\
|
|
\t.quad\t%s\n\n"
|
|
(if dev then "\t.quad\tflan_dev_reg_enable\n" else "") data_sym);
|
|
(* The ABI marker, and only in a dev build: it exists for redefinition
|
|
modules to bind against, a release build has no cells to load one into,
|
|
and gating it here is what keeps a release build's assembly byte-for-byte
|
|
what it was. [.globl] and default visibility, for the reason the cells
|
|
have them — a dlopened object has to be able to see it, which is also why
|
|
[Build.executable] passes [-rdynamic] for a dev build and nothing else. *)
|
|
if dev then
|
|
Buffer.add_string out
|
|
(Printf.sprintf
|
|
"\t.data\n\t.globl\t%s\n\t.align\t8\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, 8\n%s:\n\t.quad\t0\n\n"
|
|
(asm_sym abi_marker) (asm_sym abi_marker) (asm_sym abi_marker)
|
|
(asm_sym abi_marker));
|
|
if dev then Buffer.add_string out (emit_cells p);
|
|
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;
|
|
(match dw with
|
|
| Some d ->
|
|
Buffer.add_string out
|
|
(emit_dwarf d ~cufile ~tbeg:".Ldwtext" ~tend:".Ldwtext_end")
|
|
| None -> ());
|
|
Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
|
|
Buffer.contents out
|
|
|
|
|
|
(* -- One function into a loadable object ------------------------------ *)
|
|
|
|
(* The counterpart to [Emit.redefinition], and the reason this backend exists.
|
|
[program] above emits an executable; this emits the assembly for a [.so]
|
|
that gets dlopened into a host which is {e already running}, replacing the
|
|
body behind one or more names without restarting anything.
|
|
|
|
{b Why it cannot be [Emit.redefinition].} This file licenses its own calling
|
|
convention on the grounds that a dev build is compiled entirely here and a
|
|
release build entirely by LLVM, so the two never meet in one process. The
|
|
conventions agree on every scalar and disagree on every aggregate -- here
|
|
each goes by pointer with a hidden [sret]; LLVM classifies by eightbyte. An
|
|
[Emit.redefinition] module dlopened into an [--x86] host is therefore correct
|
|
exactly until the first redefined function takes or returns a struct. The
|
|
answer is a redefinition emitter here, not an aggregate classifier there.
|
|
|
|
{b What it does not define}, each of which [program] does and each of which
|
|
would be wrong in a module:
|
|
|
|
- no [main]: this object is loaded, not started.
|
|
- no [.init_array], so no [flan..init-data]; and no call to
|
|
[flan..init-globals], which is the other half of the same sentence now
|
|
that the computed initialisers are called from [main] instead. Rewriting a
|
|
global's storage from its initialiser would wipe the live state that
|
|
reloading exists to preserve -- sand's grid is a global and "edit the
|
|
code, keep the sand" is the whole demo.
|
|
- no [flan_dev_reg_enable] constructor: the host armed the registry when it
|
|
started.
|
|
- no [.bss] for the globals and no [.data] for the cells. Both are the
|
|
host's objects; this module names them and the loader binds them.
|
|
|
|
{b And what it must.} Every body is [.hidden] -- [emit.ml] says the same and
|
|
for the same reason, that default visibility in a shared object is
|
|
interposable. And [flan_reload_install], a named function rather than a
|
|
constructor, because the agent has to choose {e when} the swap happens: at a
|
|
frame boundary, on the game thread. [reload_host.c] and
|
|
[vendor/agent/flan_agent.c] both [dlsym] exactly that spelling.
|
|
|
|
{b A name the host was never built with.} There is no symbol to bind to and
|
|
ELF has no way to grow one, so the address is asked for by string at install
|
|
time -- [flan_dev_cell] for a function's cell, [flan_dev_global] for a
|
|
global's storage -- and parked in a slot this module defines. [Lslot] is how
|
|
every later reference reads it, and it is [Lgot]'s shape with the relocation
|
|
swapped, so no call site and no place expression had to learn a third case.
|
|
[Emit.cellptr] and [Emit.globalptr] are the same two slots on the LLVM side,
|
|
spelled the same way here so the two are readable against each other.
|
|
|
|
A new global's declared {e constant} value travels with it, because
|
|
[flan_dev_global] copies it onto the allocation the first time the name is
|
|
seen and ignores it afterwards -- which is where "a reload must not reset the
|
|
program's state" lives. [emit.ml] folds that value into an LLVM constant; it
|
|
has a folder for the IR's own syntax and this file does not. So the image is
|
|
built the way [emit_globals_init] builds a global's storage in a whole
|
|
program: a module-local buffer, written by the initialiser expression lowered
|
|
as ordinary code. A few instructions once, and no second evaluator that could
|
|
disagree with the first about what a struct literal means.
|
|
|
|
A computed initialiser sends no image at all and the allocation stays
|
|
zeroed. It is not that this module could not run one -- it could, and the
|
|
buffer above is the shape that would take. It is that an initialiser runs at
|
|
startup and a module is loaded rather than started, so a name the program is
|
|
meeting for the first time has no startup to have missed. [emit.ml] answers
|
|
it the same way.
|
|
|
|
{b The scope, and it is still narrower than [Emit.redefinition]'s.} The
|
|
transient [flan_reload_call] thunk is not built here, and is refused by name
|
|
-- this file's idiom for a case it has not earned the right to compile. *)
|
|
let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
|
?(retains = true) ?(consts = []) ?call (p : Tast.program) ~fns : string =
|
|
if not dev then
|
|
unsupported
|
|
"x86 redefinition without cells: there is nothing to publish a body \
|
|
into, and this backend's release build has no indirection";
|
|
(* A thunk this module runs itself is excluded from all of the machinery
|
|
below: [flan_reload_call] calls it directly, so it needs no cell, must not
|
|
be published into one, and must not take a registry slot -- there are 4096
|
|
of those and an expression evaluated in a loop would exhaust them.
|
|
Nothing pointing into the module is also what lets the agent unload it. *)
|
|
let transient n = call = Some n in
|
|
let target name =
|
|
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
|
|
| Some f -> f
|
|
| None -> unsupported "no such function: %s" name
|
|
in
|
|
let targets = List.map target fns in
|
|
(* A clause lifted out of a target comes with it: its body may have changed
|
|
too, and it is reached by address from inside this module rather than
|
|
through a cell. Every other lifted clause is invisible here. *)
|
|
let lifted =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
match f.Tast.fparent with
|
|
| Some q -> List.mem q fns
|
|
| None -> false)
|
|
p.Tast.fns
|
|
in
|
|
let siblings =
|
|
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
|
|
in
|
|
(* The names this module introduces, each of which gets a slot below. A
|
|
function's slot holds its cell's address and a global's holds its
|
|
storage's, so the two are the same eight bytes and differ only in what
|
|
fills them. *)
|
|
let new_fns =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
(not (known f.Tast.name)) && not (transient f.Tast.name))
|
|
siblings
|
|
and new_globals =
|
|
List.filter (fun (g : Tast.global) -> not (known g.Tast.gname))
|
|
p.Tast.globals
|
|
in
|
|
let md = layout_ctx ~checks ~dev 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 fnstbl = Hashtbl.create 64 in
|
|
List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fnstbl fn.Tast.name ())
|
|
p.Tast.fns;
|
|
(* Which symbols this object defines. Everything else -- the host's cells,
|
|
its globals, its other bodies, and every runtime entry point -- is reached
|
|
through the GOT, because a pc-relative relocation against an undefined
|
|
symbol cannot be used in a shared object at all. *)
|
|
let mine = Hashtbl.create 16 in
|
|
List.iter (fun (f : Tast.fn) -> Hashtbl.replace mine (fsym f.Tast.name) ())
|
|
(targets @ lifted);
|
|
let ext s = not (Hashtbl.mem mine s) in
|
|
(* And the third answer: a name that is nobody's symbol yet. Keyed by the
|
|
spelling the reference uses -- a function is reached through its cell, so
|
|
the key is [csym]; a global is reached by its own name, so it is [gsym].
|
|
The two can never collide, because a function and a global cannot share a
|
|
name and [gsym] and [fsym] are the same string. *)
|
|
let cellp n = asm_sym ("flan.cellp." ^ n)
|
|
and gp n = asm_sym ("flan.gp." ^ n) in
|
|
let slots = Hashtbl.create 8 in
|
|
List.iter (fun (f : Tast.fn) ->
|
|
Hashtbl.replace slots (csym f.Tast.name) (cellp f.Tast.name)) new_fns;
|
|
List.iter (fun (g : Tast.global) ->
|
|
Hashtbl.replace slots (gsym g.Tast.gname) (gp g.Tast.gname)) new_globals;
|
|
let slot s = Hashtbl.find_opt slots s in
|
|
let text = Buffer.create 8192 and rodata = Buffer.create 1024 in
|
|
Buffer.add_string text
|
|
"# Generated by flan's x86-64 backend: one or more functions, recompiled\n\
|
|
# into an object a running process can dlopen. Every symbol this file\n\
|
|
# does not define is the host's, and is reached through the GOT.\n\
|
|
\t.text\n\n";
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
let t, r = emit_fn md ~externs ~fns:fnstbl ~ext ~slot ~hidden:true f in
|
|
Buffer.add_string text t;
|
|
Buffer.add_string rodata r)
|
|
(lifted @ targets);
|
|
(* [flan_reload_install] is a function with a frame, not a run of loads and
|
|
stores, and it has to be: it calls into the runtime, and a [call] made on
|
|
an unaligned stack faults inside glibc's own [movaps] rather than anywhere
|
|
a reader would look. A prologue is what makes rsp 16-aligned at every call
|
|
below, since [frame_bytes] rounds. Its shape is [emit_globals_init]'s and
|
|
for the same reasons, down to owning a null transfer cell that no caller
|
|
hands it. *)
|
|
let ib = create () in
|
|
let f =
|
|
{ b = ib; md; fnname = "<install>"; retlbl = new_label () "install";
|
|
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
|
|
dframe = None; dslotv = None; snames = [||];
|
|
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
|
|
xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 256; externs; fns = fnstbl; ext; slot; dw = None;
|
|
ann = false; adepth = 0; alast = "" }
|
|
in
|
|
let chan = ptmp f in
|
|
f.xfer_off <- ptmp f;
|
|
f.xfer_lbl <- new_label f "ixfer";
|
|
(* A new global's initial value, written into a buffer of this module's own.
|
|
[flan_dev_global] copies it the first time the name is interned and
|
|
ignores it on every call after, so a second module mentioning the same
|
|
name cannot reset the state the reload exists to preserve. Doing it before
|
|
any lookup is deliberate: nothing outside this module can see these
|
|
buffers, so they are not a publication and the order below is still
|
|
"resolve everything, then publish".
|
|
|
|
A *computed* initialiser gets no buffer and no image: the pointer is null
|
|
and the allocation keeps calloc's zeroes. It runs at startup, and this
|
|
module is loaded rather than started -- there is no startup here to have
|
|
missed. [emit.ml] answers a new computed global the same way and for the
|
|
same reason; the value it would compute is not what a reload is for. *)
|
|
let images =
|
|
List.map
|
|
(fun (g : Tast.global) ->
|
|
let size, align = Emit.lay md g.Tast.gty in
|
|
let l =
|
|
if not (Tast.const_init g.Tast.ginit) then None
|
|
else begin
|
|
let l = rodata_label f in
|
|
scoped f (fun () -> lower f g.Tast.ginit (Lg (l, 0)));
|
|
Some l
|
|
end
|
|
in
|
|
(g, l, max 1 size, max 1 align))
|
|
new_globals
|
|
in
|
|
(* The lookups, all of them, before a single body is published. Publishing
|
|
first would expose a function whose slots are still null to anything that
|
|
called it, and here that means every call site in the host. [emit.ml] says
|
|
the same and [test_reload.ml] checks it there by grepping the IR text;
|
|
there is no text to grep on this side, so the guarantee is this loop
|
|
order and this comment. *)
|
|
let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
cstr ("flan." ^ fn.Tast.name);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_dev_cell";
|
|
store_int f.b ~src:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8)
|
|
new_fns;
|
|
List.iter
|
|
(fun ((g : Tast.global), l, size, _) ->
|
|
cstr ("flan." ^ g.Tast.gname);
|
|
movabs f.b ~dst:rsi (Int64.of_int size);
|
|
(match l with
|
|
| Some l -> lea f.b ~dst:rdx ~mm:(Sym (l, 0))
|
|
| None -> xor_rr f.b ~dst:rdx ~src:rdx);
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_dev_global";
|
|
store_int f.b ~src:rax ~mm:(Sym (gp g.Tast.gname, 0)) ~size:8)
|
|
images;
|
|
(* A [defconst] whose value the checker never folded is just bytes in the
|
|
program's memory, so a new value is published the same way a new body is:
|
|
one store, at the frame boundary the agent chose. One the checker did fold
|
|
is in the shape of the program and never gets here -- the session refuses
|
|
it before it asks for a module. *)
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
if List.exists (String.equal g.Tast.gname) consts then
|
|
scoped f (fun () -> lower f g.Tast.ginit (sym_loc f (gsym g.Tast.gname))))
|
|
p.Tast.globals;
|
|
(* And now the bodies. A name the host has is published into its cell, whose
|
|
address comes out of the GOT because the cell lives in the host; a name it
|
|
does not is published through the slot the lookup above filled. Either way
|
|
the body is this module's own and hidden, so its address is an ordinary
|
|
pc-relative [lea]. *)
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
if transient fn.Tast.name then ()
|
|
else begin
|
|
if known fn.Tast.name then
|
|
load_int f.b ~dst:rax ~mm:(Got (csym fn.Tast.name)) ~size:8
|
|
~signed:false
|
|
else
|
|
load_int f.b ~dst:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8
|
|
~signed:false;
|
|
lea f.b ~dst:r11 ~mm:(Sym (fsym fn.Tast.name, 0));
|
|
store_int f.b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8
|
|
end)
|
|
targets;
|
|
(* Nothing a constant initialiser can do transfers, so this exit is
|
|
unreachable and is emitted only when something claims to aim at 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;
|
|
xor_rr pb ~dst:rax ~src:rax;
|
|
store_int pb ~src:rax ~mm:(Frame chan) ~size:8;
|
|
lea pb ~dst:rax ~mm:(Frame chan);
|
|
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;
|
|
Buffer.add_string text
|
|
"\t.globl\tflan_reload_install\n\
|
|
\t.type\tflan_reload_install, @function\n\
|
|
flan_reload_install:\n";
|
|
Buffer.add_buffer text pb.out;
|
|
Buffer.add_buffer text f.b.out;
|
|
Buffer.add_string text
|
|
"\t.size\tflan_reload_install, . - flan_reload_install\n\n";
|
|
(* An expression evaluation compiles to a function with nowhere to be called
|
|
from, so the module says so and the agent runs it once -- after the
|
|
install, on the game thread, so it sees both the bodies this module just
|
|
published and a program state the program agrees is consistent.
|
|
|
|
The thunk takes no parameter but the transfer channel, and no caller hands
|
|
this wrapper one, so it owns a null cell on its own frame exactly as
|
|
[emit_main] does. Sixteen bytes rather than eight keeps rsp 16-aligned at
|
|
the call, which is the whole of what the ABI asks of a frame that makes
|
|
one. *)
|
|
(match call with
|
|
| None -> ()
|
|
| Some fn ->
|
|
let cb = create () in
|
|
push_r cb rbp;
|
|
mov_rr cb ~dst:rbp ~src:rsp;
|
|
sub_imm cb ~dst:rsp 16;
|
|
xor_rr cb ~dst:rax ~src:rax;
|
|
store_int cb ~src:rax ~mm:(Frame (-8)) ~size:8;
|
|
lea cb ~dst:rdi ~mm:(Frame (-8));
|
|
xor_rr cb ~dst:rax ~src:rax;
|
|
call_sym cb (fsym fn);
|
|
leave cb;
|
|
ret cb;
|
|
flush cb;
|
|
Buffer.add_string text
|
|
"\t.globl\tflan_reload_call\n\
|
|
\t.type\tflan_reload_call, @function\n\
|
|
flan_reload_call:\n";
|
|
Buffer.add_buffer text cb.out;
|
|
Buffer.add_string text
|
|
"\t.size\tflan_reload_call, . - flan_reload_call\n\n");
|
|
Buffer.add_buffer rodata f.rodata;
|
|
let out = Buffer.create 8192 in
|
|
Buffer.add_buffer out text;
|
|
(* The slots, and the buffers holding a new global's initial value. Both are
|
|
this module's own and neither is [.globl]: a second module introducing the
|
|
same name gets its own slot and fills it from the registry with the same
|
|
answer, which is exactly what makes two modules agree about a name that
|
|
has no symbol. [.bss], because every one of them is written before it is
|
|
read -- the slots by the lookups above, the images by the initialisers. *)
|
|
if new_fns <> [] || new_globals <> [] then begin
|
|
Buffer.add_string out "\n\t.bss\n";
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.align\t8\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, 8\n%s:\n\t.zero\t8\n"
|
|
(cellp fn.Tast.name) (cellp fn.Tast.name) (cellp fn.Tast.name)))
|
|
new_fns;
|
|
List.iter
|
|
(fun ((g : Tast.global), l, size, align) ->
|
|
let s = gp g.Tast.gname in
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.align\t8\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, 8\n%s:\n\t.zero\t8\n"
|
|
s s s);
|
|
(* No image where there is no initial value to copy: a computed
|
|
initialiser sends a null and the allocation stays zeroed. *)
|
|
match l with
|
|
| None -> ()
|
|
| Some l ->
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.align\t%d\n%s:\n\t.zero\t%d\n" align l size))
|
|
images
|
|
end;
|
|
(* The ABI marker this module requires of its host. A pointer-sized datum
|
|
holding the host's marker is a relocation the loader has to resolve while
|
|
it maps the object, whatever it does about lazy binding of calls, so a
|
|
host that does not define [flan.abi.x86] fails the [dlopen] outright. A
|
|
call would do as well under [RTLD_NOW], which is what both loaders here
|
|
pass, but a datum does not depend on that and costs eight bytes.
|
|
|
|
The label is local: nothing outside this module names it, and only the
|
|
relocation against the marker matters. *)
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\n\t.data\n\t.align\t8\n%s:\n\t.quad\t%s\n"
|
|
(asm_sym "flan.abi.require") (asm_sym abi_marker));
|
|
(* Nothing outside this module refers to anything in it once the call has
|
|
returned -- no cell holds an address in its text, the registry has no slot
|
|
for it, and the value it produced was copied out. So it says so, and the
|
|
agent [dlclose]s it. A module that publishes a body can never say this:
|
|
its whole purpose is to leave a pointer behind.
|
|
|
|
[nstr = 0] is the third condition and it is about data, not text. A string
|
|
literal is emitted into this module's own image, and an expression may
|
|
store one anywhere it likes -- [(set msg "tuned")] on a string global
|
|
leaves that global pointing into the mapping the agent is about to drop.
|
|
The next thunk can be mapped at the same address, so the result is silent
|
|
garbage rather than a fault. A module with no string constants has nothing
|
|
in its image anyone could still be pointing at; one with any keeps its
|
|
mapping, which costs a page and is the same bargain every redefinition
|
|
already makes. [string_const] is where the count is kept, and the install
|
|
function's own registry names go through it too -- which is right rather
|
|
than incidental, since a module that interned a name left something
|
|
behind. *)
|
|
(match call with
|
|
| Some fn
|
|
when fns = [ fn ] && consts = []
|
|
&& ((not retains) || md.Emit.nstr = 0) ->
|
|
Buffer.add_string out
|
|
"\n\t.data\n\t.globl\tflan_reload_transient\n\
|
|
\t.type\tflan_reload_transient, @object\n\
|
|
\t.size\tflan_reload_transient, 1\n\
|
|
flan_reload_transient:\n\t.byte\t1\n"
|
|
| _ -> ());
|
|
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
|