(** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one. Grown out of [spike/backend/x86.ml], which proved the shape. What is new here is everything the spike enumerated and did not do: aggregates, floats, globals, string literals, the transfer channel, and a whole program rather than one function. {1 The internal calling convention} The spike's report (DISCUSS.md item 15) called the internal convention the sharpest obstacle, because LLVM's answer for a first-class struct is an implementation detail discoverable only by disassembly — a 24-byte struct comes back in [rax]:[rdx]:[rcx], and [rcx] is a register SysV never uses for a return value. That obstacle does not exist here, and the reason is worth stating because it is the whole licence for this module: {b a dev build is compiled entirely by this backend and a release build entirely by LLVM, and the two never meet in one process.} A dev build's [.ll] is not emitted at all when this backend runs. So the convention is ours to pick, and we pick the simplest one that exists: {b The licence has an edge now, and it is the indirection cells below.} A cell is a mutable global an out-of-process redefinition can store into, and the module doing the storing is built by [Emit.redefinition], which is LLVM. The two conventions agree on scalars and disagree on every aggregate, so an LLVM-built module dlopened into a build made here would be correct exactly until a redefined function took or returned a struct. Nothing in the toolchain does that today — [flan reload] and [flan dev] build host and module through LLVM together — and the answer when something does is a redefinition emitter {e here}, not a classifier. - {b Scalars} — integers, [bool], pointers, enums, handles, allocators, function pointers — go in SysV's integer registers [rdi rsi rdx rcx r8 r9], then right-to-left on the stack. [bool] is one byte, zero-extended. - {b Floats} go in [xmm0]-[xmm7], then on the stack. - {b Every aggregate goes by pointer.} An argument is a pointer to a copy the caller made; a return is a hidden [sret] pointer in the {e first} integer register, with everything else shifted along, and the same pointer comes back in [rax]. Nothing is classified, nothing is split across register classes, and there is no eightbyte rule. - {b The transfer channel} is the last argument of all, a pointer, in the integer sequence — [emit.ml]'s [signature] rule, unchanged. {b Where this must match SysV exactly, it does}, and that is the C boundary: [flan_rt.c], [flan_dev.c], the generated FFI shim. [check.ml] rejects an aggregate in a [declare] signature and the shim flattens every struct, so a string or slice crosses as [ptr]+[len] and no Flan-emitted call ever hands C an aggregate. There is therefore no aggregate classifier in this file, and per item 15 there does not need to be one. {1 The frame, and why the spike's worst bug cannot happen here} The spike found its one real bug in a call written inside a binary operator: the evaluator spilled the left operand with [push], so [rsp] was 8 out at the call and a C callee doing an aligned spill returned garbage. It fixed that with a depth counter. This module does not have a depth counter, because it does not push. {b Every intermediate value is a frame temporary}, bump-allocated below [rbp] with a high-water mark, and the outgoing-argument area is reserved once in the prologue. [rsp] is written exactly twice — in the prologue and by [leave] — so [rsp % 16 == 0] at every call site is a property of one rounded [sub] rather than an invariant every case has to maintain. The bug class is removed rather than guarded against. That costs instructions and no correctness. A debug build does not optimise; this is the trade the brief asks for. {1 Layout} [Emit.lay] / [lay_fields] / [payload_lay], reused rather than rewritten. They are acceptance-tested against LLVM's own [getelementptr], so there is one layout calculator in this compiler and this backend is a caller of it. {1 The container} Output is an assembly file: [.byte] blobs for the instructions, with the few fields that need a relocation written as assembler expressions ([call sym], [.long lbl - . - 4]). Byte offsets stay exactly known, which is what the introspection this backend exists for will need; what we give up is writing ELF ourselves, which is several hundred lines that produce no Flan progress and in which a bug looks exactly like an encoding bug. Reversible: the encoder below hands out bytes, and who packages them is a separate question. *) exception Unsupported of string let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt (* ── The byte buffer ─────────────────────────────────────────────────── *) (* Raw bytes accumulate in [pend] and are flushed as one [.byte] directive; anything the assembler has to resolve goes out as a directive with a known size, so [n] is the exact offset of the next byte either way. *) type buf = { out : Buffer.t; mutable pend : int list; mutable n : int } let create () = { out = Buffer.create 4096; pend = []; n = 0 } let flush b = if b.pend <> [] then begin Buffer.add_string b.out "\t.byte "; Buffer.add_string b.out (String.concat "," (List.rev_map (Printf.sprintf "0x%02x") b.pend)); Buffer.add_char b.out '\n'; b.pend <- [] end let u8 b x = b.pend <- (x land 0xff) :: b.pend; b.n <- b.n + 1 let u32 b n = for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done let i32 b (n : int) = if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n; u32 b n let u64 b (n : int64) = for i = 0 to 7 do u8 b (Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL)) done let dir b s size = flush b; Buffer.add_string b.out ("\t" ^ s ^ "\n"); b.n <- b.n + size let text b s = flush b; Buffer.add_string b.out s let lbl b l = flush b; Buffer.add_string b.out (l ^ ":\n") (* ── Registers ───────────────────────────────────────────────────────── *) (* The encoding numbering, not the ABI's: these three bits are what modrm wants, which is why rsp is 4 and rbp is 5. *) let rax = 0 and rcx = 1 and rdx = 2 let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7 let r8 = 8 and r9 = 9 and r11 = 11 let xmm0 = 0 let int_args = [| rdi; rsi; rdx; rcx; r8; r9 |] let n_int_args = 6 let n_sse_args = 8 (* REX. [force] is for the 8-bit forms, where without a REX byte registers 4-7 name ah/ch/dh/bh rather than spl/bpl/sil/dil — a store of a bool from rsi would otherwise write the wrong half of rdx. *) let rex ?(force = false) b ~w ~r ~x ~m = let v = (if w then 8 else 0) lor (if r >= 8 then 4 else 0) lor (if x >= 8 then 2 else 0) lor (if m >= 8 then 1 else 0) in if v <> 0 || force then u8 b (0x40 lor v) let modrm_r b ~r ~m = u8 b (0xc0 lor ((r land 7) lsl 3) lor (m land 7)) (* [base + disp32], always disp32: a frame outgrows 128 bytes and a disp8 that silently wraps is precisely the bug this would not find. r12 and rsp need a SIB byte because 4 in the r/m field means "SIB follows". *) let modrm_m b ~r ~base ~disp = u8 b (0x80 lor ((r land 7) lsl 3) lor (base land 7)); if base land 7 = 4 then u8 b 0x24; i32 b disp (* [rip + disp32], where the displacement is a relocation the assembler fills in. modrm mod=00 r/m=101 is the rip-relative form. *) let modrm_rip b ~r ~sym ~addend = u8 b (((r land 7) lsl 3) lor 5); dir b (Printf.sprintf ".long %s%s - . - 4" sym (if addend = 0 then "" else Printf.sprintf "+%d" addend)) 4 (* The same field, against a symbol this object does not define. A [PC32] relocation against an undefined symbol cannot be used in a shared object -- [ld] refuses the link outright -- so the address is read out of the GOT instead and the loader binds the slot to whatever the host has. [@GOTPCREL] is already pc-relative, so the [- .] the plain form needs is wrong here: written with it, [as] produces an addend of -8 and the load reads the wrong slot. [-4] alone is what [llc -relocation-model=pic] produces for the same instruction, checked against it. There is no addend either: the GOT holds the symbol's address and nothing else, so a field offset is added after the load, which is what [Lgot] below does. *) let modrm_got b ~r ~sym = u8 b (((r land 7) lsl 3) lor 5); dir b (Printf.sprintf ".long %s@GOTPCREL - 4" sym) 4 (* ── Instructions ────────────────────────────────────────────────────── *) type mem = | Frame of int | Reg of int * int | Sym of string * int | Got of string (* the GOT slot holding [sym]'s address *) let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) = let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ | Got _ -> 0 in List.iter (u8 b) pfx; (match mm with | Sym _ | Got _ -> rex b ~w ~r ~x:0 ~m:0 | _ -> rex b ~w ~r ~x:0 ~m:base); List.iter (u8 b) op; match mm with | Frame d -> modrm_m b ~r ~base:rbp ~disp:d | Reg (g, d) -> modrm_m b ~r ~base:g ~disp:d | Sym (s, a) -> modrm_rip b ~r ~sym:s ~addend:a | Got s -> modrm_got b ~r ~sym:s let mov_rr b ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b 0x89; modrm_r b ~r:src ~m:dst let movabs b ~dst (n : int64) = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b (0xb8 lor (dst land 7)); u64 b n let lea b ~dst ~(mm : mem) = mem_op b ~r:dst ~op:[ 0x8d ] ~w:true ~pfx:[] ~mm (* An integer load of [size] bytes, widened to the full 64-bit register the way the operand's own signedness says. Everything downstream then works in 64 bits and narrows only at a store, which is what makes one set of arithmetic encodings cover eight integer types. *) let load_int b ~dst ~mm ~size ~signed = match size, signed with | 8, _ -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:true ~pfx:[] ~mm | 4, false -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:false ~pfx:[] ~mm | 4, true -> mem_op b ~r:dst ~op:[ 0x63 ] ~w:true ~pfx:[] ~mm | 2, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb7 ] ~w:true ~pfx:[] ~mm | 2, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbf ] ~w:true ~pfx:[] ~mm | 1, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb6 ] ~w:true ~pfx:[] ~mm | 1, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbe ] ~w:true ~pfx:[] ~mm | n, _ -> unsupported "integer load of %d bytes" n let store_int b ~src ~mm ~size = match size with | 8 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:true ~pfx:[] ~mm | 4 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[] ~mm | 2 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[ 0x66 ] ~mm | 1 -> (* The one place a REX byte is needed for its own sake. *) let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ | Got _ -> 0 in rex ~force:(src >= 4) b ~w:false ~r:src ~x:0 ~m:base; u8 b 0x88; (match mm with | Frame d -> modrm_m b ~r:src ~base:rbp ~disp:d | Reg (g, d) -> modrm_m b ~r:src ~base:g ~disp:d | Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a | Got s -> modrm_got b ~r:src ~sym:s) | n -> unsupported "integer store of %d bytes" n let alu_rr b ~op ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b op; modrm_r b ~r:src ~m:dst let add_rr b ~dst ~src = alu_rr b ~op:0x01 ~dst ~src let sub_rr b ~dst ~src = alu_rr b ~op:0x29 ~dst ~src let and_rr b ~dst ~src = alu_rr b ~op:0x21 ~dst ~src let or_rr b ~dst ~src = alu_rr b ~op:0x09 ~dst ~src let xor_rr b ~dst ~src = alu_rr b ~op:0x31 ~dst ~src let cmp_rr b ~a ~c = alu_rr b ~op:0x39 ~dst:a ~src:c let imul_rr b ~dst ~src = rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xaf; modrm_r b ~r:dst ~m:src let grp1_imm b ~ext ~dst n = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0x81; modrm_r b ~r:ext ~m:dst; i32 b n let add_imm b ~dst n = grp1_imm b ~ext:0 ~dst n let sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a (* cqo then idiv, or xor rdx,rdx then div: the sign of the operands decides which pair, and getting that wrong is a wrong answer rather than a fault. *) let cqo b = u8 b 0x48; u8 b 0x99 let idiv_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:7 ~m:src let div_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:6 ~m:src (* Shifts by cl. The count is masked to the operand width by the hardware, which is the rule the language already defines (item 15's audit). *) let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst let shl_cl b ~dst = shift_cl b ~ext:4 ~dst let shr_cl b ~dst = shift_cl b ~ext:5 ~dst let sar_cl b ~dst = shift_cl b ~ext:7 ~dst let setcc b ~cc ~dst = rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0x0f; u8 b (0x90 lor cc); modrm_r b ~r:0 ~m:dst let movzx8 b ~dst ~src = rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xb6; modrm_r b ~r:dst ~m:src let jmp_lbl b l = u8 b 0xe9; dir b (Printf.sprintf ".long %s - . - 4" l) 4 let jcc_lbl b ~cc l = u8 b 0x0f; u8 b (0x80 lor cc); dir b (Printf.sprintf ".long %s - . - 4" l) 4 let call_sym b s = flush b; dir b (Printf.sprintf "call %s" s) 5 let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm_r b ~r:2 ~m:r let leave b = u8 b 0xc9 let ret b = u8 b 0xc3 let ud2 b = u8 b 0x0f; u8 b 0x0b let push_r b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7)) (* rep movsb: rdi, rsi, rcx. Nothing is ever live in a register across a statement here, so the crudest block copy in the instruction set is also the correct one, and a struct assignment *is* the copy spec-memory.md requires. *) let rep_movsb b = u8 b 0xf3; u8 b 0xa4 let rep_stosb b = u8 b 0xf3; u8 b 0xaa (* ── SSE ─────────────────────────────────────────────────────────────── *) let sse_rm b ~pfx ~op ~r ~mm = mem_op b ~r ~op:[ 0x0f; op ] ~w:false ~pfx:[ pfx ] ~mm let sse_rr b ~pfx ~op ~r ~m = u8 b pfx; rex b ~w:false ~r ~x:0 ~m; u8 b 0x0f; u8 b op; modrm_r b ~r ~m let movsd_load b ~dst ~mm = sse_rm b ~pfx:0xf2 ~op:0x10 ~r:dst ~mm let movsd_store b ~src ~mm = sse_rm b ~pfx:0xf2 ~op:0x11 ~r:src ~mm let movss_load b ~dst ~mm = sse_rm b ~pfx:0xf3 ~op:0x10 ~r:dst ~mm let movss_store b ~src ~mm = sse_rm b ~pfx:0xf3 ~op:0x11 ~r:src ~mm let fload b ~dst ~mm ~f64 = if f64 then movsd_load b ~dst ~mm else movss_load b ~dst ~mm let fstore b ~src ~mm ~f64 = if f64 then movsd_store b ~src ~mm else movss_store b ~src ~mm let farith b ~op ~f64 ~dst ~src = sse_rr b ~pfx:(if f64 then 0xf2 else 0xf3) ~op ~r:dst ~m:src let ucomis b ~f64 ~a ~c = if f64 then u8 b 0x66; rex b ~w:false ~r:a ~x:0 ~m:c; u8 b 0x0f; u8 b 0x2e; modrm_r b ~r:a ~m:c (* Conversions. REX.W selects the 64-bit integer side in each direction. *) let cvtsi2f b ~f64 ~dst ~src = u8 b (if f64 then 0xf2 else 0xf3); rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2a; modrm_r b ~r:dst ~m:src let cvttf2si b ~f64 ~dst ~src = u8 b (if f64 then 0xf2 else 0xf3); rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2c; modrm_r b ~r:dst ~m:src let cvtsd2ss b ~dst ~src = sse_rr b ~pfx:0xf2 ~op:0x5a ~r:dst ~m:src let cvtss2sd b ~dst ~src = sse_rr b ~pfx:0xf3 ~op:0x5a ~r:dst ~m:src let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modrm_r b ~r:dst ~m:dst (* ── Types ───────────────────────────────────────────────────────────── *) (* [Emit.m] carries the struct and union tables [Emit.lay] reads. Built here rather than imported so that this module adds no line to [emit.ml]: the record has no signature hiding it and every field it needs is inert. *) let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m = let structs = Hashtbl.create 16 and unions = Hashtbl.create 16 in List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s) p.Tast.structs; List.iter (fun (u : Tast.union) -> Hashtbl.replace unions u.Tast.uname u) p.Tast.unions; { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; unions; globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks; dev; known = (fun _ -> true); dbg = None; sanitize = false; nstr = 0; nfi = 0 } let sizeof md t = fst (Emit.lay md t) let alignof md t = snd (Emit.lay md t) (* The one classification this backend makes, and it has two answers rather than SysV's eight. *) let is_agg (t : Types.t) = match t with | Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _ | Types.Alloc | Types.Handle _ | Types.Fn _ -> false | Types.Unit | Types.Never -> false | Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _ | Types.Pool _ | Types.Option _ | Types.Named _ -> true | Types.Var v -> unsupported "type variable %s" v let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false let f64_of (t : Types.t) = match t with Types.Float Types.F32 -> false | _ -> true (* Signedness for a load and for a comparison. A pointer, a handle and an enum are each unsigned machine words; [bool] is a zero-extended byte. *) let signed_of (t : Types.t) = match t with | Types.Int k -> Types.signed k | Types.Enum _ -> true | _ -> false (* ── Mangling ────────────────────────────────────────────────────────── *) (* The same names [emit.ml] gives, so a build made here links against the same runtime and a disassembly reads with the same symbols. A Flan name can hold characters an assembler will not take bare, so every symbol is quoted. *) let asm_sym s = "\"" ^ s ^ "\"" let fsym n = asm_sym ("flan." ^ n) let gsym n = asm_sym ("flan." ^ n) (* The indirection cell: a mutable global holding the address of the function that is currently this name's body. Spelled exactly as [Emit.cellname] spells it, because that is the whole point of having one here — a redefinition module is still built by LLVM, and it binds [@"flan.cell." = external global ptr] against whatever built the host. Byte-for-byte or the link fails and the piece served nothing. *) let csym n = asm_sym ("flan.cell." ^ n) (* The marker that says which backend built an image, and it is the whole of the answer to the one way these two backends can be mixed and be wrong. [emit.ml] and this file agree on every scalar and disagree on every aggregate — this file passes a struct by pointer with a hidden [sret] and LLVM classifies per SysV — so a redefinition module from one backend dlopened into a host from the other links, loads, and then dies at the first call into a redefined function that takes or returns a struct. That was measured as SIGSEGV; see HANDOFF-x86-aggregates.md. A dev build defines its own marker and a redefinition module emits a data relocation against the marker it was itself built for. A matched pair binds it and notices nothing. A crossed pair has no such symbol to bind, and the loader refuses the module at [dlopen] — before a single instruction of the new body runs, and with the missing symbol naming the backend in the message. That is the property: the mismatch is caught by the loader rather than by the processor, at load rather than at a call. [Emit.abi_marker] is the same string for the LLVM half. The two must stay distinct and neither may ever be defined by both backends, or the refusal quietly stops refusing. *) let abi_marker = "flan.abi.x86" (* ── Debug information ───────────────────────────────────────────────── *) (* DWARF, written out as bytes, for the same reason the instructions are — and the reason is worth stating first because it is the one thing about this backend that makes debug information cost more here than it does anywhere else. {b [.loc] does not work against an assembly file that has no instructions in it.} GAS builds its line table from [dwarf2_emit_insn], which runs only when an instruction is assembled, and this file assembles none: everything is a [.byte] blob. A pending [.loc] therefore sits until the *next* [.loc] and is flushed at whatever the location counter has reached by then, so every row comes out one statement late and the last statement of every function gets no row at all. Measured on GAS 2.44 and reproduced with labels interposed, which do not help. So [.debug_line] is emitted here as data, which is in any case the only spelling consistent with the rest of the file. DWARF 4 rather than 5. Version 4's file and directory tables are NUL-terminated strings and a terminator byte where 5 form-codes them, and nothing above needs a version 5 feature. A compile unit declares its own version, so a v4 unit sitting beside the v5 ones clang gives the runtime's C is not a conflict — each is read on its own terms. What is described is deliberately shallow: the compile unit, one subprogram per function, and the line table. {b No locals and no types.} [emit.ml] writes a [!DILocalVariable] per slot because every slot there is an [alloca] that [llvm.dbg.declare] can point at and LLVM computes the frame offset; here a slot is a bump-allocated frame temporary whose offset this file knows but whose *lifetime* it does not model — [scoped] reclaims temporaries and a later expression reuses the bytes. Naming an offset that holds something else half the time is worse than naming nothing, so this emits nothing rather than a confident wrong answer. That is the same call [build.ml] makes about wasm32's member offsets. *) (* One row of the line table: the label whose address it is, and the position it names. Addresses are labels rather than numbers because the assembler places the function and this file does not. *) type dwrow = { rlbl : string; rfile : int; rline : int; rcol : int } type dwsub = { sname : string; (* what a debugger calls the frame *) ssym : string; (* the symbol the linker sees *) sfile : int; sline : int; send : string; (* a label one past the function's last byte *) mutable srows : dwrow list; (* newest first *) } type dwarf = { dfiles : (string, int) Hashtbl.t; mutable dpaths : string list; (* newest first *) mutable dsubs : dwsub list; (* newest first *) mutable dcur : dwsub option; (* the function being lowered *) mutable dlast : (int * int * int) option; (* the last row's position *) (* [buf.n] as it stood when the last row was made. [lower] recurses, so an outer form and the inner one that emits the first byte of it both ask for a row at the same address; without this the table carries a run of rows that a debugger resolves by taking the last, which is the innermost form rather than the statement. Keeping the first is both smaller and the better answer. Reset to -1 per function, because the body's byte counter starts again at 0 and the entry row is at the prologue's 0. *) mutable dlastn : int; } let new_dwarf () = { dfiles = Hashtbl.create 8; dpaths = []; dsubs = []; dcur = None; dlast = None; dlastn = -1 } (* File indices are 1-based and handed out in first-seen order, which is the order the file table is written in below. A program spans more than one file whenever the prelude or a macro contributed a form, and the checker's own invented nodes carry [Loc.unknown], whose file is [] — that one never reaches here, because a row with line 0 is attributed to the enclosing function's file instead. *) let dwfile dw path = match Hashtbl.find_opt dw.dfiles path with | Some n -> n | None -> let n = List.length dw.dpaths + 1 in Hashtbl.replace dw.dfiles path n; dw.dpaths <- path :: dw.dpaths; n (* ── Function context ────────────────────────────────────────────────── *) type fnctx = { b : buf; md : Emit.m; fnname : string; (* The label the epilogue sits on. Every [return] and every fallthrough from the body jumps here, so the frame is torn down in exactly one place. *) mutable retlbl : string; fret : Types.t; slots : int array; (* rbp-relative offset of each Tast slot *) mutable xfer_off : int; (* the incoming transfer channel pointer *) mutable sret_off : int; (* where the hidden return pointer was put *) mutable retval : int; (* the scalar return value's temporary *) mutable frame : int; (* bytes currently allocated below rbp *) mutable maxframe : int; mutable outgoing : int; (* bytes the widest call needs for stack args *) (* One entry per [While] we are inside, innermost first: the label a [break] jumps to and the label a [continue] jumps to, which is the latch and not the head. *) mutable loops : (string * string) list; (* The innermost landing pad a transfer found after a call should jump to, with a flag saying whether anything ever aimed at it: a pad nobody jumps to must not be emitted, because its code would then be reached by falling into it. Empty means the function's own transfer exit, [xfer_lbl]. *) mutable pads : (string * bool ref) list; (* The function's own 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 way a [return] does, which is what reuses the epilogue and the defers for free. [unwound] says whether anything can reach it. *) mutable xfer_lbl : string; mutable unwound : bool; (* Collected while lowering: string literals and float constants both need a labelled constant in .rodata, and both are discovered mid-expression. *) rodata : Buffer.t; externs : (string, string) Hashtbl.t; fns : (string, unit) Hashtbl.t; (* True of a symbol this object does not define. Always false for a whole program, which defines everything it names bar the runtime, and where every reference is therefore pc-relative exactly as before. A redefinition module answers true for the host's cells, globals and bodies, and those go through the GOT -- see [modrm_got]. *) ext : string -> bool; (* The line table under construction, in a [--debug] build. [None] is every other build, and then [dwline] below is the only thing that looks at it and does nothing — so a release build's output is byte-identical to what it was before debug information existed. *) dw : dwarf option; } (* Module-wide rather than per-function. Two functions each holding an [if] would otherwise both emit [.Lif1] into the same [.s] and the assembler would refuse the file — a failure that only appears once a *program* is lowered and never once a single function is, which is exactly the class of thing the spike could not have found. *) let uniq = ref 0 let new_label _f tag = incr uniq; Printf.sprintf ".L%s%d" tag !uniq (* A line-table row at the point the output has reached, unless the last row already named this position. [lower] calls this for every expression, so the dedup is what keeps a statement made of a dozen nodes on one line from costing a dozen rows; the column is part of the key, so two forms on one line are still told apart. Line 0 is [Loc.unknown] — a node the checker invented rather than one anyone wrote. It is attributed to the enclosing function's own line, for [emit.ml]'s reason at its [at_loc]: a zero line in DWARF means "no line", and a debugger given one steps over the whole construct. *) let dwline f (loc : Loc.t) = match f.dw with | None -> () | Some dw -> (match dw.dcur with | None -> () | Some s -> let file, line, col = if loc.Loc.line = 0 then (s.sfile, s.sline, 1) else (dwfile dw loc.Loc.file, loc.Loc.line, loc.Loc.col) in if dw.dlast <> Some (file, line, col) && f.b.n > dw.dlastn then begin let l = new_label f "dl" in lbl f.b l; dw.dlast <- Some (file, line, col); dw.dlastn <- f.b.n; s.srows <- { rlbl = l; rfile = file; rline = line; rcol = col } :: s.srows end) (* Bump-allocate a frame temporary and answer its rbp-relative offset. The offset is negative, so the running total is rounded *up* to the alignment; rbp is 16-aligned, so that is the alignment the value actually gets. *) let alloc f size align = let a = if align <= 1 then 1 else align in f.frame <- f.frame + (if size <= 0 then 1 else size); f.frame <- (f.frame + a - 1) / a * a; if f.frame > f.maxframe then f.maxframe <- f.frame; -f.frame let tmp f (t : Types.t) = alloc f (max 1 (sizeof f.md t)) (alignof f.md t) let ptmp f = alloc f 8 8 (* Temporaries are reclaimed at the end of the expression that made them; the destination is allocated by the caller and therefore outlives the reset. *) let scoped f g = let save = f.frame in let r = g () in f.frame <- save; r (* ── Moving values ───────────────────────────────────────────────────── *) (* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else is its own width, widened on load. *) let load_scalar f ~reg ~off (t : Types.t) = if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t) else let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t) let store_scalar f ~reg ~off (t : Types.t) = if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t) else let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in store_int f.b ~src:reg ~mm:(Frame off) ~size (* Through a pointer rather than a frame offset: the same two, with the address already in a register. *) let load_scalar_at f ~reg ~base ~disp (t : Types.t) = if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t) else let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t) let store_scalar_at f ~reg ~base ~disp (t : Types.t) = if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t) else let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size (* n bytes from the address in rsi to the address in rdi. *) let blockcopy f n = if n > 0 then begin movabs f.b ~dst:rcx (Int64.of_int n); rep_movsb f.b end let copy_frames f ~dst ~src n = if n > 0 then begin lea f.b ~dst:rdi ~mm:(Frame dst); lea f.b ~dst:rsi ~mm:(Frame src); blockcopy f n end let zero_frame f ~dst n = if n > 0 then begin lea f.b ~dst:rdi ~mm:(Frame dst); xor_rr f.b ~dst:rax ~src:rax; movabs f.b ~dst:rcx (Int64.of_int n); rep_stosb f.b end (* ── Constants in .rodata ────────────────────────────────────────────── *) let rodata_label _f = incr uniq; Printf.sprintf ".Lk%d" !uniq let escape_bytes s = String.concat "," (List.map (fun c -> Printf.sprintf "0x%02x" (Char.code c)) (List.init (String.length s) (String.get s))) let string_const f s = let l = rodata_label f in Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l); if String.length s > 0 then Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s)); (* A trailing NUL nobody reads through the length, so that a pointer handed to C by a shim is still a C string if anything ever treats it as one. *) Buffer.add_string f.rodata "\t.byte 0x00\n"; l let float_const f (x : float) ~f64 = let l = rodata_label f in if f64 then Buffer.add_string f.rodata (Printf.sprintf "\t.align 8\n%s:\n\t.quad 0x%Lx\n" l (Int64.bits_of_float x)) else Buffer.add_string f.rodata (Printf.sprintf "\t.align 4\n%s:\n\t.long 0x%lx\n" l (Int32.bits_of_float x)); l (* ── Locations ───────────────────────────────────────────────────────── *) (* Where a value lives. Every value in this backend lives in memory, so the three cases are the three ways an address is formed and not three kinds of value: a frame offset, a rip-relative global, and a pointer already computed into a frame temporary. Adding a field offset to any of them is arithmetic on the displacement rather than an instruction. *) type loc = | Lf of int (* rbp + d *) | Lg of string * int (* rip-relative symbol + d *) | Lgot of string * int (* a symbol this object does not define; + d *) | Lp of int * int (* [rbp + p] is a pointer; + d *) let shift l d = match l with | Lf o -> Lf (o + d) | Lg (s, a) -> Lg (s, a + d) | Lgot (s, a) -> Lgot (s, a + d) | Lp (p, a) -> Lp (p, a + d) (* [scratch] is only touched by the [Lp] case, and every caller passes r11 — which is why r11 is never a value register anywhere below. *) let lmem f (l : loc) ~scratch : mem = match l with | Lf o -> Frame o | Lg (s, a) -> Sym (s, a) (* The GOT slot holds the address, so this is one load more than [Lg] and exactly the [Lp] shape afterwards -- the displacement is arithmetic on a register base, never on the relocation. *) | Lgot (s, a) -> load_int f.b ~dst:scratch ~mm:(Got s) ~size:8 ~signed:false; Reg (scratch, a) | Lp (p, a) -> load_int f.b ~dst:scratch ~mm:(Frame p) ~size:8 ~signed:false; Reg (scratch, a) let addr_into f ~reg (l : loc) = match l with | Lf o -> lea f.b ~dst:reg ~mm:(Frame o) | Lg (s, a) -> lea f.b ~dst:reg ~mm:(Sym (s, a)) | Lgot (s, a) -> load_int f.b ~dst:reg ~mm:(Got s) ~size:8 ~signed:false; if a <> 0 then add_imm f.b ~dst:reg a | Lp (p, a) -> load_int f.b ~dst:reg ~mm:(Frame p) ~size:8 ~signed:false; if a <> 0 then add_imm f.b ~dst:reg a (* The spellings of "name a symbol", each picking the pc-relative form for a symbol this object defines and the GOT form for one it does not. *) let sym_loc f s = if f.ext s then Lgot (s, 0) else Lg (s, 0) (* [lea] of a symbol is an address; out of the GOT the address is already there, so the [lea] becomes a load. *) let addr_sym f ~dst s = if f.ext s then load_int f.b ~dst ~mm:(Got s) ~size:8 ~signed:false else lea f.b ~dst ~mm:(Sym (s, 0)) (* Read what a global holds, as opposed to where it is -- an indirection cell is the only caller. Out of the GOT that is two loads, not one: the slot holds the cell's *address*. Collapsing them was this lane's one real bug, and it looked exactly right in the disassembly: [mov r11, cell@GOTPCREL(%rip)] beside [call *%r11] reads as "call through the cell" and in fact calls the cell. DISCUSS.md item 15 said this is how hand-encoding fails. *) let load_sym f ~dst s = if f.ext s then begin load_int f.b ~dst ~mm:(Got s) ~size:8 ~signed:false; load_int f.b ~dst ~mm:(Reg (dst, 0)) ~size:8 ~signed:false end else load_int f.b ~dst ~mm:(Sym (s, 0)) ~size:8 ~signed:false let scalar_size f (t : Types.t) = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) let load_loc f ~reg (l : loc) (t : Types.t) = let mm = lmem f l ~scratch:r11 in if is_float t then fload f.b ~dst:reg ~mm ~f64:(f64_of t) else load_int f.b ~dst:reg ~mm ~size:(scalar_size f t) ~signed:(signed_of t) let store_loc f ~reg (l : loc) (t : Types.t) = let mm = lmem f l ~scratch:r11 in if is_float t then fstore f.b ~src:reg ~mm ~f64:(f64_of t) else store_int f.b ~src:reg ~mm ~size:(scalar_size f t) (* An aggregate move. [rep movsb] rather than a sized loop for the reason the header gives: nothing is live in a register across a statement, so the crudest block copy in the instruction set is also the correct one. *) let copy_loc f ~(dst : loc) ~(src : loc) n = if n > 0 then begin addr_into f ~reg:rdi dst; addr_into f ~reg:rsi src; blockcopy f n end let zero_loc f (dst : loc) n = if n > 0 then begin addr_into f ~reg:rdi dst; xor_rr f.b ~dst:rax ~src:rax; movabs f.b ~dst:rcx (Int64.of_int n); rep_stosb f.b end (* Move a value of any type from one location to another: a block copy for an aggregate, a load and a store for a scalar, and nothing at all for Unit. *) let move f ~(dst : loc) ~(src : loc) (t : Types.t) = if not (is_void t) then if is_agg t then copy_loc f ~dst ~src (sizeof f.md t) else begin let r = if is_float t then xmm0 else rax in load_loc f ~reg:r src t; store_loc f ~reg:r dst t end let imm_into f ~reg (n : int64) = movabs f.b ~dst:reg n (* ── Struct layout, through [Emit] ───────────────────────────────────── *) let union_payload_off f (u : Tast.union) = let size, align = Emit.payload_lay f.md u in if size = 0 then 0 else let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I32; Types.Array (Int64.of_int (size / align), Types.Int (Emit.int_kind (align * 8))) ] in List.nth offs 1 let field_offsets f (sn : string) = match Hashtbl.find_opt f.md.Emit.structs sn with | Some (s : Tast.structure) -> let _, _, offs = Emit.lay_fields f.md (List.map (fun (fl : Tast.field) -> fl.Tast.fty) s.Tast.fields) in offs | None -> (* A union is a struct too, at this level: [emit.ml] lays it out as a tag and a payload blob, and the structural printer reads the tag as field 0 without unwrapping the value. *) (match Hashtbl.find_opt f.md.Emit.unions sn with | Some (u : Tast.union) -> [ 0; union_payload_off f u ] | None -> unsupported "no struct %s" sn) (* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay] measures it as — so the payload's offset is whatever [lay_fields] puts the second one at, and not a rule spelled a second time here. A union whose cases are all payload-less is a bare tag and has no second field. *) let union_of f n = match Hashtbl.find_opt f.md.Emit.unions n with | Some u -> u | None -> unsupported "no union %s" n (* The offsets of one case's fields inside the payload blob. The single place in this backend that knows how a payload is read, so [match]'s binds, [CaseField] and [MakeCase] cannot come to different conclusions about it. *) let case_offsets f (c : Tast.variant) = let _, _, offs = Emit.lay_fields f.md (List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields) in offs (* An Option is { i8 tag, T }, the same two fields [Emit.lay] measures it as. *) let option_lay f (t : Types.t) = let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I8; t ] in match offs with [ a; b ] -> a, b | _ -> unsupported "option layout" (* ── Condition codes ─────────────────────────────────────────────────── *) let cc_e = 4 and cc_ne = 5 let cc_b = 2 and cc_ae = 3 and cc_be = 6 and cc_a = 7 let cc_l = 12 and cc_ge = 13 and cc_le = 14 and cc_g = 15 let int_cc ~signed (p : Tast.prim) = match p, signed with | Tast.Eq, _ -> cc_e | Tast.Ne, _ -> cc_ne | Tast.Lt, true -> cc_l | Tast.Lt, false -> cc_b | Tast.Le, true -> cc_le | Tast.Le, false -> cc_be | Tast.Gt, true -> cc_g | Tast.Gt, false -> cc_a | Tast.Ge, true -> cc_ge | Tast.Ge, false -> cc_ae | _ -> unsupported "not a comparison" (* Parity, which on [ucomis] means "unordered": one of the operands was a NaN. Nothing else in this file reads it. *) let cc_np = 11 (* [ucomis] sets the flags the *unsigned* codes read, whichever way the operands are signed, so a float comparison never uses l/g — and it sets CF, ZF and PF all at once when either operand is a NaN. That last part is why this is not simply the unsigned table. Every comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq, one, olt, ...), which answers false for a NaN, and [setb] after an unordered compare answers true. So [<] and [<=] swap their operands and ask for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be spelled by one code at all and take a second [setnp] beside them. [(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as -9223372036854775808. *) let float_swaps (p : Tast.prim) = match p with Tast.Lt | Tast.Le -> true | _ -> false let float_cc (p : Tast.prim) = match p with | Tast.Eq -> cc_e | Tast.Ne -> cc_ne | Tast.Lt -> cc_a | Tast.Le -> cc_ae | Tast.Gt -> cc_a | Tast.Ge -> cc_ae | _ -> unsupported "not a comparison" let float_ordered (p : Tast.prim) = match p with Tast.Eq | Tast.Ne -> true | _ -> false let is_cmp (p : Tast.prim) = match p with | Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true | _ -> false (* ── The transfer channel, spec-conditions.md §6 ──────────────── *) (* One indirection more than [emit.ml] has, and it is the whole trap in this file. There [%xfer] is an alloca, so the target is one [load] away. Here [xfer_off] is a frame slot *holding the caller's pointer*, so reading the target is two loads — slot, then through it — and clearing the channel is a store *through* the pointer and never a store to [xfer_off]. Getting that wrong produces assembly that reads perfectly and a program that never sees a transfer, which is exactly the failure item 15 warns about. *) let chan_into f ~reg = load_int f.b ~dst:reg ~mm:(Frame f.xfer_off) ~size:8 ~signed:false (* The transfer target, or null. *) let xfer_load f ~reg = chan_into f ~reg; load_int f.b ~dst:reg ~mm:(Reg (reg, 0)) ~size:8 ~signed:false (* [reg] into the channel. [scratch] must not be [reg]. *) let xfer_store f ~reg ~scratch = chan_into f ~reg:scratch; store_int f.b ~src:reg ~mm:(Reg (scratch, 0)) ~size:8 let xfer_clear f = chan_into f ~reg:r11; xor_rr f.b ~dst:rax ~src:rax; store_int f.b ~src:rax ~mm:(Reg (r11, 0)) ~size:8 (* Where a transfer found after a call goes: the innermost restart-case, handler-bind or with-allocator pad we are inside, or the function's own transfer exit. Naming one marks it reached — nothing emits a pad that is only ever fallen into. *) let current_pad f = match f.pads with | (p, used) :: _ -> used := true; p | [] -> f.unwound <- true; f.xfer_lbl (* The check after a call, which is the whole of §6's lowering at a call site: two loads, a test and a branch. Only [r11] is touched, so it may be emitted between the call and the store of the value in [rax] — which is where it goes, because a transfer means the value is meaningless. A foreign call gets none: a transfer cannot cross a C frame, so there is nothing a guard there could find. The exceptions are the runtime entry points that take the channel themselves and signal through it. *) let guard f = xfer_load f ~reg:r11; test_rr f.b ~a:r11 ~c:r11; jcc_lbl f.b ~cc:cc_ne (current_pad f) (* Run [g] with a fresh pad on top of the stack, and answer the pad's label beside whether anything aimed at it. *) let with_pad f tag g = let pad = new_label f tag and used = ref false in f.pads <- (pad, used) :: f.pads; let r = g () in f.pads <- List.tl f.pads; (pad, used, r) (* ── The runtime's two dynamic stacks ────────────────────────────────── *) (* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the same rules the runtime's own structs get, and the same [Emit.lay] applies to everything else. Both live as frame temporaries of the function that establishes them, which is the point: the *address* of a frame is the identity a transfer carries, so re-entering the same restart-case gets a different one and a module loaded later cannot collide with it. *) (* { ptr prev, i32 type_id, ptr fn } *) let h_size = 24 let h_type = 8 let h_fn = 16 (* { ptr prev, i32 name_id, ptr name, i64 namelen, ptr args, i32 arity, i32 sig_id, i32 armed, ptr sig, i64 siglen } *) let r_size = 72 let r_name_id = 8 let r_name = 16 let r_namelen = 24 let r_args = 32 let r_arity = 40 let r_sig_id = 44 let r_armed = 48 let r_sig = 56 let r_siglen = 64 (* ── The calling convention, as the header states it ─────────────────── *) (* One argument as it will actually be handed over. [Aptr] is an aggregate, which always crosses as the address of a copy the caller made; [Alen] is the second word of a slice being exploded for a C callee. *) type arg = | Aint of loc * Types.t | Aflt of loc * Types.t | Aptr of loc | Alen of loc (* The C boundary, and the one place this backend must match SysV rather than pick. [check.ml] rejects an aggregate in a [declare] signature and the shim flattens every struct, so the only aggregates that reach here are the ones [emit.ml]'s own shim rules already spell out: a slice as ptr+len, and a move-only container by address. *) let classify_c (l : loc) (t : Types.t) = match t with | Types.String | Types.Slice _ -> [ Aint (l, Types.Ptr Types.Unit); Alen l ] | Types.Unit | Types.Never -> [] | Types.Vec _ | Types.Map _ | Types.Pool _ -> [ Aptr l ] | _ when is_agg t -> unsupported "aggregate %s across the C boundary" (Types.to_string t) | _ when is_float t -> [ Aflt (l, t) ] | _ -> [ Aint (l, t) ] (* Hand the arguments over. Everything has already been evaluated into frame temporaries, so loading the registers cannot disturb anything: every load below reads from rbp, and rbp does not move. Answers how many SSE registers were used, which is what [al] has to say to a variadic callee. *) let emit_args f (args : arg list) = let ints = ref 0 and sses = ref 0 and stack = ref 0 in let placed = List.map (fun a -> match a with | Aflt _ when !sses < n_sse_args -> incr sses; `Sse (!sses - 1, a) | Aflt _ -> let k = !stack in stack := k + 8; `Stack (k, a) | _ when !ints < n_int_args -> incr ints; `Int (!ints - 1, a) | _ -> let k = !stack in stack := k + 8; `Stack (k, a)) args in if !stack > f.outgoing then f.outgoing <- !stack; let into ~reg a = match a with | Aint (l, t) -> load_loc f ~reg l t | Aflt (l, t) -> fload f.b ~dst:reg ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t) | Aptr l -> addr_into f ~reg l | Alen l -> load_int f.b ~dst:reg ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8 ~signed:true in (* The stack half first, because it uses rax as its courier and a register argument must not already be sitting in rax while that happens. *) List.iter (function | `Stack (k, a) -> (match a with | Aflt (l, t) -> fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t); fstore f.b ~src:xmm0 ~mm:(Reg (rsp, k)) ~f64:(f64_of t) | _ -> into ~reg:rax a; store_int f.b ~src:rax ~mm:(Reg (rsp, k)) ~size:8) | _ -> ()) placed; List.iter (function | `Int (i, a) -> into ~reg:int_args.(i) a | `Sse (i, a) -> into ~reg:i a | `Stack _ -> ()) placed; !sses (* ── Lowering ────────────────────────────────────────────────────────── *) (* The destination handed to an expression whose value is thrown away. It is one allocated value and it is compared by identity, because it is not an address and must never be used as one: rbp+0 is the saved rbp and rbp+8 is the return address, so a 16-byte slice stored "into the sink" overwrites both and the function returns into whatever the first two words of the value happened to be. That is not hypothetical — it is how [edn.flan] failed, by jumping into .rodata several statements after the real mistake, and the mistake was a form of non-void type written in statement position. So [lower] refuses the sink for anything that has a value, and spends a frame temporary on it instead. The temporary is reclaimed at once; the point is that the store has somewhere legal to go. *) let sink = Lf 0 let rec lower f (e : Tast.expr) (dst : loc) : unit = (* The one hook the line table needs, and it is here rather than at statement granularity on purpose: the same recursion that lowers a nested call lowers its arguments, and a row per expression is what makes a backtrace through an argument name the argument rather than the call. It is inert in every build but a [--debug] one. *) dwline f e.Tast.loc; if dst == sink && not (is_void e.Tast.ty) then scoped f (fun () -> let o = tmp f e.Tast.ty in lower f e (Lf o)) else lower_at f e dst and lower_at f (e : Tast.expr) (dst : loc) : unit = let t = e.Tast.ty in match e.Tast.e with | Tast.Int (n, _) -> imm_into f ~reg:rax n; store_loc f ~reg:rax dst t | Tast.Bool b -> imm_into f ~reg:rax (if b then 1L else 0L); store_loc f ~reg:rax dst Types.Bool | Tast.Float (x, k) -> let f64 = (k = Types.F64) in let l = float_const f x ~f64 in fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 | Tast.Str s -> (* A string and a [u8] slice are the same two words, which is why [Bytes] below is a non-instruction. *) let l = string_const f s in lea f.b ~dst:rax ~mm:(Sym (l, 0)); store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; imm_into f ~reg:rax (Int64.of_int (String.length s)); store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 | Tast.Unit -> () | Tast.Zero ty -> zero_value f dst ty | Tast.None_ -> zero_value f dst t (* Reading an uninitialised value gives whatever the slot held: stable garbage rather than LLVM's [poison]. The one construct where the two backends are meant to differ — DISCUSS.md item 15, question 4. *) | Tast.Uninit _ -> () | Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ -> let src = lvalue f e in move f ~dst ~src t | Tast.Addr p -> let l = place f p in addr_into f ~reg:rax l; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 (* The symbol itself, not a load from it: a function's address is a link-time constant, and this is the spelling a lifted handler clause is reached by. [emit.ml] says the same of [Flanfn]. *) | Tast.FnAddr (Tast.Flanfn n) -> addr_sym f ~dst:rax (fsym n); store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 (* A function value someone wrote, which is the one [FnAddr] that is not the symbol. In a release build there is nothing to redefine and it is the symbol after all; in a dev build it is the cell's contents, so that a value taken after a redefinition is the new body. What that does not give — and [emit.ml] names it rather than papering over it with a trampoline — is a value taken *before* a redefinition and called after it. Once the address is in a slot there is nothing left to re-resolve. *) | Tast.FnAddr (Tast.Fnval n) -> if f.md.Emit.dev then load_sym f ~dst:rax (csym n) else addr_sym f ~dst:rax (fsym n); store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 | Tast.FnAddr (Tast.Rtfn n) -> addr_sym f ~dst:rax n; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 | Tast.Prim (p, args) -> prim f e p args dst | Tast.Call (name, args) -> (match Hashtbl.find_opt f.externs name with | Some sym -> call_c f ~sym ~args ~rty:t dst | None -> (* A dev build calls through the cell so that a redefinition reaches every existing call site; a release build names the symbol. *) call_flan f ~target:(if f.md.Emit.dev then `Cell (csym name) else `Sym (fsym name)) ~args ~rty:t dst) | Tast.CallPtr (callee, args) -> let c = eval f callee in call_flan f ~target:(`Loc c) ~args ~rty:t dst | Tast.Do body -> block f body dst t | Tast.Let (bs, body) -> List.iter (fun (slot, (v : Tast.expr)) -> scoped f (fun () -> lower f v (Lf f.slots.(slot)))) bs; block f body dst t | Tast.If (c, a, b) -> let lelse = new_label f "else" and lend = new_label f "endif" in scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool); test_rr f.b ~a:rax ~c:rax; jcc_lbl f.b ~cc:cc_e lelse; scoped f (fun () -> lower f a dst); jmp_lbl f.b lend; lbl f.b lelse; scoped f (fun () -> lower f b dst); lbl f.b lend | Tast.While (c, body, latch) -> let lhead = new_label f "head" and llatch = new_label f "latch" and lend = new_label f "endw" in lbl f.b lhead; scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool); test_rr f.b ~a:rax ~c:rax; jcc_lbl f.b ~cc:cc_e lend; f.loops <- (lend, llatch) :: f.loops; List.iter (fun s -> scoped f (fun () -> lower f s sink)) body; lbl f.b llatch; List.iter (fun s -> scoped f (fun () -> lower f s sink)) latch; f.loops <- List.tl f.loops; jmp_lbl f.b lhead; lbl f.b lend | Tast.Return v -> (match v with | Some x when not (is_void x.Tast.ty) && not (is_void f.fret) -> scoped f (fun () -> lower f x (ret_loc f)) | Some x -> scoped f (fun () -> lower f x sink) | None -> ()); jmp_lbl f.b f.retlbl | Tast.Break n -> (match List.nth_opt f.loops n with | Some (lend, _) -> jmp_lbl f.b lend | None -> unsupported "break %d outside a loop" n) | Tast.Continue n -> (match List.nth_opt f.loops n with | Some (_, llatch) -> jmp_lbl f.b llatch | None -> unsupported "continue %d outside a loop" n) | Tast.Set (p, v) -> let l = place f p in scoped f (fun () -> lower f v l) | Tast.Make (sn, xs) -> let offs = field_offsets f sn in List.iteri (fun i (x : Tast.expr) -> scoped f (fun () -> lower f x (shift dst (List.nth offs i)))) xs | Tast.Arr xs -> let elem = match t with | Types.Array (_, el) -> el | _ -> unsupported "array literal of %s" (Types.to_string t) in let sz = sizeof f.md elem in List.iteri (fun i (x : Tast.expr) -> scoped f (fun () -> lower f x (shift dst (i * sz)))) xs | Tast.Some_ x -> let payload = match t with | Types.Option el -> el | _ -> unsupported "some of %s" (Types.to_string t) in let ot, ov = option_lay f payload in imm_into f ~reg:rax 1L; store_int f.b ~src:rax ~mm:(lmem f (shift dst ot) ~scratch:r11) ~size:1; scoped f (fun () -> lower f x (shift dst ov)) | Tast.UnwrapSome x -> (* An early return and not an expression that can fail: with a [None] the enclosing function returns [None] at once. *) let payload = match x.Tast.ty with | Types.Option el -> el | _ -> unsupported "unwrap of %s" (Types.to_string x.Tast.ty) in let src = eval f x in let ot, ov = option_lay f payload in load_int f.b ~dst:rax ~mm:(lmem f (shift src ot) ~scratch:r11) ~size:1 ~signed:false; let lsome = new_label f "some" in test_rr f.b ~a:rax ~c:rax; jcc_lbl f.b ~cc:cc_ne lsome; if not (is_void f.fret) then zero_value f (ret_loc f) f.fret; jmp_lbl f.b f.retlbl; lbl f.b lsome; move f ~dst ~src:(shift src ov) payload | Tast.MakeCase (uname, case, fields) -> let u = union_of f uname in let i, c = match Tast.case_index u case with | Some (i, c) -> i, c | None -> unsupported "no case %s of %s" case uname in (* Zeroed first: an omitted field is ZII and the payload blob is wider than this case, so the bytes past its last field have to be something rather than whatever the frame held. *) zero_loc f dst (sizeof f.md t); imm_into f ~reg:rax (Int64.of_int i); store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:4; let poff = union_payload_off f u in let offs = case_offsets f c in List.iteri (fun k (x : Tast.expr) -> scoped f (fun () -> lower f x (shift dst (poff + List.nth offs k)))) fields | Tast.CaseField (target, case, i) -> move f ~dst ~src:(case_field f target case i) t | Tast.Match (scrut, arms) -> emit_match f scrut arms dst t (* 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) -> scoped f (fun () -> let l = lvalue f c in addr_into f ~reg:rsi l; imm_into f ~reg:rdi (Int64.of_int id); chan_into f ~reg:rdx; xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_signal"; guard f) (* §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 [ud2] — where [emit.ml] writes [unreachable]. *) | Tast.Signal (Tast.Serror, id, c) -> scoped f (fun () -> let l = lvalue f c in addr_into f ~reg:rsi l; imm_into f ~reg:rdi (Int64.of_int id); chan_into f ~reg:rdx; let name = match c.Tast.ty with Types.Named n -> n | _ -> "a condition" in str_args f ~preg:rcx ~nreg:r8 name; xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_error"; guard f; ud2 f.b) | Tast.Handled (frames, body) -> emit_handled f frames body dst t | Tast.RestartCase (clauses, body) -> emit_restart_case f clauses body dst t | Tast.WithAlloc (a, body) -> emit_with_alloc f a body dst t | Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) -> emit_invoke_restart f id name args sg sg_id rloc (* ── Conditions ──────────────────────────────────────────────────────── *) (* A string constant handed to the runtime as ptr+len, in two registers. *) and str_args f ~preg ~nreg s = let l = string_const f s in lea f.b ~dst:preg ~mm:(Sym (l, 0)); imm_into f ~reg:nreg (Int64.of_int (String.length s)) (* One of the runtime's [_Noreturn] refusals. Everything is already in its register; this is the call and the [ud2] that says the fall-through is not a path. *) and die f sym = xor_rr f.b ~dst:rax ~src:rax; call_sym f.b sym; ud2 f.b (* (handler-bind ((C f) ...) BODY...) — §2. Two stores and a push per frame, and the frames live on this function's own stack. Popping is by frame and not by count, which is right even if something below got the stack out of step. The body may not [return] — the checker rejects that — so the pop below and the pop in the pad are between them the only paths out. *) and emit_handled f frames body dst t = let slots = List.map (fun (h : Tast.hframe) -> let slot = alloc f h_size 8 in imm_into f ~reg:rax (Int64.of_int h.Tast.htype); store_int f.b ~src:rax ~mm:(Frame (slot + h_type)) ~size:4; (* The clause's body address, deliberately, and not a cell load: a handler frame is not a redefinable top-level value — nothing can name it and it lives only for this body. *) addr_sym f ~dst:rax (fsym h.Tast.hfn); store_int f.b ~src:rax ~mm:(Frame (slot + h_fn)) ~size:8; lea f.b ~dst:rdi ~mm:(Frame slot); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_handler_push"; slot) frames in (* Innermost first, which is the order they were pushed in reverse. *) let pop () = List.iter (fun slot -> lea f.b ~dst:rdi ~mm:(Frame slot); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_handler_pop") (List.rev slots) in let ld = new_label f "endhandled" in let pad, used, () = with_pad f "hxfer" (fun () -> block f body dst t) in pop (); jmp_lbl f.b ld; (* A transfer passing through: these frames are on this function's stack and must come off before it goes any further. Nothing here calls Flan, so the channel can stay as it is. *) if !used then begin lbl f.b pad; pop (); jmp_lbl f.b (current_pad f) end; lbl f.b ld (* (with-allocator A BODY...) — spec-memory.md's "Allocators". Save, run, restore, and restore *again at the pad*: 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. *) and emit_with_alloc f (a : Tast.expr) body dst t = let prev = ptmp f in scoped f (fun () -> let av = eval f a in load_loc f ~reg:rdi av a.Tast.ty); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_context_set"; store_int f.b ~src:rax ~mm:(Frame prev) ~size:8; let restore () = load_int f.b ~dst:rdi ~mm:(Frame prev) ~size:8 ~signed:false; xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_context_restore" in let ld = new_label f "endwith" in let pad, used, () = with_pad f "wxfer" (fun () -> block f body dst t) in restore (); jmp_lbl f.b ld; if !used then begin lbl f.b pad; restore (); jmp_lbl f.b (current_pad f) end; lbl f.b ld (* A clause's parameters as one record: 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 record, and both sides ask [Emit.lay_fields], which is the one layout calculator in this compiler. *) and args_layout f (tys : Types.t list) = let size, align, offs = Emit.lay_fields f.md tys in (max 1 size), (max 1 align), offs (* (restart-case BODY (name [p T] BODY-1) ...) — §3, §4 and §6 together. One frame per clause, so the frame a transfer names says which clause to run. §4's "innermost offering the name" falls out of the runtime's 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 at its transfer exit before returning. What is left is to take these frames off, copy §3's parameters out of the buffer the invoker filled, and start the clause. *) and emit_restart_case f clauses body dst t = (* Everything the pad reads is allocated here, before any [scoped] the body or a clause runs. The frame allocator is a bump pointer that reclaims at the end of each statement, so a slot allocated inside the body would be handed out again to the clause that has to read it — and the read would be of whatever the clause's own temporaries put there. *) let tgt = ptmp f in let bufp = ptmp f in let frames = List.map (fun (c : Tast.rclause) -> let slot = alloc f r_size 8 in let args = if c.Tast.rparams = [] then None else begin let size, align, offs = args_layout f (List.map snd c.Tast.rparams) in Some (alloc f size align, offs) end in (c, slot, args)) clauses in List.iter (fun ((c : Tast.rclause), slot, args) -> imm_into f ~reg:rax (Int64.of_int c.Tast.rname_id); store_int f.b ~src:rax ~mm:(Frame (slot + r_name_id)) ~size:4; (* 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. *) str_args f ~preg:rax ~nreg:rcx c.Tast.rname; store_int f.b ~src:rax ~mm:(Frame (slot + r_name)) ~size:8; store_int f.b ~src:rcx ~mm:(Frame (slot + r_namelen)) ~size:8; (* §3's signature, which every frame carries whether it takes parameters or not: a clause taking none has to be able to refuse arguments as loudly as one taking two of the wrong type. *) imm_into f ~reg:rax (Int64.of_int (List.length c.Tast.rparams)); store_int f.b ~src:rax ~mm:(Frame (slot + r_arity)) ~size:4; imm_into f ~reg:rax (Int64.of_int c.Tast.rsig_id); store_int f.b ~src:rax ~mm:(Frame (slot + r_sig_id)) ~size:4; str_args f ~preg:rax ~nreg:rcx c.Tast.rsig; store_int f.b ~src:rax ~mm:(Frame (slot + r_sig)) ~size:8; store_int f.b ~src:rcx ~mm:(Frame (slot + r_siglen)) ~size:8; (match args with | None -> () | Some (buf, _) -> lea f.b ~dst:rax ~mm:(Frame buf); store_int f.b ~src:rax ~mm:(Frame (slot + r_args)) ~size:8; (* 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 refuses rather than running on values no one supplied. *) xor_rr f.b ~dst:rax ~src:rax; store_int f.b ~src:rax ~mm:(Frame (slot + r_armed)) ~size:4); lea f.b ~dst:rdi ~mm:(Frame slot); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_restart_push") frames; let pop () = List.iter (fun (_, slot, _) -> lea f.b ~dst:rdi ~mm:(Frame slot); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_restart_pop") (List.rev frames) in let ld = new_label f "endrestart" in let pad, used, () = with_pad f "rxfer" (fun () -> lower f body dst) in pop (); jmp_lbl f.b ld; if !used then begin lbl f.b pad; xfer_load f ~reg:rax; store_int f.b ~src:rax ~mm:(Frame tgt) ~size:8; (* Cleared before a 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. *) xfer_clear f; pop (); List.iter (fun ((c : Tast.rclause), slot, args) -> let next = new_label f "outer" in load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false; lea f.b ~dst:rcx ~mm:(Frame slot); cmp_rr f.b ~a:rax ~c:rcx; jcc_lbl f.b ~cc:cc_ne next; (match args with | None -> () | Some (buf, offs) -> (* Aimed here by something that supplied no arguments. There is no such path from an [invoke-restart], so this is a break loop taking a restart it cannot yet fill in — refused with the reason. *) load_int f.b ~dst:rax ~mm:(Frame (slot + r_armed)) ~size:4 ~signed:true; let armed = new_label f "armed" in test_rr f.b ~a:rax ~c:rax; jcc_lbl f.b ~cc:cc_ne armed; let l0 = List.hd c.Tast.rbody in str_args f ~preg:rdi ~nreg:rsi (Loc.to_string l0.Tast.loc); str_args f ~preg:rdx ~nreg:rcx c.Tast.rname; str_args f ~preg:r8 ~nreg:r9 c.Tast.rsig; die f "flan_restart_unarmed"; lbl f.b armed; (* The frame is still addressable — it is a temporary of *this* function — and the buffer is whatever the invoker left there. *) lea f.b ~dst:rax ~mm:(Frame buf); store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8; List.iteri (fun i (slot_i, ty) -> move f ~dst:(Lf f.slots.(slot_i)) ~src:(Lp (bufp, List.nth offs i)) ty) c.Tast.rparams); scoped f (fun () -> block f c.Tast.rbody dst t); jmp_lbl f.b ld; lbl f.b next) frames; (* Aimed further out than any of these. Back into the channel it goes. *) load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false; xfer_store f ~reg:rax ~scratch:r11; jmp_lbl f.b (current_pad f) end; lbl f.b ld (* §4's lookup, then the transfer itself: the frame that was found goes into the channel and this function leaves through its landing pad. Type [Never], so nothing follows. *) and emit_invoke_restart f id name (args : Tast.expr list) sg sg_id rloc = (* The arguments first, each into a frame temporary of its own, because the lookup and its two failure paths clobber every register. *) let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in let t = ptmp f in let bufp = ptmp f in imm_into f ~reg:rdi (Int64.of_int id); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_find_restart"; store_int f.b ~src:rax ~mm:(Frame t) ~size:8; (* 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. *) let found = new_label f "found" in test_rr f.b ~a:rax ~c:rax; jcc_lbl f.b ~cc:cc_ne found; str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc); str_args f ~preg:rdx ~nreg:rcx name; die f "flan_restart_fail"; lbl f.b found; (* §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 the cheaper half. *) let ok = new_label f "sigok" and bad = new_label f "signo" in load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false; load_int f.b ~dst:rax ~mm:(Reg (r11, r_arity)) ~size:4 ~signed:false; cmp_imm f.b ~dst:rax (List.length args); jcc_lbl f.b ~cc:cc_ne bad; (* The hash is a full 32 bits and a [cmp] takes a signed imm32, so it goes through a register rather than through the immediate. *) load_int f.b ~dst:rax ~mm:(Reg (r11, r_sig_id)) ~size:4 ~signed:false; imm_into f ~reg:rcx (Int64.of_int (sg_id land 0xffffffff)); cmp_rr f.b ~a:rax ~c:rcx; jcc_lbl f.b ~cc:cc_e ok; lbl f.b bad; (* Eight arguments, so two go on the stack — which is what [outgoing] is for. 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. *) if f.outgoing < 16 then f.outgoing <- 16; str_args f ~preg:rax ~nreg:r11 sg; store_int f.b ~src:rax ~mm:(Reg (rsp, 0)) ~size:8; store_int f.b ~src:r11 ~mm:(Reg (rsp, 8)) ~size:8; load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false; load_int f.b ~dst:r8 ~mm:(Reg (r11, r_sig)) ~size:8 ~signed:false; load_int f.b ~dst:r9 ~mm:(Reg (r11, r_siglen)) ~size:8 ~signed:true; str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc); str_args f ~preg:rdx ~nreg:rcx name; die f "flan_restart_args_fail"; lbl f.b ok; (* 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 _, _, offs = args_layout f (List.map snd vals) in load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false; load_int f.b ~dst:rax ~mm:(Reg (r11, r_args)) ~size:8 ~signed:false; store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8; List.iteri (fun i (l, ty) -> move f ~dst:(Lp (bufp, List.nth offs i)) ~src:l ty) vals; load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false; imm_into f ~reg:rax 1L; store_int f.b ~src:rax ~mm:(Reg (r11, r_armed)) ~size:4 end; load_int f.b ~dst:rax ~mm:(Frame t) ~size:8 ~signed:false; xfer_store f ~reg:rax ~scratch:r11; jmp_lbl f.b (current_pad f) and zero_value f (dst : loc) (ty : Types.t) = if is_agg ty then zero_loc f dst (sizeof f.md ty) else if not (is_void ty) then if is_float ty then begin xorps f.b ~dst:xmm0; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of ty) end else begin xor_rr f.b ~dst:rax ~src:rax; store_loc f ~reg:rax dst ty end (* A statement list. Everything but the last form is evaluated for effect; the last one is the value. *) and block f body dst t = let rec go = function | [] -> () | [ (last : Tast.expr) ] -> if is_void t || is_void last.Tast.ty then scoped f (fun () -> lower f last sink) else scoped f (fun () -> lower f last dst) | s :: rest -> scoped f (fun () -> lower f s sink); go rest in go body (* The address of something that denotes a location. Nothing is copied. *) and lvalue f (e : Tast.expr) : loc = match e.Tast.e with | Tast.Local i -> Lf f.slots.(i) | Tast.Global n -> sym_loc f (gsym n) | Tast.Deref x -> let p = eval f x in Lp (off_of p, 0) | Tast.Field (x, i) -> field_loc f (lvalue f x) x.Tast.ty i (* [(at a i)] denotes a location, and the source writes through it: [(set (.x (at pts 0)) 1.5)] has to reach the array and not a copy of one of its elements. [emit.ml] gets this from [addr]'s own [At] case; without it here the store lands in a temporary and the program is quietly wrong. *) | Tast.Prim (Tast.At, a :: is) when is <> [] -> elements f (lvalue f a) a.Tast.ty is | Tast.CaseField (target, case, i) -> case_field f target case i | _ -> eval f e (* The address of one field of one case of a union value. Only ever reached under an arm that proved the tag — [match] is the only thing that proves it — or from the structural printer, which compares the same tag first. *) and case_field f (target : Tast.expr) case i = let uname = match target.Tast.ty with | Types.Named n -> n | ty -> unsupported "case field of %s" (Types.to_string ty) in let u = union_of f uname in let c = match Tast.case_index u case with | Some (_, c) -> c | None -> unsupported "no case %s of %s" case uname in shift (lvalue f target) (union_payload_off f u + List.nth (case_offsets f c) i) (* [match]. The two subjects are the same shape and are read differently: an [Option] is an i8 tag and a payload at a known offset, a declared union is an i32 tag and a blob the arm's case reinterprets. Everything past the tag and the binds is shared, which is the arrangement [emit.ml] settled on for the same reason. *) and emit_match f (scrut : Tast.expr) (arms : Tast.arm list) dst t = let base = lvalue f scrut in let tag_size, tag_of, bind_at = match scrut.Tast.ty with | Types.Named n when Hashtbl.mem f.md.Emit.unions n -> let u = union_of f n in let poff = union_payload_off f u in ( 4, (fun case -> match Tast.case_index u case with | Some (i, _) -> i | None -> unsupported "no case %s of %s" case n), fun case k -> match Tast.case_index u case with | Some (_, c) -> shift base (poff + List.nth (case_offsets f c) k), (List.nth c.Tast.vfields k).Tast.fty | None -> unsupported "no case %s of %s" case n ) | Types.Option el -> (* [lay_fields] puts the i8 tag at 0, so [base] is the tag's address the way it is for a union. *) let _, ov = option_lay f el in ( 1, (fun case -> if String.equal case "Some" then 1 else 0), fun _case _k -> shift base ov, el ) | ty -> unsupported "match on %s" (Types.to_string ty) in let lend = new_label f "endmatch" in let rec go = function | [] -> (* The checker proved exhaustiveness, so nothing reaches here. A trap rather than a fallthrough: [ud2] is a defined SIGILL at the instruction that fell through, which is the cheap half of item 15's question 4. *) ud2 f.b | (a : Tast.arm) :: rest -> let lnext = new_label f "arm" in (match a.Tast.acase with | None -> () | Some case -> load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:tag_size ~signed:false; cmp_imm f.b ~dst:rax (tag_of case); jcc_lbl f.b ~cc:cc_ne lnext); List.iteri (fun k slot -> let src, fty = bind_at (match a.Tast.acase with Some c -> c | None -> "") k in move f ~dst:(Lf f.slots.(slot)) ~src fty) a.Tast.binds; block f a.Tast.abody dst t; jmp_lbl f.b lend; if a.Tast.acase <> None then (lbl f.b lnext; go rest) in go arms; lbl f.b lend and field_loc f (base : loc) (ty : Types.t) i = match ty with | Types.Named sn -> shift base (List.nth (field_offsets f sn) i) | Types.Ptr (Types.Named sn) -> shift (Lp (off_of base, 0)) (List.nth (field_offsets f sn) i) | Types.String | Types.Slice _ -> shift base (if i = 0 then 0 else 8) | Types.Option el -> let ot, ov = option_lay f el in shift base (if i = 0 then ot else ov) | _ -> unsupported "field of %s" (Types.to_string ty) and off_of (l : loc) = match l with | Lf o -> o | _ -> unsupported "a pointer value must be a frame temporary" and place f (p : Tast.place) : loc = match p with | Tast.Plocal i -> Lf f.slots.(i) | Tast.Pglobal n -> sym_loc f (gsym n) | Tast.Pderef x -> let q = eval f x in Lp (off_of q, 0) | Tast.Pfield (x, i) -> field_loc f (lvalue f x) x.Tast.ty i (* [(at grid r c)] is one node with two indices, not two nodes: an array of arrays is contiguous, so the second index walks into the element the first one landed on. *) | Tast.Pindex (x, is) -> elements f (lvalue f x) x.Tast.ty is (* One element of an array, a slice or a pointer. No bounds check: the check [emit.ml] emits signals, and signalling is the row of item 15's table with no plan here yet — so this backend is the [--no-bounds-checks] shape of the program and says so. *) and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc = match is with | [] -> base | i :: rest -> let elem = match ty with | Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el | Types.String -> Types.Int Types.U8 | t -> unsupported "index into %s" (Types.to_string t) in elements f (element f base ty i) elem rest (* ── Bounds checks ───────────────────────────────────────────────────── *) (* [emit.ml]'s [check_at] and [check_slice], which could not exist here until the guard did: the runtime's bounds error *signals*, so the call is an ordinary one that returns when a handler or the break loop transferred, and what makes it a check rather than a call is the guard after it. The fall-through past the guard is what is unreachable — nothing answered, so the runtime already died inside the call — and [ud2] is where [emit.ml] writes [unreachable]. That is also the answer to "does a bounds trap run defers": an answered one does, because it leaves through the innermost pad; an unanswered one still does not, because it is a die inside C. Identical on both backends. *) and bounds_call f sym (loc : Loc.t) (extra : int list) = let s = Loc.to_string loc in str_args f ~preg:rdi ~nreg:rsi s; let regs = [| rdx; rcx; r8; r9 |] in List.iteri (fun k off -> load_int f.b ~dst:regs.(k) ~mm:(Frame off) ~size:8 ~signed:true) extra; chan_into f ~reg:regs.(List.length extra); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b sym; guard f; ud2 f.b (* The length an index is checked against, or [None] for the forms [emit.ml] does not check either: a raw pointer, which has no length, and a string, which its [element_addr] does not index at all. *) and index_len _f (base : loc) (ty : Types.t) = match ty with | Types.Array (n, _) -> Some (`Const n) | Types.Slice _ -> Some (`At (shift base 8)) | _ -> None and load_len f = function | `Const n -> imm_into f ~reg:rcx n | `At l -> load_int f.b ~dst:rcx ~mm:(lmem f l ~scratch:r11) ~size:8 ~signed:true (* [at] is strict: the last valid index is len - 1, and one unsigned compare catches a negative index as well as an oversized one. *) and check_at f (base : loc) (ty : Types.t) (i : Tast.expr) (iv : loc) = if f.md.Emit.checks then match index_len f base ty with | None -> () | Some len -> scoped f (fun () -> let a = ptmp f and b = ptmp f in load_loc f ~reg:rax iv i.Tast.ty; store_int f.b ~src:rax ~mm:(Frame a) ~size:8; load_len f len; store_int f.b ~src:rcx ~mm:(Frame b) ~size:8; cmp_rr f.b ~a:rax ~c:rcx; let ok = new_label f "inb" in jcc_lbl f.b ~cc:cc_b ok; bounds_call f "flan_bounds_error" i.Tast.loc [ a; b ]; lbl f.b ok) (* [slice] is not strict: a slice ending at len — or an empty one at lo = len — is legal. [lo <= hi] is not redundant with [hi <= len], because a reversed range would otherwise yield hi - lo as a huge unsigned length, which is a worse hole than the missing check. *) and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr) (llo : loc) (hi : Tast.expr) (lhi : loc) = if f.md.Emit.checks then let len = match ty with | Types.Array (n, _) -> Some (`Const n) | Types.Slice _ | Types.String -> Some (`At (shift base 8)) | _ -> None in match len with | None -> () | Some len -> scoped f (fun () -> let a = ptmp f and b = ptmp f and c = ptmp f in load_loc f ~reg:rax llo lo.Tast.ty; store_int f.b ~src:rax ~mm:(Frame a) ~size:8; load_loc f ~reg:rdx lhi hi.Tast.ty; store_int f.b ~src:rdx ~mm:(Frame b) ~size:8; load_len f len; store_int f.b ~src:rcx ~mm:(Frame c) ~size:8; let ok = new_label f "inb" and bad = new_label f "oob" in cmp_rr f.b ~a:rax ~c:rdx; jcc_lbl f.b ~cc:cc_a bad; cmp_rr f.b ~a:rdx ~c:rcx; jcc_lbl f.b ~cc:cc_be ok; lbl f.b bad; bounds_call f "flan_slice_error" loc [ a; b; c ]; lbl f.b ok) (* [emit.ml]'s [check_div] and [check_cast], item 3 of HANDOFF-x86-rt.md's list, and the one item on it that was blocked on a language decision rather than on code. That decision is in HANDOFF-arith.md: a divide or remainder by zero, the one division that overflows, and a float to integer cast whose value does not fit all signal ArithError, exactly as a bad index signals BoundsError. Why it could not be left to the hardware, which is the temptation here and is what this backend did until now. `idiv` raises SIGFPE on both the zero and the overflow case, and a SIGFPE cannot be caught and resumed — so there is no version of this that tests afterwards, and nothing that dies with a location. The other backend calls the same three situations undefined and folds them to whatever it likes. Neither is a behaviour a program can be written against, and the two disagreed, which is what a survey diff would eventually have found the hard way. These reuse [bounds_call] unchanged: it spells the whole shape — the location string into rdi/rsi, the extra arguments out of frame temporaries into rdx/rcx/r8/r9, the channel after them, the guard, and the [ud2] that stands where [emit.ml] writes [unreachable]. flan_arith_error takes three extras, so the channel lands in r9 and the register file is exactly full. *) (* The codes are [emit.ml]'s, read from there rather than copied: they are an agreement with flan_arith_fail in the runtime, and an agreement kept in two places is an agreement that drifts. *) (* rax holds the dividend and rcx the divisor, both already widened to 64 bits by [load_loc] according to their own signedness — which is what lets the overflow test compare against the *narrow* type's most negative value in a 64-bit register and mean it. Two tests and two ways out rather than [emit.ml]'s single branch with a [select], because there is no [select] here and a second compare on the cold path is free. The ordinary path still pays one compare and one not-taken branch, which is the same as over there. Both tests are dropped when a literal divisor cannot trigger them. That is not a micro-optimisation: (/ x 2) is the common case and would otherwise carry a compare and a branch forever. *) and check_div f (loc : Loc.t) ~is_rem (k : Types.ikind) ~lit = if f.md.Emit.checks then begin let need_zero = match lit with Some n -> Int64.equal n 0L | None -> true in let need_ovf = Types.signed k && (match lit with Some n -> Int64.equal n (-1L) | None -> true) in if need_zero || need_ovf then scoped f (fun () -> let so = ptmp f and sa = ptmp f and sb = ptmp f in store_int f.b ~src:rax ~mm:(Frame sa) ~size:8; store_int f.b ~src:rcx ~mm:(Frame sb) ~size:8; let ok = new_label f "arith" and bad = new_label f "arithbad" in let zcode = if is_rem then Emit.arith_rem_zero else Emit.arith_div_zero in let ocode = if is_rem then Emit.arith_rem_overflow else Emit.arith_div_overflow in if need_zero then begin let nz = new_label f "arithnz" in cmp_imm f.b ~dst:rcx 0; jcc_lbl f.b ~cc:cc_ne nz; imm_into f ~reg:rdx (Int64.of_int zcode); store_int f.b ~src:rdx ~mm:(Frame so) ~size:8; jmp_lbl f.b bad; lbl f.b nz end; if need_ovf then begin cmp_imm f.b ~dst:rcx (-1); jcc_lbl f.b ~cc:cc_ne ok; (* Through r11 rather than as an immediate: the most negative i64 does not fit the imm32 [cmp_imm] encodes, and one spelling for every width beats a special case for the one that does not. *) imm_into f ~reg:r11 (Int64.neg (Int64.shift_left 1L (Types.bits k - 1))); cmp_rr f.b ~a:rax ~c:r11; jcc_lbl f.b ~cc:cc_ne ok; imm_into f ~reg:rdx (Int64.of_int ocode); store_int f.b ~src:rdx ~mm:(Frame so) ~size:8 end else jmp_lbl f.b ok; lbl f.b bad; bounds_call f "flan_arith_error" loc [ so; sa; sb ]; lbl f.b ok; (* rdx is the high half of the dividend and [cqo] is what fills it, so whatever the overflow test left there does not survive; rax and rcx are untouched on this path and do not need reloading. *) ()) end (* A float to integer cast whose value does not fit. xmm0 holds the value, in the *source's* precision, and the bounds are compared in that same precision rather than widened to a double first the way [emit.ml] does it: both bounds are powers of two, so both are exact in an f32 as well as in an f64, and the two tests therefore answer identically. Doing it here saves a conversion and a second live xmm register. The direction of each compare is chosen so that a NaN fails both. [ucomis] sets CF, ZF and PF together when either operand is unordered, so the test for the low end is written as "jump to the failure when below", which a NaN takes, and the test for the high end swaps its operands and asks the same question the other way round. A NaN cast to an integer is exactly as undefined as 1e300 is and has no business walking through the guard. *) and check_cast f (loc : Loc.t) (src : Types.fkind) (k : Types.ikind) = if f.md.Emit.checks then begin let f64 = (src = Types.F64) in let n = Types.bits k in let signed = Types.signed k in let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in let lo_i = if signed then Int64.neg (Int64.shift_left 1L (n - 1)) else 0L in let hi_i = if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L else if n = 64 then -1L else Int64.sub (Int64.shift_left 1L n) 1L in let klo = float_const f lo_f ~f64 and khi = float_const f hi_f ~f64 in scoped f (fun () -> let so = ptmp f and sa = ptmp f and sb = ptmp f in let ok = new_label f "fits" and bad = new_label f "nofit" in fload f.b ~dst:1 ~mm:(Sym (klo, 0)) ~f64; ucomis f.b ~f64 ~a:xmm0 ~c:1; jcc_lbl f.b ~cc:cc_b bad; fload f.b ~dst:1 ~mm:(Sym (khi, 0)) ~f64; (* The operands the other way round, so that the code asked for is one a NaN answers false to: this is "hi > v" and not "v < hi". *) ucomis f.b ~f64 ~a:1 ~c:xmm0; jcc_lbl f.b ~cc:cc_a ok; lbl f.b bad; imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_range); store_int f.b ~src:rax ~mm:(Frame so) ~size:8; imm_into f ~reg:rax lo_i; store_int f.b ~src:rax ~mm:(Frame sa) ~size:8; imm_into f ~reg:rax hi_i; store_int f.b ~src:rax ~mm:(Frame sb) ~size:8; bounds_call f "flan_arith_error" loc [ so; sa; sb ]; lbl f.b ok) end and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc = let elem = match ty with | Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el | Types.String -> Types.Int Types.U8 | t -> unsupported "index into %s" (Types.to_string t) in let iv = eval f i in check_at f base ty i iv; (match ty with | Types.Array _ -> addr_into f ~reg:rax base | _ -> (* A slice's data pointer is its first word; a raw pointer is itself. *) load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:8 ~signed:false); load_loc f ~reg:rcx iv i.Tast.ty; let sz = max 1 (sizeof f.md elem) in if sz <> 1 then begin imm_into f ~reg:rdx (Int64.of_int sz); imul_rr f.b ~dst:rcx ~src:rdx end; add_rr f.b ~dst:rax ~src:rcx; let p = ptmp f in store_int f.b ~src:rax ~mm:(Frame p) ~size:8; Lp (p, 0) (* Evaluate into a fresh temporary and answer where it landed. Always a copy, never the slot itself: [emit.ml] loads an operand where the operand is written, left-to-right evaluation is *required* and not a preference (item 15, question 4), and a later argument that assigns to the same slot must not be able to change what an earlier one already saw. *) and eval f (e : Tast.expr) : loc = if is_void e.Tast.ty then (lower f e sink; sink) else begin let o = tmp f e.Tast.ty in lower f e (Lf o); Lf o end and ret_loc f = if is_agg f.fret then Lp (f.sret_off, 0) else Lf f.retval (* ── Calls ───────────────────────────────────────────────────────────── *) (* Flan calling Flan. The convention is the header's, entire: scalars in the integer or SSE sequence, every aggregate by pointer, a hidden [sret] in the first integer register when the result is an aggregate, and the transfer channel last of all. *) and call_flan f ~target ~args ~rty dst = let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in let callee = match target with | `Sym s -> `Sym s | `Cell s -> `Cell s | `Loc l -> `Loc (off_of l) in let sret = (not (is_void rty)) && is_agg rty in let head = if sret then [ Aptr dst ] else [] in let body = List.concat_map (fun (l, ty) -> if is_void ty then [] else if is_agg ty then [ Aptr l ] else if is_float ty then [ Aflt (l, ty) ] else [ Aint (l, ty) ]) vals in (* The channel is this frame's own: a callee that transfers writes through the pointer we were handed, so one cell serves the whole chain. *) let chan = [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] in ignore (emit_args f (head @ body @ chan)); (* The cell is loaded *after* the arguments, and [emit.ml] has the same as a load-bearing comment: a redefinition that lands between two calls still must not land in the middle of one. [r11] is scratch and no argument register, so this cannot disturb what [emit_args] just placed. [CallPtr] is deliberately the other way round — the callee there is written first and there is no cell to keep out of an argument list. *) (match callee with | `Sym s -> call_sym f.b s | `Cell s -> load_sym f ~dst:r11 s; call_r f.b r11 | `Loc o -> load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false; call_r f.b r11); (* §6 at a call site, and it is every call site: a callee that transferred wrote a frame address through the channel, and the value in [rax] means nothing. The guard touches only [r11], so it goes between the call and the store rather than after it. A call by pointer is guarded by the same guard — a transfer is carried by the channel whether the callee was reached by name or by address. *) guard f; if (not (is_void rty)) && not sret then store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty (* Flan calling C. SysV exactly, because this is the boundary where it has to be — and the only aggregates that get here are the ones the shim rules already flatten. *) and call_c f ~sym ~args ~rty dst = call_native f ~sym:(asm_sym sym) ~args ~rty dst (* The two runtime entry points whose bounds check signals. They are the only [Rt] symbols that can transfer, so they are the only ones that take the channel and the only ones guarded — everything else in this family is arithmetic over a container header and cannot reach a handler. A Vec is checked inside the runtime rather than in emitted code (BUILT.md), so this is where [(at v i)] gets what [(at arr i)] gets from [check_at]. *) and rt_signals sym = String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice" and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst = (* A Vec, a Map and a Pool are move-only and cross to the runtime as their *address*, which is what lets an operation mutate the caller's container in place. [eval] would hand over the address of a copy, and the runtime would grow that and leave the caller's header at length zero — which is how [bounds-condition.flan] failed, as an in-bounds (at v 1) signalling against a length of 0. Every other aggregate is read-only across this boundary, so a copy there is harmless. *) let vals = List.map (fun (a : Tast.expr) -> (match a.Tast.ty with | Types.Vec _ | Types.Map _ | Types.Pool _ -> lvalue f a | _ -> eval f a), a.Tast.ty) args in let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] else flat in let nsse = emit_args f flat in (* [al] is how many SSE registers were used, which a variadic callee reads. Harmless on a fixed one, and a [declare] does not say which it is. *) imm_into f ~reg:rax (Int64.of_int nsse); call_sym f.b sym; if chan then guard f; if not (is_void rty) then begin (* Unreachable, and it is worth saying why rather than leaving it reading like a gap in the backend. Nothing that crosses this boundary returns an aggregate, by two rules that both live in [check.ml]: - every aggregate-valued runtime result comes back through an *out-pointer* the checker allocates, so the Flan-level return type is [Unit] or a scalar. [flan_vec_as_slice] is the one that looks like a counter-example and is not: [check.ml] builds it as [rt loc Types.Unit] and [flan_rt.c] writes the two words through [void *out]. Every other [rt] builder in the file answers [Unit], an [Int], a [Ptr], an [Alloc] or a [Handle]. - [crossable], which admits [String] and [Slice _] only as "a parameter" and refuses an aggregate return from a [declare] outright. So this is a guard against those two rules changing, and not a feature waiting to be written. If one ever does change, the work it names is *SysV classification* and not the internal convention in the header: C returns a 16-byte slice in rax:rdx, and there is no classifier in this file. Refusing is the honest answer until there is. *) if is_agg rty then unsupported "%s returns %s by value, which needs SysV return classification this \ backend does not have" sym (Types.to_string rty); store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty end (* ── Primitives ──────────────────────────────────────────────────────── *) and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = let t = e.Tast.ty in match p, args with | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem | Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ a; b ] -> let la = eval f a in let lb = eval f b in if is_float t then begin let f64 = f64_of t in fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64; fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64; let op = match p with | Tast.Add -> 0x58 | Tast.Sub -> 0x5c | Tast.Mul -> 0x59 | Tast.Div -> 0x5e | _ -> unsupported "that operator on %s" (Types.to_string t) in farith f.b ~op ~f64 ~dst:xmm0 ~src:1; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 end else begin let signed = signed_of t in load_loc f ~reg:rax la a.Tast.ty; load_loc f ~reg:rcx lb b.Tast.ty; (match p with | Tast.Add -> add_rr f.b ~dst:rax ~src:rcx | Tast.Sub -> sub_rr f.b ~dst:rax ~src:rcx | Tast.Mul -> imul_rr f.b ~dst:rax ~src:rcx | Tast.BitAnd -> and_rr f.b ~dst:rax ~src:rcx | Tast.BitOr -> or_rr f.b ~dst:rax ~src:rcx | Tast.BitXor -> xor_rr f.b ~dst:rax ~src:rcx (* The count is masked to the operand width by the hardware, which is the rule the language already defines. *) | Tast.Shl -> shl_cl f.b ~dst:rax | Tast.Shr -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax | Tast.Div | Tast.Rem -> (* The guard goes *before* the instruction, which is the whole of why it has to be emitted at all: `idiv` raises SIGFPE on both the zero and the overflow case and a SIGFPE cannot be caught and resumed. Integers only — this arm is already inside the non-float half — because IEEE x / 0.0 is an infinity and is a defined answer. *) (match t with | Types.Int k -> let lit = match b.Tast.e with Tast.Int (n, _) -> Some n | _ -> None in check_div f e.Tast.loc ~is_rem:(p = Tast.Rem) k ~lit | _ -> ()); if signed then (cqo f.b; idiv_r f.b ~src:rcx) else (xor_rr f.b ~dst:rdx ~src:rdx; div_r f.b ~src:rcx); if p = Tast.Rem then mov_rr f.b ~dst:rax ~src:rdx | _ -> unsupported "arithmetic"); store_loc f ~reg:rax dst t end | _, [ a; b ] when is_cmp p -> let la = eval f a in let lb = eval f b in if is_float a.Tast.ty then begin let f64 = f64_of a.Tast.ty in let x, y = if float_swaps p then lb, la else la, lb in fload f.b ~dst:xmm0 ~mm:(lmem f x ~scratch:r11) ~f64; fload f.b ~dst:1 ~mm:(lmem f y ~scratch:r11) ~f64; ucomis f.b ~f64 ~a:xmm0 ~c:1; setcc f.b ~cc:(float_cc p) ~dst:rax; if float_ordered p then begin movzx8 f.b ~dst:rax ~src:rax; setcc f.b ~cc:cc_np ~dst:rcx; movzx8 f.b ~dst:rcx ~src:rcx; and_rr f.b ~dst:rax ~src:rcx end end else begin load_loc f ~reg:rax la a.Tast.ty; load_loc f ~reg:rcx lb b.Tast.ty; cmp_rr f.b ~a:rax ~c:rcx; setcc f.b ~cc:(int_cc ~signed:(signed_of a.Tast.ty) p) ~dst:rax end; movzx8 f.b ~dst:rax ~src:rax; store_loc f ~reg:rax dst Types.Bool | Tast.Not, [ a ] -> let la = eval f a in if Types.equal a.Tast.ty Types.Bool then begin load_loc f ~reg:rax la Types.Bool; grp1_imm f.b ~ext:6 ~dst:rax 1 end else begin load_loc f ~reg:rax la a.Tast.ty; not_r f.b ~dst:rax end; store_loc f ~reg:rax dst t | Tast.Len, [ a ] -> (match a.Tast.ty with | Types.Array (n, _) -> imm_into f ~reg:rax n | Types.String | Types.Slice _ -> let l = lvalue f a in load_int f.b ~dst:rax ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8 ~signed:true | ty -> unsupported "len of %s" (Types.to_string ty)); store_loc f ~reg:rax dst t | Tast.At, a :: is when is <> [] -> let l = elements f (lvalue f a) a.Tast.ty is in move f ~dst ~src:l t | Tast.Slice, [ a; lo; hi ] -> let elem = match a.Tast.ty with | Types.Array (_, el) | Types.Slice el -> el | Types.String -> Types.Int Types.U8 | ty -> unsupported "slice of %s" (Types.to_string ty) in let base = lvalue f a in let llo = eval f lo in let lhi = eval f hi in (* The source is read once, and the check goes between reading it and the arithmetic: the length it is checked against must be the one the arithmetic uses. *) check_slice f base a.Tast.ty e.Tast.loc lo llo hi lhi; (match a.Tast.ty with | Types.Array _ -> addr_into f ~reg:rax base | _ -> load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:8 ~signed:false); load_loc f ~reg:rcx llo lo.Tast.ty; let sz = max 1 (sizeof f.md elem) in if sz <> 1 then begin imm_into f ~reg:rdx (Int64.of_int sz); imul_rr f.b ~dst:rcx ~src:rdx end; add_rr f.b ~dst:rax ~src:rcx; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; load_loc f ~reg:rax lhi hi.Tast.ty; load_loc f ~reg:rcx llo lo.Tast.ty; sub_rr f.b ~dst:rax ~src:rcx; store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 (* (slice-from-ptr p n): the two words a slice already is, with the pointer the caller handed over and the length the caller promised. A [Slice _] is {ptr, i64} here exactly as it is in [emit.ml], so there is no new representation to build — one store of the pointer and one of the length. The check is the *length itself* and not a range, because nothing here knows how many elements live behind that pointer; only the caller does. So what is checked is the half that can be — that the promise is not absurd — and it is a *signed* test, which matters: [check_slice]'s compares are unsigned, and a negative i32 sign-extended to 64 bits is a huge unsigned value that [jbe] waves straight through. It reuses [flan_slice_error] for [emit.ml]'s reason: the violated condition is 0 <= n, which has the shape of a reversed slice, so the range is reported as [0 n) against a length of 0. *) | Tast.SliceFromPtr, [ p; n ] -> let lp = eval f p in let ln = eval f n in if f.md.Emit.checks then scoped f (fun () -> let a = ptmp f and b = ptmp f and c = ptmp f in xor_rr f.b ~dst:rax ~src:rax; store_int f.b ~src:rax ~mm:(Frame a) ~size:8; store_int f.b ~src:rax ~mm:(Frame c) ~size:8; load_loc f ~reg:rax ln n.Tast.ty; store_int f.b ~src:rax ~mm:(Frame b) ~size:8; cmp_imm f.b ~dst:rax 0; let ok = new_label f "inb" in jcc_lbl f.b ~cc:cc_ge ok; bounds_call f "flan_slice_error" e.Tast.loc [ a; b; c ]; lbl f.b ok); load_loc f ~reg:rax lp p.Tast.ty; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; load_loc f ~reg:rax ln n.Tast.ty; store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 (* string and [u8] are the same two words, so both directions are views and not copies — the same non-instruction [emit.ml] emits. *) | (Tast.Bytes | Tast.StrOfBytes), [ a ] -> lower f a dst | Tast.I64ToBytes, [ a ] -> shim_out f "flan_i64_to_bytes" a dst | Tast.U64ToBytes, [ a ] -> shim_out f "flan_u64_to_bytes" a dst | Tast.F64ToBytes, [ a ] -> shim_out f "flan_f64_to_bytes" a dst | Tast.EscapeBytes, [ a ] -> let l = eval f a in slice_in_out f "flan_escape_bytes" l dst | Tast.BytesToI64, [ a ] -> call_rt f ~sym:"flan_bytes_to_i64" ~args:[ a ] ~rty:t dst | Tast.BytesToF64, [ a ] -> call_rt f ~sym:"flan_bytes_to_f64" ~args:[ a ] ~rty:t dst | Tast.WriteStdout, [ a ] -> call_rt f ~sym:"flan_write_stdout" ~args:[ a ] ~rty:Types.Unit sink | Tast.Exit, [ a ] -> call_rt f ~sym:"flan_exit" ~args:[ a ] ~rty:Types.Unit sink; ud2 f.b | Tast.Argv, [] -> addr_into f ~reg:rdi dst; xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_argv" | Tast.SizeOf ty, [] -> imm_into f ~reg:rax (Int64.of_int (sizeof f.md ty)); store_loc f ~reg:rax dst t | Tast.AlignOf ty, [] -> imm_into f ~reg:rax (Int64.of_int (alignof f.md ty)); store_loc f ~reg:rax dst t | Tast.AddrOf, [ a ] -> let l = lvalue f a in addr_into f ~reg:rax l; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 (* The allocation registry's notes are the one runtime family a release build drops on the floor, and [emit.ml:1918] drops it with this same guard — the checker builds a [Tast.Rt] it does not know is unwanted, because it does not know whether this is a dev build and does not have to. [emit.ml] is careful to drop it before the arguments are walked, so that taking the address of the container being described does not leave an escaped alloca for mem2reg to refuse; here the arguments are not touched until [call_rt], so answering [()] is already early enough. The test is [emit.ml]'s byte for byte, strict [>] included: bare [flan_dev_reg_note] is the runtime's own entry point and is never a [Tast.Rt]; what [check.ml] builds is the [_vec], [_map] and [_pool] wrappers, each of which is longer than the prefix. The node's type is [Unit], so there is nothing to store and [dst] is untouched. *) | Tast.Rt sym, _ when (not f.md.Emit.dev) && String.length sym > 17 && String.equal (String.sub sym 0 17) "flan_dev_reg_note" -> () | Tast.Rt sym, _ -> call_rt f ~sym ~args ~rty:t dst | Tast.Cast target, [ a ] -> cast f a target dst | _ -> unsupported "primitive with %d arguments" (List.length args) (* [void shim(T, flan_slice *out)] — a scalar in, a slice written through a hidden out pointer. The three number printers, and nothing else. *) and shim_out f sym (a : Tast.expr) dst = let l = eval f a in if is_float a.Tast.ty then begin fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of a.Tast.ty); addr_into f ~reg:rdi dst; imm_into f ~reg:rax 1L end else begin load_loc f ~reg:rdi l a.Tast.ty; addr_into f ~reg:rsi dst; imm_into f ~reg:rax 0L end; call_sym f.b sym (* [void shim(ptr, i64, flan_slice *out)] — a slice in, a slice out. *) and slice_in_out f sym (src : loc) dst = load_int f.b ~dst:rdi ~mm:(lmem f src ~scratch:r11) ~size:8 ~signed:false; load_int f.b ~dst:rsi ~mm:(lmem f (shift src 8) ~scratch:r11) ~size:8 ~signed:true; addr_into f ~reg:rdx dst; xor_rr f.b ~dst:rax ~src:rax; call_sym f.b sym (* Every conversion, and there are only four shapes of them. Integer to integer is already the load and store rules: a load widens the way the source's own signedness says, and a store narrows to the destination's width, so one pair covers all sixty-four pairings. *) and cast f (a : Tast.expr) (target : Types.t) dst = let concrete (t : Types.t) = match t with Types.Enum _ -> Types.Int Types.I32 | t -> t in let src_t = concrete a.Tast.ty and dst_t = concrete target in let l = eval f a in match is_float src_t, is_float dst_t with | false, false -> load_loc f ~reg:rax l src_t; store_loc f ~reg:rax dst dst_t | true, true -> fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t); if f64_of src_t && not (f64_of dst_t) then cvtsd2ss f.b ~dst:xmm0 ~src:xmm0 else if (not (f64_of src_t)) && f64_of dst_t then cvtss2sd f.b ~dst:xmm0 ~src:xmm0; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) | false, true -> load_loc f ~reg:rax l src_t; cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) | true, false -> fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t); (* [cvttsd2si] answers a fixed "integer indefinite" for a value out of range, which is a number rather than an answer — and the other backend calls the same cast undefined and will fold it to anything. So the value is tested against the destination's range first. *) (match src_t, dst_t with | Types.Float sk, Types.Int k -> check_cast f a.Tast.loc sk k | _ -> ()); cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0; store_loc f ~reg:rax dst dst_t (* ── Call frame information ──────────────────────────────────────────── *) (* The whole frame model, in five directives. [.cfi] is the one thing the assembler gets right against a file with no instructions in it, and it is worth saying so beside the debug-information section above, which is about the thing it gets wrong: CFI advances are computed from frag positions, where the line table's are computed from having assembled an instruction. Measured — a [.byte]-only function comes out of [readelf --debug-dump=frames] with exact advances. The content is a constant because of the header's own claim that [rsp] is written exactly twice. On entry the CFA is [rsp+8]; [push rbp] makes it [rsp+16] and puts the saved [rbp] at [cfa-16]; [mov rsp, rbp] moves the rule onto [rbp], where it stays for the whole body, because the only other write to [rsp] is the [leave]. After that [rsp] is [rbp+8] again and the CFA is [rsp+8]. Register 6 is [rbp] and 7 is [rsp] in DWARF's numbering; the return address is column 16 and the CIE already says it is at [cfa-8]. Emitted only in a [--debug] build, so that a release build's assembly stays byte-for-byte what it was. That is a conservative call rather than a principled one: this description is correct in every build, and a release build is where an unwind through a crash would most want it. What stops it from being unconditional today is only that nothing measures the [.eh_frame] it would add. *) let cfi_after_push b = text b "\t.cfi_def_cfa_offset 16\n\t.cfi_offset 6, -16\n" let cfi_after_mov b = text b "\t.cfi_def_cfa_register 6\n" let cfi_after_leave b = text b "\t.cfi_def_cfa 7, 8\n" (* ── A function ──────────────────────────────────────────────────────── *) (* The frame is rounded to 16 and reserves the outgoing-argument area in the same [sub]. [push rbp] takes entry's [rsp ≡ 8 (mod 16)] to [rsp ≡ 0], so [rbp ≡ 0] and — because [rsp] is written exactly here and by [leave] — [rsp ≡ 0] at every call site in the body. That is the whole licence for having no depth counter, and it is one rounded subtraction rather than an invariant every case has to maintain. *) let frame_bytes f = ((f.maxframe + f.outgoing + 15) / 16) * 16 (* Where each argument arrives, in the order the header lays down: a hidden [sret] first when the result is an aggregate, then the parameters, then the transfer channel. Answers one entry per incoming value — a register number, or a positive [rbp] displacement for the ones that came on the stack. *) type incoming = Ireg of int | Isse of int | Istk of int let incoming_of ~sret (params : Types.t list) = let ints = ref 0 and sses = ref 0 and stk = ref 0 in let next_int () = if !ints < n_int_args then (incr ints; Ireg int_args.(!ints - 1)) else (let k = !stk in stk := k + 8; Istk (16 + k)) in let next_sse () = if !sses < n_sse_args then (incr sses; Isse (!sses - 1)) else (let k = !stk in stk := k + 8; Istk (16 + k)) in let sret_at = if sret then Some (next_int ()) else None in let ps = List.map (fun ty -> if is_void ty then Istk (-1) else if is_agg ty then next_int () else if is_float ty then next_sse () else next_int ()) params in sret_at, ps, next_int () let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) ?(hidden = false) ?dw (fn : Tast.fn) : string * string = let b = create () in let nslots = Array.length fn.Tast.slots in let f = { b; md; fnname = fn.Tast.name; retlbl = ""; fret = fn.Tast.ret; slots = Array.make nslots 0; xfer_off = 0; sret_off = 0; retval = 0; frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = []; xfer_lbl = ""; unwound = false; rodata = Buffer.create 64; externs; fns; ext; dw } in (* The subprogram this function's rows hang off. Its first row is the function symbol itself, at the line the [defn] was written on, so the entry has a position before the prologue has run; every row after it comes out of [dwline] as the body is lowered. [dlast] is not primed with it, which is deliberate — the first form of the body sits at a different column even when it is on the same line, so it gets a row of its own, and two rows are what let a debugger put a breakpoint after the prologue rather than on it. *) let cfi = match dw with None -> false | Some _ -> true in let sub = match dw with | None -> None | Some d -> let line = if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line in let file = dwfile d fn.Tast.floc.Loc.file in let s = { sname = fn.Tast.name; ssym = fsym fn.Tast.name; sfile = file; sline = line; send = new_label f "fe"; srows = [ { rlbl = fsym fn.Tast.name; rfile = file; rline = line; rcol = 1 } ] } in d.dcur <- Some s; d.dlast <- None; d.dlastn <- -1; d.dsubs <- s :: d.dsubs; Some s in (* The header's own frame model: every slot and every temporary is bump-allocated below rbp, and the high-water mark is what the prologue subtracts. Nothing is ever pushed. *) Array.iteri (fun i ty -> f.slots.(i) <- tmp f ty) fn.Tast.slots; let sret = (not (is_void fn.Tast.ret)) && is_agg fn.Tast.ret in f.xfer_off <- ptmp f; if sret then f.sret_off <- ptmp f; if (not sret) && not (is_void fn.Tast.ret) then f.retval <- tmp f fn.Tast.ret; f.retlbl <- new_label f "ret"; f.xfer_lbl <- new_label f "xfer"; let sret_at, param_at, xfer_at = incoming_of ~sret fn.Tast.params in (* An aggregate parameter arrives as a pointer to the caller's copy and has to be copied into its slot before anything else runs — and [rep movsb] eats rdi, rsi and rcx, which is where three of the other parameters still are. So every incoming register is spilled first and the copies happen afterwards, out of frame temporaries. *) let spills = List.map2 (fun ty at -> match at with | Ireg _ when is_agg ty -> Some (ptmp f) | _ -> None) fn.Tast.params param_at in (* The body. Lowered into its own buffer, because the prologue's [sub] needs a frame size only the body can decide, and every relocation this backend emits is an assembler expression — so nothing has to be patched. *) let last = ref None in let rec go = function | [] -> () | [ (e : Tast.expr) ] -> last := Some e; go [] | e :: rest -> scoped f (fun () -> lower f e sink); go rest in go fn.Tast.body; (match !last with | Some e when (not (is_void fn.Tast.ret)) && not (is_void e.Tast.ty) -> scoped f (fun () -> lower f e (ret_loc f)) | Some e -> scoped f (fun () -> lower f e sink) | None -> ()); (* The transfer exit, 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. Emitted here, *before* the prologue buffer is made, because [frame_bytes] is read when the prologue is built and everything below allocates temporaries and makes calls that move the high-water mark. *) let zero_return () = if not (is_void fn.Tast.ret) then zero_value f (ret_loc f) fn.Tast.ret in if f.unwound then begin (* The body falls through to the epilogue, so it has to be sent there explicitly before this: otherwise the last statement runs straight into the transfer exit and the defers run a second time. [emit.ml] cannot have this bug — its [ret] terminates the block. *) jmp_lbl f.b f.retlbl; lbl f.b f.xfer_lbl; (* [emit.ml] leaves here with [ret zeroinitializer]. The value is meaningless to a caller — its guard sees the channel set and never looks at it — but [main] is a caller with no guard, and what it finds in [rax] is the process exit status. Zero rather than whatever the return temporary held. *) if fn.Tast.fdefers <> [] 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 saved = ptmp f in xfer_load f ~reg:rax; store_int f.b ~src:rax ~mm:(Frame saved) ~size:8; xfer_clear f; let cleanup = new_label f "cleanup" and used = ref false in f.pads <- [ (cleanup, used) ]; List.iter (fun e -> scoped f (fun () -> lower f e sink)) fn.Tast.fdefers; f.pads <- []; load_int f.b ~dst:rax ~mm:(Frame saved) ~size:8 ~signed:false; xfer_store f ~reg:rax ~scratch:r11; zero_return (); jmp_lbl f.b f.retlbl; (* 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 lbl f.b cleanup; str_args f ~preg:rdi ~nreg:rsi (Loc.to_string fn.Tast.floc); die f "flan_transfer_fail" end end else begin zero_return (); jmp_lbl f.b f.retlbl end end; (* And if [f.unwound] is false there is nothing to emit: the defers on the transfer exit are dead because no path names that exit. This used to be a refusal, on the theory that a function with a defer and no transfer exit was a sign the reasoning had gone wrong. It is not — it is every leaf function with a defer, and [spike/x86/p9-dead-defers.flan] is ten lines of it. [emit.ml]'s [emit_fn] writes the whole exit under the same [if f.unwound], and so drops them too. What makes the drop safe is that [unwound] is not an approximation. Every site that can leave a transfer in the channel and keep going either emits [guard] — [Signal], [bounds_call], the two [rt_signals] entry points, and every call by name or by pointer — or jumps to [current_pad] outright, which is [invoke-restart] and the three re-propagating pads. So [unwound] is false exactly when no transfer can arrive. A function whose every call sits inside a [restart-case] is not a counterexample: the guard sets that pad's [used], the pad is emitted, and its tail re-propagates through [current_pad] with the pad stack already popped. *) (* The prologue, now that the frame size is known. *) let pb = create () in push_r pb rbp; if cfi then cfi_after_push pb; mov_rr pb ~dst:rbp ~src:rsp; if cfi then cfi_after_mov pb; let n = frame_bytes f in if n > 0 then sub_imm pb ~dst:rsp n; (match sret_at with | Some (Ireg r) -> store_int pb ~src:r ~mm:(Frame f.sret_off) ~size:8 | Some (Istk d) -> load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; store_int pb ~src:rax ~mm:(Frame f.sret_off) ~size:8 | _ -> ()); List.iteri (fun i ty -> let at = List.nth param_at i and sp = List.nth spills i in let slot = f.slots.(i) in match at, sp with | Ireg r, Some p -> store_int pb ~src:r ~mm:(Frame p) ~size:8 | Ireg r, None -> if is_void ty then () else store_int pb ~src:r ~mm:(Frame slot) ~size:(match ty with Types.Bool -> 1 | _ -> max 1 (fst (Emit.lay md ty))) | Isse i', _ -> fstore pb ~src:i' ~mm:(Frame slot) ~f64:(f64_of ty) | Istk d, _ -> if is_agg ty then begin (* The caller put a pointer there, not the aggregate. *) load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; store_int pb ~src:rax ~mm:(Frame (match sp with Some p -> p | None -> slot)) ~size:8 end else if not (is_void ty) then begin load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:(signed_of ty); store_int pb ~src:rax ~mm:(Frame slot) ~size:(match ty with Types.Bool -> 1 | _ -> max 1 (fst (Emit.lay md ty))) end) fn.Tast.params; (match xfer_at with | Ireg r -> store_int pb ~src:r ~mm:(Frame f.xfer_off) ~size:8 | Istk d -> load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8 | Isse _ -> unsupported "the channel in an SSE register"); (* And now the aggregate copies, with every incoming register safely in the frame. A struct parameter *is* a copy — spec-memory.md's assignment rule, made by the caller and taken again here so the callee owns it. *) List.iteri (fun i ty -> match List.nth spills i with | Some p -> lea pb ~dst:rdi ~mm:(Frame f.slots.(i)); load_int pb ~dst:rsi ~mm:(Frame p) ~size:8 ~signed:false; movabs pb ~dst:rcx (Int64.of_int (fst (Emit.lay md ty))); rep_movsb pb | None -> ()) fn.Tast.params; (* The epilogue, in exactly one place. *) lbl f.b f.retlbl; if sret then load_int f.b ~dst:rax ~mm:(Frame f.sret_off) ~size:8 ~signed:false else if not (is_void fn.Tast.ret) then load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax) ~off:f.retval fn.Tast.ret; leave f.b; if cfi then cfi_after_leave f.b; ret f.b; flush pb; flush f.b; let sym = fsym fn.Tast.name in let out = Buffer.create 1024 in Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym); (* [emit.ml:2072] says this is load-bearing and it is: default visibility in a shared object is interposable, and that applies to taking the address too, so a plain reference from inside a redefinition module would resolve to the *host's* copy and the module would install the very body it is replacing. Only a module's own bodies are hidden; a whole program emits none. *) if hidden then Buffer.add_string out (Printf.sprintf "\t.hidden\t%s\n" sym); Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym); Buffer.add_string out (sym ^ ":\n"); if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out (Buffer.contents pb.out); Buffer.add_string out (Buffer.contents f.b.out); (* One past the last byte, which is what [DW_AT_high_pc] and the line table's closing [DW_LNE_end_sequence] both want. [.size]'s [. - sym] says the same thing but is an expression rather than a symbol, and [DW_FORM_addr] takes a symbol. *) (match sub with | Some s -> Buffer.add_string out (s.send ^ ":\n") | None -> ()); (match dw with Some d -> d.dcur <- None | None -> ()); if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym); Buffer.contents out, Buffer.contents f.rodata (* ── C's main ────────────────────────────────────────────────────────── *) (* The same four shapes [emit.ml]'s [emit_main] adapts to, and the same order: the runtime is initialised while argc and argv are still in the registers the loader put them in, the program's own end of the transfer channel is a null cell on this frame, and the exit goes through [flan_exit] because stdout is a FILE* and something has to flush it. *) let emit_main ?(cfi = false) (md : Emit.m) (fn : Tast.fn) = let b = create () in push_r b rbp; if cfi then cfi_after_push b; mov_rr b ~dst:rbp ~src:rsp; if cfi then cfi_after_mov b; sub_imm b ~dst:rsp 48; (* [al] is zero at every call this backend makes, variadic or not — see [call_native]. Setting it here too costs two bytes and keeps the rule without an exception, which is worth more than the two bytes. *) xor_rr b ~dst:rax ~src:rax; call_sym b "flan_rt_init"; let xfer = -8 and argv = -32 in xor_rr b ~dst:rax ~src:rax; store_int b ~src:rax ~mm:(Frame xfer) ~size:8; (match fn.Tast.params with | [] -> lea b ~dst:rdi ~mm:(Frame xfer) | [ _ ] -> lea b ~dst:rdi ~mm:(Frame argv); xor_rr b ~dst:rax ~src:rax; call_sym b "flan_argv"; lea b ~dst:rdi ~mm:(Frame argv); lea b ~dst:rsi ~mm:(Frame xfer) | _ -> unsupported "main takes at most one parameter"); call_sym b (fsym "main"); if Types.equal fn.Tast.ret (Types.Int Types.I32) then mov_rr b ~dst:rdi ~src:rax else xor_rr b ~dst:rdi ~src:rdi; xor_rr b ~dst:rax ~src:rax; call_sym b "flan_exit"; ud2 b; flush b; ignore md; let out = Buffer.create 256 in Buffer.add_string out "\t.globl\tmain\n\t.type\tmain, @function\nmain:\n"; (* No [.cfi_def_cfa 7, 8] to close with, because this one has no epilogue: it leaves through [flan_exit] and the [ud2] after that is unreachable. The rbp rule therefore holds to the last byte, which is what a backtrace out of anything [main] called needs. *) if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out (Buffer.contents b.out); if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out "\t.size\tmain, . - main\n\n"; Buffer.contents out (* ── Globals ─────────────────────────────────────────────────────────── *) (* Every global is a zeroed object and an initialiser that runs before [main] does. [emit.ml] folds the initialiser into an LLVM constant instead, which it can because it has a constant folder for the IR's own syntax; running the same expression as code costs a few instructions once and needs no second evaluator that could disagree with the first about what a struct literal means. *) let emit_globals_data (md : Emit.m) (globals : Tast.global list) = let out = Buffer.create 256 in Buffer.add_string out "\t.bss\n"; List.iter (fun (g : Tast.global) -> let size, align = Emit.lay md g.Tast.gty in let sym = gsym g.Tast.gname in Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n\t.align\t%d\n\t.type\t%s, @object\n\ \t.size\t%s, %d\n%s:\n\t.zero\t%d\n" sym align sym sym (max 1 size) sym (max 1 size))) globals; Buffer.contents out let init_sym = "\"flan..init-globals\"" let emit_globals_init ?(cfi = false) (md : Emit.m) ~externs ~fns (globals : Tast.global list) = let b = create () in let f = { b; md; fnname = ""; retlbl = new_label () "ginit"; fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0; frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = []; xfer_lbl = ""; unwound = false; rodata = Buffer.create 64; externs; fns; ext = (fun _ -> false); dw = None } in (* Two slots, not one: [xfer_off] holds the *pointer* every call passes on, and [cell] is what it points at. Storing a null into [xfer_off] itself — which is what this did while nothing could transfer — hands every callee a null channel to write through. No caller gives this function one, so it owns the cell. *) let cell = ptmp f in f.xfer_off <- ptmp f; f.xfer_lbl <- new_label f "gxfer"; List.iter (fun (g : Tast.global) -> scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0)))) globals; (* Nothing establishes a handler or a restart before this runs, so a transfer out of an initialiser has nowhere to go and cannot arise: a bounds failure here finds no handler and dies inside the runtime. The exit still exists because a guard names it. *) if f.unwound then begin jmp_lbl f.b f.retlbl; lbl f.b f.xfer_lbl; jmp_lbl f.b f.retlbl end; let pb = create () in push_r pb rbp; if cfi then cfi_after_push pb; mov_rr pb ~dst:rbp ~src:rsp; if cfi then cfi_after_mov pb; let n = frame_bytes f in if n > 0 then sub_imm pb ~dst:rsp n; (* No caller hands this one a channel, so it gets a null cell of its own and passes that cell's address on. *) xor_rr pb ~dst:rax ~src:rax; store_int pb ~src:rax ~mm:(Frame cell) ~size:8; lea pb ~dst:rax ~mm:(Frame cell); store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8; lbl f.b f.retlbl; leave f.b; if cfi then cfi_after_leave f.b; ret f.b; flush pb; flush f.b; let out = Buffer.create 512 in Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n%s:\n" init_sym init_sym); if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out (Buffer.contents pb.out); Buffer.add_string out (Buffer.contents f.b.out); if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" init_sym init_sym); Buffer.contents out, Buffer.contents f.rodata (* ── The program ─────────────────────────────────────────────────────── *) (* What is left of the precondition that used to stand in for conditions. It was a whole-program argument: this backend emitted no guard after a call, which is sound exactly when nothing in the reachable set can ever *write* the channel, so the build refused by name the moment it found something that could. Every call site is guarded now and the argument has retired — except in one place, which is why the walk is still here. A global's initialiser runs from [flan..init-globals], before [main] and before anything has established a handler or a restart. It owns its own channel cell because no caller hands it one, so a transfer out of an initialiser has nowhere to go: its exit would return to the loader. Refused by name rather than compiled into a return into ld.so. *) let check_no_transfer (p : Tast.program) = let bad what = unsupported "%s in a global's initialiser: it runs before main, before \ anything can handle it, and a transfer out of it has nowhere \ to go" what in let rec ex (e : Tast.expr) = (match e.Tast.e with | Tast.Signal _ -> bad "signal" | Tast.InvokeRestart _ -> bad "invoke-restart" | Tast.RestartCase _ -> bad "restart-case" | Tast.Handled _ -> bad "handler-bind" | _ -> ()); iter_sub ex e and iter_sub g (e : Tast.expr) = match e.Tast.e with | Tast.Prim (_, xs) | Tast.Call (_, xs) | Tast.Arr xs | Tast.Do xs | Tast.Make (_, xs) | Tast.MakeCase (_, _, xs) -> List.iter g xs | Tast.CallPtr (a, xs) -> g a; List.iter g xs | Tast.Handled (_, xs) -> List.iter g xs | Tast.Let (bs, body) -> List.iter (fun (_, x) -> g x) bs; List.iter g body | Tast.If (a, b, c) -> g a; g b; g c | Tast.While (a, b, l) -> g a; List.iter g b; List.iter g l | Tast.Return (Some x) | Tast.Some_ x | Tast.Deref x | Tast.UnwrapSome x | Tast.Field (x, _) | Tast.CaseField (x, _, _) | Tast.Signal (_, _, x) -> g x | Tast.Set (pl, x) -> place_ g pl; g x | Tast.Addr pl -> place_ g pl | Tast.Match (x, arms) -> g x; List.iter (fun (a : Tast.arm) -> List.iter g a.Tast.abody) arms | Tast.RestartCase (cs, x) -> List.iter (fun (c : Tast.rclause) -> List.iter g c.Tast.rbody) cs; g x | Tast.WithAlloc (a, body) -> g a; List.iter g body | Tast.InvokeRestart (_, _, xs, _, _, _) -> List.iter g xs | _ -> () and place_ g (pl : Tast.place) = match pl with | Tast.Pfield (x, _) | Tast.Pderef x -> g x | Tast.Pindex (x, ys) -> g x; List.iter g ys | _ -> () in List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals (* One cell per function, initialised to the body this build compiled, and [.globl] so that a redefinition module can bind to it. Nothing has been redefined yet when the program starts, so a dev build begins by behaving exactly like a release one — the indirection is the only difference, and that is what makes the whole corpus a test of it. [.data] and not [.bss]: the initialiser is a relocation against the body, not a zero. Default visibility, because interposition is the point here; only a redefined *body* is hidden, and this backend emits none. What is not here is [Emit.cellptr] — the second, deeper spelling for a name the host was never built with. It cannot arise in a whole-program build, where [known] is true of everything, and it belongs with the redefinition module that would introduce such a name. *) let emit_cells (p : Tast.program) = let out = Buffer.create 256 in Buffer.add_string out "\t.data\n"; List.iter (fun (fn : Tast.fn) -> let c = csym fn.Tast.name in Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n\t.align\t8\n\t.type\t%s, @object\n\ \t.size\t%s, 8\n%s:\n\t.quad\t%s\n" c c c c (fsym fn.Tast.name))) p.Tast.fns; Buffer.contents out (* ── The DWARF sections ──────────────────────────────────────────────── *) (* A path inside an assembler string literal. Flan source paths contain neither of these two characters in practice, but a path is user input and a stray backslash would end the directive rather than the string. *) let asm_str s = let b = Buffer.create (String.length s + 8) in String.iter (fun c -> if c = '"' || c = '\\' then Buffer.add_char b '\\'; Buffer.add_char b c) s; Buffer.contents b (* Absolute, because the file table below gives every entry directory index 0 and a debugger then reads the name as written. [emit.ml]'s [dfile] splits the same absolute path into a [!DIFile]'s filename and directory; DWARF is happy with either and one string is fewer moving parts. *) let abspath p = if Filename.is_relative p then Filename.concat (Sys.getcwd ()) p else p (* [DW_LNE_set_address] on a label: the escape opcode, a length of 9, the sub-opcode, and eight bytes of address the assembler relocates. Every row gets one of these rather than a [DW_LNS_advance_pc] with a computed delta, and the reason is that a delta would be a difference of two labels inside a [.uleb128], which asks the assembler to resolve a value whose size affects the values after it. That does work, but it is exactly the kind of thing whose failure looks like a DWARF bug. Rows are eleven bytes each here and that is a debug build's business. *) let dw_set_address b lbl = Buffer.add_string b (Printf.sprintf "\t.byte\t0, 9, 2\n\t.quad\t%s\n" lbl) (* The line-number program: one sequence per function, closed with an end_sequence at the label one past its last byte. The registers are reset at the head of every sequence, which is why [line] starts at 1 and [file] at 1 in each. Rows within a sequence must be address-ordered, and they are for free: [dwline] appends them in the order the bytes are emitted. *) let dw_line_program (dw : dwarf) = let b = Buffer.create 4096 in List.iter (fun s -> let line = ref 1 and file = ref 1 and col = ref 0 in List.iter (fun r -> dw_set_address b r.rlbl; if r.rfile <> !file then begin Buffer.add_string b (Printf.sprintf "\t.byte\t4\n\t.uleb128 %d\n" r.rfile); file := r.rfile end; if r.rcol <> !col then begin Buffer.add_string b (Printf.sprintf "\t.byte\t5\n\t.uleb128 %d\n" r.rcol); col := r.rcol end; if r.rline <> !line then begin Buffer.add_string b (Printf.sprintf "\t.byte\t3\n\t.sleb128 %d\n" (r.rline - !line)); line := r.rline end; Buffer.add_string b "\t.byte\t1\n") (List.rev s.srows); dw_set_address b s.send; Buffer.add_string b "\t.byte\t0, 1, 1\n") (List.rev dw.dsubs); Buffer.contents b (* The three sections. [tbeg] and [tend] bracket everything this object puts in [.text] — the compile unit claims that whole range, including the C [main] shim and the globals' initialiser, neither of which has any rows. That is honest: they are code this unit produced, and a debugger that finds no line for an address inside them says so. *) let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend = let out = Buffer.create 8192 in (* The compile unit's directory, and the directory table the file entries index into. [emit.ml]'s [dfile] splits every path into a basename and a directory the same way, and the reason to match it is what a debugger prints: a frame reads [debug.flan:19] rather than the eighty characters of an absolute path. Directory index 0 is the compile unit's own directory, so a file sitting beside the one that named the unit -- which is most of them -- costs no entry at all. *) let cudir = Filename.dirname (abspath cufile) in let dirs = ref [] in let dirix d = if String.equal d cudir then 0 else match List.assoc_opt d !dirs with | Some n -> n | None -> let n = List.length !dirs + 1 in dirs := !dirs @ [ (d, n) ]; n in let files = List.map (fun p -> let a = abspath p in (Filename.basename a, dirix (Filename.dirname a))) (List.rev dw.dpaths) in Buffer.add_string out "\n# Debug information. Written out as data rather than left to the\n\ # assembler's .loc, which cannot work here: GAS builds its line table\n\ # when it assembles an instruction, and this file assembles none.\n"; (* .debug_abbrev. Two abbreviations, because two shapes of DIE are all that is described. *) Buffer.add_string out "\t.section\t.debug_abbrev,\"\",@progbits\n\ .Ldwabbrev:\n\ \t.uleb128 1\n\ \t.uleb128 0x11\t\t# DW_TAG_compile_unit\n\ \t.byte\t1\t\t# has children\n\ \t.uleb128 0x25\n\t.uleb128 0x08\t# DW_AT_producer DW_FORM_string\n\ \t.uleb128 0x13\n\t.uleb128 0x05\t# DW_AT_language DW_FORM_data2\n\ \t.uleb128 0x03\n\t.uleb128 0x08\t# DW_AT_name DW_FORM_string\n\ \t.uleb128 0x1b\n\t.uleb128 0x08\t# DW_AT_comp_dir DW_FORM_string\n\ \t.uleb128 0x11\n\t.uleb128 0x01\t# DW_AT_low_pc DW_FORM_addr\n\ \t.uleb128 0x12\n\t.uleb128 0x07\t# DW_AT_high_pc DW_FORM_data8\n\ \t.uleb128 0x10\n\t.uleb128 0x17\t# DW_AT_stmt_list DW_FORM_sec_offset\n\ \t.byte\t0, 0\n\ \t.uleb128 2\n\ \t.uleb128 0x2e\t\t# DW_TAG_subprogram\n\ \t.byte\t0\t\t# no children\n\ \t.uleb128 0x3f\n\t.uleb128 0x19\t# DW_AT_external DW_FORM_flag_present\n\ \t.uleb128 0x03\n\t.uleb128 0x08\t# DW_AT_name DW_FORM_string\n\ \t.uleb128 0x6e\n\t.uleb128 0x08\t# DW_AT_linkage_name DW_FORM_string\n\ \t.uleb128 0x3a\n\t.uleb128 0x0f\t# DW_AT_decl_file DW_FORM_udata\n\ \t.uleb128 0x3b\n\t.uleb128 0x0f\t# DW_AT_decl_line DW_FORM_udata\n\ \t.uleb128 0x11\n\t.uleb128 0x01\t# DW_AT_low_pc DW_FORM_addr\n\ \t.uleb128 0x12\n\t.uleb128 0x07\t# DW_AT_high_pc DW_FORM_data8\n\ \t.byte\t0, 0\n\ \t.byte\t0\n"; (* .debug_info. DW_LANG_C99 for [emit.ml]'s reason: it is less a claim about the source language than the truth about the data model, and it is what makes a debugger's own struct printing correct against this layout. *) Buffer.add_string out (Printf.sprintf "\t.section\t.debug_info,\"\",@progbits\n\ .Ldwinfo:\n\ \t.long\t.Ldwinfo_end - .Ldwinfo_ver\n\ .Ldwinfo_ver:\n\ \t.short\t4\n\ \t.long\t.Ldwabbrev\n\ \t.byte\t8\n\ \t.uleb128 1\n\ \t.asciz\t\"flan (x86-64)\"\n\ \t.short\t0x000c\t\t# DW_LANG_C99\n\ \t.asciz\t\"%s\"\n\ \t.asciz\t\"%s\"\n\ \t.quad\t%s\n\ \t.quad\t%s - %s\n\ \t.long\t.Ldwline\n" (asm_str (Filename.basename (abspath cufile))) (asm_str cudir) tbeg tend tbeg); List.iter (fun s -> Buffer.add_string out (Printf.sprintf "\t.uleb128 2\n\t.asciz\t\"%s\"\n\t.asciz\t\"%s\"\n\ \t.uleb128 %d\n\t.uleb128 %d\n\t.quad\t%s\n\t.quad\t%s - %s\n" (asm_str s.sname) (asm_str ("flan." ^ s.sname)) s.sfile s.sline s.ssym s.send s.ssym)) (List.rev dw.dsubs); Buffer.add_string out "\t.byte\t0\n.Ldwinfo_end:\n"; (* .debug_line. The standard opcode lengths are the standard ones; changing them would change nothing, since every row below is spelled out of the three opcodes this emitter uses and never out of a special opcode. *) Buffer.add_string out "\t.section\t.debug_line,\"\",@progbits\n\ .Ldwline:\n\ \t.long\t.Ldwline_end - .Ldwline_ver\n\ .Ldwline_ver:\n\ \t.short\t4\n\ \t.long\t.Ldwline_prog - .Ldwline_hdr\n\ .Ldwline_hdr:\n\ \t.byte\t1\t\t# minimum_instruction_length\n\ \t.byte\t1\t\t# maximum_operations_per_instruction\n\ \t.byte\t1\t\t# default_is_stmt\n\ \t.byte\t0xfb\t\t# line_base = -5\n\ \t.byte\t14\t\t# line_range\n\ \t.byte\t13\t\t# opcode_base\n\ \t.byte\t0,1,1,1,1,0,0,0,1,0,0,1\n"; List.iter (fun (d, _) -> Buffer.add_string out (Printf.sprintf "\t.asciz\t\"%s\"\n" (asm_str d))) !dirs; Buffer.add_string out "\t.byte\t0\t\t# end of the directory table\n"; List.iter (fun (name, dir) -> Buffer.add_string out (Printf.sprintf "\t.asciz\t\"%s\"\n\t.uleb128 %d\n\t.uleb128 0\n\ \t.uleb128 0\n" (asm_str name) dir)) files; Buffer.add_string out "\t.byte\t0\n.Ldwline_prog:\n"; Buffer.add_string out (dw_line_program dw); Buffer.add_string out ".Ldwline_end:\n"; Buffer.contents out (* A whole program as one assembly file. *) let program ~checks ?(dev = false) ?(debug = false) (p : Tast.program) : string = check_no_transfer p; let md = layout_ctx ~checks ~dev p in let externs = Hashtbl.create 16 in List.iter (fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym) p.Tast.externs; let fns = Hashtbl.create 64 in List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fns fn.Tast.name ()) p.Tast.fns; let dw = if debug then Some (new_dwarf ()) else None in (* The file every diagnostic in this unit is really about: the first function anyone actually wrote. [emit.ml]'s [new_dbg] picks it the same way and for the same reason -- the prelude contributes functions too, and naming the prelude as the compile unit would be true and useless. *) let cufile = 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 -> "" in let text = Buffer.create 65536 and rodata = Buffer.create 4096 in Buffer.add_string text "# Generated by flan's x86-64 backend (the dev one). The instructions are\n\ # .byte blobs so that every byte offset stays exactly known; the few\n\ # fields that need a relocation are assembler expressions.\n"; (* A numbered [.file] is what stops clang's integrated assembler from generating a compile unit of its *own* over this file -- one that names the .s, and whose rows land at the [call] mnemonics, which are the only real instructions here. Those addresses are inside the functions this unit already describes, so two units would claim them. Measured: with the directive, the assembler emits an empty line table and nothing else. Harmless in a release build, where it is simply never emitted. *) if debug then Buffer.add_string text (Printf.sprintf "\t.file\t1 \"%s\"\n" (asm_str (abspath cufile))); (* The label the compile unit's range starts at, and it is emitted only in a debug build so that a release build's assembly is byte-for-byte what it was before any of this existed. *) Buffer.add_string text (if debug then "\t.text\n.Ldwtext:\n\n" else "\t.text\n\n"); List.iter (fun (fn : Tast.fn) -> let t, r = emit_fn md ~externs ~fns ?dw fn in Buffer.add_string text t; Buffer.add_string rodata r) p.Tast.fns; let ginit, gr = emit_globals_init ~cfi:debug md ~externs ~fns p.Tast.globals in Buffer.add_string text ginit; Buffer.add_string rodata gr; (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with | Some fn -> Buffer.add_string text (emit_main ~cfi:debug md fn) (* No [main] is not an error, and [emit.ml] treats it the same way: a program can be linked against a C host that brings its own entry point, which is what [reload_host.c] is. Refusing here made a --x86 host for the reload tests impossible to build. *) | None -> ()); (* The end of everything this object puts in .text, and therefore the end of the compile unit's range. It has to be written while .text is still the current section, which is why it is here and not beside the sections below. *) if debug then Buffer.add_string text ".Ldwtext_end:\n"; let out = Buffer.create 65536 in Buffer.add_buffer out text; (* The globals' initialiser runs before main, through the same constructor slot [emit.ml] uses to arm the allocation registry. *) (* [flan_dev_reg_enable] arms the allocation registry, and a dev build is the only build that has one. A constructor rather than a line in [main] for [emit.ml]'s reason: a [defvar] initialiser allocates before [main] runs, and a note that arrived before the flag was set would be a block the table never heard of. It is ordered before [init_sym] here for the same reason. Leaving it out was the one visible difference between a `--x86 --dev` build and an LLVM one over the whole corpus: [registry.flan] asks [(live? ...)] and got four zeroes. *) Buffer.add_string out (Printf.sprintf "\t.section\t.init_array,\"aw\",@init_array\n\t.align\t8\n%s\ \t.quad\t%s\n\n" (if dev then "\t.quad\tflan_dev_reg_enable\n" else "") init_sym); (* The ABI marker, and only in a dev build: it exists for redefinition modules to bind against, a release build has no cells to load one into, and gating it here is what keeps a release build's assembly byte-for-byte what it was. [.globl] and default visibility, for the reason the cells have them — a dlopened object has to be able to see it, which is also why [Build.executable] passes [-rdynamic] for a dev build and nothing else. *) if dev then Buffer.add_string out (Printf.sprintf "\t.data\n\t.globl\t%s\n\t.align\t8\n\t.type\t%s, @object\n\ \t.size\t%s, 8\n%s:\n\t.quad\t0\n\n" (asm_sym abi_marker) (asm_sym abi_marker) (asm_sym abi_marker) (asm_sym abi_marker)); if dev then Buffer.add_string out (emit_cells p); Buffer.add_string out (emit_globals_data md p.Tast.globals); Buffer.add_string out "\n\t.section\t.rodata\n"; Buffer.add_buffer out rodata; (match dw with | Some d -> Buffer.add_string out (emit_dwarf d ~cufile ~tbeg:".Ldwtext" ~tend:".Ldwtext_end") | None -> ()); Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; Buffer.contents out (* -- One function into a loadable object ------------------------------ *) (* The counterpart to [Emit.redefinition], and the reason this backend exists. [program] above emits an executable; this emits the assembly for a [.so] that gets dlopened into a host which is {e already running}, replacing the body behind one or more names without restarting anything. {b Why it cannot be [Emit.redefinition].} This file licenses its own calling convention on the grounds that a dev build is compiled entirely here and a release build entirely by LLVM, so the two never meet in one process. The conventions agree on every scalar and disagree on every aggregate -- here each goes by pointer with a hidden [sret]; LLVM classifies by eightbyte. An [Emit.redefinition] module dlopened into an [--x86] host is therefore correct exactly until the first redefined function takes or returns a struct. The answer is a redefinition emitter here, not an aggregate classifier there. {b What it does not define}, each of which [program] does and each of which would be wrong in a module: - no [main]: this object is loaded, not started. - no [.init_array] and in particular no [flan..init-globals]. Re-running a global's initialiser would wipe the live state that reloading exists to preserve -- sand's grid is a global and "edit the code, keep the sand" is the whole demo. - no [flan_dev_reg_enable] constructor: the host armed the registry when it started. - no [.bss] for the globals and no [.data] for the cells. Both are the host's objects; this module names them and the loader binds them. {b And what it must.} Every body is [.hidden] -- [emit.ml] says the same and for the same reason, that default visibility in a shared object is interposable. And [flan_reload_install], a named function rather than a constructor, because the agent has to choose {e when} the swap happens: at a frame boundary, on the game thread. [reload_host.c] and [vendor/agent/flan_agent.c] both [dlsym] exactly that spelling. {b The scope, and it is narrower than [Emit.redefinition]'s.} Only names the host already has. A name introduced since has no symbol to bind to, and [Emit.redefinition] answers that with [flan_dev_cell] / [flan_dev_global] and [Emit.cellptr]'s deeper spelling -- a module-local slot resolved by string at install time. That is not built here, and neither is the [consts] republish nor the transient [flan_reload_call] thunk. Each is refused by name, which is this file's idiom for a case it has not earned the right to compile. *) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) ?(consts = []) ?call (p : Tast.program) ~fns : string = if not dev then unsupported "x86 redefinition without cells: there is nothing to publish a body \ into, and this backend's release build has no indirection"; if consts <> [] then unsupported "x86 redefinition: republishing a defconst is not built yet"; (match call with | Some _ -> unsupported "x86 redefinition: the transient flan_reload_call thunk is not built yet" | None -> ()); let target name = match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with | Some f -> f | None -> unsupported "no such function: %s" name in let targets = List.map target fns in (* A clause lifted out of a target comes with it: its body may have changed too, and it is reached by address from inside this module rather than through a cell. Every other lifted clause is invisible here. *) let lifted = List.filter (fun (f : Tast.fn) -> match f.Tast.fparent with | Some q -> List.mem q fns | None -> false) p.Tast.fns in let siblings = List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns in List.iter (fun (f : Tast.fn) -> if not (known f.Tast.name) then unsupported "x86 redefinition: %s is new to this session, and a name the host \ was not built with needs the flan_dev_cell lookup and \ Emit.cellptr's second spelling, which are not built here yet" f.Tast.name) siblings; List.iter (fun (g : Tast.global) -> if not (known g.Tast.gname) then unsupported "x86 redefinition: the global %s is new to this session, and a new \ global needs the flan_dev_global lookup, which is not built here \ yet" g.Tast.gname) p.Tast.globals; let md = layout_ctx ~checks ~dev p in let externs = Hashtbl.create 16 in List.iter (fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym) p.Tast.externs; let fnstbl = Hashtbl.create 64 in List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fnstbl fn.Tast.name ()) p.Tast.fns; (* Which symbols this object defines. Everything else -- the host's cells, its globals, its other bodies, and every runtime entry point -- is reached through the GOT, because a pc-relative relocation against an undefined symbol cannot be used in a shared object at all. *) let mine = Hashtbl.create 16 in List.iter (fun (f : Tast.fn) -> Hashtbl.replace mine (fsym f.Tast.name) ()) (targets @ lifted); let ext s = not (Hashtbl.mem mine s) in let text = Buffer.create 8192 and rodata = Buffer.create 1024 in Buffer.add_string text "# Generated by flan's x86-64 backend: one or more functions, recompiled\n\ # into an object a running process can dlopen. Every symbol this file\n\ # does not define is the host's, and is reached through the GOT.\n\ \t.text\n\n"; List.iter (fun (f : Tast.fn) -> let t, r = emit_fn md ~externs ~fns:fnstbl ~ext ~hidden:true f in Buffer.add_string text t; Buffer.add_string rodata r) (lifted @ targets); (* Publishing: one store per target, and the cell's address has to be read out of the GOT first because the cell itself lives in the host. The body is this module's own and hidden, so its address is an ordinary pc-relative [lea]. *) let b = create () in List.iter (fun (f : Tast.fn) -> load_int b ~dst:rax ~mm:(Got (csym f.Tast.name)) ~size:8 ~signed:false; lea b ~dst:r11 ~mm:(Sym (fsym f.Tast.name, 0)); store_int b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8) targets; ret b; flush b; Buffer.add_string text "\t.globl\tflan_reload_install\n\ \t.type\tflan_reload_install, @function\n\ flan_reload_install:\n"; Buffer.add_buffer text b.out; Buffer.add_string text "\t.size\tflan_reload_install, . - flan_reload_install\n\n"; let out = Buffer.create 8192 in Buffer.add_buffer out text; (* The ABI marker this module requires of its host. A pointer-sized datum holding the host's marker is a relocation the loader has to resolve while it maps the object, whatever it does about lazy binding of calls, so a host that does not define [flan.abi.x86] fails the [dlopen] outright. A call would do as well under [RTLD_NOW], which is what both loaders here pass, but a datum does not depend on that and costs eight bytes. The label is local: nothing outside this module names it, and only the relocation against the marker matters. *) Buffer.add_string out (Printf.sprintf "\n\t.data\n\t.align\t8\n%s:\n\t.quad\t%s\n" (asm_sym "flan.abi.require") (asm_sym abi_marker)); Buffer.add_string out "\n\t.section\t.rodata\n"; Buffer.add_buffer out rodata; Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; Buffer.contents out