(** 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;
  (* 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.
     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;
  externs : (string, string) Hashtbl.t;
  fns : (string, unit) Hashtbl.t;
}

(* Module-wide rather than per-function. Two functions each holding an [if]
   would otherwise both emit [.Lif1] into the same [.s] and the assembler would
   refuse the file — a failure that only appears once a *program* is lowered
   and never once a single function is, which is exactly the class of thing the
   spike could not have found. *)
let uniq = ref 0

let new_label _f tag = incr uniq; Printf.sprintf ".L%s%d" tag !uniq

(* Bump-allocate a frame temporary and answer its rbp-relative offset. The
   offset is negative, so the running total is rounded *up* to the alignment;
   rbp is 16-aligned, so that is the alignment the value actually gets. *)
let alloc f size align =
  let a = if align <= 1 then 1 else align in
  f.frame <- f.frame + (if size <= 0 then 1 else size);
  f.frame <- (f.frame + a - 1) / a * a;
  if f.frame > f.maxframe then f.maxframe <- f.frame;
  -f.frame

let tmp f (t : Types.t) = alloc f (max 1 (sizeof f.md t)) (alignof f.md t)
let ptmp f = alloc f 8 8

(* Temporaries are reclaimed at the end of the expression that made them; the
   destination is allocated by the caller and therefore outlives the reset. *)
let scoped f g =
  let save = f.frame in
  let r = g () in
  f.frame <- save;
  r

(* ── Moving values ───────────────────────────────────────────────────── *)

(* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else
   is its own width, widened on load. *)
let load_scalar f ~reg ~off (t : Types.t) =
  if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t)
  else
    let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
    load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t)

let store_scalar f ~reg ~off (t : Types.t) =
  if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t)
  else
    let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
    store_int f.b ~src:reg ~mm:(Frame off) ~size

(* Through a pointer rather than a frame offset: the same two, with the
   address already in a register. *)
let load_scalar_at f ~reg ~base ~disp (t : Types.t) =
  if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
  else
    let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
    load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t)

let store_scalar_at f ~reg ~base ~disp (t : Types.t) =
  if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
  else
    let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
    store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size

(* n bytes from the address in rsi to the address in rdi. *)
let blockcopy f n =
  if n > 0 then begin
    movabs f.b ~dst:rcx (Int64.of_int n);
    rep_movsb f.b
  end

let copy_frames f ~dst ~src n =
  if n > 0 then begin
    lea f.b ~dst:rdi ~mm:(Frame dst);
    lea f.b ~dst:rsi ~mm:(Frame src);
    blockcopy f n
  end

let zero_frame f ~dst n =
  if n > 0 then begin
    lea f.b ~dst:rdi ~mm:(Frame dst);
    xor_rr f.b ~dst:rax ~src:rax;
    movabs f.b ~dst:rcx (Int64.of_int n);
    rep_stosb f.b
  end

(* ── Constants in .rodata ────────────────────────────────────────────── *)

let rodata_label _f = incr uniq; Printf.sprintf ".Lk%d" !uniq

let escape_bytes s =
  String.concat ","
    (List.map (fun c -> Printf.sprintf "0x%02x" (Char.code c))
       (List.init (String.length s) (String.get s)))

let string_const f s =
  let l = rodata_label f in
  Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l);
  if String.length s > 0 then
    Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s));
  (* A trailing NUL nobody reads through the length, so that a pointer handed
     to C by a shim is still a C string if anything ever treats it as one. *)
  Buffer.add_string f.rodata "\t.byte 0x00\n";
  l

let float_const f (x : float) ~f64 =
  let l = rodata_label f in
  if f64 then
    Buffer.add_string f.rodata
      (Printf.sprintf "\t.align 8\n%s:\n\t.quad 0x%Lx\n" l (Int64.bits_of_float x))
  else
    Buffer.add_string f.rodata
      (Printf.sprintf "\t.align 4\n%s:\n\t.long 0x%lx\n" l (Int32.bits_of_float x));
  l

(* ── Locations ───────────────────────────────────────────────────────── *)

(* Where a value lives. Every value in this backend lives in memory, so the
   three cases are the three ways an address is formed and not three kinds of
   value: a frame offset, a rip-relative global, and a pointer already computed
   into a frame temporary. Adding a field offset to any of them is arithmetic
   on the displacement rather than an instruction. *)
type loc =
  | Lf of int                     (* rbp + d *)
  | Lg of string * int            (* rip-relative symbol + d *)
  | Lp of int * int               (* [rbp + p] is a pointer; + d *)

let shift l d =
  match l with
  | Lf o -> Lf (o + d)
  | Lg (s, a) -> Lg (s, a + d)
  | Lp (p, a) -> Lp (p, a + d)

(* [scratch] is only touched by the [Lp] case, and every caller passes r11 —
   which is why r11 is never a value register anywhere below. *)
let lmem f (l : loc) ~scratch : mem =
  match l with
  | Lf o -> Frame o
  | Lg (s, a) -> Sym (s, a)
  | Lp (p, a) ->
    load_int f.b ~dst:scratch ~mm:(Frame p) ~size:8 ~signed:false;
    Reg (scratch, a)

let addr_into f ~reg (l : loc) =
  match l with
  | Lf o -> lea f.b ~dst:reg ~mm:(Frame o)
  | Lg (s, a) -> lea f.b ~dst:reg ~mm:(Sym (s, a))
  | Lp (p, a) ->
    load_int f.b ~dst:reg ~mm:(Frame p) ~size:8 ~signed:false;
    if a <> 0 then add_imm f.b ~dst:reg a

let scalar_size f (t : Types.t) =
  match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t)

let load_loc f ~reg (l : loc) (t : Types.t) =
  let mm = lmem f l ~scratch:r11 in
  if is_float t then fload f.b ~dst:reg ~mm ~f64:(f64_of t)
  else load_int f.b ~dst:reg ~mm ~size:(scalar_size f t) ~signed:(signed_of t)

let store_loc f ~reg (l : loc) (t : Types.t) =
  let mm = lmem f l ~scratch:r11 in
  if is_float t then fstore f.b ~src:reg ~mm ~f64:(f64_of t)
  else store_int f.b ~src:reg ~mm ~size:(scalar_size f t)

(* An aggregate move. [rep movsb] rather than a sized loop for the reason the
   header gives: nothing is live in a register across a statement, so the
   crudest block copy in the instruction set is also the correct one. *)
let copy_loc f ~(dst : loc) ~(src : loc) n =
  if n > 0 then begin
    addr_into f ~reg:rdi dst;
    addr_into f ~reg:rsi src;
    blockcopy f n
  end

let zero_loc f (dst : loc) n =
  if n > 0 then begin
    addr_into f ~reg:rdi dst;
    xor_rr f.b ~dst:rax ~src:rax;
    movabs f.b ~dst:rcx (Int64.of_int n);
    rep_stosb f.b
  end

(* Move a value of any type from one location to another: a block copy for an
   aggregate, a load and a store for a scalar, and nothing at all for Unit. *)
let move f ~(dst : loc) ~(src : loc) (t : Types.t) =
  if not (is_void t) then
    if is_agg t then copy_loc f ~dst ~src (sizeof f.md t)
    else begin
      let r = if is_float t then xmm0 else rax in
      load_loc f ~reg:r src t;
      store_loc f ~reg:r dst t
    end

let imm_into f ~reg (n : int64) = movabs f.b ~dst:reg n

(* ── Struct layout, through [Emit] ───────────────────────────────────── *)

let 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 -> unsupported "no struct %s" sn

(* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay]
   measures it as — so the payload's offset is whatever [lay_fields] puts the
   second one at, and not a rule spelled a second time here. A union whose
   cases are all payload-less is a bare tag and has no second field. *)
let union_payload_off f (u : Tast.union) =
  let size, align = Emit.payload_lay f.md u in
  if size = 0 then 0
  else
    let _, _, offs =
      Emit.lay_fields f.md
        [ Types.Int Types.I32;
          Types.Array (Int64.of_int (size / align),
                       Types.Int (Emit.int_kind (align * 8))) ]
    in
    List.nth offs 1

let union_of f n =
  match Hashtbl.find_opt f.md.Emit.unions n with
  | Some u -> u
  | None -> unsupported "no union %s" n

(* The offsets of one case's fields inside the payload blob. The single place
   in this backend that knows how a payload is read, so [match]'s binds,
   [CaseField] and [MakeCase] cannot come to different conclusions about it. *)
let case_offsets f (c : Tast.variant) =
  let _, _, offs =
    Emit.lay_fields f.md
      (List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields)
  in
  offs

(* An Option is { i8 tag, T }, the same two fields [Emit.lay] measures it as. *)
let option_lay f (t : Types.t) =
  let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I8; t ] in
  match offs with [ a; b ] -> a, b | _ -> unsupported "option layout"

(* ── Condition codes ─────────────────────────────────────────────────── *)

let cc_e = 4 and cc_ne = 5
let cc_b = 2 and cc_ae = 3 and cc_be = 6 and cc_a = 7
let cc_l = 12 and cc_ge = 13 and cc_le = 14 and cc_g = 15

let int_cc ~signed (p : Tast.prim) =
  match p, signed with
  | Tast.Eq, _ -> cc_e
  | Tast.Ne, _ -> cc_ne
  | Tast.Lt, true -> cc_l   | Tast.Lt, false -> cc_b
  | Tast.Le, true -> cc_le  | Tast.Le, false -> cc_be
  | Tast.Gt, true -> cc_g   | Tast.Gt, false -> cc_a
  | Tast.Ge, true -> cc_ge  | Tast.Ge, false -> cc_ae
  | _ -> unsupported "not a comparison"

(* [ucomis] sets the flags the *unsigned* codes read, whichever way the
   operands are signed, so a float comparison never uses l/g. *)
let float_cc (p : Tast.prim) =
  match p with
  | Tast.Eq -> cc_e | Tast.Ne -> cc_ne
  | Tast.Lt -> cc_b | Tast.Le -> cc_be
  | Tast.Gt -> cc_a | Tast.Ge -> cc_ae
  | _ -> unsupported "not a comparison"

let is_cmp (p : Tast.prim) =
  match p with
  | Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true
  | _ -> false

(* ── The calling convention, as the header states it ─────────────────── *)

(* One argument as it will actually be handed over. [Aptr] is an aggregate,
   which always crosses as the address of a copy the caller made; [Alen] is the
   second word of a slice being exploded for a C callee. *)
type arg =
  | Aint of loc * Types.t
  | Aflt of loc * Types.t
  | Aptr of loc
  | Alen of loc

(* The C boundary, and the one place this backend must match SysV rather than
   pick. [check.ml] rejects an aggregate in a [declare] signature and the shim
   flattens every struct, so the only aggregates that reach here are the ones
   [emit.ml]'s own shim rules already spell out: a slice as ptr+len, and a
   move-only container by address. *)
let classify_c (l : loc) (t : Types.t) =
  match t with
  | Types.String | Types.Slice _ -> [ Aint (l, Types.Ptr Types.Unit); Alen l ]
  | Types.Unit | Types.Never -> []
  | Types.Vec _ | Types.Map _ | Types.Pool _ -> [ Aptr l ]
  | _ when is_agg t ->
    unsupported "aggregate %s across the C boundary" (Types.to_string t)
  | _ when is_float t -> [ Aflt (l, t) ]
  | _ -> [ Aint (l, t) ]

(* Hand the arguments over. Everything has already been evaluated into frame
   temporaries, so loading the registers cannot disturb anything: every load
   below reads from rbp, and rbp does not move. Answers how many SSE registers
   were used, which is what [al] has to say to a variadic callee. *)
let emit_args f (args : arg list) =
  let ints = ref 0 and sses = ref 0 and stack = ref 0 in
  let placed =
    List.map
      (fun a ->
         match a with
         | Aflt _ when !sses < n_sse_args -> incr sses; `Sse (!sses - 1, a)
         | Aflt _ -> let k = !stack in stack := k + 8; `Stack (k, a)
         | _ when !ints < n_int_args -> incr ints; `Int (!ints - 1, a)
         | _ -> let k = !stack in stack := k + 8; `Stack (k, a))
      args
  in
  if !stack > f.outgoing then f.outgoing <- !stack;
  let into ~reg a =
    match a with
    | Aint (l, t) -> load_loc f ~reg l t
    | Aflt (l, t) -> fload f.b ~dst:reg ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t)
    | Aptr l -> addr_into f ~reg l
    | Alen l ->
      load_int f.b ~dst:reg ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8
        ~signed:true
  in
  (* The stack half first, because it uses rax as its courier and a register
     argument must not already be sitting in rax while that happens. *)
  List.iter
    (function
      | `Stack (k, a) ->
        (match a with
         | Aflt (l, t) ->
           fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t);
           fstore f.b ~src:xmm0 ~mm:(Reg (rsp, k)) ~f64:(f64_of t)
         | _ ->
           into ~reg:rax a;
           store_int f.b ~src:rax ~mm:(Reg (rsp, k)) ~size:8)
      | _ -> ())
    placed;
  List.iter
    (function
      | `Int (i, a) -> into ~reg:int_args.(i) a
      | `Sse (i, a) -> into ~reg:i a
      | `Stack _ -> ())
    placed;
  !sses

(* ── Lowering ────────────────────────────────────────────────────────── *)

(* The destination handed to an expression whose value is thrown away.

   It is one allocated value and it is compared by identity, because it is not
   an address and must never be used as one: rbp+0 is the saved rbp and rbp+8
   is the return address, so a 16-byte slice stored "into the sink" overwrites
   both and the function returns into whatever the first two words of the
   value happened to be. That is not hypothetical — it is how [edn.flan]
   failed, by jumping into .rodata several statements after the real mistake,
   and the mistake was a form of non-void type written in statement position.

   So [lower] refuses the sink for anything that has a value, and spends a
   frame temporary on it instead. The temporary is reclaimed at once; the
   point is that the store has somewhere legal to go. *)
let sink = Lf 0

let rec lower f (e : Tast.expr) (dst : loc) : unit =
  if dst == sink && not (is_void e.Tast.ty) then
    scoped f (fun () ->
      let o = tmp f e.Tast.ty in
      lower f e (Lf o))
  else lower_at f e dst

and lower_at f (e : Tast.expr) (dst : loc) : unit =
  let t = e.Tast.ty in
  match e.Tast.e with
  | Tast.Int (n, _) -> imm_into f ~reg:rax n; store_loc f ~reg:rax dst t
  | Tast.Bool b ->
    imm_into f ~reg:rax (if b then 1L else 0L);
    store_loc f ~reg:rax dst Types.Bool
  | Tast.Float (x, k) ->
    let f64 = (k = Types.F64) in
    let l = float_const f x ~f64 in
    fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64;
    fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
  | Tast.Str s ->
    (* A string and a [u8] slice are the same two words, which is why [Bytes]
       below is a non-instruction. *)
    let l = string_const f s in
    lea f.b ~dst:rax ~mm:(Sym (l, 0));
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
    imm_into f ~reg:rax (Int64.of_int (String.length s));
    store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
  | Tast.Unit -> ()
  | Tast.Zero ty -> zero_value f dst ty
  | Tast.None_ -> zero_value f dst t
  (* Reading an uninitialised value gives whatever the slot held: stable
     garbage rather than LLVM's [poison]. The one construct where the two
     backends are meant to differ — DISCUSS.md item 15, question 4. *)
  | Tast.Uninit _ -> ()
  | Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
    let src = lvalue f e in
    move f ~dst ~src t
  | Tast.Addr p ->
    let l = place f p in
    addr_into f ~reg:rax l;
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
  (* Not the indirection cell: this backend owns the whole build and nothing
     is redefined into it, so a function's address is its symbol. When it
     stops being true, [Fnval] is the case that grows a load. *)
  | Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n) ->
    lea f.b ~dst:rax ~mm:(Sym (fsym n, 0));
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
  | Tast.FnAddr (Tast.Rtfn n) ->
    lea f.b ~dst:rax ~mm:(Sym (n, 0));
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
  | Tast.Prim (p, args) -> prim f e p args dst
  | Tast.Call (name, args) ->
    (match Hashtbl.find_opt f.externs name with
     | Some sym -> call_c f ~sym ~args ~rty:t dst
     | None -> call_flan f ~target:(`Sym (fsym name)) ~args ~rty:t dst)
  | Tast.CallPtr (callee, args) ->
    let c = eval f callee in
    call_flan f ~target:(`Loc c) ~args ~rty:t dst
  | Tast.Do body -> block f body dst t
  | Tast.Let (bs, body) ->
    List.iter
      (fun (slot, (v : Tast.expr)) ->
         scoped f (fun () -> lower f v (Lf f.slots.(slot))))
      bs;
    block f body dst t
  | Tast.If (c, a, b) ->
    let lelse = new_label f "else" and lend = new_label f "endif" in
    scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool);
    test_rr f.b ~a:rax ~c:rax;
    jcc_lbl f.b ~cc:cc_e lelse;
    scoped f (fun () -> lower f a dst);
    jmp_lbl f.b lend;
    lbl f.b lelse;
    scoped f (fun () -> lower f b dst);
    lbl f.b lend
  | Tast.While (c, body, latch) ->
    let lhead = new_label f "head" and llatch = new_label f "latch"
    and lend = new_label f "endw" in
    lbl f.b lhead;
    scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool);
    test_rr f.b ~a:rax ~c:rax;
    jcc_lbl f.b ~cc:cc_e lend;
    f.loops <- (lend, llatch) :: f.loops;
    List.iter (fun s -> scoped f (fun () -> lower f s sink)) body;
    lbl f.b llatch;
    List.iter (fun s -> scoped f (fun () -> lower f s sink)) latch;
    f.loops <- List.tl f.loops;
    jmp_lbl f.b lhead;
    lbl f.b lend
  | Tast.Return v ->
    (match v with
     | Some x when not (is_void x.Tast.ty) && not (is_void f.fret) ->
       scoped f (fun () -> lower f x (ret_loc f))
     | Some x -> scoped f (fun () -> lower f x sink)
     | None -> ());
    jmp_lbl f.b f.retlbl
  | Tast.Break n ->
    (match List.nth_opt f.loops n with
     | Some (lend, _) -> jmp_lbl f.b lend
     | None -> unsupported "break %d outside a loop" n)
  | Tast.Continue n ->
    (match List.nth_opt f.loops n with
     | Some (_, llatch) -> jmp_lbl f.b llatch
     | None -> unsupported "continue %d outside a loop" n)
  | Tast.Set (p, v) ->
    let l = place f p in
    scoped f (fun () -> lower f v l)
  | Tast.Make (sn, xs) ->
    let offs = field_offsets f sn in
    List.iteri
      (fun i (x : Tast.expr) ->
         scoped f (fun () -> lower f x (shift dst (List.nth offs i))))
      xs
  | Tast.Arr xs ->
    let elem =
      match t with
      | Types.Array (_, el) -> el
      | _ -> unsupported "array literal of %s" (Types.to_string t)
    in
    let sz = sizeof f.md elem in
    List.iteri
      (fun i (x : Tast.expr) ->
         scoped f (fun () -> lower f x (shift dst (i * sz))))
      xs
  | Tast.Some_ x ->
    let payload =
      match t with
      | Types.Option el -> el
      | _ -> unsupported "some of %s" (Types.to_string t)
    in
    let ot, ov = option_lay f payload in
    imm_into f ~reg:rax 1L;
    store_int f.b ~src:rax ~mm:(lmem f (shift dst ot) ~scratch:r11) ~size:1;
    scoped f (fun () -> lower f x (shift dst ov))
  | Tast.UnwrapSome x ->
    (* An early return and not an expression that can fail: with a [None] the
       enclosing function returns [None] at once. *)
    let payload =
      match x.Tast.ty with
      | Types.Option el -> el
      | _ -> unsupported "unwrap of %s" (Types.to_string x.Tast.ty)
    in
    let src = eval f x in
    let ot, ov = option_lay f payload in
    load_int f.b ~dst:rax ~mm:(lmem f (shift src ot) ~scratch:r11) ~size:1
      ~signed:false;
    let lsome = new_label f "some" in
    test_rr f.b ~a:rax ~c:rax;
    jcc_lbl f.b ~cc:cc_ne lsome;
    if not (is_void f.fret) then zero_value f (ret_loc f) f.fret;
    jmp_lbl f.b f.retlbl;
    lbl f.b lsome;
    move f ~dst ~src:(shift src ov) payload
  | Tast.MakeCase (uname, case, fields) ->
    let u = union_of f uname in
    let i, c =
      match Tast.case_index u case with
      | Some (i, c) -> i, c
      | None -> unsupported "no case %s of %s" case uname
    in
    (* Zeroed first: an omitted field is ZII and the payload blob is wider
       than this case, so the bytes past its last field have to be something
       rather than whatever the frame held. *)
    zero_loc f dst (sizeof f.md t);
    imm_into f ~reg:rax (Int64.of_int i);
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:4;
    let poff = union_payload_off f u in
    let offs = case_offsets f c in
    List.iteri
      (fun k (x : Tast.expr) ->
         scoped f (fun () -> lower f x (shift dst (poff + List.nth offs k))))
      fields
  | Tast.CaseField (target, case, i) ->
    move f ~dst ~src:(case_field f target case i) t
  | Tast.Match (scrut, arms) -> emit_match f scrut arms dst t
  | Tast.Signal _ | Tast.Handled _ | Tast.RestartCase _
  | Tast.InvokeRestart _ | Tast.WithAlloc _ ->
    unsupported "conditions, in %s" f.fnname

and zero_value f (dst : loc) (ty : Types.t) =
  if is_agg ty then zero_loc f dst (sizeof f.md ty)
  else if not (is_void ty) then
    if is_float ty then begin
      xorps f.b ~dst:xmm0;
      fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of ty)
    end else begin
      xor_rr f.b ~dst:rax ~src:rax;
      store_loc f ~reg:rax dst ty
    end

(* A statement list. Everything but the last form is evaluated for effect; the
   last one is the value. *)
and block f body dst t =
  let rec go = function
    | [] -> ()
    | [ (last : Tast.expr) ] ->
      if is_void t || is_void last.Tast.ty then
        scoped f (fun () -> lower f last sink)
      else scoped f (fun () -> lower f last dst)
    | s :: rest -> scoped f (fun () -> lower f s sink); go rest
  in
  go body

(* The address of something that denotes a location. Nothing is copied. *)
and lvalue f (e : Tast.expr) : loc =
  match e.Tast.e with
  | Tast.Local i -> Lf f.slots.(i)
  | Tast.Global n -> Lg (gsym n, 0)
  | Tast.Deref x -> let p = eval f x in Lp (off_of p, 0)
  | Tast.Field (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
  (* [(at a i)] denotes a location, and the source writes through it:
     [(set (.x (at pts 0)) 1.5)] has to reach the array and not a copy of one
     of its elements. [emit.ml] gets this from [addr]'s own [At] case; without
     it here the store lands in a temporary and the program is quietly
     wrong. *)
  | Tast.Prim (Tast.At, a :: is) when is <> [] ->
    elements f (lvalue f a) a.Tast.ty is
  | Tast.CaseField (target, case, i) -> case_field f target case i
  | _ -> eval f e

(* The address of one field of one case of a union value. Only ever reached
   under an arm that proved the tag — [match] is the only thing that proves
   it — or from the structural printer, which compares the same tag first. *)
and case_field f (target : Tast.expr) case i =
  let uname =
    match target.Tast.ty with
    | Types.Named n -> n
    | ty -> unsupported "case field of %s" (Types.to_string ty)
  in
  let u = union_of f uname in
  let c =
    match Tast.case_index u case with
    | Some (_, c) -> c
    | None -> unsupported "no case %s of %s" case uname
  in
  shift (lvalue f target) (union_payload_off f u + List.nth (case_offsets f c) i)

(* [match]. The two subjects are the same shape and are read differently: an
   [Option] is an i8 tag and a payload at a known offset, a declared union is
   an i32 tag and a blob the arm's case reinterprets. Everything past the tag
   and the binds is shared, which is the arrangement [emit.ml] settled on for
   the same reason. *)
and emit_match f (scrut : Tast.expr) (arms : Tast.arm list) dst t =
  let base = lvalue f scrut in
  let tag_size, tag_of, bind_at =
    match scrut.Tast.ty with
    | Types.Named n when Hashtbl.mem f.md.Emit.unions n ->
      let u = union_of f n in
      let poff = union_payload_off f u in
      ( 4,
        (fun case ->
           match Tast.case_index u case with
           | Some (i, _) -> i
           | None -> unsupported "no case %s of %s" case n),
        fun case k ->
          match Tast.case_index u case with
          | Some (_, c) ->
            shift base (poff + List.nth (case_offsets f c) k),
            (List.nth c.Tast.vfields k).Tast.fty
          | None -> unsupported "no case %s of %s" case n )
    | Types.Option el ->
      (* [lay_fields] puts the i8 tag at 0, so [base] is the tag's address the
         way it is for a union. *)
      let _, ov = option_lay f el in
      ( 1,
        (fun case -> if String.equal case "Some" then 1 else 0),
        fun _case _k -> shift base ov, el )
    | ty -> unsupported "match on %s" (Types.to_string ty)
  in
  let lend = new_label f "endmatch" in
  let rec go = function
    | [] ->
      (* The checker proved exhaustiveness, so nothing reaches here. A trap
         rather than a fallthrough: [ud2] is a defined SIGILL at the
         instruction that fell through, which is the cheap half of item 15's
         question 4. *)
      ud2 f.b
    | (a : Tast.arm) :: rest ->
      let lnext = new_label f "arm" in
      (match a.Tast.acase with
       | None -> ()
       | Some case ->
         load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:tag_size
           ~signed:false;
         cmp_imm f.b ~dst:rax (tag_of case);
         jcc_lbl f.b ~cc:cc_ne lnext);
      List.iteri
        (fun k slot ->
           let src, fty =
             bind_at (match a.Tast.acase with Some c -> c | None -> "") k
           in
           move f ~dst:(Lf f.slots.(slot)) ~src fty)
        a.Tast.binds;
      block f a.Tast.abody dst t;
      jmp_lbl f.b lend;
      if a.Tast.acase <> None then (lbl f.b lnext; go rest)
  in
  go arms;
  lbl f.b lend

and field_loc f (base : loc) (ty : Types.t) i =
  match ty with
  | Types.Named sn -> shift base (List.nth (field_offsets f sn) i)
  | Types.Ptr (Types.Named sn) ->
    shift (Lp (off_of base, 0)) (List.nth (field_offsets f sn) i)
  | Types.String | Types.Slice _ -> shift base (if i = 0 then 0 else 8)
  | Types.Option el -> let ot, ov = option_lay f el in
    shift base (if i = 0 then ot else ov)
  | _ -> unsupported "field of %s" (Types.to_string ty)

and off_of (l : loc) =
  match l with
  | Lf o -> o
  | _ -> unsupported "a pointer value must be a frame temporary"

and place f (p : Tast.place) : loc =
  match p with
  | Tast.Plocal i -> Lf f.slots.(i)
  | Tast.Pglobal n -> Lg (gsym n, 0)
  | Tast.Pderef x -> let q = eval f x in Lp (off_of q, 0)
  | Tast.Pfield (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
  (* [(at grid r c)] is one node with two indices, not two nodes: an array of
     arrays is contiguous, so the second index walks into the element the
     first one landed on. *)
  | Tast.Pindex (x, is) -> elements f (lvalue f x) x.Tast.ty is

(* One element of an array, a slice or a pointer. No bounds check: the check
   [emit.ml] emits signals, and signalling is the row of item 15's table with
   no plan here yet — so this backend is the [--no-bounds-checks] shape of the
   program and says so. *)
and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc =
  match is with
  | [] -> base
  | i :: rest ->
    let elem =
      match ty with
      | Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el
      | Types.String -> Types.Int Types.U8
      | t -> unsupported "index into %s" (Types.to_string t)
    in
    elements f (element f base ty i) elem rest

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
  (match ty with
   | Types.Array _ -> addr_into f ~reg:rax base
   | _ ->
     (* A slice's data pointer is its first word; a raw pointer is itself. *)
     load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:8 ~signed:false);
  load_loc f ~reg:rcx iv i.Tast.ty;
  let sz = max 1 (sizeof f.md elem) in
  if sz <> 1 then begin
    imm_into f ~reg:rdx (Int64.of_int sz);
    imul_rr f.b ~dst:rcx ~src:rdx
  end;
  add_rr f.b ~dst:rax ~src:rcx;
  let p = ptmp f in
  store_int f.b ~src:rax ~mm:(Frame p) ~size:8;
  Lp (p, 0)

(* Evaluate into a fresh temporary and answer where it landed. Always a copy,
   never the slot itself: [emit.ml] loads an operand where the operand is
   written, left-to-right evaluation is *required* and not a preference (item
   15, question 4), and a later argument that assigns to the same slot must
   not be able to change what an earlier one already saw. *)
and eval f (e : Tast.expr) : loc =
  if is_void e.Tast.ty then (lower f e sink; sink)
  else begin
    let o = tmp f e.Tast.ty in
    lower f e (Lf o);
    Lf o
  end

and ret_loc f = if is_agg f.fret then Lp (f.sret_off, 0) else Lf f.retval

(* ── Calls ───────────────────────────────────────────────────────────── *)

(* Flan calling Flan. The convention is the header's, entire: scalars in the
   integer or SSE sequence, every aggregate by pointer, a hidden [sret] in the
   first integer register when the result is an aggregate, and the transfer
   channel last of all. *)
and call_flan f ~target ~args ~rty dst =
  let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
  let callee =
    match target with `Sym s -> `Sym s | `Loc l -> `Loc (off_of l)
  in
  let sret = (not (is_void rty)) && is_agg rty in
  let head = if sret then [ Aptr dst ] else [] in
  let body =
    List.concat_map
      (fun (l, ty) ->
         if is_void ty then []
         else if is_agg ty then [ Aptr l ]
         else if is_float ty then [ Aflt (l, ty) ]
         else [ Aint (l, ty) ])
      vals
  in
  (* The channel is this frame's own: a callee that transfers writes through
     the pointer we were handed, so one cell serves the whole chain. *)
  let chan = [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] in
  ignore (emit_args f (head @ body @ chan));
  (match callee with
   | `Sym s -> call_sym f.b s
   | `Loc o ->
     load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false;
     call_r f.b r11);
  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

and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~args ~rty dst

and call_native f ~sym ~(args : Tast.expr list) ~rty dst =
  let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
  let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals 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 not (is_void rty) then begin
    if is_agg rty then unsupported "aggregate return from %s" sym;
    store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty
  end

(* ── Primitives ──────────────────────────────────────────────────────── *)

and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
  let t = e.Tast.ty in
  match p, args with
  | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem
    | Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ a; b ] ->
    let la = eval f a in
    let lb = eval f b in
    if is_float t then begin
      let f64 = f64_of t in
      fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64;
      fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64;
      let op =
        match p with
        | Tast.Add -> 0x58 | Tast.Sub -> 0x5c
        | Tast.Mul -> 0x59 | Tast.Div -> 0x5e
        | _ -> unsupported "that operator on %s" (Types.to_string t)
      in
      farith f.b ~op ~f64 ~dst:xmm0 ~src:1;
      fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
    end else begin
      let signed = signed_of t in
      load_loc f ~reg:rax la a.Tast.ty;
      load_loc f ~reg:rcx lb b.Tast.ty;
      (match p with
       | Tast.Add -> add_rr f.b ~dst:rax ~src:rcx
       | Tast.Sub -> sub_rr f.b ~dst:rax ~src:rcx
       | Tast.Mul -> imul_rr f.b ~dst:rax ~src:rcx
       | Tast.BitAnd -> and_rr f.b ~dst:rax ~src:rcx
       | Tast.BitOr -> or_rr f.b ~dst:rax ~src:rcx
       | Tast.BitXor -> xor_rr f.b ~dst:rax ~src:rcx
       (* The count is masked to the operand width by the hardware, which is
          the rule the language already defines. *)
       | Tast.Shl -> shl_cl f.b ~dst:rax
       | Tast.Shr -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax
       | Tast.Div | Tast.Rem ->
         if signed then (cqo f.b; idiv_r f.b ~src:rcx)
         else (xor_rr f.b ~dst:rdx ~src:rdx; div_r f.b ~src:rcx);
         if p = Tast.Rem then mov_rr f.b ~dst:rax ~src:rdx
       | _ -> unsupported "arithmetic");
      store_loc f ~reg:rax dst t
    end
  | _, [ a; b ] when is_cmp p ->
    let la = eval f a in
    let lb = eval f b in
    if is_float a.Tast.ty then begin
      let f64 = f64_of a.Tast.ty in
      fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64;
      fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64;
      ucomis f.b ~f64 ~a:xmm0 ~c:1;
      setcc f.b ~cc:(float_cc p) ~dst:rax
    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
    (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
  (* string and [u8] are the same two words, so both directions are views and
     not copies — the same non-instruction [emit.ml] emits. *)
  | (Tast.Bytes | Tast.StrOfBytes), [ a ] -> lower f a dst
  | Tast.I64ToBytes, [ a ] -> shim_out f "flan_i64_to_bytes" a dst
  | Tast.U64ToBytes, [ a ] -> shim_out f "flan_u64_to_bytes" a dst
  | Tast.F64ToBytes, [ a ] -> shim_out f "flan_f64_to_bytes" a dst
  | Tast.EscapeBytes, [ a ] ->
    let l = eval f a in
    slice_in_out f "flan_escape_bytes" l dst
  | Tast.BytesToI64, [ a ] ->
    call_rt f ~sym:"flan_bytes_to_i64" ~args:[ a ] ~rty:t dst
  | Tast.BytesToF64, [ a ] ->
    call_rt f ~sym:"flan_bytes_to_f64" ~args:[ a ] ~rty:t dst
  | Tast.WriteStdout, [ a ] ->
    call_rt f ~sym:"flan_write_stdout" ~args:[ a ] ~rty:Types.Unit sink
  | Tast.Exit, [ a ] ->
    call_rt f ~sym:"flan_exit" ~args:[ a ] ~rty:Types.Unit sink;
    ud2 f.b
  | Tast.Argv, [] ->
    addr_into f ~reg:rdi dst;
    xor_rr f.b ~dst:rax ~src:rax;
    call_sym f.b "flan_argv"
  | Tast.SizeOf ty, [] ->
    imm_into f ~reg:rax (Int64.of_int (sizeof f.md ty));
    store_loc f ~reg:rax dst t
  | Tast.AlignOf ty, [] ->
    imm_into f ~reg:rax (Int64.of_int (alignof f.md ty));
    store_loc f ~reg:rax dst t
  | Tast.AddrOf, [ a ] ->
    let l = lvalue f a in
    addr_into f ~reg:rax l;
    store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
  | Tast.Rt sym, _ -> call_rt f ~sym ~args ~rty:t dst
  | Tast.Cast target, [ a ] -> cast f a target dst
  | _ -> unsupported "primitive with %d arguments" (List.length args)

(* [void shim(T, flan_slice *out)] — a scalar in, a slice written through a
   hidden out pointer. The three number printers, and nothing else. *)
and shim_out f sym (a : Tast.expr) dst =
  let l = eval f a in
  if is_float a.Tast.ty then begin
    fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of a.Tast.ty);
    addr_into f ~reg:rdi dst;
    imm_into f ~reg:rax 1L
  end else begin
    load_loc f ~reg:rdi l a.Tast.ty;
    addr_into f ~reg:rsi dst;
    imm_into f ~reg:rax 0L
  end;
  call_sym f.b sym

(* [void shim(ptr, i64, flan_slice *out)] — a slice in, a slice out. *)
and slice_in_out f sym (src : loc) dst =
  load_int f.b ~dst:rdi ~mm:(lmem f src ~scratch:r11) ~size:8 ~signed:false;
  load_int f.b ~dst:rsi ~mm:(lmem f (shift src 8) ~scratch:r11) ~size:8
    ~signed:true;
  addr_into f ~reg:rdx dst;
  xor_rr f.b ~dst:rax ~src:rax;
  call_sym f.b sym

(* Every conversion, and there are only four shapes of them. Integer to
   integer is already the load and store rules: a load widens the way the
   source's own signedness says, and a store narrows to the destination's
   width, so one pair covers all sixty-four pairings. *)
and cast f (a : Tast.expr) (target : Types.t) dst =
  let concrete (t : Types.t) =
    match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
  in
  let src_t = concrete a.Tast.ty and dst_t = concrete target in
  let l = eval f a in
  match is_float src_t, is_float dst_t with
  | false, false ->
    load_loc f ~reg:rax l src_t;
    store_loc f ~reg:rax dst dst_t
  | true, true ->
    fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
    if f64_of src_t && not (f64_of dst_t) then cvtsd2ss f.b ~dst:xmm0 ~src:xmm0
    else if (not (f64_of src_t)) && f64_of dst_t then
      cvtss2sd f.b ~dst:xmm0 ~src:xmm0;
    fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
  | false, true ->
    load_loc f ~reg:rax l src_t;
    cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax;
    fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
  | true, false ->
    fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
    cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0;
    store_loc f ~reg:rax dst dst_t

(* ── A function ──────────────────────────────────────────────────────── *)

(* The frame is rounded to 16 and reserves the outgoing-argument area in the
   same [sub]. [push rbp] takes entry's [rsp ≡ 8 (mod 16)] to [rsp ≡ 0], so
   [rbp ≡ 0] and — because [rsp] is written exactly here and by [leave] —
   [rsp ≡ 0] at every call site in the body. That is the whole licence for
   having no depth counter, and it is one rounded subtraction rather than an
   invariant every case has to maintain. *)
let frame_bytes f = ((f.maxframe + f.outgoing + 15) / 16) * 16

(* Where each argument arrives, in the order the header lays down: a hidden
   [sret] first when the result is an aggregate, then the parameters, then the
   transfer channel. Answers one entry per incoming value — a register number,
   or a positive [rbp] displacement for the ones that came on the stack. *)
type incoming = Ireg of int | Isse of int | Istk of int

let incoming_of ~sret (params : Types.t list) =
  let ints = ref 0 and sses = ref 0 and stk = ref 0 in
  let next_int () =
    if !ints < n_int_args then (incr ints; Ireg int_args.(!ints - 1))
    else (let k = !stk in stk := k + 8; Istk (16 + k))
  in
  let next_sse () =
    if !sses < n_sse_args then (incr sses; Isse (!sses - 1))
    else (let k = !stk in stk := k + 8; Istk (16 + k))
  in
  let sret_at = if sret then Some (next_int ()) else None in
  let ps =
    List.map
      (fun ty ->
         if is_void ty then Istk (-1)
         else if is_agg ty then next_int ()
         else if is_float ty then next_sse ()
         else next_int ())
      params
  in
  sret_at, ps, next_int ()

let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
  let b = create () in
  let nslots = Array.length fn.Tast.slots in
  let f =
    { b; md; fnname = fn.Tast.name; retlbl = "";
      fret = fn.Tast.ret; slots = Array.make nslots 0;
      xfer_off = 0; sret_off = 0; retval = 0;
      frame = 0; maxframe = 0; outgoing = 0;
      loops = []; pads = []; rodata = Buffer.create 64; externs; fns }
  in
  (* The header's own frame model: every slot and every temporary is
     bump-allocated below rbp, and the high-water mark is what the prologue
     subtracts. Nothing is ever pushed. *)
  Array.iteri (fun i ty -> f.slots.(i) <- tmp f ty) fn.Tast.slots;
  let sret = (not (is_void fn.Tast.ret)) && is_agg fn.Tast.ret in
  f.xfer_off <- ptmp f;
  if sret then f.sret_off <- ptmp f;
  if (not sret) && not (is_void fn.Tast.ret) then f.retval <- tmp f fn.Tast.ret;
  f.retlbl <- new_label f "ret";
  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 is not built, and nothing can reach it: no node in this
     program signals or invokes a restart (checked before any of this runs), so
     [fdefers] has no second path to run on. *)
  if fn.Tast.fdefers <> [] then
    unsupported "%s has defers on the transfer path" fn.Tast.name;

  (* The prologue, now that the frame size is known. *)
  let pb = create () in
  push_r pb rbp;
  mov_rr pb ~dst:rbp ~src:rsp;
  let n = frame_bytes f in
  if n > 0 then sub_imm pb ~dst:rsp n;
  (match sret_at with
   | Some (Ireg r) -> store_int pb ~src:r ~mm:(Frame f.sret_off) ~size:8
   | Some (Istk d) ->
     load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
     store_int pb ~src:rax ~mm:(Frame f.sret_off) ~size:8
   | _ -> ());
  List.iteri
    (fun i ty ->
       let at = List.nth param_at i and sp = List.nth spills i in
       let slot = f.slots.(i) in
       match at, sp with
       | Ireg r, Some p -> store_int pb ~src:r ~mm:(Frame p) ~size:8
       | Ireg r, None ->
         if is_void ty then ()
         else store_int pb ~src:r ~mm:(Frame slot)
                ~size:(match ty with Types.Bool -> 1
                                   | _ -> max 1 (fst (Emit.lay md ty)))
       | Isse i', _ ->
         fstore pb ~src:i' ~mm:(Frame slot) ~f64:(f64_of ty)
       | Istk d, _ ->
         if is_agg ty then begin
           (* The caller put a pointer there, not the aggregate. *)
           load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
           store_int pb ~src:rax ~mm:(Frame (match sp with Some p -> p | None -> slot))
             ~size:8
         end else if not (is_void ty) then begin
           load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:(signed_of ty);
           store_int pb ~src:rax ~mm:(Frame slot)
             ~size:(match ty with Types.Bool -> 1
                                | _ -> max 1 (fst (Emit.lay md ty)))
         end)
    fn.Tast.params;
  (match xfer_at with
   | Ireg r -> store_int pb ~src:r ~mm:(Frame f.xfer_off) ~size:8
   | Istk d ->
     load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false;
     store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8
   | Isse _ -> unsupported "the channel in an SSE register");
  (* And now the aggregate copies, with every incoming register safely in the
     frame. A struct parameter *is* a copy — spec-memory.md's assignment rule,
     made by the caller and taken again here so the callee owns it. *)
  List.iteri
    (fun i ty ->
       match List.nth spills i with
       | Some p ->
         lea pb ~dst:rdi ~mm:(Frame f.slots.(i));
         load_int pb ~dst:rsi ~mm:(Frame p) ~size:8 ~signed:false;
         movabs pb ~dst:rcx (Int64.of_int (fst (Emit.lay md ty)));
         rep_movsb pb
       | None -> ())
    fn.Tast.params;

  (* The epilogue, in exactly one place. *)
  lbl f.b f.retlbl;
  if sret then load_int f.b ~dst:rax ~mm:(Frame f.sret_off) ~size:8 ~signed:false
  else if not (is_void fn.Tast.ret) then
    load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax)
      ~off:f.retval fn.Tast.ret;
  leave f.b;
  ret f.b;
  flush pb;
  flush f.b;
  let sym = fsym fn.Tast.name in
  let out = Buffer.create 1024 in
  Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym);
  Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym);
  Buffer.add_string out (sym ^ ":\n");
  Buffer.add_string out (Buffer.contents pb.out);
  Buffer.add_string out (Buffer.contents f.b.out);
  Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
  Buffer.contents out, Buffer.contents f.rodata

(* ── C's main ────────────────────────────────────────────────────────── *)

(* The same four shapes [emit.ml]'s [emit_main] adapts to, and the same order:
   the runtime is initialised while argc and argv are still in the registers
   the loader put them in, the program's own end of the transfer channel is a
   null cell on this frame, and the exit goes through [flan_exit] because
   stdout is a FILE* and something has to flush it. *)
let emit_main (md : Emit.m) (fn : Tast.fn) =
  let b = create () in
  push_r b rbp;
  mov_rr b ~dst:rbp ~src:rsp;
  sub_imm b ~dst:rsp 48;
  (* [al] is zero at every call this backend makes, variadic or not — see
     [call_native]. Setting it here too costs two bytes and keeps the rule
     without an exception, which is worth more than the two bytes. *)
  xor_rr b ~dst:rax ~src:rax;
  call_sym b "flan_rt_init";
  let xfer = -8 and argv = -32 in
  xor_rr b ~dst:rax ~src:rax;
  store_int b ~src:rax ~mm:(Frame xfer) ~size:8;
  (match fn.Tast.params with
   | [] -> lea b ~dst:rdi ~mm:(Frame xfer)
   | [ _ ] ->
     lea b ~dst:rdi ~mm:(Frame argv);
     xor_rr b ~dst:rax ~src:rax;
     call_sym b "flan_argv";
     lea b ~dst:rdi ~mm:(Frame argv);
     lea b ~dst:rsi ~mm:(Frame xfer)
   | _ -> unsupported "main takes at most one parameter");
  call_sym b (fsym "main");
  if Types.equal fn.Tast.ret (Types.Int Types.I32) then
    mov_rr b ~dst:rdi ~src:rax
  else xor_rr b ~dst:rdi ~src:rdi;
  xor_rr b ~dst:rax ~src:rax;
  call_sym b "flan_exit";
  ud2 b;
  flush b;
  ignore md;
  let out = Buffer.create 256 in
  Buffer.add_string out "\t.globl\tmain\n\t.type\tmain, @function\nmain:\n";
  Buffer.add_string out (Buffer.contents b.out);
  Buffer.add_string out "\t.size\tmain, . - main\n\n";
  Buffer.contents out

(* ── Globals ─────────────────────────────────────────────────────────── *)

(* Every global is a zeroed object and an initialiser that runs before [main]
   does. [emit.ml] folds the initialiser into an LLVM constant instead, which
   it can because it has a constant folder for the IR's own syntax; running the
   same expression as code costs a few instructions once and needs no second
   evaluator that could disagree with the first about what a struct literal
   means. *)
let emit_globals_data (md : Emit.m) (globals : Tast.global list) =
  let out = Buffer.create 256 in
  Buffer.add_string out "\t.bss\n";
  List.iter
    (fun (g : Tast.global) ->
       let size, align = Emit.lay md g.Tast.gty in
       let sym = gsym g.Tast.gname in
       Buffer.add_string out
         (Printf.sprintf "\t.globl\t%s\n\t.align\t%d\n\t.type\t%s, @object\n\
                          \t.size\t%s, %d\n%s:\n\t.zero\t%d\n"
            sym align sym sym (max 1 size) sym (max 1 size)))
    globals;
  Buffer.contents out

let init_sym = "\"flan..init-globals\""

let emit_globals_init (md : Emit.m) ~externs ~fns (globals : Tast.global list) =
  let b = create () in
  let f =
    { b; md; fnname = "<globals>"; retlbl = new_label () "ginit";
      fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
      frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
      rodata = Buffer.create 64; externs; fns }
  in
  f.xfer_off <- ptmp f;
  List.iter
    (fun (g : Tast.global) ->
       scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0))))
    globals;
  let pb = create () in
  push_r pb rbp;
  mov_rr pb ~dst:rbp ~src:rsp;
  let n = frame_bytes f in
  if n > 0 then sub_imm pb ~dst:rsp n;
  (* No caller hands this one a channel, so it gets a null one of its own. *)
  xor_rr pb ~dst:rax ~src:rax;
  store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8;
  lbl f.b f.retlbl;
  leave f.b;
  ret f.b;
  flush pb; flush f.b;
  let out = Buffer.create 512 in
  Buffer.add_string out
    (Printf.sprintf "\t.type\t%s, @function\n%s:\n" init_sym init_sym);
  Buffer.add_string out (Buffer.contents pb.out);
  Buffer.add_string out (Buffer.contents f.b.out);
  Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" init_sym init_sym);
  Buffer.contents out, Buffer.contents f.rodata

(* ── The program ─────────────────────────────────────────────────────── *)

(* The guard that makes the missing transfer guard sound. [emit.ml] emits a
   check of the channel after every call; this backend emits none, and the
   reason it may is a whole-program one: if nothing in the reachable set can
   ever *write* the channel, no call can ever come back with it set. That is a
   property of the program and not of the backend, so it is checked here rather
   than assumed — and when it fails the build stops with the node that broke
   it rather than running with a guard that is not there. *)
let check_no_transfer (p : Tast.program) =
  let bad what = unsupported "%s needs the transfer channel, which this \
                              backend does not emit a guard for" 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"
     | Tast.WithAlloc _ -> bad "with-allocator"
     | Tast.Prim (Tast.Rt s, _)
       when String.equal s "flan_vec_at" || String.equal s "flan_vec_as_slice" ->
       bad ("(" ^ s ^ ")")
     | _ -> ());
    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 (fn : Tast.fn) -> List.iter ex fn.Tast.body; List.iter ex fn.Tast.fdefers)
    p.Tast.fns;
  List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals

(* A whole program as one assembly file. *)
let program (p : Tast.program) : string =
  check_no_transfer p;
  let md = layout_ctx p in
  let externs = Hashtbl.create 16 in
  List.iter
    (fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
    p.Tast.externs;
  let fns = Hashtbl.create 64 in
  List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fns fn.Tast.name ()) p.Tast.fns;
  let text = Buffer.create 65536 and rodata = Buffer.create 4096 in
  Buffer.add_string text
    "# Generated by flan's x86-64 backend (the dev one). The instructions are\n\
     # .byte blobs so that every byte offset stays exactly known; the few\n\
     # fields that need a relocation are assembler expressions.\n\
     \t.text\n\n";
  List.iter
    (fun (fn : Tast.fn) ->
       let t, r = emit_fn md ~externs ~fns fn in
       Buffer.add_string text t;
       Buffer.add_string rodata r)
    p.Tast.fns;
  let ginit, gr = emit_globals_init md ~externs ~fns p.Tast.globals in
  Buffer.add_string text ginit;
  Buffer.add_string rodata gr;
  (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
   | Some fn -> Buffer.add_string text (emit_main md fn)
   | None -> unsupported "no main");
  let out = Buffer.create 65536 in
  Buffer.add_buffer out text;
  (* The globals' initialiser runs before main, through the same constructor
     slot [emit.ml] uses to arm the allocation registry. *)
  Buffer.add_string out
    (Printf.sprintf "\t.section\t.init_array,\"aw\",@init_array\n\t.align\t8\n\
                     \t.quad\t%s\n\n" init_sym);
  Buffer.add_string out (emit_globals_data md p.Tast.globals);
  Buffer.add_string out "\n\t.section\t.rodata\n";
  Buffer.add_buffer out rodata;
  Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
  Buffer.contents out