Joseph Ferano
6cc94e00d6
The name freed up by the rename now means what C means by it: the members overlay one storage, the size is the largest of them, the alignment the strictest, and nothing anywhere records which one was written. It serves two things that wanted it. Binding a C header means holding the union the library holds and reading whichever member the library's own tag says is live -- a tag Flan cannot see, because the rule relating them is prose in a manual. Overlaying an f32 on a u32 to look at its bits is the other, and it is the same read. So that read is defined rather than refused. This is the one place in the checker where bytes win over safety on purpose, and the alternative was not a safer language, it was no feature: type punning *is* reading the member that was not written. The promise is the one C's implementations make and C's standard does not -- the layout is the target's, the bytes are the bytes, a read is a reinterpretation of them -- and what is not promised is anything about bytes nobody wrote, where a member wider than the one last stored reads a tail that is indeterminate exactly as a struct's padding is. ZII narrows that to almost nothing: a union starts all-bytes-zero unless uninit says otherwise. uninit on one is allowed, unlike on a defdata. The refusal there was never about garbage; it is that a tag steers, and a tag no case names falls past every comparison in a match into a block LLVM may treat as unreachable. An untagged union steers nothing. Which is also why three things are refused, each for a reason that does not expire with a milestone. No move-only member: nothing knows which member is live, so nothing can tear one down, and unlike the struct and defdata refusals this is not waiting on recursive teardown -- there is no fact for teardown to read. No bool at any depth: an i1 loaded from a byte that is neither 0 nor 1 is a value the optimiser may assume cannot exist, and a union is the only type that can produce one. No defdata at any depth, for the reason uninit gives, arriving the other way round. An Option member is fine and the walk says why: its match is a tag test and a branch, not a chain with an unreachable tail. Two members in one literal, a match on a union, a union map key and a member written into a global initialiser are each refused by name. A union is a field list whose every offset is zero, so it travels as a Tast.structure and the checker, the emitter and the x86 backend each grow one table rather than one shape. A value is a zeroed temporary and a store -- Set over Pfield, which every backend already has -- so there is no new IR node and no layout rule spelled out a second time per backend. The LLVM type is the blob clang gives a union, the DWARF is DW_TAG_union_type with every member at zero, and the printer names the type and does not walk it: it cannot know which member is live, and one of them may be a pointer. cimport can now check what it could not. A C record holding a union member was not recorded at all, so the defstruct beside it went unchecked rather than checked wrongly; a named union member resolves to a defunion now and the whole record is compared field by field. The defunion itself is compared against the header's union as a set and not in order -- every member is at offset zero, so a permuted one is the same type and reporting it would be a finding that is not one -- while a member the header has and Flan lacks is reported, because that is what changes the size. A defunion against a C struct, or a defstruct against a C union, is reported in both directions. An anonymous union member is still skipped, and the comment now says that the gap is on the Flan side: there is nothing to declare.
4233 lines
192 KiB
OCaml
4233 lines
192 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 sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n
|
|
let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n
|
|
|
|
let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst
|
|
let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst
|
|
let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a
|
|
|
|
(* cqo then idiv, or xor rdx,rdx then div: the sign of the operands decides
|
|
which pair, and getting that wrong is a wrong answer rather than a fault. *)
|
|
let cqo b = u8 b 0x48; u8 b 0x99
|
|
let idiv_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:7 ~m:src
|
|
let div_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:6 ~m:src
|
|
|
|
(* Shifts by cl. The count is masked to the operand width by the hardware,
|
|
which is the rule the language already defines (item 15's audit). *)
|
|
let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
|
|
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
|
|
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
|
|
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
|
|
|
|
let setcc b ~cc ~dst =
|
|
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
|
|
u8 b 0x0f; u8 b (0x90 lor cc); modrm_r b ~r:0 ~m:dst
|
|
|
|
let movzx8 b ~dst ~src =
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xb6; modrm_r b ~r:dst ~m:src
|
|
|
|
let jmp_lbl b l = u8 b 0xe9; dir b (Printf.sprintf ".long %s - . - 4" l) 4
|
|
let jcc_lbl b ~cc l = u8 b 0x0f; u8 b (0x80 lor cc); dir b (Printf.sprintf ".long %s - . - 4" l) 4
|
|
|
|
let call_sym b s = flush b; dir b (Printf.sprintf "call %s" s) 5
|
|
let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm_r b ~r:2 ~m:r
|
|
let leave b = u8 b 0xc9
|
|
let ret b = u8 b 0xc3
|
|
let ud2 b = u8 b 0x0f; u8 b 0x0b
|
|
let push_r b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7))
|
|
|
|
(* rep movsb: rdi, rsi, rcx. Nothing is ever live in a register across a
|
|
statement here, so the crudest block copy in the instruction set is also
|
|
the correct one, and a struct assignment *is* the copy spec-memory.md
|
|
requires. *)
|
|
let rep_movsb b = u8 b 0xf3; u8 b 0xa4
|
|
let rep_stosb b = u8 b 0xf3; u8 b 0xaa
|
|
|
|
(* ── SSE ─────────────────────────────────────────────────────────────── *)
|
|
|
|
let sse_rm b ~pfx ~op ~r ~mm = mem_op b ~r ~op:[ 0x0f; op ] ~w:false ~pfx:[ pfx ] ~mm
|
|
let sse_rr b ~pfx ~op ~r ~m =
|
|
u8 b pfx; rex b ~w:false ~r ~x:0 ~m; u8 b 0x0f; u8 b op; modrm_r b ~r ~m
|
|
|
|
let movsd_load b ~dst ~mm = sse_rm b ~pfx:0xf2 ~op:0x10 ~r:dst ~mm
|
|
let movsd_store b ~src ~mm = sse_rm b ~pfx:0xf2 ~op:0x11 ~r:src ~mm
|
|
let movss_load b ~dst ~mm = sse_rm b ~pfx:0xf3 ~op:0x10 ~r:dst ~mm
|
|
let movss_store b ~src ~mm = sse_rm b ~pfx:0xf3 ~op:0x11 ~r:src ~mm
|
|
|
|
let fload b ~dst ~mm ~f64 = if f64 then movsd_load b ~dst ~mm else movss_load b ~dst ~mm
|
|
let fstore b ~src ~mm ~f64 = if f64 then movsd_store b ~src ~mm else movss_store b ~src ~mm
|
|
|
|
let farith b ~op ~f64 ~dst ~src = sse_rr b ~pfx:(if f64 then 0xf2 else 0xf3) ~op ~r:dst ~m:src
|
|
let ucomis b ~f64 ~a ~c =
|
|
if f64 then u8 b 0x66;
|
|
rex b ~w:false ~r:a ~x:0 ~m:c; u8 b 0x0f; u8 b 0x2e; modrm_r b ~r:a ~m:c
|
|
|
|
(* Conversions. REX.W selects the 64-bit integer side in each direction. *)
|
|
let cvtsi2f b ~f64 ~dst ~src =
|
|
u8 b (if f64 then 0xf2 else 0xf3);
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2a; modrm_r b ~r:dst ~m:src
|
|
|
|
let cvttf2si b ~f64 ~dst ~src =
|
|
u8 b (if f64 then 0xf2 else 0xf3);
|
|
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2c; modrm_r b ~r:dst ~m:src
|
|
|
|
let cvtsd2ss b ~dst ~src = sse_rr b ~pfx:0xf2 ~op:0x5a ~r:dst ~m:src
|
|
let cvtss2sd b ~dst ~src = sse_rr b ~pfx:0xf3 ~op:0x5a ~r:dst ~m:src
|
|
let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modrm_r b ~r:dst ~m:dst
|
|
|
|
(* ── Types ───────────────────────────────────────────────────────────── *)
|
|
|
|
(* [Emit.m] carries the struct and 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;
|
|
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions;
|
|
globals = Hashtbl.create 1; 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.Handle _ | Types.Fn _ -> false
|
|
| Types.Unit | Types.Never -> false
|
|
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
|
|
| Types.Pool _ | Types.Option _ | Types.Named _ -> true
|
|
| Types.Var v -> unsupported "type variable %s" v
|
|
|
|
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
|
|
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false
|
|
let f64_of (t : Types.t) = match t with Types.Float Types.F32 -> false | _ -> true
|
|
|
|
(* Signedness for a load and for a comparison. A pointer, a handle and an enum
|
|
are each unsigned machine words; [bool] is a zero-extended byte. *)
|
|
let signed_of (t : Types.t) =
|
|
match t with
|
|
| Types.Int k -> Types.signed k
|
|
| Types.Enum _ -> true
|
|
| _ -> false
|
|
|
|
(* ── Mangling ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The same names [emit.ml] gives, so a build made here links against the same
|
|
runtime and a disassembly reads with the same symbols. A Flan name can hold
|
|
characters an assembler will not take bare, so every symbol is quoted. *)
|
|
let asm_sym s = "\"" ^ s ^ "\""
|
|
let fsym n = asm_sym ("flan." ^ n)
|
|
let gsym n = asm_sym ("flan." ^ n)
|
|
|
|
(* 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 *)
|
|
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
|
|
|
|
(* ── 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 _ | Types.Pool _ -> [ Aptr l ]
|
|
| _ when is_agg t ->
|
|
unsupported "aggregate %s across the C boundary" (Types.to_string t)
|
|
| _ when is_float t -> [ Aflt (l, t) ]
|
|
| _ -> [ Aint (l, t) ]
|
|
|
|
(* Hand the arguments over. Everything has already been evaluated into frame
|
|
temporaries, so loading the registers cannot disturb anything: every load
|
|
below reads from rbp, and rbp does not move. Answers how many SSE registers
|
|
were used, which is what [al] has to say to a variadic callee. *)
|
|
let emit_args f (args : arg list) =
|
|
let ints = ref 0 and sses = ref 0 and stack = ref 0 in
|
|
let placed =
|
|
List.map
|
|
(fun a ->
|
|
match a with
|
|
| Aflt _ when !sses < n_sse_args -> incr sses; `Sse (!sses - 1, a)
|
|
| Aflt _ -> let k = !stack in stack := k + 8; `Stack (k, a)
|
|
| _ when !ints < n_int_args -> incr ints; `Int (!ints - 1, a)
|
|
| _ -> let k = !stack in stack := k + 8; `Stack (k, a))
|
|
args
|
|
in
|
|
if !stack > f.outgoing then f.outgoing <- !stack;
|
|
let into ~reg a =
|
|
match a with
|
|
| Aint (l, t) -> load_loc f ~reg l t
|
|
| Aflt (l, t) -> fload f.b ~dst:reg ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t)
|
|
| Aptr l -> addr_into f ~reg l
|
|
| Alen l ->
|
|
load_int f.b ~dst:reg ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8
|
|
~signed:true
|
|
in
|
|
(* The stack half first, because it uses rax as its courier and a register
|
|
argument must not already be sitting in rax while that happens. *)
|
|
List.iter
|
|
(function
|
|
| `Stack (k, a) ->
|
|
(match a with
|
|
| Aflt (l, t) ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t);
|
|
fstore f.b ~src:xmm0 ~mm:(Reg (rsp, k)) ~f64:(f64_of t)
|
|
| _ ->
|
|
into ~reg:rax a;
|
|
store_int f.b ~src:rax ~mm:(Reg (rsp, k)) ~size:8)
|
|
| _ -> ())
|
|
placed;
|
|
List.iter
|
|
(function
|
|
| `Int (i, a) -> into ~reg:int_args.(i) a
|
|
| `Sse (i, a) -> into ~reg:i a
|
|
| `Stack _ -> ())
|
|
placed;
|
|
!sses
|
|
|
|
(* ── Lowering ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The destination handed to an expression whose value is thrown away.
|
|
|
|
It is one allocated value and it is compared by identity, because it is not
|
|
an address and must never be used as one: rbp+0 is the saved rbp and rbp+8
|
|
is the return address, so a 16-byte slice stored "into the sink" overwrites
|
|
both and the function returns into whatever the first two words of the
|
|
value happened to be. That is not hypothetical — it is how [edn.flan]
|
|
failed, by jumping into .rodata several statements after the real mistake,
|
|
and the mistake was a form of non-void type written in statement position.
|
|
|
|
So [lower] refuses the sink for anything that has a value, and spends a
|
|
frame temporary on it instead. The temporary is reclaimed at once; the
|
|
point is that the store has somewhere legal to go. *)
|
|
let sink = Lf 0
|
|
|
|
let rec lower f (e : Tast.expr) (dst : loc) : unit =
|
|
(* 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))))
|
|
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)
|
|
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)
|
|
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. [lo <= hi] is not redundant with [hi <= len], because a reversed
|
|
range would otherwise yield hi - lo as a huge unsigned length, which is a
|
|
worse hole than the missing check. *)
|
|
and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr)
|
|
(llo : loc) (hi : Tast.expr) (lhi : loc) =
|
|
if f.md.Emit.checks then
|
|
let len =
|
|
match ty with
|
|
| Types.Array (n, _) -> Some (`Const n)
|
|
| Types.Slice _ | Types.String -> Some (`At (shift base 8))
|
|
| _ -> None
|
|
in
|
|
match len with
|
|
| None -> ()
|
|
| Some len ->
|
|
scoped f (fun () ->
|
|
let a = ptmp f and b = ptmp f and c = ptmp f in
|
|
load_loc f ~reg:rax llo lo.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
|
|
load_loc f ~reg:rdx lhi hi.Tast.ty;
|
|
store_int f.b ~src:rdx ~mm:(Frame b) ~size:8;
|
|
load_len f len;
|
|
store_int f.b ~src:rcx ~mm:(Frame c) ~size:8;
|
|
let ok = new_label f "inb" and bad = new_label f "oob" in
|
|
cmp_rr f.b ~a:rax ~c:rdx;
|
|
jcc_lbl f.b ~cc:cc_a bad;
|
|
cmp_rr f.b ~a:rdx ~c:rcx;
|
|
jcc_lbl f.b ~cc:cc_be ok;
|
|
lbl f.b bad;
|
|
bounds_call f "flan_slice_error" loc [ a; b; c ];
|
|
lbl f.b ok)
|
|
|
|
(* [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, a Map and a Pool are move-only and cross to the runtime as their
|
|
*address*, which is what lets an operation mutate the caller's container
|
|
in place. [eval] would hand over the address of a copy, and the runtime
|
|
would grow that and leave the caller's header at length zero — which is
|
|
how [bounds-condition.flan] failed, as an in-bounds (at v 1) signalling
|
|
against a length of 0. Every other aggregate is read-only across this
|
|
boundary, so a copy there is harmless. *)
|
|
let vals =
|
|
List.map
|
|
(fun (a : Tast.expr) ->
|
|
(match a.Tast.ty with
|
|
| Types.Vec _ | Types.Map _ | Types.Pool _ -> lvalue f a
|
|
| _ -> eval f a), a.Tast.ty)
|
|
args
|
|
in
|
|
let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in
|
|
let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] else flat in
|
|
let nsse = emit_args f flat in
|
|
(* [al] is how many SSE registers were used, which a variadic callee reads.
|
|
Harmless on a fixed one, and a [declare] does not say which it is. *)
|
|
imm_into f ~reg:rax (Int64.of_int nsse);
|
|
call_sym f.b sym;
|
|
if chan then guard f;
|
|
if not (is_void rty) then begin
|
|
(* 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], an [Alloc] or a [Handle].
|
|
- [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 count is masked to the operand width by the hardware, which is
|
|
the rule the language already defines. *)
|
|
| Tast.Shl -> shl_cl f.b ~dst:rax
|
|
| Tast.Shr -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax
|
|
| Tast.Div | Tast.Rem ->
|
|
(* 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. *)
|
|
| Tast.SliceFromPtr, [ p; n ] ->
|
|
let lp = eval f p in
|
|
let ln = eval f n in
|
|
if f.md.Emit.checks then
|
|
scoped f (fun () ->
|
|
let a = ptmp f and b = ptmp f and c = ptmp f in
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
|
|
store_int f.b ~src:rax ~mm:(Frame c) ~size:8;
|
|
load_loc f ~reg:rax ln n.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(Frame b) ~size:8;
|
|
cmp_imm f.b ~dst:rax 0;
|
|
let ok = new_label f "inb" in
|
|
jcc_lbl f.b ~cc:cc_ge ok;
|
|
bounds_call f "flan_slice_error" e.Tast.loc [ a; b; c ];
|
|
lbl f.b ok);
|
|
load_loc f ~reg:rax lp p.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
|
load_loc f ~reg:rax ln n.Tast.ty;
|
|
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
|
|
(* string and [u8] are the same two words, so both directions are views and
|
|
not copies — the same non-instruction [emit.ml] emits. *)
|
|
| (Tast.Bytes | Tast.StrOfBytes), [ a ] -> lower f a dst
|
|
| Tast.I64ToBytes, [ a ] -> shim_out f "flan_i64_to_bytes" a dst
|
|
| Tast.U64ToBytes, [ a ] -> shim_out f "flan_u64_to_bytes" a dst
|
|
| Tast.F64ToBytes, [ a ] -> shim_out f "flan_f64_to_bytes" a dst
|
|
| Tast.EscapeBytes, [ a ] ->
|
|
let l = eval f a in
|
|
slice_in_out f "flan_escape_bytes" l dst
|
|
| Tast.BytesToI64, [ a ] ->
|
|
call_rt f ~sym:"flan_bytes_to_i64" ~args:[ a ] ~rty:t dst
|
|
| Tast.BytesToF64, [ a ] ->
|
|
call_rt f ~sym:"flan_bytes_to_f64" ~args:[ a ] ~rty:t dst
|
|
| Tast.WriteStdout, [ a ] ->
|
|
call_rt f ~sym:"flan_write_stdout" ~args:[ a ] ~rty:Types.Unit sink
|
|
| Tast.Exit, [ a ] ->
|
|
call_rt f ~sym:"flan_exit" ~args:[ a ] ~rty:Types.Unit sink;
|
|
ud2 f.b
|
|
| Tast.Argv, [] ->
|
|
addr_into f ~reg:rdi dst;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b "flan_argv"
|
|
| Tast.SizeOf ty, [] ->
|
|
imm_into f ~reg:rax (Int64.of_int (sizeof f.md ty));
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.AlignOf ty, [] ->
|
|
imm_into f ~reg:rax (Int64.of_int (alignof f.md ty));
|
|
store_loc f ~reg:rax dst t
|
|
| Tast.AddrOf, [ a ] ->
|
|
let l = lvalue f a in
|
|
addr_into f ~reg:rax l;
|
|
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
|
|
(* 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], [_map] and [_pool]
|
|
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, flan_slice *out)] — a scalar in, a slice written through a
|
|
hidden out pointer. The three number printers, and nothing else. *)
|
|
and shim_out f sym (a : Tast.expr) dst =
|
|
let l = eval f a in
|
|
if is_float a.Tast.ty then begin
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of a.Tast.ty);
|
|
addr_into f ~reg:rdi dst;
|
|
imm_into f ~reg:rax 1L
|
|
end else begin
|
|
load_loc f ~reg:rdi l a.Tast.ty;
|
|
addr_into f ~reg:rsi dst;
|
|
imm_into f ~reg:rax 0L
|
|
end;
|
|
call_sym f.b sym
|
|
|
|
(* [void shim(ptr, i64, flan_slice *out)] — a slice in, a slice out. *)
|
|
and slice_in_out f sym (src : loc) dst =
|
|
load_int f.b ~dst:rdi ~mm:(lmem f src ~scratch:r11) ~size:8 ~signed:false;
|
|
load_int f.b ~dst:rsi ~mm:(lmem f (shift src 8) ~scratch:r11) ~size:8
|
|
~signed:true;
|
|
addr_into f ~reg:rdx dst;
|
|
xor_rr f.b ~dst:rax ~src:rax;
|
|
call_sym f.b sym
|
|
|
|
(* Every conversion, and there are only four shapes of them. Integer to
|
|
integer is already the load and store rules: a load widens the way the
|
|
source's own signedness says, and a store narrows to the destination's
|
|
width, so one pair covers all sixty-four pairings. *)
|
|
and cast f (a : Tast.expr) (target : Types.t) dst =
|
|
let concrete (t : Types.t) =
|
|
match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
|
|
in
|
|
let src_t = concrete a.Tast.ty and dst_t = concrete target in
|
|
let l = eval f a in
|
|
match is_float src_t, is_float dst_t with
|
|
| false, false ->
|
|
load_loc f ~reg:rax l src_t;
|
|
store_loc f ~reg:rax dst dst_t
|
|
| true, true ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
|
|
if f64_of src_t && not (f64_of dst_t) then cvtsd2ss f.b ~dst:xmm0 ~src:xmm0
|
|
else if (not (f64_of src_t)) && f64_of dst_t then
|
|
cvtss2sd f.b ~dst:xmm0 ~src:xmm0;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
|
|
| false, true ->
|
|
load_loc f ~reg:rax l src_t;
|
|
cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax;
|
|
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
|
|
| true, false ->
|
|
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
|
|
(* [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 ~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";
|
|
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;
|
|
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;
|
|
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 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;
|
|
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 ~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
|
|
|
|
(* ── 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) (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";
|
|
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 an initialiser that runs before [main]
|
|
does. [emit.ml] folds the initialiser into an LLVM constant instead, which
|
|
it can because it has a constant folder for the IR's own syntax; running the
|
|
same expression as code costs a few instructions once and needs no second
|
|
evaluator that could disagree with the first about what a struct literal
|
|
means. *)
|
|
let emit_globals_data (md : Emit.m) (globals : Tast.global list) =
|
|
let out = Buffer.create 256 in
|
|
Buffer.add_string out "\t.bss\n";
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
let size, align = Emit.lay md g.Tast.gty in
|
|
let sym = gsym g.Tast.gname in
|
|
Buffer.add_string out
|
|
(Printf.sprintf "\t.globl\t%s\n\t.align\t%d\n\t.type\t%s, @object\n\
|
|
\t.size\t%s, %d\n%s:\n\t.zero\t%d\n"
|
|
sym align sym sym (max 1 size) sym (max 1 size)))
|
|
globals;
|
|
Buffer.contents out
|
|
|
|
let init_sym = "\"flan..init-globals\""
|
|
|
|
let emit_globals_init ?(cfi = false) ?(ann = false) (md : Emit.m) ~externs ~fns
|
|
(globals : Tast.global list) =
|
|
let b = create () in
|
|
let f =
|
|
{ b; md; fnname = "<globals>"; retlbl = new_label () "ginit";
|
|
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
|
|
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
|
|
xfer_lbl = ""; unwound = false;
|
|
rodata = Buffer.create 64; externs; fns; 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 establishes a handler or a restart before this runs, so a
|
|
transfer out of an initialiser has nowhere to go and cannot arise: a
|
|
bounds failure here finds no handler and dies inside the runtime. The
|
|
exit still exists because a guard names it. *)
|
|
if f.unwound then begin
|
|
jmp_lbl f.b f.retlbl; lbl f.b f.xfer_lbl; jmp_lbl f.b f.retlbl
|
|
end;
|
|
let pb = create () in
|
|
push_r pb rbp;
|
|
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" init_sym init_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" init_sym init_sym);
|
|
Buffer.contents out, Buffer.contents f.rodata
|
|
|
|
(* ── The program ─────────────────────────────────────────────────────── *)
|
|
|
|
(* What is left of the precondition that used to stand in for conditions.
|
|
|
|
It was a whole-program argument: this backend emitted no guard after a call,
|
|
which is sound exactly when nothing in the reachable set can ever *write*
|
|
the channel, so the build refused by name the moment it found something that
|
|
could. Every call site is guarded now and the argument has retired — except
|
|
in one place, which is why the walk is still here.
|
|
|
|
A global's initialiser runs from [flan..init-globals], before [main] and
|
|
before anything has established a handler or a restart. It owns its own
|
|
channel cell because no caller hands it one, so a transfer out of an
|
|
initialiser has nowhere to go: its exit would return to the loader. Refused
|
|
by name rather than compiled into a return into ld.so. *)
|
|
let check_no_transfer (p : Tast.program) =
|
|
let bad what =
|
|
unsupported "%s in a global's initialiser: it runs before main, before \
|
|
anything can handle it, and a transfer out of it has nowhere \
|
|
to go" what
|
|
in
|
|
let rec ex (e : Tast.expr) =
|
|
(match e.Tast.e with
|
|
| Tast.Signal _ -> bad "signal"
|
|
| Tast.InvokeRestart _ -> bad "invoke-restart"
|
|
| Tast.RestartCase _ -> bad "restart-case"
|
|
| Tast.Handled _ -> bad "handler-bind"
|
|
| _ -> ());
|
|
iter_sub ex e
|
|
and iter_sub g (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Prim (_, xs) | Tast.Call (_, xs) | Tast.Arr xs | Tast.Do xs
|
|
| Tast.Make (_, xs) | Tast.MakeCase (_, _, xs) -> List.iter g xs
|
|
| Tast.CallPtr (a, xs) -> g a; List.iter g xs
|
|
| Tast.Handled (_, xs) -> List.iter g xs
|
|
| Tast.Let (bs, body) -> List.iter (fun (_, x) -> g x) bs; List.iter g body
|
|
| Tast.If (a, b, c) -> g a; g b; g c
|
|
| Tast.While (a, b, l) -> g a; List.iter g b; List.iter g l
|
|
| Tast.Return (Some x) | Tast.Some_ x | Tast.Deref x | Tast.UnwrapSome x
|
|
| Tast.Field (x, _) | Tast.CaseField (x, _, _) | Tast.Signal (_, _, x) -> g x
|
|
| Tast.Set (pl, x) -> place_ g pl; g x
|
|
| Tast.Addr pl -> place_ g pl
|
|
| Tast.Match (x, arms) ->
|
|
g x; List.iter (fun (a : Tast.arm) -> List.iter g a.Tast.abody) arms
|
|
| Tast.RestartCase (cs, x) ->
|
|
List.iter (fun (c : Tast.rclause) -> List.iter g c.Tast.rbody) cs; g x
|
|
| Tast.WithAlloc (a, body) -> g a; List.iter g body
|
|
| Tast.InvokeRestart (_, _, xs, _, _, _) -> List.iter g xs
|
|
| _ -> ()
|
|
and place_ g (pl : Tast.place) =
|
|
match pl with
|
|
| Tast.Pfield (x, _) | Tast.Pderef x -> g x
|
|
| Tast.Pindex (x, ys) -> g x; List.iter g ys
|
|
| _ -> ()
|
|
in
|
|
List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals
|
|
|
|
(* 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 =
|
|
check_no_transfer p;
|
|
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;
|
|
let ginit, gr =
|
|
emit_globals_init ~cfi:debug ~ann:annotate md ~externs ~fns p.Tast.globals
|
|
in
|
|
Buffer.add_string text ginit;
|
|
Buffer.add_string rodata gr;
|
|
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
|
| Some fn ->
|
|
Buffer.add_string text (emit_main ~cfi:debug ~ann:annotate 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: a [defvar] initialiser allocates before [main] runs,
|
|
and a note that arrived before the flag was set would be a block the table
|
|
never heard of. It is ordered before [init_sym] here for the same reason.
|
|
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 "") init_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] and in particular no [flan..init-globals]. Re-running a
|
|
global's 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 initial 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.
|
|
|
|
{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;
|
|
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". *)
|
|
let images =
|
|
List.map
|
|
(fun (g : Tast.global) ->
|
|
let size, align = Emit.lay md g.Tast.gty in
|
|
let l = rodata_label f in
|
|
scoped f (fun () -> lower f g.Tast.ginit (Lg (l, 0)));
|
|
(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);
|
|
lea f.b ~dst:rdx ~mm:(Sym (l, 0));
|
|
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\
|
|
\t.align\t%d\n%s:\n\t.zero\t%d\n"
|
|
s s s 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
|