The encoder and the frame model for a hand-written x86-64 backend

INCOMPLETE AND NOT WIRED IN. lib/x86.ml is not in lib/dune, so nothing
compiles it and nothing calls it; `dune test --root . -j 1` was green at
the tip this branched from and is unaffected, because no file the build
reads was changed. The module itself has never been type-checked.

What is here: the instruction encoder (integer and SSE, loads and stores
at every width, division, shifts, setcc, rip-relative addressing, rep
movsb), the layout bridge to Emit.lay, the frame allocator, and the
.rodata constant emitters. What is not here: the expression lowering,
the call sequence, the function prologue and epilogue, the assembly file
assembly, the build.ml flag and the differential harness. The header
comment is the design; the second half of the file is missing.

THE INTERNAL CONVENTION, which is the decision hardest to recover from
the code, and which is chosen rather than inherited:

  - Scalars -- integers, bool, ptr, enum, handle, allocator, Fn -- in
    SysV's integer registers rdi rsi rdx rcx r8 r9, then right to left
    on the stack. bool is one byte, zero-extended on load.
  - Floats in xmm0-xmm7, then on the stack.
  - EVERY aggregate by pointer. An argument is a pointer to a copy the
    caller made; a return is a hidden sret pointer in the FIRST integer
    register with every other argument shifted along, and that same
    pointer comes back in rax. Nothing is classified, nothing is split
    across register classes, there is no eightbyte rule.
  - The transfer channel is the last argument of all, a pointer, in the
    integer sequence -- emit.ml's `signature` rule, unchanged. It is a
    pointer to a pointer: main allocates one cell, stores null, and
    threads its address down; a callee that transfers stores non-null
    into it and every caller loads, tests and branches to its pad.
  - Frame: 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, by the
    prologue's sub and by leave. So rsp % 16 == 0 at every call site is
    a property of one rounded sub, and the spike's depth counter is not
    needed -- its bug class is removed rather than guarded against.

WHY THE CONVENTION IS OURS TO PICK, confirmed rather than assumed: a dev
build compiled by this backend never emits a .ll at all, and a release
build never runs this backend, so no process holds code from both. The
only boundary that must match SysV exactly is C, and check.ml rejects an
aggregate in a `declare` while the generated shim flattens every struct,
so no Flan-emitted call ever hands C an aggregate. I found no path that
mixes the two backends in one process. I did NOT get far enough to test
that claim by running anything, so it stands on reading build.ml's
`executable` and emit.ml's `signature`, not on an experiment.

WHAT THE MEASUREMENT SAYS, and it is the one new fact this branch has.
spike/backend/hist.ml histograms Tast nodes over a program after Reach
prunes it. Item 15's four buckets undercount what a whole-program build
must do on day one:

  - enum-compare.flan needs Str, Make, Field and Call before it prints
    anything, because the prelude builds a slice to print one. Aggregates
    are not a later row; they are in the first program.
  - loops.flan carries Handled, RestartCase and Signal one each. The
    "no plan" row is in the reachable set of a program that only loops,
    so conditions cannot be deferred behind a whole-program flag.
  - The text primitives (Bytes, I64ToBytes, WriteStdout) are C calls,
    not instruction work, so they are cheap.

WHAT THE NEXT PERSON SHOULD DO FIRST, in order:

  1. Finish the lowering as destination-driven: `eval f e ~dst` writes
     e's value into [rbp+dst] and nothing is ever live in a register
     across a statement. That is what makes aggregates and scalars one
     code path and what keeps the frame model's promise.
  2. Emit an assembly file -- .byte blobs with `call sym` and
     `.long lbl - . - 4` for the few relocated fields -- and add the
     flag to build.ml as FLAN_X86 plus an `opts` field, off by default.
     Do not write an ELF writer; it produces no Flan progress and a bug
     in it looks exactly like an encoding bug.
  3. Copy test/test_sanitize.ml's shape for the differential harness.
     There is no differential run yet, so nothing about correctness has
     been demonstrated on this branch.
  4. Bounds checks are implementable and should not be skipped:
     flan_bounds_error(ptr, i64, i64, i64, ptr) and flan_slice_error
     take the transfer channel, so they are an ordinary guarded call.

THE TWO LANGUAGE PREREQUISITES, unchanged and still not decided here.
Uninit is the one that bites: this backend gives whatever the stack slot
held, LLVM may reason from poison, and that is the one construct where
the two backends are supposed to differ. Division by zero, INT64_MIN/-1
and the float-to-int cast are the other three that x86 answers
differently from LLVM's "undefined" -- idiv raises SIGFPE where LLVM
says nothing, and cvttsd2si answers the integer indefinite value. The
Fn-value question -- body pointer or cell pointer -- is untouched: the
lowering here would have emitted direct calls, which means no
redefinition, and that is a gap to close before this backend is the dev
backend rather than an experiment.
This commit is contained in:
Joseph Ferano 2026-09-13 09:42:50 +07:00
parent f715be029d
commit 66d315813f

502
lib/x86.ml Normal file
View File

@ -0,0 +1,502 @@
(** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one.
Grown out of [spike/backend/x86.ml], which proved the shape. What is new
here is everything the spike enumerated and did not do: aggregates, floats,
globals, string literals, the transfer channel, and a whole program rather
than one function.
{1 The internal calling convention}
The spike's report (DISCUSS.md item 15) called the internal convention the
sharpest obstacle, because LLVM's answer for a first-class struct is an
implementation detail discoverable only by disassembly a 24-byte struct
comes back in [rax]:[rdx]:[rcx], and [rcx] is a register SysV never uses
for a return value.
That obstacle does not exist here, and the reason is worth stating because
it is the whole licence for this module: {b a dev build is compiled
entirely by this backend and a release build entirely by LLVM, and the two
never meet in one process.} A dev build's [.ll] is not emitted at all when
this backend runs. So the convention is ours to pick, and we pick the
simplest one that exists:
- {b Scalars} integers, [bool], pointers, enums, handles, allocators,
function pointers go in SysV's integer registers [rdi rsi rdx rcx r8
r9], then right-to-left on the stack. [bool] is one byte, zero-extended.
- {b Floats} go in [xmm0]-[xmm7], then on the stack.
- {b Every aggregate goes by pointer.} An argument is a pointer to a copy
the caller made; a return is a hidden [sret] pointer in the {e first}
integer register, with everything else shifted along, and the same
pointer comes back in [rax]. Nothing is classified, nothing is split
across register classes, and there is no eightbyte rule.
- {b The transfer channel} is the last argument of all, a pointer, in the
integer sequence [emit.ml]'s [signature] rule, unchanged.
{b Where this must match SysV exactly, it does}, and that is the C
boundary: [flan_rt.c], [flan_dev.c], the generated FFI shim. [check.ml]
rejects an aggregate in a [declare] signature and the shim flattens every
struct, so a string or slice crosses as [ptr]+[len] and no Flan-emitted
call ever hands C an aggregate. There is therefore no aggregate classifier
in this file, and per item 15 there does not need to be one.
{1 The frame, and why the spike's worst bug cannot happen here}
The spike found its one real bug in a call written inside a binary
operator: the evaluator spilled the left operand with [push], so [rsp] was
8 out at the call and a C callee doing an aligned spill returned garbage.
It fixed that with a depth counter.
This module does not have a depth counter, because it does not push.
{b Every intermediate value is a frame temporary}, bump-allocated below
[rbp] with a high-water mark, and the outgoing-argument area is reserved
once in the prologue. [rsp] is written exactly twice in the prologue and
by [leave] so [rsp % 16 == 0] at every call site is a property of one
rounded [sub] rather than an invariant every case has to maintain. The bug
class is removed rather than guarded against.
That costs instructions and no correctness. A debug build does not
optimise; this is the trade the brief asks for.
{1 Layout}
[Emit.lay] / [lay_fields] / [payload_lay], reused rather than rewritten.
They are acceptance-tested against LLVM's own [getelementptr], so there is
one layout calculator in this compiler and this backend is a caller of it.
{1 The container}
Output is an assembly file: [.byte] blobs for the instructions, with the
few fields that need a relocation written as assembler expressions
([call sym], [.long lbl - . - 4]). Byte offsets stay exactly known, which
is what the introspection this backend exists for will need; what we give
up is writing ELF ourselves, which is several hundred lines that produce
no Flan progress and in which a bug looks exactly like an encoding bug.
Reversible: the encoder below hands out bytes, and who packages them is a
separate question. *)
exception Unsupported of string
let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt
(* ── The byte buffer ─────────────────────────────────────────────────── *)
(* Raw bytes accumulate in [pend] and are flushed as one [.byte] directive;
anything the assembler has to resolve goes out as a directive with a known
size, so [n] is the exact offset of the next byte either way. *)
type buf = { out : Buffer.t; mutable pend : int list; mutable n : int }
let create () = { out = Buffer.create 4096; pend = []; n = 0 }
let flush b =
if b.pend <> [] then begin
Buffer.add_string b.out "\t.byte ";
Buffer.add_string b.out
(String.concat "," (List.rev_map (Printf.sprintf "0x%02x") b.pend));
Buffer.add_char b.out '\n';
b.pend <- []
end
let u8 b x =
b.pend <- (x land 0xff) :: b.pend;
b.n <- b.n + 1
let u32 b n = for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done
let i32 b (n : int) =
if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n;
u32 b n
let u64 b (n : int64) =
for i = 0 to 7 do
u8 b
(Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL))
done
let dir b s size =
flush b;
Buffer.add_string b.out ("\t" ^ s ^ "\n");
b.n <- b.n + size
let text b s = flush b; Buffer.add_string b.out s
let lbl b l = flush b; Buffer.add_string b.out (l ^ ":\n")
(* ── Registers ───────────────────────────────────────────────────────── *)
(* The encoding numbering, not the ABI's: these three bits are what modrm
wants, which is why rsp is 4 and rbp is 5. *)
let rax = 0 and rcx = 1 and rdx = 2
let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7
let r8 = 8 and r9 = 9 and r11 = 11
let xmm0 = 0
let int_args = [| rdi; rsi; rdx; rcx; r8; r9 |]
let n_int_args = 6
let n_sse_args = 8
(* REX. [force] is for the 8-bit forms, where without a REX byte registers 4-7
name ah/ch/dh/bh rather than spl/bpl/sil/dil a store of a bool from rsi
would otherwise write the wrong half of rdx. *)
let rex ?(force = false) b ~w ~r ~x ~m =
let v =
(if w then 8 else 0)
lor (if r >= 8 then 4 else 0)
lor (if x >= 8 then 2 else 0)
lor (if m >= 8 then 1 else 0)
in
if v <> 0 || force then u8 b (0x40 lor v)
let modrm_r b ~r ~m = u8 b (0xc0 lor ((r land 7) lsl 3) lor (m land 7))
(* [base + disp32], always disp32: a frame outgrows 128 bytes and a disp8 that
silently wraps is precisely the bug this would not find. r12 and rsp need a
SIB byte because 4 in the r/m field means "SIB follows". *)
let modrm_m b ~r ~base ~disp =
u8 b (0x80 lor ((r land 7) lsl 3) lor (base land 7));
if base land 7 = 4 then u8 b 0x24;
i32 b disp
(* [rip + disp32], where the displacement is a relocation the assembler fills
in. modrm mod=00 r/m=101 is the rip-relative form. *)
let modrm_rip b ~r ~sym ~addend =
u8 b (((r land 7) lsl 3) lor 5);
dir b
(Printf.sprintf ".long %s%s - . - 4" sym
(if addend = 0 then "" else Printf.sprintf "+%d" addend))
4
(* ── Instructions ────────────────────────────────────────────────────── *)
type mem = Frame of int | Reg of int * int | Sym of string * int
let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) =
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
List.iter (u8 b) pfx;
(match mm with
| Sym _ -> rex b ~w ~r ~x:0 ~m:0
| _ -> rex b ~w ~r ~x:0 ~m:base);
List.iter (u8 b) op;
match mm with
| Frame d -> modrm_m b ~r ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r ~sym:s ~addend:a
let mov_rr b ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b 0x89; modrm_r b ~r:src ~m:dst
let movabs b ~dst (n : int64) =
rex b ~w:true ~r:0 ~x:0 ~m:dst;
u8 b (0xb8 lor (dst land 7));
u64 b n
let lea b ~dst ~(mm : mem) = mem_op b ~r:dst ~op:[ 0x8d ] ~w:true ~pfx:[] ~mm
(* An integer load of [size] bytes, widened to the full 64-bit register the
way the operand's own signedness says. Everything downstream then works in
64 bits and narrows only at a store, which is what makes one set of
arithmetic encodings cover eight integer types. *)
let load_int b ~dst ~mm ~size ~signed =
match size, signed with
| 8, _ -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:true ~pfx:[] ~mm
| 4, false -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:false ~pfx:[] ~mm
| 4, true -> mem_op b ~r:dst ~op:[ 0x63 ] ~w:true ~pfx:[] ~mm
| 2, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb7 ] ~w:true ~pfx:[] ~mm
| 2, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbf ] ~w:true ~pfx:[] ~mm
| 1, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb6 ] ~w:true ~pfx:[] ~mm
| 1, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbe ] ~w:true ~pfx:[] ~mm
| n, _ -> unsupported "integer load of %d bytes" n
let store_int b ~src ~mm ~size =
match size with
| 8 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:true ~pfx:[] ~mm
| 4 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[] ~mm
| 2 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[ 0x66 ] ~mm
| 1 ->
(* The one place a REX byte is needed for its own sake. *)
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
rex ~force:(src >= 4) b ~w:false ~r:src ~x:0 ~m:base;
u8 b 0x88;
(match mm with
| Frame d -> modrm_m b ~r:src ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r:src ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a)
| n -> unsupported "integer store of %d bytes" n
let alu_rr b ~op ~dst ~src =
rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b op; modrm_r b ~r:src ~m:dst
let add_rr b ~dst ~src = alu_rr b ~op:0x01 ~dst ~src
let sub_rr b ~dst ~src = alu_rr b ~op:0x29 ~dst ~src
let and_rr b ~dst ~src = alu_rr b ~op:0x21 ~dst ~src
let or_rr b ~dst ~src = alu_rr b ~op:0x09 ~dst ~src
let xor_rr b ~dst ~src = alu_rr b ~op:0x31 ~dst ~src
let cmp_rr b ~a ~c = alu_rr b ~op:0x39 ~dst:a ~src:c
let imul_rr b ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xaf; modrm_r b ~r:dst ~m:src
let grp1_imm b ~ext ~dst n =
rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0x81; modrm_r b ~r:ext ~m:dst; i32 b n
let add_imm b ~dst n = grp1_imm b ~ext:0 ~dst n
let sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n
let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n
let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst
let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst
let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a
(* cqo then idiv, or xor rdx,rdx then div: the sign of the operands decides
which pair, and getting that wrong is a wrong answer rather than a fault. *)
let cqo b = u8 b 0x48; u8 b 0x99
let idiv_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:7 ~m:src
let div_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:6 ~m:src
(* Shifts by cl. The count is masked to the operand width by the hardware,
which is the rule the language already defines (item 15's audit). *)
let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
let setcc b ~cc ~dst =
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
u8 b 0x0f; u8 b (0x90 lor cc); modrm_r b ~r:0 ~m:dst
let movzx8 b ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xb6; modrm_r b ~r:dst ~m:src
let jmp_lbl b l = u8 b 0xe9; dir b (Printf.sprintf ".long %s - . - 4" l) 4
let jcc_lbl b ~cc l = u8 b 0x0f; u8 b (0x80 lor cc); dir b (Printf.sprintf ".long %s - . - 4" l) 4
let call_sym b s = flush b; dir b (Printf.sprintf "call %s" s) 5
let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm_r b ~r:2 ~m:r
let leave b = u8 b 0xc9
let ret b = u8 b 0xc3
let ud2 b = u8 b 0x0f; u8 b 0x0b
let push_r b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7))
(* rep movsb: rdi, rsi, rcx. Nothing is ever live in a register across a
statement here, so the crudest block copy in the instruction set is also
the correct one, and a struct assignment *is* the copy spec-memory.md
requires. *)
let rep_movsb b = u8 b 0xf3; u8 b 0xa4
let rep_stosb b = u8 b 0xf3; u8 b 0xaa
(* ── SSE ─────────────────────────────────────────────────────────────── *)
let sse_rm b ~pfx ~op ~r ~mm = mem_op b ~r ~op:[ 0x0f; op ] ~w:false ~pfx:[ pfx ] ~mm
let sse_rr b ~pfx ~op ~r ~m =
u8 b pfx; rex b ~w:false ~r ~x:0 ~m; u8 b 0x0f; u8 b op; modrm_r b ~r ~m
let movsd_load b ~dst ~mm = sse_rm b ~pfx:0xf2 ~op:0x10 ~r:dst ~mm
let movsd_store b ~src ~mm = sse_rm b ~pfx:0xf2 ~op:0x11 ~r:src ~mm
let movss_load b ~dst ~mm = sse_rm b ~pfx:0xf3 ~op:0x10 ~r:dst ~mm
let movss_store b ~src ~mm = sse_rm b ~pfx:0xf3 ~op:0x11 ~r:src ~mm
let fload b ~dst ~mm ~f64 = if f64 then movsd_load b ~dst ~mm else movss_load b ~dst ~mm
let fstore b ~src ~mm ~f64 = if f64 then movsd_store b ~src ~mm else movss_store b ~src ~mm
let farith b ~op ~f64 ~dst ~src = sse_rr b ~pfx:(if f64 then 0xf2 else 0xf3) ~op ~r:dst ~m:src
let ucomis b ~f64 ~a ~c =
if f64 then u8 b 0x66;
rex b ~w:false ~r:a ~x:0 ~m:c; u8 b 0x0f; u8 b 0x2e; modrm_r b ~r:a ~m:c
(* Conversions. REX.W selects the 64-bit integer side in each direction. *)
let cvtsi2f b ~f64 ~dst ~src =
u8 b (if f64 then 0xf2 else 0xf3);
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2a; modrm_r b ~r:dst ~m:src
let cvttf2si b ~f64 ~dst ~src =
u8 b (if f64 then 0xf2 else 0xf3);
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2c; modrm_r b ~r:dst ~m:src
let cvtsd2ss b ~dst ~src = sse_rr b ~pfx:0xf2 ~op:0x5a ~r:dst ~m:src
let cvtss2sd b ~dst ~src = sse_rr b ~pfx:0xf3 ~op:0x5a ~r:dst ~m:src
let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modrm_r b ~r:dst ~m:dst
(* ── Types ───────────────────────────────────────────────────────────── *)
(* [Emit.m] carries the struct and union tables [Emit.lay] reads. Built here
rather than imported so that this module adds no line to [emit.ml]: the
record has no signature hiding it and every field it needs is inert. *)
let layout_ctx (p : Tast.program) : Emit.m =
let structs = Hashtbl.create 16 and unions = Hashtbl.create 16 in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
p.Tast.structs;
List.iter (fun (u : Tast.union) -> Hashtbl.replace unions u.Tast.uname u)
p.Tast.unions;
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; unions;
globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks = false;
dev = false; known = (fun _ -> true); dbg = None; sanitize = false;
nstr = 0; nfi = 0 }
let sizeof md t = fst (Emit.lay md t)
let alignof md t = snd (Emit.lay md t)
(* The one classification this backend makes, and it has two answers rather
than SysV's eight. *)
let is_agg (t : Types.t) =
match t with
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _
| Types.Alloc | Types.Handle _ | Types.Fn _ -> false
| Types.Unit | Types.Never -> false
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
| Types.Pool _ | Types.Option _ | Types.Named _ -> true
| Types.Var v -> unsupported "type variable %s" v
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false
let f64_of (t : Types.t) = match t with Types.Float Types.F32 -> false | _ -> true
(* Signedness for a load and for a comparison. A pointer, a handle and an enum
are each unsigned machine words; [bool] is a zero-extended byte. *)
let signed_of (t : Types.t) =
match t with
| Types.Int k -> Types.signed k
| Types.Enum _ -> true
| _ -> false
(* ── Mangling ────────────────────────────────────────────────────────── *)
(* The same names [emit.ml] gives, so a build made here links against the same
runtime and a disassembly reads with the same symbols. A Flan name can hold
characters an assembler will not take bare, so every symbol is quoted. *)
let asm_sym s = "\"" ^ s ^ "\""
let fsym n = asm_sym ("flan." ^ n)
let gsym n = asm_sym ("flan." ^ n)
(* ── Function context ────────────────────────────────────────────────── *)
type fnctx = {
b : buf;
md : Emit.m;
fnname : string;
fret : Types.t;
slots : int array; (* rbp-relative offset of each Tast slot *)
xfer_off : int; (* the incoming transfer channel pointer *)
sret_off : int; (* where the hidden return pointer was put *)
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 *)
mutable nlbl : int;
(* One entry per [While] we are inside, innermost first: the label a [break]
jumps to and the label a [continue] jumps to, which is the latch and not
the head. *)
mutable loops : (string * string) list;
(* The innermost landing pad a transfer found after a call should jump to.
Empty means the function's own transfer exit. *)
mutable pads : string list;
(* Collected while lowering: string literals and float constants both need a
labelled constant in .rodata, and both are discovered mid-expression. *)
rodata : Buffer.t;
mutable nconst : int;
externs : (string, string) Hashtbl.t;
fns : (string, unit) Hashtbl.t;
}
let new_label f tag = f.nlbl <- f.nlbl + 1; Printf.sprintf ".L%s%d" tag f.nlbl
(* Bump-allocate a frame temporary and answer its rbp-relative offset. The
offset is negative, so the running total is rounded *up* to the alignment;
rbp is 16-aligned, so that is the alignment the value actually gets. *)
let alloc f size align =
let a = if align <= 1 then 1 else align in
f.frame <- f.frame + (if size <= 0 then 1 else size);
f.frame <- (f.frame + a - 1) / a * a;
if f.frame > f.maxframe then f.maxframe <- f.frame;
-f.frame
let tmp f (t : Types.t) = alloc f (max 1 (sizeof f.md t)) (alignof f.md t)
let ptmp f = alloc f 8 8
(* Temporaries are reclaimed at the end of the expression that made them; the
destination is allocated by the caller and therefore outlives the reset. *)
let scoped f g =
let save = f.frame in
let r = g () in
f.frame <- save;
r
(* ── Moving values ───────────────────────────────────────────────────── *)
(* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else
is its own width, widened on load. *)
let load_scalar f ~reg ~off (t : Types.t) =
if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t)
let store_scalar f ~reg ~off (t : Types.t) =
if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
store_int f.b ~src:reg ~mm:(Frame off) ~size
(* Through a pointer rather than a frame offset: the same two, with the
address already in a register. *)
let load_scalar_at f ~reg ~base ~disp (t : Types.t) =
if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t)
let store_scalar_at f ~reg ~base ~disp (t : Types.t) =
if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size
(* n bytes from the address in rsi to the address in rdi. *)
let blockcopy f n =
if n > 0 then begin
movabs f.b ~dst:rcx (Int64.of_int n);
rep_movsb f.b
end
let copy_frames f ~dst ~src n =
if n > 0 then begin
lea f.b ~dst:rdi ~mm:(Frame dst);
lea f.b ~dst:rsi ~mm:(Frame src);
blockcopy f n
end
let zero_frame f ~dst n =
if n > 0 then begin
lea f.b ~dst:rdi ~mm:(Frame dst);
xor_rr f.b ~dst:rax ~src:rax;
movabs f.b ~dst:rcx (Int64.of_int n);
rep_stosb f.b
end
(* ── Constants in .rodata ────────────────────────────────────────────── *)
let rodata_label f =
f.nconst <- f.nconst + 1;
Printf.sprintf ".Lc%s%d" (String.concat "" (String.split_on_char '.' "k")) f.nconst
let escape_bytes s =
String.concat ","
(List.map (fun c -> Printf.sprintf "0x%02x" (Char.code c))
(List.init (String.length s) (String.get s)))
let string_const f s =
let l = rodata_label f in
Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l);
if String.length s > 0 then
Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s));
(* A trailing NUL nobody reads through the length, so that a pointer handed
to C by a shim is still a C string if anything ever treats it as one. *)
Buffer.add_string f.rodata "\t.byte 0x00\n";
l
let float_const f (x : float) ~f64 =
let l = rodata_label f in
if f64 then
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 8\n%s:\n\t.quad 0x%Lx\n" l (Int64.bits_of_float x))
else
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 4\n%s:\n\t.long 0x%lx\n" l (Int32.bits_of_float x));
l