From 66d315813ff6d48f37d78f4f9b1e23d2f0746925 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 09:42:50 +0700 Subject: [PATCH] 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. --- lib/x86.ml | 502 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 502 insertions(+) create mode 100644 lib/x86.ml diff --git a/lib/x86.ml b/lib/x86.ml new file mode 100644 index 0000000..ebe2095 --- /dev/null +++ b/lib/x86.ml @@ -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