flan/lib/emit.ml

(** Typed IR → LLVM IR, as text.

    Text rather than libLLVM bindings, for the reasons in plan.org: the build
    dependency is a clang on PATH instead of a version-pinned libLLVM with C++
    linkage, the output is readable when something is wrong, and an LLVM
    upgrade does not break the compiler. The only thing text loses is the
    in-process JIT, and that was measured at ~13ms — below perception.

    Layout — this is the whole of it, and it is deliberately C's:

    {v
      i8..i64 / u8..u64   i8..i64          signedness lives in the ops
      f32 f64             float double
      bool                i1
      [T] and string      { ptr, i64 }     ptr+len, non-owning
      [n T]               [n x T]          inline, a value
      (Ptr T)             ptr              opaque pointers
      (Option T)          { i8, T }        tag 0 None, 1 Some
      a struct            a literal struct in declaration order
      Unit and Never      {}               zero-sized, one value
    v}

    No object headers anywhere, which is the consequence that drives everything
    (plan.org, Memory) — a Flan struct is exactly its C struct.

    Two things fall out of the layout and are load-bearing:

    - Every slot is an [alloca], so reading a local is a [load] and assigning is
      a [store]. Aggregates are SSA values in LLVM, so a [store] of a struct or
      a fixed array *is* the copy that spec-memory.md requires on assignment,
      and a slice copies its view for the same reason. [addr] of a local is then
      just the alloca. [mem2reg] removes the ones nobody took the address of.
    - A place lowers to a pointer and a value to a load from it, which is the
      split the interpreter would have had to make by hand: [(set (.pos c) ...)]
      through a [(Ptr Cursor)] becomes a [getelementptr] on the pointer, not on
      a copy of the struct. *)

let fail = Loc.fail

(* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
   Emission is all side effect — instructions, calls, branches to a [ret] — so
   left-to-right is required, not a preference. Same rule as in Check. *)
let rec map_lr f = function
  | [] -> []
  | x :: rest -> let y = f x in y :: map_lr f rest

(* ── Names ─────────────────────────────────────────────────────────── *)

(* Flan names contain -, ?, > and /, so every emitted name is quoted. The
   [flan.] prefix keeps the Flan [main] from colliding with C's. *)
let quoted s = "\"" ^ s ^ "\""
let fname n = "@" ^ quoted ("flan." ^ n)
let gname n = "@" ^ quoted ("flan." ^ n)
let sname n = "%" ^ quoted n

(* ── Types ─────────────────────────────────────────────────────────── *)

let rec ll (t : Types.t) =
  match t with
  | Types.Int k -> "i" ^ string_of_int (Types.bits k)
  | Types.Float Types.F32 -> "float"
  | Types.Float Types.F64 -> "double"
  | Types.Bool -> "i1"
  | Types.String | Types.Slice _ -> "%slice"
  | Types.Unit | Types.Never -> "{}"
  | Types.Named n -> sname n
  (* A C enum is an i32 — its own type in the checker, nothing at all here. *)
  | Types.Enum _ -> "i32"
  | Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
  | Types.Ptr _ -> "ptr"
  | Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
  | Types.Map _ | Types.Fn _ | Types.Var _ ->
    (* The checker rejects each of these by name — nothing reaches here. *)
    failwith ("no layout for " ^ Types.to_string t)

let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false

(* ── Module-level state ────────────────────────────────────────────── *)

type m = {
  out     : Buffer.t;
  strs    : Buffer.t;                        (* string literal constants *)
  structs : (string, Tast.structure) Hashtbl.t;
  globals : (string, Types.t) Hashtbl.t;
  (* Flan name -> C symbol, for the foreign functions. A call to one names the
     symbol directly; there is no thunk. *)
  externs : (string, string) Hashtbl.t;
  checks  : bool;                            (* emit bounds checks *)
  mutable nstr : int;
}

let field_ty m sn i =
  let s = Hashtbl.find m.structs sn in
  (List.nth s.Tast.fields i).Tast.fty

(* ── Per-function state ────────────────────────────────────────────── *)

type f = {
  md            : m;
  allocas       : Buffer.t;   (* the entry block: mem2reg only promotes these *)
  b             : Buffer.t;
  mutable n     : int;
  mutable live  : bool;       (* is the current block still open? *)
  ret           : Types.t;
  slots         : string array;
  slot_tys      : Types.t array;
}

let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
let fresh_label f name = f.n <- f.n + 1; Printf.sprintf "%s%d" name f.n

(* Nothing may follow a terminator, so emission after one is dropped: the code
   is unreachable and LLVM would reject it. *)
let ins f fmt =
  Printf.ksprintf (fun s -> if f.live then Buffer.add_string f.b ("  " ^ s ^ "\n")) fmt

let term f fmt =
  Printf.ksprintf
    (fun s -> if f.live then Buffer.add_string f.b ("  " ^ s ^ "\n"); f.live <- false)
    fmt

let label f name =
  Buffer.add_string f.b (Printf.sprintf "\n%s:\n" name);
  f.live <- true

let alloca f ty =
  let name = fresh f in
  Buffer.add_string f.allocas (Printf.sprintf "  %s = alloca %s\n" name (ll ty));
  name

(* ── Constants ─────────────────────────────────────────────────────── *)

(* LLVM's hex form is exact, which decimal is not: a literal must mean the same
   thing after a round trip through the .ll file. *)
let float_const (k : Types.fkind) x =
  let x = match k with Types.F32 -> Int32.float_of_bits (Int32.bits_of_float x)
                     | Types.F64 -> x in
  Printf.sprintf "0x%Lx" (Int64.bits_of_float x)

let escape s =
  let b = Buffer.create (String.length s + 8) in
  String.iter
    (fun c ->
       if c = '"' || c = '\\' || Char.code c < 0x20 || Char.code c > 0x7e then
         Buffer.add_string b (Printf.sprintf "\\%02X" (Char.code c))
       else Buffer.add_char b c)
    s;
  Buffer.contents b

(* The constant itself, as the pointer and length a caller needs separately —
   a bounds message crosses to C as ptr+len like any other slice. *)
let string_bytes m s =
  let id = Printf.sprintf "@\".str.%d\"" m.nstr in
  m.nstr <- m.nstr + 1;
  Buffer.add_string m.strs
    (Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
       id (String.length s) (escape s));
  id, String.length s

let string_const m s =
  let id, n = string_bytes m s in
  (* The value alone: LLVM takes the type from the operand's context. *)
  Printf.sprintf "{ ptr %s, i64 %d }" id n

(* ── Bounds checks ───────────────────────────────────────────────────── *)

(* A failure is a branch to a [noreturn] call and then [unreachable] — the same
   explicit shape as [return] and [some], so wasm32 needs no unwinding for it
   either. Whether to check is its own flag, not the optimisation level: dev
   builds trap, release builds do not (NEXT.md), and the acceptance table runs
   at both -O0 and -O2 with the checks on either way.

   Indices are i32 in Flan and sign-extended to i64 for the gep, so a negative
   one arrives here as a huge unsigned value: an unsigned comparison catches
   the negative and the too-large case in a single test. *)
let fail_block f (loc : Loc.t) ok emit_call =
  let good = fresh_label f "inb" and bad = fresh_label f "oob" in
  term f "br i1 %s, label %%%s, label %%%s" ok good bad;
  label f bad;
  let id, n = string_bytes f.md (Loc.to_string loc) in
  emit_call id n;
  term f "unreachable";
  label f good

(* [at] is strict: the last valid index is len - 1. *)
let check_at f loc idx len =
  if f.md.checks then begin
    let ok = fresh f in
    ins f "%s = icmp ult i64 %s, %s" ok idx len;
    fail_block f loc ok (fun id n ->
      ins f "call void @flan_bounds_fail(ptr %s, i64 %d, i64 %s, i64 %s)"
        id n idx len)
  end

(* [slice] is not: a slice ending at len — or an empty one at lo = len — is
   legal, and its one-past-the-end gep is defined. [lo <= hi] is not redundant
   with it, because a reversed range would otherwise yield hi - lo as a huge
   unsigned length, which is a worse hole than the missing check. *)
let check_slice f loc lo hi len =
  if f.md.checks then begin
    let a = fresh f in
    ins f "%s = icmp ule i64 %s, %s" a lo hi;
    let b = fresh f in
    ins f "%s = icmp ule i64 %s, %s" b hi len;
    let ok = fresh f in
    ins f "%s = and i1 %s, %s" ok a b;
    fail_block f loc ok (fun id n ->
      ins f "call void @flan_slice_fail(ptr %s, i64 %d, i64 %s, i64 %s, i64 %s)"
        id n lo hi len)
  end

(* ── Expressions ───────────────────────────────────────────────────── *)

let icmp_op signed = function
  | Tast.Eq -> "eq" | Tast.Ne -> "ne"
  | Tast.Lt -> if signed then "slt" else "ult"
  | Tast.Le -> if signed then "sle" else "ule"
  | Tast.Gt -> if signed then "sgt" else "ugt"
  | Tast.Ge -> if signed then "sge" else "uge"
  | _ -> assert false

let fcmp_op = function
  | Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt"
  | Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
  | _ -> assert false

let rec value f (e : Tast.expr) : string =
  match e.Tast.e with
  | Tast.Int (n, _) -> Int64.to_string n
  | Tast.Float (x, k) -> float_const k x
  | Tast.Bool b -> if b then "true" else "false"
  | Tast.Str s -> string_const f.md s
  | Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
  | Tast.Uninit _ -> "poison"
  | Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
    (* Everything that denotes a location is a load from its address. *)
    load f (addr f e) e.Tast.ty
  | Tast.Addr p -> fst (place f p)
  | Tast.Prim (p, args) -> prim f e p args
  | Tast.Call (name, args) ->
    (match Hashtbl.find_opt f.md.externs name with
     | Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
     | None -> call f e.Tast.ty (fname name) args)
  | Tast.Do body -> block f body
  | Tast.Let (bs, body) ->
    List.iter
      (fun (slot, v) ->
         let v' = value f v in
         ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot))
      bs;
    block f body
  | Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
  | Tast.While (c, body) -> emit_while f c body; "zeroinitializer"
  | Tast.Return v ->
    (match v with
     | None -> term f "ret %s zeroinitializer" (ll f.ret)
     | Some v ->
       let v' = value f v in
       term f "ret %s %s" (ll f.ret) v');
    "zeroinitializer"
  | Tast.Set (p, v) ->
    let ptr, ty = place f p in
    let v' = value f v in
    ins f "store %s %s, ptr %s" (ll ty) v' ptr;
    "zeroinitializer"
  | Tast.Make (_, fields) -> aggregate f e.Tast.ty fields
  | Tast.Arr items -> aggregate f e.Tast.ty items
  | Tast.Some_ v ->
    let v' = value f v in
    let t = ll e.Tast.ty in
    let a = fresh f in
    ins f "%s = insertvalue %s zeroinitializer, i8 1, 0" a t;
    let b = fresh f in
    ins f "%s = insertvalue %s %s, %s %s, 1" b t a (ll v.Tast.ty) v';
    b
  | Tast.Match (s, arms) -> emit_match f e.Tast.ty s arms
  | Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v

and load f ptr ty =
  let t = fresh f in
  ins f "%s = load %s, ptr %s" t (ll ty) ptr;
  t

(* The address of an expression that denotes a location. Anything else is
   spilled to a temporary first, so [(at (f) 0)] on a returned array works. *)
and addr f (e : Tast.expr) : string =
  match e.Tast.e with
  | Tast.Local i -> f.slots.(i)
  | Tast.Global n -> gname n
  | Tast.Deref p -> value f p
  | Tast.Field (target, i) -> field_addr f target i
  | Tast.Prim (Tast.At, target :: idx) -> fst (element_addr f target idx)
  | _ ->
    let tmp = alloca f e.Tast.ty in
    let v = value f e in
    ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
    tmp

and field_addr f (target : Tast.expr) i =
  let base = addr f target in
  let sn = match target.Tast.ty with
    | Types.Named n -> n
    | t -> failwith ("field of " ^ Types.to_string t)
  in
  let p = fresh f in
  ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p (sname sn) base i;
  p

(* One index per dimension, so [(at grid row col)] is two geps. Indices are
   i32 in Flan and i64 in a gep. *)
and element_addr f (target : Tast.expr) idx =
  let rec go ptr ty = function
    | [] -> ptr, ty
    | (i : Tast.expr) :: rest ->
      let iv = value f i in
      let i64 = fresh f in
      ins f "%s = sext %s %s to i64" i64 (ll i.Tast.ty) iv;
      (match ty with
       | Types.Array (n, elem) ->
         (* The bound is static; LLVM folds the check away for a literal index. *)
         check_at f i.Tast.loc i64 (Int64.to_string n);
         let p = fresh f in
         ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
           p (ll ty) ptr i64;
         go p elem rest
       | Types.Slice elem ->
         (* A slice is ptr+len, so step through the pointer it holds. *)
         let s = load f ptr ty in
         let base = fresh f in
         ins f "%s = extractvalue %%slice %s, 0" base s;
         let len = fresh f in
         ins f "%s = extractvalue %%slice %s, 1" len s;
         check_at f i.Tast.loc i64 len;
         let p = fresh f in
         ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
         go p elem rest
       | t -> failwith ("index into " ^ Types.to_string t))
  in
  go (addr f target) target.Tast.ty idx

and place f (p : Tast.place) : string * Types.t =
  match p with
  | Tast.Plocal i -> f.slots.(i), f.slot_tys.(i)
  | Tast.Pglobal n -> gname n, Hashtbl.find f.md.globals n
  | Tast.Pfield (target, i) ->
    let sn = match target.Tast.ty with
      | Types.Named n -> n | t -> failwith ("field of " ^ Types.to_string t)
    in
    field_addr f target i, field_ty f.md sn i
  | Tast.Pindex (target, idx) -> element_addr f target idx
  | Tast.Pderef target ->
    let t = match target.Tast.ty with
      | Types.Ptr t -> t | t -> failwith ("deref of " ^ Types.to_string t)
    in
    value f target, t
  | Tast.Pkey _ -> failwith "Map places are milestone 6"

(* A struct or fixed-array value, built field by field from zeroinitializer.
   The checker already filled the omitted fields in with Zero, so this is
   simply every field in declaration order. *)
and aggregate f ty parts =
  let t = ll ty in
  let acc = ref "zeroinitializer" in
  List.iteri
    (fun i (p : Tast.expr) ->
       let v = value f p in
       let next = fresh f in
       ins f "%s = insertvalue %s %s, %s %s, %d" next t !acc (ll p.Tast.ty) v i;
       acc := next)
    parts;
  !acc

and block f body =
  match body with
  | [] -> "zeroinitializer"
  | _ ->
    let last = ref "zeroinitializer" in
    List.iter (fun e -> last := value f e) body;
    !last

and call f ret name args =
  let vs = map_lr (fun (a : Tast.expr) ->
    let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
  let t = fresh f in
  ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
  t

(* A foreign call, where the same rule applies as to the runtime shims: a slice
   or a string crosses as ptr+len and never as a struct by value. Every other
   argument type is a scalar, because [check.ml] rejects an extern signature
   that would need an aggregate — that is the shim's job, in C, where clang
   knows the target's calling convention. *)
and extern_call f ret name args =
  let vs =
    List.concat_map
      (fun (a : Tast.expr) ->
         match a.Tast.ty with
         | Types.String | Types.Slice _ ->
           let p, n = explode f a in
           [ Printf.sprintf "ptr %s" p; Printf.sprintf "i64 %s" n ]
         | ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
      args
  in
  if is_void ret then begin
    ins f "call void %s(%s)" name (String.concat ", " vs);
    "zeroinitializer"
  end else begin
    let t = fresh f in
    ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
    t
  end

and emit_if f ty c t e =
  let cv = value f c in
  let lt = fresh_label f "then" and le = fresh_label f "else"
  and ld = fresh_label f "endif" in
  let result = if is_void ty then None else Some (alloca f ty) in
  term f "br i1 %s, label %%%s, label %%%s" cv lt le;
  let arm lbl (branch : Tast.expr) =
    label f lbl;
    let v = value f branch in
    (match result with
     | Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
     | _ -> ());
    let reached = f.live in
    term f "br label %%%s" ld;
    reached
  in
  let a = arm lt t in
  let b = arm le e in
  if not (a || b) then begin
    (* Both branches diverge, so there is no join: nothing follows. *)
    f.live <- false;
    "zeroinitializer"
  end else begin
    label f ld;
    match result with Some r -> load f r ty | None -> "zeroinitializer"
  end

and emit_while f c body =
  let lc = fresh_label f "loop" and lb = fresh_label f "body"
  and le = fresh_label f "endloop" in
  term f "br label %%%s" lc;
  label f lc;
  let cv = value f c in
  term f "br i1 %s, label %%%s, label %%%s" cv lb le;
  label f lb;
  List.iter (fun e -> ignore (value f e)) body;
  term f "br label %%%s" lc;
  label f le

and emit_match f ty scrut arms =
  let sv = value f scrut in
  let sty = ll scrut.Tast.ty in
  let tag = fresh f in
  ins f "%s = extractvalue %s %s, 0" tag sty sv;
  let payload_ty = match scrut.Tast.ty with
    | Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
  in
  let ld = fresh_label f "endmatch" in
  let result = if is_void ty then None else Some (alloca f ty) in
  let reached = ref false in
  let rec go = function
    | [] -> term f "unreachable"       (* the checker proved exhaustiveness *)
    | (a : Tast.arm) :: rest ->
      let lb = fresh_label f "arm" and ln = fresh_label f "next" in
      (match a.Tast.acase with
       | None -> term f "br label %%%s" lb
       | Some c ->
         let want = if c = "Some" then 1 else 0 in
         let t = fresh f in
         ins f "%s = icmp eq i8 %s, %d" t tag want;
         term f "br i1 %s, label %%%s, label %%%s" t lb ln);
      label f lb;
      List.iter
        (fun slot ->
           let v = fresh f in
           ins f "%s = extractvalue %s %s, 1" v sty sv;
           ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot))
        a.Tast.binds;
      let v = block f a.Tast.abody in
      (match result with
       | Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
       | _ -> ());
      if f.live then reached := true;
      term f "br label %%%s" ld;
      if a.Tast.acase <> None then begin label f ln; go rest end
  in
  go arms;
  if not !reached then begin f.live <- false; "zeroinitializer" end
  else begin
    label f ld;
    match result with Some r -> load f r ty | None -> "zeroinitializer"
  end

(* (some x): unwrap Some, else return None from the enclosing function. The
   early return is explicit — a branch to a ret, not platform unwinding, so
   native and wasm32 do the same thing (plan.org, Compilation). *)
and emit_unwrap f ty v =
  let ov = value f v in
  let oty = ll v.Tast.ty in
  let tag = fresh f in
  ins f "%s = extractvalue %s %s, 0" tag oty ov;
  let isnone = fresh f in
  ins f "%s = icmp eq i8 %s, 0" isnone tag;
  let ln = fresh_label f "none" and lc = fresh_label f "some" in
  term f "br i1 %s, label %%%s, label %%%s" isnone ln lc;
  label f ln;
  term f "ret %s zeroinitializer" (ll f.ret);
  label f lc;
  let out = fresh f in
  ins f "%s = extractvalue %s %s, 1" out oty ov;
  ignore ty;
  out

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

and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
  match p, args with
  | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
    let a = value f x in
    let b = value f y in
    let op = match x.Tast.ty, p with
      | Types.Float _, Tast.Add -> "fadd" | Types.Float _, Tast.Sub -> "fsub"
      | Types.Float _, Tast.Mul -> "fmul" | Types.Float _, Tast.Div -> "fdiv"
      | Types.Float _, _ -> "frem"
      | Types.Int _, Tast.Add -> "add" | Types.Int _, Tast.Sub -> "sub"
      | Types.Int _, Tast.Mul -> "mul"
      | Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
      | Types.Int k, _ -> if Types.signed k then "srem" else "urem"
      | t, _ -> failwith ("arithmetic on " ^ Types.to_string t)
    in
    let t = fresh f in
    (* No nsw/nuw: arithmetic wraps (plan.org, Types). *)
    ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
    t
  | (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
    let a = value f x in
    let b = value f y in
    let t = fresh f in
    (match x.Tast.ty with
     | Types.Float _ ->
       ins f "%s = fcmp %s %s %s, %s" t (fcmp_op p) (ll x.Tast.ty) a b
     | Types.Int k ->
       ins f "%s = icmp %s %s %s, %s" t (icmp_op (Types.signed k) p)
         (ll x.Tast.ty) a b
     | t' -> failwith ("comparison on " ^ Types.to_string t'));
    t
  | (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
    let a = value f x in
    let b = value f y in
    let op = match x.Tast.ty, p with
      | _, Tast.BitAnd -> "and" | _, Tast.BitOr -> "or"
      | _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
      | Types.Int k, _ -> if Types.signed k then "ashr" else "lshr"
      | t, _ -> failwith ("bitwise on " ^ Types.to_string t)
    in
    let t = fresh f in
    ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
    t
  | Tast.Not, [ x ] ->
    let a = value f x in
    let t = fresh f in
    ins f "%s = xor i1 %s, true" t a;
    t
  | Tast.Len, [ x ] ->
    (match x.Tast.ty with
     | Types.Array (n, _) -> Int64.to_string n
     | _ ->
       let v = value f x in
       let n = fresh f in
       ins f "%s = extractvalue %%slice %s, 1" n v;
       let t = fresh f in
       ins f "%s = trunc i64 %s to i32" t n;
       t)
  | Tast.At, target :: idx ->
    let p, elem = element_addr f target idx in
    load f p elem
  | Tast.Slice, [ target; lo; hi ] ->
    (* lo is evaluated once and used twice — as the offset and as part of the
       length — so it must not be emitted twice. *)
    let lov = value f lo in
    let hiv = value f hi in
    let lo64 = fresh f in
    ins f "%s = sext i32 %s to i64" lo64 lov;
    let hi64 = fresh f in
    ins f "%s = sext i32 %s to i64" hi64 hiv;
    (* The source is read once, and the check goes between reading it and the
       gep: the length it is checked against must be the one the gep uses. *)
    let base =
      match target.Tast.ty with
      | Types.Array (n, _) ->
        let a = addr f target in
        check_slice f e.Tast.loc lo64 hi64 (Int64.to_string n);
        let p = fresh f in
        ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
          p (ll target.Tast.ty) a lo64;
        p
      | Types.Slice elem ->
        let v = value f target in
        let q = fresh f in
        ins f "%s = extractvalue %%slice %s, 0" q v;
        let n = fresh f in
        ins f "%s = extractvalue %%slice %s, 1" n v;
        check_slice f e.Tast.loc lo64 hi64 n;
        let p = fresh f in
        ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) q lo64;
        p
      | Types.String ->
        let v = value f target in
        let q = fresh f in
        ins f "%s = extractvalue %%slice %s, 0" q v;
        let n = fresh f in
        ins f "%s = extractvalue %%slice %s, 1" n v;
        check_slice f e.Tast.loc lo64 hi64 n;
        let p = fresh f in
        ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
        p
      | t -> failwith ("slice of " ^ Types.to_string t)
    in
    let d = fresh f in
    ins f "%s = sub i64 %s, %s" d hi64 lo64;
    let a = fresh f in
    ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a base;
    let b = fresh f in
    ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a d;
    b
  (* string and [u8] have the same layout, so bytes is the identity — a view,
     no copy (plan.org, Milestone-2 primitives). *)
  | Tast.Bytes, [ x ] -> value f x
  | Tast.BytesToF64, [ x ] -> shim_in f "@flan_bytes_to_f64" "double" x
  | Tast.BytesToI64, [ x ] -> shim_in f "@flan_bytes_to_i64" "i64" x
  | Tast.F64ToBytes, [ x ] -> shim_out f "@flan_f64_to_bytes" x
  | Tast.I64ToBytes, [ x ] -> shim_out f "@flan_i64_to_bytes" x
  | Tast.WriteStdout, [ x ] ->
    let p, n = explode f x in
    ins f "call void @flan_write_stdout(ptr %s, i64 %s)" p n;
    "zeroinitializer"
  | Tast.Exit, [ x ] ->
    let v = value f x in
    ins f "call void @flan_exit(i32 %s)" v;
    term f "unreachable";
    "zeroinitializer"
  | Tast.Argv, [] ->
    let tmp = alloca f (Types.Slice Types.String) in
    ins f "call void @flan_argv(ptr %s)" tmp;
    load f tmp (Types.Slice Types.String)
  | Tast.Cast target, [ x ] -> cast f x target
  | _ -> failwith "malformed primitive"

(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
and explode f (x : Tast.expr) =
  let v = value f x in
  let p = fresh f in
  ins f "%s = extractvalue %%slice %s, 0" p v;
  let n = fresh f in
  ins f "%s = extractvalue %%slice %s, 1" n v;
  p, n

and shim_in f name ret x =
  let p, n = explode f x in
  let t = fresh f in
  ins f "%s = call %s %s(ptr %s, i64 %s)" t ret name p n;
  t

and shim_out f name (x : Tast.expr) =
  let v = value f x in
  let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
  ins f "call void %s(%s %s, ptr %s)" name (ll x.Tast.ty) v tmp;
  load f tmp (Types.Slice (Types.Int Types.U8))

and cast f (x : Tast.expr) target =
  let v = value f x in
  let src = x.Tast.ty in
  if Types.equal src target then v
  else
    let op =
      match src, target with
      | Types.Int a, Types.Int b ->
        if Types.bits b < Types.bits a then "trunc"
        else if Types.bits b = Types.bits a then "bitcast"
        else if Types.signed a then "sext" else "zext"
      | Types.Int a, Types.Float _ -> if Types.signed a then "sitofp" else "uitofp"
      | Types.Float _, Types.Int b -> if Types.signed b then "fptosi" else "fptoui"
      | Types.Float a, Types.Float b ->
        if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc"
      | _ -> failwith "unsupported cast"
    in
    if op = "bitcast" then v
    else begin
      let t = fresh f in
      ins f "%s = %s %s %s to %s" t op (ll src) v (ll target);
      t
    end

(* ── Functions ─────────────────────────────────────────────────────── *)

let emit_fn m (fn : Tast.fn) =
  let n = Array.length fn.Tast.slots in
  let f = {
    md = m;
    allocas = Buffer.create 256;
    b = Buffer.create 1024;
    n = 0;
    live = true;
    ret = fn.Tast.ret;
    slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
    slot_tys = fn.Tast.slots;
  } in
  (* Every slot is an alloca in the entry block, because [addr] may take the
     address of any of them and mem2reg only promotes entry-block allocas. *)
  Array.iteri
    (fun i ty ->
       Buffer.add_string f.allocas
         (Printf.sprintf "  %s = alloca %s\n" f.slots.(i) (ll ty)))
    fn.Tast.slots;
  (* Parameters arrive as SSA values and are stored into their slots at once,
     which is also the copy a value struct gets on assignment. *)
  List.iteri
    (fun i ty ->
       Buffer.add_string f.allocas
         (Printf.sprintf "  store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
    fn.Tast.params;
  let last = ref "zeroinitializer" in
  List.iter (fun e -> last := value f e) fn.Tast.body;
  (* A Unit function's body may end on a form of any type — the value is
     discarded, so the return is the Unit constant rather than that value. *)
  if Types.equal fn.Tast.ret Types.Unit then last := "zeroinitializer";
  term f "ret %s %s" (ll fn.Tast.ret) !last;
  let params =
    List.mapi (fun i ty -> Printf.sprintf "%s %%p%d" (ll ty) i) fn.Tast.params
  in
  Buffer.add_string m.out
    (Printf.sprintf "\ndefine %s %s(%s) {\nentry:\n%s%s}\n"
       (ll fn.Tast.ret) (fname fn.Tast.name) (String.concat ", " params)
       (Buffer.contents f.allocas) (Buffer.contents f.b))

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

(* A global's initialiser is a compile-time constant: literals live in
   read-only memory and zeroed globals live in BSS and cost nothing to start
   (plan.org, Data model). There is no init-at-startup path, by design. *)
let rec const m (e : Tast.expr) =
  match e.Tast.e with
  | Tast.Int (n, _) -> Int64.to_string n
  | Tast.Float (x, k) -> float_const k x
  | Tast.Bool b -> if b then "true" else "false"
  | Tast.Str s -> string_const m s
  | Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
  | Tast.Uninit _ -> "poison"
  | Tast.Make (_, parts) | Tast.Arr parts ->
    let inner =
      map_lr (fun (p : Tast.expr) ->
        Printf.sprintf "%s %s" (ll p.Tast.ty) (const m p)) parts
    in
    (match e.Tast.ty with
     | Types.Array _ -> "[" ^ String.concat ", " inner ^ "]"
     | _ -> "{ " ^ String.concat ", " inner ^ " }")
  | Tast.Some_ v ->
    Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m v)
  | _ ->
    fail e.Tast.loc
      "a global's value must be a compile-time constant — this one is computed"

let emit_global m (g : Tast.global) =
  Buffer.add_string m.out
    (Printf.sprintf "%s = %s %s %s\n" (gname g.Tast.gname)
       (if g.Tast.gconst then "constant" else "global")
       (ll g.Tast.gty) (const m g.Tast.ginit))

(* ── Program ───────────────────────────────────────────────────────── *)

let header = {|; Generated by flan. The layout is C's: no object headers anywhere,
; so a Flan struct is exactly its C struct and nothing marshals.

%slice = type { ptr, i64 }

declare void @flan_rt_init(i32, ptr)
declare void @flan_argv(ptr)
declare void @flan_write_stdout(ptr, i64)
declare void @flan_exit(i32)
declare double @flan_bytes_to_f64(ptr, i64)
declare i64 @flan_bytes_to_i64(ptr, i64)
declare void @flan_f64_to_bytes(double, ptr)
declare void @flan_i64_to_bytes(i64, ptr)
declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold
declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold
|}

(* C's main, adapting to whichever of the four shapes Flan's main has: argv and
   the i32 status are each optional (plan.org, Milestone-2 primitives). *)
let emit_main m (fn : Tast.fn) =
  let b = Buffer.create 256 in
  Buffer.add_string b "\ndefine i32 @main(i32 %argc, ptr %argv) {\nentry:\n";
  Buffer.add_string b "  call void @flan_rt_init(i32 %argc, ptr %argv)\n";
  let args =
    if fn.Tast.params = [] then ""
    else begin
      Buffer.add_string b "  %a = alloca %slice\n";
      Buffer.add_string b "  call void @flan_argv(ptr %a)\n";
      Buffer.add_string b "  %args = load %slice, ptr %a\n";
      "%slice %args"
    end
  in
  Buffer.add_string b
    (Printf.sprintf "  %%r = call %s %s(%s)\n" (ll fn.Tast.ret)
       (fname "main") args);
  (* Flushing matters: stdout is a FILE* and the acceptance test reads it. *)
  Buffer.add_string b "  call void @flan_exit(i32 ";
  Buffer.add_string b
    (if Types.equal fn.Tast.ret (Types.Int Types.I32) then "%r" else "0");
  Buffer.add_string b ")\n  unreachable\n}\n";
  Buffer.add_string m.out (Buffer.contents b)

(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
   [slice], a release build is told to drop them. *)
let program ?(checks = true) (p : Tast.program) : string =
  let m = {
    out = Buffer.create 8192; strs = Buffer.create 512;
    structs = Hashtbl.create 16; globals = Hashtbl.create 16;
    externs = Hashtbl.create 32;
    checks; nstr = 0;
  } in
  List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
    p.Tast.structs;
  List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
    p.Tast.globals;
  List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym)
    p.Tast.externs;
  List.iter
    (fun (s : Tast.structure) ->
       Buffer.add_string m.out
         (Printf.sprintf "%s = type { %s }\n" (sname s.Tast.sname)
            (String.concat ", "
               (List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
    p.Tast.structs;
  Buffer.add_char m.out '\n';
  (* The foreign declarations. Every struct that crosses this boundary was
     flattened by a C shim, so each of these is scalars only and no calling
     convention has to be reproduced here. *)
  List.iter
    (fun (e : Tast.extern) ->
       Buffer.add_string m.out
         (Printf.sprintf "declare %s @%s(%s)\n"
            (ll e.Tast.eret) e.Tast.esym
            (String.concat ", "
               (List.concat_map
                  (fun (t : Types.t) ->
                     match t with
                     | Types.String | Types.Slice _ -> [ "ptr"; "i64" ]
                     | t -> [ ll t ])
                  e.Tast.eparams))))
    p.Tast.externs;
  if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
  List.iter (emit_global m) p.Tast.globals;
  List.iter (emit_fn m) p.Tast.fns;
  (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
   | Some fn -> emit_main m fn
   | None -> ());
  header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out