(** 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

(* A dev build's redefinable calls go through a cell: a mutable global holding
   the address of the function that is current. Redefinition is then one store,
   and every existing call site follows it — which is the whole point, since a
   call bound at link time cannot be made to notice a new body. Release builds
   have no cells and call the symbol directly. *)
let cellname n = "@" ^ quoted ("flan.cell." ^ n)

(* A name the host was never built with — a defn or a defvar typed in after the
   process started — has no symbol to bind to, so it is keyed by string through
   [flan_dev_cell] / [flan_dev_global] and the answer is cached in one of these
   module-local slots. One indirection more than a name the host has, which is
   why the compiler picks per name rather than routing everything this way. *)
(* The transfer channel's parameter, the one name that is not a Flan name. It
   is not a slot: nothing in the language can address it, and it is read and
   written only by the guards this file emits. *)
let xfer_param = "%xfer"

(* The condition's own name, for the message an unhandled [error] prints. The
   checker has already refused anything that is not a struct. *)
let struct_name_of (t : Types.t) =
  match t with Types.Named n -> n | _ -> "a condition"

let cellptr n = "@" ^ quoted ("flan.cellp." ^ n)
let globalptr n = "@" ^ quoted ("flan.gp." ^ 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"
  (* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a
     copy of one: see Types. Opaque here in the same sense [ptr] is. *)
  | Types.Alloc -> "ptr"
  (* ptr + len + cap + allocator, and two more words the runtime owns: see
     flan_rt.c's (Vec T) header for why they are in every build. Nothing in
     this file reads a field of one — every operation is a runtime call taking
     the Vec's address — so the shape is here only so that a slot, a struct
     field and a copy in the IR are the right number of bytes. *)
  | Types.Vec _ -> "%vec"
  | 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

(* -- Debug info ----------------------------------------------------- *)

(* DWARF, as LLVM metadata. This is only worth the lines it takes because of
   the layout above: a Flan struct *is* its C struct, every slot is an alloca
   and there are no tag words, so the debug info describes machine types
   directly and lldb has to learn nothing about Flan. The compile unit says
   DW_LANG_C99 for that reason -- it is less a claim about the source language
   than the truth about the data model, and it is what makes lldb's own
   struct-printing correct here.

   Metadata is a flat numbered pool with no ordering requirement, so a node can
   be allocated an id, referred to, and written out later -- which is what
   makes a recursive struct (a field of type [(Ptr Self)]) expressible. *)

type dbg = {
  mutable dn : int;                          (* next metadata id *)
  dout       : Buffer.t;                     (* the [!N = ...] lines *)
  dfiles     : (string, int) Hashtbl.t;      (* path -> !DIFile *)
  dtys       : (string, int) Hashtbl.t;      (* Types.to_string -> a type node *)
  dlocs      : (string, int) Hashtbl.t;      (* scope:line:col -> !DILocation *)
  mutable dcu : int;
}

let dalloc d = let n = d.dn in d.dn <- n + 1; n

let dput d n body = Buffer.add_string d.dout (Printf.sprintf "!%d = %s\n" n body)

let dnode d body = let n = dalloc d in dput d n body; n

(* Metadata strings are C strings in the .ll grammar, so the two characters
   that could end one have to be escaped. Flan names contain - ? > and /, none
   of which do. *)
let dstr s =
  let b = Buffer.create (String.length s + 2) in
  String.iter
    (fun c ->
       if c = '"' || c = '\\' then (Buffer.add_char b '\\'; Buffer.add_char b c)
       else Buffer.add_char b c)
    s;
  Buffer.contents b

let dfile d path =
  match Hashtbl.find_opt d.dfiles path with
  | Some n -> n
  | None ->
    let abs =
      if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path
    in
    let n =
      dnode d
        (Printf.sprintf "!DIFile(filename: \"%s\", directory: \"%s\")"
           (dstr (Filename.basename abs)) (dstr (Filename.dirname abs)))
    in
    Hashtbl.replace d.dfiles path n;
    n

(* -- Layout ----------------------------------------------------------
   DWARF wants member offsets as integer literals: [!DIDerivedType(tag:
   DW_TAG_member, offset: N)] takes a constant and nothing else, so the
   [ptrtoint (ptr getelementptr ...)] form this file uses elsewhere for a size
   is not accepted there and these have to be computed. That makes this the one
   place in the backend where a layout number is worked out rather than handed
   to LLVM, and it is exactly where a wrong answer shows up as a plausible
   value printed for the wrong field. So the acceptance test checks every
   offset against LLVM's own [getelementptr] answer for the same struct type,
   not against a table written by the same hand as the code.

   The rules are C's, which is what LLVM gives a non-packed literal struct:
   natural alignment, each member at the next aligned offset, tail padding out
   to the struct's own alignment. The numbers are the host's -- [ptr] is 8
   bytes -- which is why [Build] refuses a debug build for wasm32. *)

let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a

(* ── 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 *)
  dev     : bool;                            (* call through cells (below) *)
  (* Was this name in the build the running process came from? False only in a
     redefinition module, and only for a name introduced since. *)
  known   : string -> bool;
  (* [Some] in a debug build. It lives on the module rather than being passed
     down because every emitter that can produce an instruction has to be able
     to hang a location on it. *)
  dbg     : dbg option;
  (* True in a sanitized build, and the whole of what ASan needs from us.
     AddressSanitizer is an LLVM *pass*, but it instruments only functions
     carrying the [sanitize_address] attribute — which clang's C frontend adds
     and nothing adds to IR written by hand. Passing -fsanitize=address to the
     clang run over this .ll therefore instruments the runtime's C and not one
     instruction of Flan; measured, not assumed (see NEXT.md). So every
     [define] here names attribute group #0 and [finish] writes it out.

     There is no equivalent for UndefinedBehaviorSanitizer: its checks are
     emitted by the C frontend as branches to __ubsan_handle_*, and no
     attribute asks a pass to produce them. UBSan over this .ll covers the C
     and nothing else. *)
  sanitize : bool;
  mutable nstr : int;
  (* The frame descriptors a dev build's shadow stack points at, counted apart
     from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
     whether an expression thunk's module may be unloaded — a string literal in
     the module image is something the program may still be pointing at after
     the thunk returns. A frame descriptor is not: the frames that named it
     were popped on the way out, and the break loop copies the bytes it shows
     rather than keeping the pointer. Counting these in [nstr] would silently
     stop every C-x C-e module from ever being unloaded. *)
  mutable nfi : int;
}

(* The attribute group every emitted function names, empty unless sanitizing.
   Spelled once so the [define] sites and [finish] cannot disagree. *)
let attrs m = if m.sanitize then " #0" else ""

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

(* Size and alignment in bytes. *)
let rec lay m (t : Types.t) : int * int =
  match t with
  | Types.Int k -> let n = Types.bits k / 8 in n, n
  | Types.Float Types.F32 -> 4, 4
  | Types.Float Types.F64 -> 8, 8
  (* [i1] occupies a byte in memory. *)
  | Types.Bool -> 1, 1
  | Types.String | Types.Slice _ -> 16, 8
  | Types.Unit | Types.Never -> 0, 1
  | Types.Enum _ -> 4, 4
  | Types.Ptr _ -> 8, 8
  | Types.Alloc -> 8, 8
  | Types.Vec _ -> 48, 8
  (* [n x T] adds no padding of its own: T's size already carries its tail. *)
  | Types.Array (n, e) -> let s, a = lay m e in Int64.to_int n * s, a
  | Types.Option e -> let s, a, _ = lay_fields m [ Types.Int Types.I8; e ] in s, a
  | Types.Named n ->
    (match Hashtbl.find_opt m.structs n with
     | Some st ->
       let s, a, _ =
         lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields)
       in
       s, a
     | None -> failwith ("no layout for struct " ^ n))
  | Types.Map _ | Types.Fn _ | Types.Var _ ->
    failwith ("no layout for " ^ Types.to_string t)

(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
  let off = ref 0 and al = ref 1 and rev = ref [] in
  List.iter
    (fun t ->
       let s, a = lay m t in
       let a = if a < 1 then 1 else a in
       off := align_up !off a;
       rev := !off :: !rev;
       off := !off + s;
       if a > !al then al := a)
    tys;
  align_up !off !al, !al, List.rev !rev

(* A DWARF type node for a Flan type, memoised by the type's printed form so
   the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int =
  let key = Types.to_string t in
  match Hashtbl.find_opt d.dtys key with
  | Some n -> n
  | None ->
    let basic name bits enc =
      dnode d
        (Printf.sprintf "!DIBasicType(name: \"%s\", size: %d, encoding: %s)"
           (dstr name) bits enc)
    in
    (* A struct-shaped node, with its id claimed before the members are built:
       a field of type [(Ptr Self)] comes back through here. *)
    let composite name members =
      let id = dalloc d in
      Hashtbl.replace d.dtys key id;
      let size, al, offs = lay_fields m (List.map snd members) in
      let ms =
        List.map2
          (fun (mname, mty) off ->
             let fs, fa = lay m mty in
             let base = dty m d mty in
             dnode d
               (Printf.sprintf
                  "!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: %d)"
                  (dstr mname) base (fs * 8) (fa * 8) (off * 8)))
          members offs
      in
      dput d id
        (Printf.sprintf
           "!DICompositeType(tag: DW_TAG_structure_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
           (dstr name) (size * 8) (al * 8)
           (String.concat ", " (List.map (fun i -> Printf.sprintf "!%d" i) ms)));
      id
    in
    let n =
      match t with
      | Types.Int k ->
        (* DW_ATE_signed / DW_ATE_unsigned, not the _char variants: an i8 is a
           number in Flan, and lldb prints a character for a char. *)
        basic (Types.to_string t) (Types.bits k)
          (if Types.signed k then "DW_ATE_signed" else "DW_ATE_unsigned")
      | Types.Float k -> basic (Types.to_string t) (Types.bits_f k) "DW_ATE_float"
      | Types.Bool -> basic "bool" 8 "DW_ATE_boolean"
      | Types.Enum e -> basic e 32 "DW_ATE_signed"
      | Types.Unit | Types.Never -> composite (Types.to_string t) []
      | Types.Ptr e ->
        let id = dalloc d in
        Hashtbl.replace d.dtys key id;
        (* [(Ptr Unit)] and [(Ptr Never)] are the opaque pointer, and a DWARF
           pointer with no base type is exactly C's void *. *)
        let base =
          match e with
          | Types.Unit | Types.Never -> "null"
          | e -> Printf.sprintf "!%d" (dty m d e)
        in
        dput d id
          (Printf.sprintf
             "!DIDerivedType(tag: DW_TAG_pointer_type, baseType: %s, size: 64)" base);
        id
      | Types.Array (n, e) ->
        let base = dty m d e in
        let size, al = lay m t in
        let sub = dnode d (Printf.sprintf "!DISubrange(count: %Ld)" n) in
        dnode d
          (Printf.sprintf
             "!DICompositeType(tag: DW_TAG_array_type, baseType: !%d, size: %d, align: %d, elements: !{!%d})"
             base (size * 8) (al * 8) sub)
      (* ptr+len, and shown as ptr+len. There is no hidden owner and no
         capacity, so two members are the whole truth about a slice. *)
      | Types.String ->
        composite "string"
          [ ("ptr", Types.Ptr (Types.Int Types.U8)); ("len", Types.Int Types.I64) ]
      | Types.Slice e ->
        composite (Types.to_string t)
          [ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64) ]
      | Types.Option e ->
        composite (Types.to_string t)
          [ ("tag", Types.Int Types.U8); ("value", e) ]
      | Types.Named sn ->
        (match Hashtbl.find_opt m.structs sn with
         | Some st ->
           composite sn
             (List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty))
                st.Tast.fields)
         | None -> failwith ("no debug type for struct " ^ sn))
      (* An opaque pointer under lldb, which is the truth: the allocator's
         fields are the runtime's C and lldb already has that type from
         flan_rt.c's own debug info. *)
      | Types.Alloc ->
        dnode d
          "!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)"
      (* Shown as what it is. The two dev words are in the layout and so they
         are here too: a debugger that showed four fields of a six-field struct
         would put the reader's offsets out by two. *)
      | Types.Vec e ->
        composite (Types.to_string t)
          [ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64);
            ("cap", Types.Int Types.I64); ("allocator", Types.Alloc);
            ("gen", Types.Int Types.I64); ("epoch", Types.Int Types.I64) ]
      | Types.Map _ | Types.Fn _ | Types.Var _ ->
        failwith ("no debug type for " ^ Types.to_string t)
    in
    Hashtbl.replace d.dtys key n;
    n

(* ── 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;
  (* The transfer channel's landing blocks, spec-conditions.md §6. A guard
     after a call branches to the innermost one; each pops whatever frames it
     established and either catches the transfer or forwards it outward. The
     innermost is first, and with none open a transfer leaves the function
     through [unwind], which runs its defers (§5) and returns early. The flag
     says the block was branched to, so an unused one is not emitted. *)
  mutable pads  : (string * bool ref) list;
  unwind        : string;
  mutable unwound : bool;
  defers        : Tast.expr list;
  (* The function's !DISubprogram, in a debug build, and the line it was
     declared on -- the fallback for a node the checker made up. *)
  dsub          : int option;
  dline         : int;
  (* The value the shadow-stack head held when this function was entered, in a
     dev build: [Some %fprev]. Every [ret] restores it — see [ret] — which is
     what makes the pop happen on the transfer path as well as the normal one.
     [None] in a release build, where there is no frame at all. *)
  mutable frame : string option;
  (* Where a dev build records each slot's address, so that a stopped frame's
     locals can be read. [None] in a release build and in a function with no
     named slot at all. Only *named* slots are recorded: a slot the compiler
     invented has no name to show, and leaving its alloca unrecorded leaves it
     promotable, which is where most of the cost of this would otherwise be.
     An entry is null until the binding that fills the slot has run — that is
     how "not bound yet at this point" is told from "bound", with no liveness
     analysis and no bitmap. *)
  mutable slotv : string option;
  snames        : string option array;
  (* The [, !dbg !N] suffix every instruction in this function carries, or "".
     Uniform rather than only on the instructions that want a line: LLVM's
     verifier rejects a call without a location inside a function that has
     debug info, and this file emits calls from a dozen places -- the bounds
     failure, the handler push and pop, the transfer guards -- none of which
     would remember to ask. *)
  mutable dloc  : string;
}

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 ^ f.dloc ^ "\n")) fmt

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

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

(* Every [ret] in a function body goes through here, which is the whole of how
   the shadow stack's pop is got right. There are five of them — an explicit
   [return] with a value and without, the [none] arm of [(some x)], the tail of
   the body, and the landing block a transfer leaves through — and the last of
   those is the one that matters: a condition handled further out unwinds past
   this frame, so a pop written only on the normal path leaves a dead frame on
   the stack after every handled error, and the next backtrace is a lie. Same
   lesson [emit_with_alloc] learned about the context allocator. *)
let ret f v =
  (match f.frame with
   | Some prev -> ins f "store ptr %s, ptr @flan_frame_head" prev
   | None -> ());
  term f "ret %s %s" (ll f.ret) v

(* The store that says "this slot is bound now". Emitted at each binding of a
   named slot — a [let], a match arm, a restart clause's parameters — and at
   entry for the parameters, which are bound before any of the body runs.

   It is deliberately the *address* and not a flag: the reader needs the
   address anyway, so one store carries both facts, and a slot that has not
   been reached yet reads as null rather than as a plausible value at an
   address nobody wrote. *)
let bind_slot f i =
  match f.slotv with
  | None -> ()
  | Some v ->
    if i < Array.length f.snames && f.snames.(i) <> None then begin
      let p = fresh f in
      ins f "%s = getelementptr inbounds ptr, ptr %s, i32 %d" p v i;
      ins f "store ptr %s, ptr %s" f.slots.(i) p
    end

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

(* For the few slots whose LLVM type is not a Flan type: a handler frame is the
   runtime's shape, not something [Types] can name. *)
let alloca_raw f lltype =
  let name = fresh f in
  Buffer.add_string f.allocas (Printf.sprintf "  %s = alloca %s\n" name lltype);
  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

(* A NUL-terminated copy, for the two dev lookups that take a C string. Flan
   strings are ptr+len and never NUL-terminated, so this is its own constant. *)
let cstring m s =
  let id = Printf.sprintf "@\".name.%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\\00\"\n"
       id (String.length s + 1) (escape s));
  id

(* ── The shadow stack's descriptors ──────────────────────────────────── *)

(* One [flan_fninfo] per function in a dev build: the name and the location,
   as bytes and lengths, plus how many slots the frame has. It is static data —
   nothing about a function changes between two calls to it — so a frame stores
   a pointer to this and not six fields of its own.

   The strings go through [m.nfi] rather than [string_bytes], which is the
   whole of why that counter exists; see [m.nfi]. *)
let fi_bytes m s =
  let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
  m.nfi <- m.nfi + 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

(* What the two ends compare about a frame's slots, since neither can see the
   other. Same idea as a restart frame's [rsig_id], and for the same reason: a
   frame on the stack was compiled from *some* body, the session holds
   whatever body it last accepted, and installing while stopped is deliberately
   allowed — so the two can be different bodies of the same function, and a
   slot count alone does not notice a rename or a reordering. Pairing [q] with
   [p]'s value and saying nothing is exactly the "visible rather than correct"
   failure this project has already named once.

   Over the names *and* the spellings of the types, because either can change
   on its own. Computed here and read from here by [Dev], so there is one
   definition of it and it cannot drift. *)
let slot_fingerprint (fn : Tast.fn) =
  let b = Buffer.create 128 in
  Array.iteri
    (fun i ty ->
       (match
          if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None
        with
        | Some n -> Buffer.add_string b n
        | None -> ());
       Buffer.add_char b ':';
       Buffer.add_string b (Types.to_string ty);
       Buffer.add_char b ';')
    fn.Tast.slots;
  Hashtbl.hash (Buffer.contents b) land 0x3fffffff

let fninfo m (fn : Tast.fn) ~nslots =
  let nid, nlen = fi_bytes m fn.Tast.name in
  let lid, llen = fi_bytes m (Loc.to_string fn.Tast.floc) in
  let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
  m.nfi <- m.nfi + 1;
  Buffer.add_string m.strs
    (Printf.sprintf
       "%s = private unnamed_addr constant %%fninfo { ptr %s, i64 %d, ptr %s, i64 %d, i32 %d, i32 %d }\n"
       id nid nlen lid llen nslots (slot_fingerprint fn));
  id

(* ── 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

(* Every [Tast] node already carries the position it was read from, and until
   now nothing wrote them out. The location is set for the duration of a node's
   own emission and restored afterwards, so instructions a parent emits *after*
   a child -- the branch at the end of an [if], the store of a [set] -- are
   attributed to the parent and not to whatever ran last inside it. *)
let rec value f (e : Tast.expr) : string =
  match f.dsub with
  | None -> value_at f e
  | Some _ ->
    let saved = f.dloc in
    at_loc f e.Tast.loc;
    let v = value_at f e in
    f.dloc <- saved;
    v

(* The [!DILocation] for a position, memoised: a loop body emits the same few
   lines over and over and each would otherwise make its own node. *)
and at_loc f (loc : Loc.t) =
  match f.md.dbg, f.dsub with
  | Some d, Some sub ->
    (* Line 0 is [Loc.unknown] -- a node the checker made up rather than one
       anyone wrote. It is attributed to the function's own line instead, since
       a zero line in DWARF means "no line" and would make lldb step over the
       whole construct. *)
    let line = if loc.Loc.line = 0 then f.dline else loc.Loc.line in
    let key = Printf.sprintf "%d:%d:%d" sub line loc.Loc.col in
    let id =
      match Hashtbl.find_opt d.dlocs key with
      | Some id -> id
      | None ->
        let id =
          dnode d
            (Printf.sprintf "!DILocation(line: %d, column: %d, scope: !%d)"
               line loc.Loc.col sub)
        in
        Hashtbl.replace d.dlocs key id; id
    in
    f.dloc <- Printf.sprintf ", !dbg !%d" id
  | _ -> ()

and value_at 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 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);
         bind_slot f 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 -> ret f "zeroinitializer"
     | Some v ->
       let v' = value f v in
       ret f 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
  (* The condition crosses as a pointer: a handler runs while the signalling
     frame is still alive, so there is nothing to copy and nothing to own. *)
  | Tast.Signal (Tast.Ssignal, id, c) ->
    let p = addr f c in
    ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
    guard f;
    "zeroinitializer"
  (* §2's diverging variant. [flan_error] does not return unless a handler
     transferred, so the guard is the only way out and the fall-through is
     unreachable. It cannot be marked noreturn for that reason — it does
     return, on exactly one path. *)
  | Tast.Signal (Tast.Serror, id, c) ->
    let p = addr f c in
    let name = struct_name_of c.Tast.ty in
    let nid, nn = string_bytes f.md name in
    ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
      id p xfer_param nid nn;
    guard f;
    term f "unreachable";
    "zeroinitializer"
  | Tast.Handled (frames, body) -> emit_handled f frames body
  | Tast.RestartCase (clauses, body) -> emit_restart_case f e.Tast.ty clauses body
  | Tast.WithAlloc (a, body) -> emit_with_alloc f e.Tast.ty a body
  (* §4's lookup, then the transfer itself: the frame that was found goes into
     the channel and this function leaves through its landing block. Type
     Never, so nothing follows. *)
  | Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) ->
    (* The arguments are already in slots — the checker put them there, so an
       argument that transferred on its own has been guarded before anything
       here runs. *)
    let vals = List.map (fun a -> (value f a, a.Tast.ty)) args in
    let t = fresh f in
    ins f "%s = call ptr @flan_find_restart(i32 %d)" t id;
    let ok = fresh f in
    ins f "%s = icmp ne ptr %s, null" ok t;
    (* No frame offers the name. That is a runtime error at the invoke site —
       not an unwind past everything — because there is nowhere to resume. *)
    fail_block f rloc ok (fun id n ->
      let nid, nn = string_bytes f.md name in
      ins f "call void @flan_restart_fail(ptr %s, i64 %d, ptr %s, i64 %d)"
        id n nid nn);
    (* §3's run-time check. A restart is found by name on a dynamic stack, so
       what it takes is not knowable here: the frame carries its parameter
       count and the hash of how they are spelled, and both are compared.
       The count is not redundant with the hash — it is what makes a 32-bit
       collision between two different signatures harmless in practice — and
       it is also the cheaper half. *)
    let arity = fresh f in
    ins f "%s = load i32, ptr %s" arity (restart_field f t 5);
    let a_ok = fresh f in
    ins f "%s = icmp eq i32 %s, %d" a_ok arity (List.length args);
    let want = fresh f in
    ins f "%s = load i32, ptr %s" want (restart_field f t 6);
    let s_ok = fresh f in
    ins f "%s = icmp eq i32 %s, %d" s_ok want sg_id;
    let both = fresh f in
    ins f "%s = and i1 %s, %s" both a_ok s_ok;
    fail_block f rloc both (fun id n ->
      let nid, nn = string_bytes f.md name in
      (* What the frame says it takes is read off the frame, because only the
         frame knows; what was given is this call site's own spelling. *)
      let wp = fresh f in
      ins f "%s = load ptr, ptr %s" wp (restart_field f t 8);
      let wl = fresh f in
      ins f "%s = load i64, ptr %s" wl (restart_field f t 9);
      let gid, gn = string_bytes f.md sg in
      ins f
        "call void @flan_restart_args_fail(ptr %s, i64 %d, ptr %s, i64 %d, \
         ptr %s, i64 %s, ptr %s, i64 %d)" id n nid nn wp wl gid gn);
    (* Into the buffer the target frame owns, field by field: this frame is
       about to go, and the clause runs after it has. The layout is the one the
       signature just agreed on. *)
    if vals <> [] then begin
      let buf = fresh f in
      ins f "%s = load ptr, ptr %s" buf (restart_field f t 4);
      let sty =
        "{ " ^ String.concat ", " (List.map (fun (_, ty) -> ll ty) vals) ^ " }"
      in
      List.iteri
        (fun i (v, ty) ->
           let p = fresh f in
           ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
             p sty buf i;
           ins f "store %s %s, ptr %s" (ll ty) v p)
        vals;
      ins f "store i32 1, ptr %s" (restart_field f t 7)
    end;
    ins f "store ptr %s, ptr %s" t xfer_param;
    term f "br label %%%s" (current_pad f);
    "zeroinitializer"

(* Where a global's storage is. A global the host was built with is a symbol;
   one introduced since lives wherever [flan_dev_global] put it. *)
and global_addr f n =
  if (not f.md.dev) || f.md.known n then gname n
  else begin
    let p = fresh f in
    ins f "%s = load ptr, ptr %s" p (globalptr n);
    p
  end

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 -> global_addr f 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
  (* An Option is { i8, T } and has no declared name to gep through, so its
     layout is spelled out instead. Nothing in the surface language reaches a
     field of one -- [match] and [some] are how an Option is opened -- but the
     structural printer does, to read the tag without unwrapping a None. *)
  let sty = match target.Tast.ty with
    | Types.Named n -> sname n
    | Types.Option _ as t -> ll t
    | 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 sty 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 -> global_addr f 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

(* 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 flan 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
  (* The cell is loaded *after* the arguments, so a redefinition that lands
     between two calls still cannot land in the middle of one. *)
  let callee =
    if not f.md.dev then fname flan
    else if f.md.known flan then begin
      let p = fresh f in
      ins f "%s = load ptr, ptr %s" p (cellname flan);
      p
    end else begin
      (* The cell itself is not a symbol here; its address was looked up by
         name at install time and cached. *)
      let c = fresh f in
      ins f "%s = load ptr, ptr %s" c (cellptr flan);
      let p = fresh f in
      ins f "%s = load ptr, ptr %s" p c;
      p
    end
  in
  let t = fresh f in
  ins f "%s = call %s %s(%s)" t (ll ret) callee
    (String.concat ", " (vs @ [ "ptr " ^ xfer_param ]));
  guard f;
  t

(* The check after a call, which is the whole of §6's lowering at a call site:
   a load, a compare and a branch that reads like ordinary code. A foreign call
   gets none — a transfer cannot cross a C frame, so there is nothing a guard
   there could find. *)
and guard f =
  if f.live then begin
    let t = fresh f in
    ins f "%s = load ptr, ptr %s" t xfer_param;
    let c = fresh f in
    ins f "%s = icmp ne ptr %s, null" c t;
    let cont = fresh_label f "on" in
    let pad = current_pad f in
    term f "br i1 %s, label %%%s, label %%%s" c pad cont;
    label f cont
  end

and current_pad f =
  match f.pads with
  | (p, used) :: _ -> used := true; p
  | [] -> f.unwound <- true; f.unwind

(* 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

(* Establishing a handler is two stores and a push, per spec-conditions.md §2,
   and the frame lives on this function's own stack. Popping is by frame rather
   than by count: restoring what this one displaced is right even if something
   below it left the stack out of step.

   The body may not [return] — the checker rejects that — so the pops here are
   on the only path out. *)
and emit_handled f frames body =
  let allocated =
    List.map
      (fun (h : Tast.hframe) ->
         let slot = alloca_raw f "%handler" in
         let ty = fresh f in
         ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 1"
           ty slot;
         ins f "store i32 %d, ptr %s" h.Tast.htype ty;
         let fp = fresh f in
         ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 2"
           fp slot;
         (* The clause's body address, deliberately, and not a cell load:
            plan.org makes a top-level function value a stable trampoline over
            its cell, but a handler frame is not one — nothing can name it, and
            it lives only for this body. A reload landing while it is on the
            stack finds what it pushed still valid, which is what "old code is
            never unloaded" means. See NEXT.md, conditions step 1. *)
         ins f "store ptr %s, ptr %s" (fname h.Tast.hfn) fp;
         ins f "call void @flan_handler_push(ptr %s)" slot;
         slot)
      frames
  in
  let pop () =
    (* Innermost first, which is the order they were pushed in reverse. *)
    List.iter
      (fun slot -> ins f "call void @flan_handler_pop(ptr %s)" slot)
      (List.rev allocated)
  in
  let ld = fresh_label f "endhandled" in
  let pad = fresh_label f "hxfer" and used = ref false in
  f.pads <- (pad, used) :: f.pads;
  let last = block f body in
  f.pads <- List.tl f.pads;
  ignore last;
  let reached = f.live in
  if f.live then begin pop (); term f "br label %%%s" ld end;
  (* A transfer passing through: these frames are on the establishing
     function's stack and must come off before it goes any further, and this is
     the only path out that the checker's refusal of [return] leaves. Nothing
     here calls Flan, so the channel can stay as it is. *)
  if !used then begin
    label f pad;
    pop ();
    term f "br label %%%s" (current_pad f)
  end;
  if not reached then begin f.live <- false; "zeroinitializer" end
  else begin label f ld; "zeroinitializer" end

(* A clause's parameters, as one LLVM struct: what the invoker stores into and
   what the clause loads out of. The two ends never see each other, so the
   layout is agreed by the signature hash they compare first — same types in
   the same order is the same struct. *)
and args_type (c : Tast.rclause) =
  "{ " ^ String.concat ", " (List.map (fun (_, t) -> ll t) c.Tast.rparams) ^ " }"

and restart_field f slot i =
  let p = fresh f in
  ins f "%s = getelementptr inbounds %%restart, ptr %s, i32 0, i32 %d" p slot i;
  p

(* (with-allocator A BODY...) — spec-memory.md's "Allocators".

   Save, run, restore, and *restore again at the pad*. The second restore is
   the whole reason this is a node rather than a let and two calls: a body that
   errors, or one a handler transfers out of, leaves through [current_pad], and
   a context allocator left pointing into a region nobody outside the body has
   heard of would be wrong in the break loop, which is exactly where someone is
   about to allocate to render a condition.

   It releases nothing, per the spec: the region this names is released, if
   ever, by an explicit [free-all] somewhere else. *)
and emit_with_alloc f ty (a : Tast.expr) body =
  let av = value f a in
  let prev = fresh f in
  ins f "%s = call ptr @flan_context_set(ptr %s)" prev av;
  let result = if is_void ty then None else Some (alloca f ty) in
  let ld = fresh_label f "endwith" in
  let pad = fresh_label f "wxfer" and used = ref false in
  let reached = ref false in
  f.pads <- (pad, used) :: f.pads;
  let v = block f body in
  f.pads <- List.tl f.pads;
  if f.live then begin
    ins f "call void @flan_context_restore(ptr %s)" prev;
    (match result with
     | Some r -> ins f "store %s %s, ptr %s" (ll ty) v r
     | None -> ());
    reached := true;
    term f "br label %%%s" ld
  end;
  label f pad;
  ins f "call void @flan_context_restore(ptr %s)" prev;
  term f "br label %%%s" (current_pad f);
  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

(* (restart-case BODY (name [p T] BODY-1) ...) — §3, §4 and §6 together.

   One frame per clause, so that the frame a transfer names says which clause
   to run: the address is the identity, which is exact where a number would
   have to be unique against every module the running program might later load.
   §4's "innermost offering the name" falls out of the stack walk, and
   re-entering a restart-case works because each activation allocates its own
   frames.

   §5's defers between here and the invoke have already run — each function on
   the way out ran its own before returning. What is left here is to take these
   frames off, copy §3's parameters out of the buffer the invoker filled, and
   start the clause.

   The parameters live in a buffer this frame owns, not the invoker's: by the
   time a clause runs, every frame between the two has returned, so anything on
   the invoking side is gone. The invoker stores into it while both are alive,
   which is the one moment they are. *)
and emit_restart_case f ty clauses body =
  let result = if is_void ty then None else Some (alloca f ty) in
  let frames =
    map_lr
      (fun (c : Tast.rclause) ->
         let slot = alloca_raw f "%restart" in
         ins f "store i32 %d, ptr %s" c.Tast.rname_id (restart_field f slot 1);
         (* The name itself, beside the hash. A hash is all that matching
            needs, but a break loop has to *show* someone their choices, and
            nothing at run time can turn a hash back into a name. *)
         let sid, slen = string_bytes f.md c.Tast.rname in
         ins f "store ptr %s, ptr %s" sid (restart_field f slot 2);
         ins f "store i64 %d, ptr %s" slen (restart_field f slot 3);
         (* §3's signature, which every frame carries whether it takes
            parameters or not: an [invoke-restart] compares against whatever
            frame the name found, and a clause taking none has to be able to
            refuse arguments as loudly as one taking two of the wrong type. *)
         ins f "store i32 %d, ptr %s"
           (List.length c.Tast.rparams) (restart_field f slot 5);
         ins f "store i32 %d, ptr %s" c.Tast.rsig_id (restart_field f slot 6);
         let gid, glen = string_bytes f.md c.Tast.rsig in
         ins f "store ptr %s, ptr %s" gid (restart_field f slot 8);
         ins f "store i64 %d, ptr %s" glen (restart_field f slot 9);
         let args =
           if c.Tast.rparams = [] then None
           else begin
             let buf = alloca_raw f (args_type c) in
             ins f "store ptr %s, ptr %s" buf (restart_field f slot 4);
             (* Nothing has filled it in yet. Whoever aims a transfer at this
                frame without going through an [invoke-restart] — the break
                loop, today — leaves this zero, and the clause traps rather
                than running on values no one supplied. *)
             ins f "store i32 0, ptr %s" (restart_field f slot 7);
             Some buf
           end
         in
         ins f "call void @flan_restart_push(ptr %s)" slot;
         (slot, args))
      clauses
  in
  let args_of slot = List.assoc slot frames in
  let frames = List.map fst frames in
  let pop () =
    List.iter
      (fun slot -> ins f "call void @flan_restart_pop(ptr %s)" slot)
      (List.rev frames)
  in
  let ld = fresh_label f "endrestart" in
  let pad = fresh_label f "rxfer" and used = ref false in
  let reached = ref false in
  let yield v =
    if f.live then begin
      (match result with
       | Some r -> ins f "store %s %s, ptr %s" (ll ty) v r
       | None -> ());
      reached := true;
      term f "br label %%%s" ld
    end
  in
  f.pads <- (pad, used) :: f.pads;
  let v = value f body in
  f.pads <- List.tl f.pads;
  if f.live then pop ();
  yield v;
  label f pad;
  let tgt = fresh f in
  ins f "%s = load ptr, ptr %s" tgt xfer_param;
  (* Cleared before the clause runs, and put back if this transfer turns out to
     be aimed further out. A clause body is ordinary code and its calls are
     guarded like any other; it must not start with the channel still set. *)
  ins f "store ptr null, ptr %s" xfer_param;
  pop ();
  (* §3's parameters, copied out of the frame's buffer into the clause's own
     slots before its body starts. The frame is still addressable — it is an
     alloca of *this* function — and the buffer is whatever the invoker left
     there. *)
  let bind_params slot (c : Tast.rclause) =
    match args_of slot with
    | None -> ()
    | Some buf ->
      let armed = fresh f in
      ins f "%s = load i32, ptr %s" armed (restart_field f slot 7);
      let ok = fresh f in
      ins f "%s = icmp ne i32 %s, 0" ok armed;
      (* Aimed here by something that supplied no arguments — there is no such
         path from an [invoke-restart], so this is the break loop taking a
         restart it cannot yet fill in. Refused with the reason, rather than
         running the clause on a buffer nobody wrote. *)
      fail_block f (List.hd c.Tast.rbody).Tast.loc ok (fun id n ->
        let nid, nn = string_bytes f.md c.Tast.rname in
        let gid, gn = string_bytes f.md c.Tast.rsig in
        ins f
          "call void @flan_restart_unarmed(ptr %s, i64 %d, ptr %s, i64 %d, \
           ptr %s, i64 %d)" id n nid nn gid gn);
      List.iteri
        (fun i (slot_i, ty) ->
           let p = fresh f in
           ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
             p (args_type c) buf i;
           let v = load f p ty in
           ins f "store %s %s, ptr %s" (ll ty) v f.slots.(slot_i);
           bind_slot f slot_i)
        c.Tast.rparams
  in
  let rec dispatch = function
    | [] ->
      ins f "store ptr %s, ptr %s" tgt xfer_param;
      term f "br label %%%s" (current_pad f)
    | (slot, (c : Tast.rclause)) :: rest ->
      let hit = fresh_label f "restart" and next = fresh_label f "outer" in
      let t = fresh f in
      ins f "%s = icmp eq ptr %s, %s" t tgt slot;
      term f "br i1 %s, label %%%s, label %%%s" t hit next;
      label f hit;
      bind_params slot c;
      yield (block f c.Tast.rbody);
      label f next;
      dispatch rest
  in
  dispatch (List.combine frames clauses);
  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

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);
           bind_slot f 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;
  ret f "zeroinitializer";
  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
     (* An enum is an i32 at run time, and [Types.is_comparable] says so by
        admitting one — the checker was stating an intent the backend never
        honoured, so [(= k :a)] type checked and then died here with no source
        location. Signed, because a member may be declared negative. *)
     | Types.Enum _ ->
       ins f "%s = icmp %s %s %s, %s" t (icmp_op true 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
    (* The count is masked to the operand's width. LLVM makes an over-wide
       shift poison, and a poison return at -O2 is a function that returns
       nothing at all; masking is what the hardware does anyway, and LLVM folds
       the [and] away whenever the count is a constant. [check] has already
       rejected a literal that is out of range, so this only ever fires on a
       computed count. *)
    let b =
      match x.Tast.ty, p with
      | Types.Int k, (Tast.Shl | Tast.Shr) ->
        let m = fresh f in
        ins f "%s = and %s %s, %d" m (ll x.Tast.ty) b (Types.bits k - 1);
        m
      | _ -> b
    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
  (* (string b), and the same non-instruction for the same reason: String and
     Slice _ are both %slice. See check.ml's "string" case. *)
  | Tast.StrOfBytes, [ 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.U64ToBytes, [ x ] -> shim_out f "@flan_u64_to_bytes" x
  | Tast.EscapeBytes, [ x ] -> shim_in_out f "@flan_escape_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)
  (* One arm for every runtime entry point the allocator and container runtime
     has. The result type is the node's own and the argument types are the
     arguments' own, so nothing here has to know which symbol it is calling. *)
  | Tast.Rt sym, args ->
    let vs =
      List.concat
        (map_lr
           (fun (a : Tast.expr) ->
              match a.Tast.ty with
              | Types.String | Types.Slice _ ->
                let p, n = explode f a in
                [ "ptr " ^ p; "i64 " ^ n ]
              | Types.Unit | Types.Never -> []
              (* A Vec is move-only and never copied, so it crosses to the
                 runtime as its address — which is also what lets an operation
                 mutate the caller's Vec in place. *)
              | Types.Vec _ -> [ "ptr " ^ addr f a ]
              | t -> [ ll t ^ " " ^ value f a ])
           args)
    in
    let args' = String.concat ", " vs in
    if is_void e.Tast.ty then begin
      ins f "call void @%s(%s)" sym args';
      "zeroinitializer"
    end else begin
      let t = fresh f in
      ins f "%s = call %s @%s(%s)" t (ll e.Tast.ty) sym args';
      t
    end
  | Tast.SizeOf t, [] -> Printf.sprintf "%d" (fst (lay f.md t))
  | Tast.AlignOf t, [] -> Printf.sprintf "%d" (snd (lay f.md t))
  | Tast.AddrOf, [ x ] -> addr f x
  | 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))

(* Slice in, slice out: [shim_in] returns a scalar and [shim_out] takes one, so
   a shim that transforms bytes into bytes is neither. *)
and shim_in_out f name (x : Tast.expr) =
  let p, n = explode f x in
  let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
  ins f "call void %s(ptr %s, i64 %s, ptr %s)" name p n tmp;
  load f tmp (Types.Slice (Types.Int Types.U8))

and cast f (x : Tast.expr) target =
  let v = value f x in
  (* An enum is an i32 at run time and its own type only in the checker, so a
     cast involving one is a cast on that i32. Nothing in the surface language
     produces this — a keyword resolves against the enum and never widens — but
     the REPL's renderer needs an enum's number when it falls outside the
     declared members. *)
  let concrete (t : Types.t) =
    match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
  in
  let src = concrete x.Tast.ty and target = concrete target 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"
      (* Nothing in the surface language writes this: [check.ml] has no cast
         between pointer types. The locals thunk does — it is handed a slot's
         address as a raw pointer and has to read it as the type the slot
         holds — and under opaque pointers there is no instruction to emit for
         it, both sides being [ptr]. *)
      | Types.Ptr _, Types.Ptr _ -> "bitcast"
      | _ -> 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 ─────────────────────────────────────────────────────── *)

(* The one place a Flan function's LLVM signature is spelled. A [define] and
   the [declare] a redefinition module needs for the same function have to
   agree exactly, and the way they stop agreeing is one of them growing a case
   for Unit or for a slice parameter that the other never gets. *)
let signature ~named (fn : Tast.fn) =
  let params =
    List.mapi
      (fun i ty -> if named then Printf.sprintf "%s %%p%d" (ll ty) i else ll ty)
      fn.Tast.params
  in
  (* The transfer channel, spec-conditions.md §6: one [ptr] appended to every
     signature, written by an [invoke-restart] and checked after every call.
     Uniform rather than only on the functions that need it — the spec's escape
     analysis is an optimisation, and in a dev build a cell can hold anything,
     so the honest answer to "what can this call?" is "anything". *)
  let params = params @ [ (if named then "ptr " ^ xfer_param else "ptr") ] in
  Printf.sprintf "%s %s(%s)" (ll fn.Tast.ret) (fname fn.Tast.name)
    (String.concat ", " params)

(* [hidden] on a redefinition's own body, and this is load-bearing. Default
   visibility in a shared object is interposable: [@"flan.bump"] inside the
   module would resolve to the *host's* copy, so the installer would publish
   the function it was replacing and the reload would appear to do nothing. *)
(* The name a slot goes into the debug info under. [Tast.fn.snames] carries the
   source name of every slot the source named, parameters included, so that is
   the answer wherever there is one.

   A slot with no name is one the compiler invented -- [dotimes]'s hidden
   bound, the pair (min) and (max) evaluate their operands into -- and it keeps
   [s<index>], which is what it actually is. That is deliberate rather than a
   fallback: a synthesized slot has no source name to print, and inventing a
   plausible one would put a variable in the debugger that the programmer
   cannot find in the file. [s4] is honest about being the frame's fourth slot.

   [snames] is indexed defensively because a driver may build a frame by
   appending arrays ([Session]'s evaluation thunk does), and a short [snames]
   should cost a name, not raise. *)
let slot_name ~pnames ~snames ~nparams i =
  let named = if i < Array.length snames then snames.(i) else None in
  match named with
  | Some n when n <> "" -> n
  | _ ->
    if i < nparams then
      match List.nth_opt pnames i with
      | Some n when n <> "" -> n
      | _ -> Printf.sprintf "p%d" i
    else Printf.sprintf "s%d" i

let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
  let n = Array.length fn.Tast.slots in
  (* The subprogram's id is claimed before the body is emitted, because every
     instruction in the body refers to it, and the node itself is written at
     the end once the retained variables are known. *)
  let dsub = match m.dbg with None -> None | Some d -> Some (dalloc d) 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;
    pads = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers;
    frame = None; slotv = None; snames = fn.Tast.snames;
    dsub;
    dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
    dloc = "";
  } 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;
  (* The shadow stack's push, in the entry block, and the pop is at every
     [ret] (see [ret]). plan.org has had *Frames: shadow stack* in the dev
     column since the beginning; this is it, and it is dev-only, so a shipped
     game pays nothing for it.

     Inline rather than a call in either direction: this is on every call in a
     dev build, and a call to record a call would be most of what it costs. The
     record is four words on this frame's own stack, of which two are stored
     from static data and two are reserved for the slots [locals] needs -- they
     are written, not left as whatever the stack held, because a frame with a
     garbage [slots] pointer is one the break loop could follow.

     A lifted handler-bind clause pushes one like any other function, which is
     right: it really is on the stack, and a backtrace that skipped it would
     show a gap exactly where the handler ran. *)
  if m.dev then begin
    (* The slot table, and it is the whole of what [locals] reads. One [ptr]
       per slot, null until the slot is bound; the frame points at it.

       Only a function with at least one *named* slot gets one, and only named
       slots are ever recorded in it. That is not a saving of stores — the
       nulls are written either way — it is a saving of *optimisation*: a slot
       whose address is stored anywhere escapes, and an escaped alloca is one
       mem2reg cannot promote. The slots that would hurt most to demote are
       exactly the ones with no name to show: [dotimes]'s hidden bound, the
       temporaries (min) and (max) evaluate their operands into, the walk's own
       scratch in a render thunk. *)
    let named = Array.exists (fun n -> n <> None) fn.Tast.snames in
    if named && n > 0 then begin
      let v = fresh f in
      Buffer.add_string f.allocas
        (Printf.sprintf "  %s = alloca [%d x ptr]\n" v n);
      (* Every entry, not only the named ones: "null means not bound" has to
         hold at every index, or a reader has to know which indices it may
         trust, and that is a second thing to keep in step. *)
      for i = 0 to n - 1 do
        let p = fresh f in
        Buffer.add_string f.allocas
          (Printf.sprintf "  %s = getelementptr inbounds ptr, ptr %s, i32 %d\n"
             p v i);
        Buffer.add_string f.allocas
          (Printf.sprintf "  store ptr null, ptr %s\n" p)
      done;
      f.slotv <- Some v
    end;
    let info = fninfo m fn ~nslots:(if f.slotv = None then 0 else n) in
    let prev = fresh f in
    Buffer.add_string f.allocas "  %frame = alloca %flanframe
";
    Buffer.add_string f.allocas
      (Printf.sprintf "  %s = load ptr, ptr @flan_frame_head
" prev);
    Buffer.add_string f.allocas
      (Printf.sprintf "  store ptr %s, ptr %%frame
" prev);
    List.iter
      (fun line -> Buffer.add_string f.allocas ("  " ^ line ^ "\n"))
      [ "%frame.i = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 1";
        Printf.sprintf "store ptr %s, ptr %%frame.i" info;
        "%frame.s = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 2";
        Printf.sprintf "store ptr %s, ptr %%frame.s"
          (match f.slotv with Some v -> v | None -> "null");
        "store ptr %frame, ptr @flan_frame_head" ];
    f.frame <- Some prev;
    (* The parameters are bound before the body starts, so they are recorded
       here rather than at a binding site there is none of. *)
    List.iteri (fun i _ ->
      match f.slotv with
      | None -> ()
      | Some v ->
        if i < Array.length fn.Tast.snames && fn.Tast.snames.(i) <> None then begin
          let p = fresh f in
          Buffer.add_string f.allocas
            (Printf.sprintf "  %s = getelementptr inbounds ptr, ptr %s, i32 %d\n"
               p v i);
          Buffer.add_string f.allocas
            (Printf.sprintf "  store ptr %s, ptr %s\n" f.slots.(i) p)
        end)
      fn.Tast.params
  end;
  (* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it
     describes. This is the whole of what lldb needs to print a local: the slot
     is ordinary stack storage of an ordinary machine type, so there is no
     accessor to describe and no header to skip. *)
  (match m.dbg, dsub with
   | Some d, Some sub ->
     let file = dfile d fn.Tast.floc.Loc.file in
     let nparams = List.length fn.Tast.params in
     let vars =
       Array.to_list
         (Array.mapi
            (fun i ty ->
               let arg =
                 (* [arg:] is 1-based over the LLVM formals, and the transfer
                    channel is appended after all of them, so a parameter's
                    index is its Flan index either way. The channel itself gets
                    no variable: nothing in the language can name it. *)
                 if i < nparams then Printf.sprintf ", arg: %d" (i + 1) else ""
               in
               dnode d
                 (Printf.sprintf
                    "!DILocalVariable(name: \"%s\"%s, scope: !%d, file: !%d, line: %d, type: !%d)"
                    (dstr (slot_name ~pnames ~snames:fn.Tast.snames ~nparams i))
                    arg sub file f.dline
                    (dty m d ty)))
            fn.Tast.slots)
     in
     let dl =
       dnode d
         (Printf.sprintf "!DILocation(line: %d, column: 1, scope: !%d)" f.dline sub)
     in
     List.iteri
       (fun i v ->
          Buffer.add_string f.allocas
            (Printf.sprintf
               "  call void @llvm.dbg.declare(metadata ptr %s, metadata !%d, metadata !DIExpression()), !dbg !%d\n"
               f.slots.(i) v dl))
       vars;
     let sty =
       dnode d
         (Printf.sprintf "!DISubroutineType(types: !{%s})"
            (String.concat ", "
               ((if is_void fn.Tast.ret then "null"
                 else Printf.sprintf "!%d" (dty m d fn.Tast.ret))
                :: List.map (fun t -> Printf.sprintf "!%d" (dty m d t))
                     fn.Tast.params)))
     in
     dput d sub
       (Printf.sprintf
          "distinct !DISubprogram(name: \"%s\", linkageName: \"flan.%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})"
          (dstr fn.Tast.name) (dstr fn.Tast.name) file file f.dline sty f.dline
          d.dcu
          (String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars)));
     at_loc f fn.Tast.floc
   | _ -> ());
  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";
  ret f !last;
  (* The transfer exit, spec-conditions.md §5 and §6. A transfer that reached
     the top of this function without a restart-case to catch it leaves the
     same way a [return] does — which is what reuses the existing return path,
     and with it the defers, for free. The value returned is meaningless: the
     caller's guard sees the channel set and never looks at it. *)
  if f.unwound then begin
    label f f.unwind;
    let cleanup = "unwind.cleanup" and used = ref false in
    if f.defers <> [] then begin
      (* The channel is cleared while the defers run and put back after. A
         defer makes ordinary calls and each one is guarded; with the channel
         still set the first of them would branch straight back here. *)
      let tgt = fresh f in
      ins f "%s = load ptr, ptr %s" tgt xfer_param;
      ins f "store ptr null, ptr %s" xfer_param;
      f.pads <- [ (cleanup, used) ];
      List.iter (fun e -> ignore (value f e)) f.defers;
      f.pads <- [];
      ins f "store ptr %s, ptr %s" tgt xfer_param
    end;
    ret f "zeroinitializer";
    (* A defer that starts a *second* transfer while the first is unwinding.
       §6's per-frame slot nests, but nothing here does: the first transfer's
       target is in hand and the defers are half run. Refused loudly rather
       than resolved to one of them. *)
    if !used then begin
      label f cleanup;
      let id, n = string_bytes f.md (Loc.to_string fn.Tast.floc) in
      ins f "call void @flan_transfer_fail(ptr %s, i64 %d)" id n;
      term f "unreachable"
    end
  end;
  Buffer.add_string m.out
    (Printf.sprintf "\ndefine %s%s%s%s {\nentry:\n%s%s}\n"
       (if hidden then "hidden " else "") (signature ~named:true fn) (attrs m)
       (match dsub with None -> "" | Some n -> Printf.sprintf " !dbg !%d" n)
       (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"

(* A dev build emits a [defconst] as a mutable [global]. Two things follow, and
   both are wanted: LLVM can no longer fold a read of it, and a redefinition
   module can store a new value into it — so tuning a constant live works,
   which it cannot when its only copy is immutable in .rodata. A release build
   emits [constant] and gets all the folding back. *)
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 && not m.dev 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 }
; (Vec T), spec-memory.md. The element type is nowhere in it: the runtime is
; type-erased and every operation is handed size and align at its call site.
%vec = type { ptr, i64, i64, ptr, i64, i64 }
; A handler frame: the one it displaced, the condition type it matches, and
; the lifted function that runs. Allocated on the establishing frame's stack.
%handler = type { ptr, i32, ptr }
; A restart frame: the one it displaced and the name it offers. There is no
; target field, because the frame's own address *is* the target — which makes
; a transfer's aim exact, and makes re-entering a restart-case work with
; nothing extra, since each activation allocates its own.
;
; Then §3's parameters: the buffer the clause reads them out of — owned by the
; restart-case, because the invoker's frame is gone by the time a clause runs —
; how many there are, the hash of how they are spelled, whether anything has
; filled the buffer in, and that spelling itself for the message when the two
; ends disagree. The first four fields are what the runtime's own
; [flan_restart] declares and their offsets do not move.
%restart = type { ptr, i32, ptr, i64, ptr, i32, i32, i32, ptr, i64 }
; A shadow-stack frame and the static description of the function that pushed
; it (runtime/flan_dev.c). Dev builds only: [emit_fn] pushes one on entry and
; every [ret] restores the head, the transfer path included. A release build
; emits neither, and the head below is then a symbol nothing in the .ll names.
%fninfo = type { ptr, i64, ptr, i64, i32, i32 }
%flanframe = type { ptr, ptr, ptr }
@flan_frame_head = external global ptr

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_u64_to_bytes(i64, ptr)
declare void @flan_escape_bytes(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(i32, ptr, ptr)
declare void @flan_error(i32, ptr, ptr, ptr, i64)
declare void @flan_restart_push(ptr)
declare void @flan_restart_pop(ptr)
declare ptr @flan_find_restart(i32)
declare void @flan_restart_fail(ptr, i64, ptr, i64) noreturn cold
declare void @flan_restart_args_fail(ptr, i64, ptr, i64, ptr, i64, ptr, i64) noreturn cold
declare void @flan_restart_unarmed(ptr, i64, ptr, i64, ptr, i64) noreturn cold
declare void @flan_transfer_fail(ptr, i64) noreturn cold
declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold
declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_temp()
declare ptr @flan_heap_allocator()
declare ptr @flan_context_set(ptr)
declare void @flan_context_restore(ptr)
declare ptr @flan_arena_new(i64)
declare void @flan_arena_destroy(ptr)
declare void @flan_alloc_free_all(ptr, ptr, i64)
declare i8 @flan_alloc_can_free(ptr)
declare i8 @flan_alloc_can_free_all(ptr)
declare i64 @flan_alloc_epoch(ptr)
declare i64 @flan_alloc_live_blocks(ptr)
declare i64 @flan_alloc_id(ptr)
declare i64 @flan_alloc_fail_bytes()
declare i64 @flan_alloc_fail_align()
declare i64 @flan_alloc_fail_id()
declare i64 @flan_alloc_budget(ptr)
declare void @flan_alloc_set_budget(ptr, i64)
declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_vec_clone(ptr, ptr, ptr, i64, i64, ptr, i64)
declare i64 @flan_vec_len(ptr, ptr, i64)
declare ptr @flan_vec_at(ptr, i32, i64, ptr, i64)
declare void @flan_vec_as_slice(ptr, ptr, i32, i32, i64, ptr, i64)
declare void @flan_vec_free(ptr, i64, i64, ptr, i64)
; The filesystem. flan_file_read is not here: nothing Flan emits calls it —
; only flan_slurp_into does, from C — and flan_slurp_into is runtime glue
; rather than a fourth host call. See flan_rt.c for why the widening stops
; here. `embed` needs none of these: it is a compile-time constant.
declare i8 @flan_file_size(ptr, i64, ptr)
declare i8 @flan_file_write(ptr, i64, ptr, i64)
declare i64 @flan_file_fail_reason()
declare i8 @flan_slurp_into(ptr, ptr, i64)
|}

(* 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
    (Printf.sprintf "\ndefine i32 @main(i32 %%argc, ptr %%argv)%s {\nentry:\n"
       (attrs m));
  Buffer.add_string b "  call void @flan_rt_init(i32 %argc, ptr %argv)\n";
  (* The program's own end of the transfer channel. Nothing can be transferring
     when [main] returns: a restart is found by name on the restart stack, and
     an [invoke-restart] that finds none fails at the invoke site rather than
     unwinding past everything. *)
  Buffer.add_string b (Printf.sprintf "  %s = alloca ptr\n" xfer_param);
  Buffer.add_string b
    (Printf.sprintf "  store ptr null, ptr %s\n" xfer_param);
  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")
       (if args = "" then "ptr " ^ xfer_param else args ^ ", ptr " ^ xfer_param));
  (* 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)

(* Everything a module needs before its own definitions: the tables the
   emitters look names up in, the struct types, and the foreign [declare]s.
   Both entry points below start here, so a redefinition module cannot drift
   from the whole-program one in how it names or lays out a type. *)
(* Which file the compile unit is about. Every subprogram carries its own
   [!DIFile], so this only decides what a debugger calls the unit as a whole;
   the first function anyone actually wrote is the honest answer. *)
let cu_file (p : Tast.program) =
  match
    List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
  with
  | Some f -> f.Tast.floc.Loc.file
  | None -> "<flan>"

let new_dbg (p : Tast.program) =
  let d =
    { dn = 0; dout = Buffer.create 4096; dfiles = Hashtbl.create 8;
      dtys = Hashtbl.create 32; dlocs = Hashtbl.create 256; dcu = 0 }
  in
  let file = dfile d (cu_file p) in
  d.dcu <- dalloc d;
  (* [isOptimized: false] is not decoration: it is what a debug build is, and
     [Build] sets -O0 to make it true. DW_LANG_C99 because the layout is C's
     and lldb's C support is then exactly right for it. *)
  dput d d.dcu
    (Printf.sprintf
       "distinct !DICompileUnit(language: DW_LANG_C99, file: !%d, producer: \"flan\", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false)"
       file);
  d

let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
      (p : Tast.program) =
  let m = {
    out = Buffer.create 8192; strs = Buffer.create 512;
    structs = Hashtbl.create 16; globals = Hashtbl.create 16;
    externs = Hashtbl.create 32;
    checks; dev; known; nstr = 0; nfi = 0; sanitize;
    dbg = (if debug then Some (new_dbg p) else None);
  } 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';
  m

(* The two named metadata nodes without which none of the above survives:
   LLVM drops every scrap of debug metadata, silently and with no diagnostic,
   if "Debug Info Version" is absent. A build that "works" and shows nothing in
   the debugger is that flag. *)
let dmodule d =
  let b = Buffer.create 512 in
  Buffer.add_string b
    "\ndeclare void @llvm.dbg.declare(metadata, metadata, metadata)\n\n";
  let dv = dalloc d and div = dalloc d in
  dput d dv "!{i32 7, !\"Dwarf Version\", i32 5}";
  dput d div "!{i32 2, !\"Debug Info Version\", i32 3}";
  Buffer.add_string b (Printf.sprintf "!llvm.dbg.cu = !{!%d}\n" d.dcu);
  Buffer.add_string b
    (Printf.sprintf "!llvm.module.flags = !{!%d, !%d}\n\n" dv div);
  Buffer.add_buffer b d.dout;
  Buffer.contents b

let finish m =
  header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
  ^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "")
  ^ (match m.dbg with None -> "" | Some d -> dmodule d)

(* [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) ?(dev = false) ?(debug = false) ?(pnames = [])
      ?(sanitize = false) (p : Tast.program) : string =
  let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in
  (* One cell per function, initialised to the function this build compiled.
     Nothing has been redefined yet, so a dev build starts out behaving exactly
     like a release one — the indirection is the only difference. *)
  if dev then begin
    List.iter
      (fun (fn : Tast.fn) ->
         Buffer.add_string m.out
           (Printf.sprintf "%s = global ptr %s\n" (cellname fn.Tast.name)
              (fname fn.Tast.name)))
      p.Tast.fns;
    Buffer.add_char m.out '\n'
  end;
  List.iter (emit_global m) p.Tast.globals;
  List.iter
    (fun (fn : Tast.fn) ->
       emit_fn m
         ~pnames:(match List.assoc_opt fn.Tast.name pnames with
                  | Some ns -> ns | None -> [])
         fn)
    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 -> ());
  finish m

(* A list of top-level forms, compiled into their own module against a host
   that is already running — the redefinition unit (NEXT.md, the dev loop).
   [C-c C-c] passes one name, [C-c C-k] passes a file's worth; there is one
   code path either way.

   The difference from [program] is almost entirely in what this module *does
   not* define:

   - a global the host has is [external]. Defining it would give the loaded
     object a second copy, and the whole point of reloading into a live process
     is that the state survives: sand's grid is a global, and "edit the code,
     keep the sand" is the demo. So a redefinition can change a function's body
     and can never re-initialise the program's data.
   - a function the host has is reached through its cell, which is the host's
     symbol, so a redefined [settle] calls whatever [move-grain] is current
     rather than carrying a private copy of it.
   - there is no [main]; this module is loaded, not started.

   A name the host does *not* have is the case ELF cannot express, since there
   is no symbol to bind to and no way to grow one. Those go through
   [flan_dev_cell] / [flan_dev_global], keyed by string, resolved once at
   install time into a module-local slot. See runtime/flan_dev.c.

   String literals still have to come along: they are this module's own
   constants, and omitting them is an undefined [@.str.N] at link time. *)
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
      ?(known = fun _ -> true) ?(retains = true)
      ?call ?(consts = []) (p : Tast.program) ~fns : string =
  let target name =
    match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
    | Some f -> f
    | None -> failwith (Printf.sprintf "no such function: %s" name)
  in
  let targets = List.map target fns in
  (* A clause lifted out of one of these comes with it: its body may have
     changed too, and it is reached by address from inside the module rather
     than through a cell. Every other lifted clause is invisible here — it
     needs no declaration, since nothing in this module names it. *)
  let lifted =
    List.filter
      (fun (f : Tast.fn) ->
         match f.Tast.fparent with
         | Some p -> List.mem p fns
         | None -> false)
      p.Tast.fns
  in
  (* The rest of the program, as the cell and registry machinery below sees it.
     A lifted clause has neither, so it must not appear in either. *)
  let siblings =
    List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
  in
  let m = new_module ~checks ~dev ~known ~debug p in
  (* A thunk the module runs itself is excluded from all of this: it is called
     directly by [flan_reload_call], so it needs no cell, must not be published
     into one, and must not take a registry slot — there are 4096 of those and
     an expression evaluated in a loop would exhaust them. Nothing pointing
     into the module is also what lets the agent unload it afterwards. *)
  let transient f = call = Some f in
  let new_fns =
    List.filter
      (fun (f : Tast.fn) ->
         (not (known f.Tast.name)) && not (transient f.Tast.name))
      siblings
  and new_globals =
    List.filter (fun (g : Tast.global) -> not (known g.Tast.gname)) p.Tast.globals
  in
  List.iter
    (fun (g : Tast.global) ->
       Buffer.add_string m.out
         (if known g.Tast.gname then
            Printf.sprintf "%s = external %s %s\n" (gname g.Tast.gname)
              (if g.Tast.gconst && not dev then "constant" else "global")
              (ll g.Tast.gty)
          else
            Printf.sprintf "%s = internal global ptr null\n"
              (globalptr g.Tast.gname)))
    p.Tast.globals;
  if dev then begin
    (* The cells are the host's, like the globals. Referencing one is how a
       redefined function reaches its siblings, and storing into one is how it
       replaces itself. A name the host lacks gets a slot instead, filled by
       the installer below. *)
    List.iter
      (fun (f : Tast.fn) ->
         if not (transient f.Tast.name) then
           Buffer.add_string m.out
             (if known f.Tast.name then
                Printf.sprintf "%s = external global ptr\n" (cellname f.Tast.name)
              else
                Printf.sprintf "%s = internal global ptr null\n"
                  (cellptr f.Tast.name)))
      siblings;
    if new_fns <> [] || new_globals <> [] then
      Buffer.add_string m.out
        "\ndeclare ptr @flan_dev_cell(ptr)\n\
         declare ptr @flan_dev_global(ptr, i64, ptr)\n";
    Buffer.add_char m.out '\n'
  end
  else
    (* Without cells there is nothing to route a call through, so the siblings
       are named directly and every one of them needs a declaration. *)
    List.iter
      (fun (f : Tast.fn) ->
         if not (List.exists (String.equal f.Tast.name) fns) then
           Buffer.add_string m.out
             (Printf.sprintf "declare %s\n" (signature ~named:false f)))
      siblings;
  (* Hidden for the same reason a redefined body is: default visibility in a
     shared object is interposable, and that applies to taking the address too,
     so a plain reference would resolve to the host's copy of the clause and
     this module would install the very handler it is replacing. *)
  List.iter (fun f -> emit_fn m ~hidden:true f) lifted;
  List.iter (fun f -> emit_fn m ~hidden:dev f) targets;
  if dev then begin
    (* Publishing is a separate, named function rather than a constructor: the
       agent has to choose *when* the swap happens — at a frame boundary, on
       the game thread — and a loader-run ctor would do it during dlopen, on
       whatever thread called it, in the middle of a frame.

       Order inside it is load-bearing. Every lookup is resolved before any
       body is published, because publishing first exposes a function whose
       slots are still null to anything that calls it. *)
    let b = Buffer.create 512 in
    let n = ref 0 in
    let fresh () = incr n; Printf.sprintf "%%d%d" !n in
    List.iter
      (fun (f : Tast.fn) ->
         let t = fresh () in
         Buffer.add_string b
           (Printf.sprintf "  %s = call ptr @flan_dev_cell(ptr %s)\n  store ptr %s, ptr %s\n"
              t (cstring m ("flan." ^ f.Tast.name)) t (cellptr f.Tast.name)))
      new_fns;
    List.iter
      (fun (g : Tast.global) ->
         let t = fresh () in
         (* sizeof, spelled the way LLVM spells it: the offset of element one
            of a null pointer. Cheaper than a layout calculator in OCaml that
            would have to agree with LLVM's on every target. *)
         (* Its declared initial value travels with it, as a constant the
            runtime copies on the allocation and ignores afterwards. Without
            this a new (defvar n i64 42) or a new defconst would silently be
            zero — calloc is only the right answer for ZII. *)
         let init = Printf.sprintf "@\".init.%d\"" m.nstr in
         m.nstr <- m.nstr + 1;
         Buffer.add_string m.strs
           (Printf.sprintf "%s = private constant %s %s\n" init
              (ll g.Tast.gty) (const m g.Tast.ginit));
         Buffer.add_string b
           (Printf.sprintf
              "  %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n  \
               store ptr %s, ptr %s\n"
              t (cstring m ("flan." ^ g.Tast.gname)) (ll g.Tast.gty) init t
              (globalptr g.Tast.gname)))
      new_globals;
    (* A constant whose value the checker never consumed is just bytes in the
       program's memory, so a new value is published the same way a new body
       is: one store, at the frame boundary. One the checker *did* consume is
       in the shape of the program and never gets here — the session refuses
       it. *)
    List.iter
      (fun (g : Tast.global) ->
         if List.exists (String.equal g.Tast.gname) consts then
           Buffer.add_string b
             (Printf.sprintf "  store %s %s, ptr %s\n" (ll g.Tast.gty)
                (const m g.Tast.ginit) (gname g.Tast.gname)))
      p.Tast.globals;
    List.iter
      (fun (f : Tast.fn) ->
         if transient f.Tast.name then ()
         else if known f.Tast.name then
           Buffer.add_string b
             (Printf.sprintf "  store ptr %s, ptr %s\n" (fname f.Tast.name)
                (cellname f.Tast.name))
         else begin
           let t = fresh () in
           Buffer.add_string b
             (Printf.sprintf "  %s = load ptr, ptr %s\n  store ptr %s, ptr %s\n"
                t (cellptr f.Tast.name) (fname f.Tast.name) t)
         end)
      targets;
    Buffer.add_string m.out
      (Printf.sprintf "\ndefine void @flan_reload_install() {\nentry:\n%s  ret void\n}\n"
         (Buffer.contents b));
    (* An expression evaluation compiles to a function with nowhere to be
       called from, so the module says so and the agent runs it once — after
       the install, on the game thread, so it sees both the bodies this module
       just published and a program state the program agrees is consistent. *)
    match call with
    | Some fn ->
      Buffer.add_string m.out
        (Printf.sprintf
           "\ndefine void @flan_reload_call() {\nentry:\n  \
            %s = alloca ptr\n  store ptr null, ptr %s\n  \
            call %s %s(ptr %s)\n  ret void\n}\n"
           xfer_param xfer_param (ll Types.Unit) (fname fn) xfer_param);
      (* Nothing outside this module refers to anything in it once the call has
         returned — no cell holds an address in its text, the registry has no
         slot for it, and the value it produced was copied out. So it says so,
         and the agent unloads it. A module that publishes a body can never say
         this: its whole purpose is to leave a pointer behind.

         [m.nstr = 0] is the third condition and it is about *data*, not text.
         A string literal is emitted into this module's own image, and an
         expression may store one anywhere it likes — [(set msg "tuned")] on a
         string global leaves that global pointing into the mapping the agent
         is about to drop. The next thunk can be mapped at the same address, so
         the result is silent garbage rather than a fault. A module with no
         string constants has nothing in its image anyone could still be
         pointing at; one with any keeps its mapping, which costs a page and is
         the same bargain every redefinition already makes. *)
      (* [retains = false] is a caller saying it knows where every literal in
         this module goes. The [m.nstr] test below is a conservative stand-in
         for that — an expression may store a string literal anywhere it likes,
         and a global left pointing into an unmapped image is silent garbage
         rather than a fault. A locals thunk is the case where the answer is
         known: every literal it emits goes to [flan_dev_emit], which memcpys
         into the result buffer, so nothing outside the module holds an address
         inside it once the call has returned. Without this, clicking through
         the frames of a break loop costs a permanent mapping per click. *)
      if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
        Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
    | None -> ()
  end;
  finish m