(** 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 (docs/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; (* ── Annotation ── A comment waiting for the bytes it is about, newest last, each with the serial that says who queued it. Nothing here reaches the object: the assembler discards a comment, and splitting one [.byte] directive into two is the same bytes in the same order. What it buys is a listing whose runs of machine code are each headed by the Flan form that produced them. Queued rather than written, because the point of the comment is to sit above bytes and a form that emits none must not leave its heading on the next form's. So [annote] queues, the first byte written afterwards flushes the queue, and [unannote] withdraws whatever its own form queued and never spent. *) mutable ann : (int * string) list; (* How far to indent a run of bytes, which is the nesting depth of the form that is emitting it. An argument's bytes step in and the call's step back out, so the shape of the expression is visible in the left margin without reading a single comment. *) mutable ind : string; } let create () = { out = Buffer.create 4096; pend = []; n = 0; ann = []; ind = "" } let flush b = if b.pend <> [] then begin Buffer.add_string b.out ("\t" ^ b.ind ^ ".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 (* The serial of the highest-numbered comment that has actually been written. [unannote] compares against it to tell "my heading is still waiting and should be withdrawn" from "my heading was spent on bytes I emitted". Module scope because the serials are, and they are because a function's prologue and its body are two buffers. *) let annser = ref 0 let annmax = ref 0 (* Bytes are about to be written, so anything queued is about them. *) let ann_due b = if b.ann <> [] then begin flush b; List.iter (fun (s, line) -> Buffer.add_string b.out line; Buffer.add_char b.out '\n'; if s > !annmax then annmax := s) b.ann; b.ann <- [] end let u8 b x = if b.ann <> [] then ann_due b; 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 (* A relocation, a label and raw text all count as "bytes about to be written" for the queue's purpose: each is part of the run its form produced, and a heading has to arrive before the label its form's code begins at. *) let dir b s size = ann_due b; flush b; Buffer.add_string b.out ("\t" ^ b.ind ^ s ^ "\n"); b.n <- b.n + size let text b s = ann_due b; flush b; Buffer.add_string b.out s let lbl b l = ann_due b; flush b; Buffer.add_string b.out (l ^ ":\n") (* The margin a run of bytes is written at. Changing it flushes, because [flush] writes the margin as it stands when the line is written and the bytes pending at that moment were accumulated under the old one — without this, the tail of an outer form comes out at the indentation its last argument had. *) let set_ind b s = if b.ind <> s then begin flush b; b.ind <- s end (* Queue one comment line. [pre] is written as given — the callers below spell their own leading tab and hash — and the serial comes back so that the form that queued it can withdraw it if it turns out to have emitted nothing. *) let annote b line = incr annser; b.ann <- b.ann @ [ (!annser, line) ]; !annser (* Drop every heading queued at or after [s] and still unspent. Answers whether [s] itself was spent, which is the only thing a caller wants to know. *) let unannote b s = if b.ann <> [] then b.ann <- List.filter (fun (k, _) -> k < s) b.ann; !annmax >= s (* ── 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 (* For the listing only — nothing encodes through this. In the same order the numbering above is in, which is the modrm one and not the alphabetical one a reader might expect. *) let rname = [| "rax"; "rcx"; "rdx"; "rbx"; "rsp"; "rbp"; "rsi"; "rdi"; "r8"; "r9"; "r10"; "r11"; "r12"; "r13"; "r14"; "r15" |] let regname r = if r >= 0 && r < 16 then rname.(r) else Printf.sprintf "r?%d" r (* 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 and_imm b ~dst n = grp1_imm b ~ext:4 ~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, always 64 bits wide, because every integer in this backend is computed in a full register and narrowed only on the way to memory. The hardware masks the count to 63 for a 64-bit shift and to 31 for a 32-bit one, and to nothing narrower than that — there is no 8- or 16-bit masking rule to inherit. So the width the count is masked to is a property of the *instruction* emitted, not of the language's type, and since the instruction is always the 64-bit one the caller has to mask the count itself for every width below 64. See the shift arm in [prim_to]. *) 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 data type 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 datas = Hashtbl.create 16 in let 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.data) -> Hashtbl.replace datas u.Tast.dname u) p.Tast.datas; List.iter (fun (u : Tast.structure) -> Hashtbl.replace unions u.Tast.sname u) p.Tast.unions; { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; 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.Fn _ -> false | Types.Unit | Types.Never -> false | Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _ | 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; (* [Some slot] of a symbol that does not exist anywhere: a function or a global the host was never built with, introduced by a redefinition module while the process was running. There is no symbol to bind to and ELF has no way to grow one, so the address is looked up by string at install time and parked in [slot], which is this module's own object. Always [None] for a whole program, where [known] is true of everything -- so the whole-program path emits byte-identical output and the survey goes on being a structural check on all of this. [ext] and this are two questions and not one: [ext] says "the host's, reach it through the GOT", this says "nobody's yet, reach it through a slot I filled". *) slot : string -> string option; (* 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; (* True when this listing is meant to be read by a person rather than handed to clang — see [program]'s [annotate]. Every annotation in this file is behind it, so that a build's assembly is character-for-character what it was before any of this existed and [survey.sh] goes on comparing the same text it always compared. *) ann : bool; (* How deeply nested the form being lowered is, which is what the left margin of the listing shows. *) mutable adepth : int; (* The last heading written, so that a macro that expands to forty forms at one call site does not print that call site forty times. *) mutable alast : string; } (* 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) (* ── Annotation ──────────────────────────────────────────────────────── *) (* Everything below writes comments and nothing else, and all of it is behind [f.ann]. The reason it is worth the code is the one the frame model makes unavoidable: every intermediate value in this backend lives in a frame temporary, so a listing is a wall of [-0x48(%rbp)] and there is no way to tell which of those is the loop counter and which is where the left operand of an [imul] was parked. LLVM's output names its values and this file's cannot, so the names have to be written down beside it instead. A comment costs nothing in the object — the assembler discards it — so what it buys is paid for entirely in the size of the [.s], which nothing but a reader ever looks at. *) (* One bookkeeping line: something the compiler put there that no form in the source asked for, named once so that a reader who meets it again recognises it. The post-call guard and the bounds-check triple are the two that matter most, because they are the two a reader counts instructions in and wonders about. *) (* Wrapped rather than written as given, and whitespace collapsed on the way: the callers below spell their text across several source lines, and an assembly comment that runs to two hundred columns is one nobody reads. *) let wrap ~pre ~width s = let words = List.filter (fun w -> w <> "") (String.split_on_char ' ' (String.map (fun c -> if c = '\n' || c = '\t' then ' ' else c) s)) in let lines = ref [] and cur = Buffer.create 80 in let emit () = if Buffer.length cur > 0 then begin lines := (pre ^ Buffer.contents cur) :: !lines; Buffer.clear cur end in List.iter (fun w -> if Buffer.length cur > 0 && String.length pre + Buffer.length cur + 1 + String.length w > width then emit (); if Buffer.length cur > 0 then Buffer.add_char cur ' '; Buffer.add_string cur w) words; emit (); List.rev !lines let note f s = if f.ann then List.iter (fun l -> ignore (annote f.b l)) (wrap ~pre:(Printf.sprintf "\t%s# " f.b.ind) ~width:78 s) (* The same, on a buffer rather than a function context: the prologue is built into its own buffer before [f.b] is finished with. *) let bnote ann b s = if ann then List.iter (fun l -> ignore (annote b l)) (wrap ~pre:"\t# " ~width:78 s) (* The heading for one Flan form, queued against whatever bytes it goes on to emit. Three things are deliberately not annotated. A form the checker invented carries [Loc.unknown], and there is no source text to quote for it; it inherits the heading of the form that contains it, which is where it came from and therefore the true answer. An atom — a literal, a local, a global — is skipped because annotating it would steal its parent's heading. A multiply of a local by a literal lowers as a load, a load and an [imul]: if the two operands each queued a heading of their own, the heading standing above the [imul] would name the literal, and the one line a reader of this file most wants to be right would be wrong. Skipping the atoms leaves the multiply queued until the first byte and spanning the whole run, which is the answer. And a form at the same source position as the last heading written is skipped, which is what keeps a macro from printing its call site once per form of its expansion. *) let atomic (e : Tast.expr) = match e.Tast.e with | Tast.Int _ | Tast.Bool _ | Tast.Float _ | Tast.Str _ | Tast.Unit | Tast.Zero _ | Tast.None_ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ | Tast.FnAddr _ -> true | _ -> false let annot f (e : Tast.expr) = if (not f.ann) || atomic e || e.Tast.loc.Loc.line = 0 then None else let loc = e.Tast.loc in let where = Printf.sprintf "%s:%d:%d" (Filename.basename loc.Loc.file) loc.Loc.line loc.Loc.col in match Loc.snippet loc with | None -> None | Some src -> let src = match loc.Loc.macro with | Some m -> Printf.sprintf "%s [from the macro %s]" src m | None -> src in let key = where ^ " " ^ src in if key = f.alast then None else begin f.alast <- key; set_ind f.b (String.make (2 * min 12 f.adepth) ' '); let head = Printf.sprintf "\t%s# %s" f.b.ind src in let pad = max 1 (62 - String.length head) in Some (annote f.b (head ^ String.make pad ' ' ^ where)) 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 note f (Printf.sprintf "rep movsb: %d bytes from rsi to rdi. An aggregate is copied rather than \ aliased — spec-memory.md's assignment rule" n); 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 note f (Printf.sprintf "rep stosb: %d bytes of zero, which is what this backend \ spells a zero value as" n); 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))) (* Counted, on the same field [emit.ml] counts it on and for the same one reason: it is the test [redefinition] applies before it lets an expression thunk's module say it may be unloaded. A string literal is emitted into this module's image and the expression may store it anywhere it likes, so a module holding one keeps its mapping. A float constant is a label in the same section and is deliberately not counted -- it is loaded, never retained. *) let string_const f s = f.md.Emit.nstr <- f.md.Emit.nstr + 1; 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 *) (* A name that did not exist when the host was built, so there is no symbol anywhere to bind to. The address lives in a slot this module defines and [flan_reload_install] fills by asking the runtime's registry for it by string. The slot is this object's own, so naming it is pc-relative and never goes through the GOT; reading it is the one extra load, which is exactly [Lgot]'s shape with [Sym] where it has [Got]. *) | Lslot of string * int (* a module-local slot holds the address; + 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) | Lslot (s, a) -> Lslot (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) | Lslot (s, a) -> load_int f.b ~dst:scratch ~mm:(Sym (s, 0)) ~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 | Lslot (s, a) -> load_int f.b ~dst:reg ~mm:(Sym (s, 0)) ~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 = match f.slot s with | Some sl -> Lslot (sl, 0) | None -> 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. docs/DISCUSS.md item 15 said this is how hand-encoding fails. *) let load_sym f ~dst s = match f.slot s with (* The slot holds the cell's address, just as the GOT entry below does, so this is the same two loads with one relocation swapped. Which is the point of spelling a run-time-new name this way: every site that reaches a cell already double-loads, and none of them had to learn a third case. *) | Some sl -> load_int f.b ~dst ~mm:(Sym (sl, 0)) ~size:8 ~signed:false; load_int f.b ~dst ~mm:(Reg (dst, 0)) ~size:8 ~signed:false | None -> 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 data_payload_off f (u : Tast.data) = 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 data type 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.datas sn with | Some (u : Tast.data) -> [ 0; data_payload_off f u ] | None -> (* And a union is a struct at this level too, with the one difference that makes it a union: every member starts where the union starts, so the offsets are zeros and the member's own type is what the load or the store reads the bytes as. One list per member and not a single zero, because the caller indexes it by member. *) match Hashtbl.find_opt f.md.Emit.unions sn with | Some (u : Tast.structure) -> List.map (fun _ -> 0) u.Tast.fields | None -> unsupported "no struct %s" sn) (* A data type 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 data type whose cases are all payload-less is a bare tag and has no second field. *) let data_of f n = match Hashtbl.find_opt f.md.Emit.datas n with | Some u -> u | None -> unsupported "no data type %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 = note f "The transfer guard, after every call to Flan code: load this frame's channel, load \ through it, test, and branch if it is set — a callee that transferred left a \ target there and the value in rax means nothing."; 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 _ -> [ 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 if not f.ann then lower_at f e dst else begin (* The second hook, and it hangs off the same recursion for the same reason: a heading queued here spans exactly the bytes this form and everything inside it emit, so the listing nests the way the source does. Withdrawn again if the form emitted nothing — a [defer] that is hoisted, a [Unit] in statement position — because a heading left standing would be read as belonging to whatever came next. *) let prev = f.alast in (* Captured before [annot], which moves the margin as a side effect of queueing a heading: restoring what it moved is the point. *) let d = f.adepth and ind = f.b.ind in let s = annot f e in f.adepth <- d + 1; lower_at f e dst; f.adepth <- d; set_ind f.b ind; match s with | Some s -> if not (unannote f.b s) then f.alast <- prev | None -> () end 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 — docs/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 (dname, case, fields) -> let u = data_of f dname in let i, c = match Tast.case_index u case with | Some (i, c) -> i, c | None -> unsupported "no case %s of %s" case dname 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 = data_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 data type 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 dname = match target.Tast.ty with | Types.Named n -> n | ty -> unsupported "case field of %s" (Types.to_string ty) in let u = data_of f dname in let c = match Tast.case_index u case with | Some (_, c) -> c | None -> unsupported "no case %s of %s" case dname in shift (lvalue f target) (data_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 data type 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.datas n -> let u = data_of f n in let poff = data_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 data type. *) 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) = note f (Printf.sprintf "Out of bounds: the location string, the operands, and this frame's channel, \ then %s, which signals" sym); 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; note f "ud2, where emit.ml writes unreachable. Nothing answered the signal, so the runtime \ already died inside that call and nothing falls through to here."; 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 () -> note f "The bounds check. One unsigned compare catches a negative index as well as an \ oversized one, and the not-taken branch is the whole of the fast path."; 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. Two compares, and only one of them is a bounds check. [hi <= len] is the bounds check. It asks whether the caller's range fits inside the thing being sliced, which is a question about a length this backend has to go and load, and [--no-bounds-checks] exists to stop asking it — the release decision, taken by someone who accepts undefined behaviour if their indices are wrong. [lo <= hi] is a different claim and survives the flag. The two words stored at the bottom of this case are a slice, and the second is a *count*: the `sub` in the caller computes hi - lo, and everything downstream — the len primitive, a re-slice, flan_write_stdout, any C this is handed to — reads it as a non-negative number of elements. A reversed range does not build an out-of-range slice, it builds a value that is not a slice: (slice s 2 1) stores -1, and -1 read as a count is 18446744073709551615. There is no build in which that is the intended behaviour, so there is no flag that turns the compare off. flan_vec_as_slice validates its own [l > h] unconditionally in plain C and always has; this is the same rule, arriving late on the emitted path. Hence the shape below. All three frame temporaries are stored before either compare and outside the flag, because [bounds_call] reads all three and the third is the length the message prints — gate the store along with the compare and an unchecked build traps with the right range beside a garbage length, which is a wrong answer that builds, links and passes every test that reads the IR rather than the text. *) and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr) (llo : loc) (hi : Tast.expr) (lhi : loc) = 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" in cmp_rr f.b ~a:rax ~c:rdx; if f.md.Emit.checks then begin let bad = new_label f "oob" in 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 end else jcc_lbl f.b ~cc:cc_be ok; 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 docs/handoffs/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 docs/handoffs/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 () -> note f (Printf.sprintf "The arithmetic guard: %s%s%s, and the failure path signals through \ flan_arith_fail" (if need_zero then "a zero divisor" else "") (if need_zero && need_ovf then " and " else "") (if need_ovf then "the one overflowing division" else "")); 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 note f "The range check on a float-to-integer cast. Two compares, written in the \ directions that make a NaN fail both of them."; 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 -> note f "The indirection cell. A dev build calls through it rather than to the symbol, so \ that a redefinition installed while the process runs is reached by the next \ call."; 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 (docs/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 and a Map 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 _ -> 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] or an [Alloc]. - [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 language masks a computed count to the operand's width minus one and says so out loud (NEXT.md's sharp edges); [emit] writes that mask into the IR at 2041. The hardware would do it too if the shift were the operand's width, but [shift_cl] is 64 bits wide whatever the type says, so what the silicon masks to is 63 and not 31, 15 or 7. Without the [and] a count of 32 on an i32 shifts the sign-extended value out of the low half and stores zero, where the rule — and LLVM — say the count is 0 and the value comes back unchanged. One extra [and] on the count register buys the agreement; 64-bit shifts skip it because there the hardware's mask is already the rule's. A literal out of range never reaches here: [check] rejects it as a typo. *) | Tast.Shl | Tast.Shr -> (match t with | Types.Int k when Types.bits k < 64 -> and_imm f.b ~dst:rcx (Types.bits k - 1) | _ -> ()); (match p with | Tast.Shl -> shl_cl f.b ~dst:rax | _ -> 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. It is not behind [f.md.Emit.checks], and the reason is the one [check_slice] above spells out at length. [--no-bounds-checks] drops a comparison against a known length; this comparison has no length to be against — the paragraph above says as much — so the flag has nothing here to drop. The word being stored into the second half of [dst] is the slice's count, and a count that is negative is not a slice with the bounds check taken off, it is not a slice. So the test runs in every build, exactly as [lo <= hi] does. *) | Tast.SliceFromPtr, [ p; n ] -> let lp = eval f p in let ln = eval f n in 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 (* [b] is the caller's buffer, a frame slot the checker gave this call site. See check.ml's [to_bytes]: a backend temporary here would be reclaimed at the end of this expression and the slice outlives it. *) | Tast.I64ToBytes, [ a; b ] -> shim_out f "flan_i64_to_bytes" a b dst | Tast.U64ToBytes, [ a; b ] -> shim_out f "flan_u64_to_bytes" a b dst | Tast.F64ToBytes, [ a; b ] -> shim_out f "flan_f64_to_bytes" a b 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] and [_map] 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, uint8_t *buf, flan_slice *out)] — a scalar in, text rendered into the caller's buffer, and a slice over it written through a hidden out pointer. The three number printers, and nothing else. Both operands are evaluated before any argument register is loaded: evaluating one is arbitrary code and would otherwise overwrite the other. *) and shim_out f sym (a : Tast.expr) (buf : Tast.expr) dst = let l = eval f a in let lb = eval f buf 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); load_loc f ~reg:rdi lb buf.Tast.ty; addr_into f ~reg:rsi dst; imm_into f ~reg:rax 1L end else begin load_loc f ~reg:rdi l a.Tast.ty; load_loc f ~reg:rsi lb buf.Tast.ty; addr_into f ~reg:rdx 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 () (* ── The frame map ───────────────────────────────────────────────────── *) (* What a listing out of this backend needs most, and the one thing no amount of disassembly recovers. LLVM's output names its values; this file's names nothing, because every value it has lives in a frame temporary and a temporary has no name to print. So the key goes above the function: which displacement is which parameter, which is which named local, where the compiler's own three live, and where the nameless temporaries begin. Everything here is read out of state [emit_fn] already keeps. Nothing is recomputed and nothing is guessed, which is why this cannot drift from the code it describes: [f.slots] *is* what the prologue stores through. The one thing deliberately not described is any individual temporary. [scoped] reclaims them and a later statement reuses the bytes, so naming an offset that holds something else half the time is worse than saying where the region starts — which is the same call the DWARF above makes about locals, and for the same reason. *) let where_from = function | Ireg r -> Printf.sprintf "from %s" (regname r) | Isse i -> Printf.sprintf "from xmm%d" i | Istk d -> Printf.sprintf "from the caller's stack, at rbp+0x%x" d let frame_map (md : Emit.m) (fn : Tast.fn) ~slots ~fixed ~total ~outgoing ~xfer_off ~sret_off ~retval ~sret ~sret_at ~param_at ~xfer_at = let b = Buffer.create 1024 in let line s = Buffer.add_string b (if s = "" then "#\n" else "# " ^ s ^ "\n") in (* The prose paragraphs wrap; the table below does not, because its columns are the point of it. *) let para s = List.iter (fun l -> Buffer.add_string b (l ^ "\n")) (wrap ~pre:"# " ~width:76 s) in let bar = "# " ^ String.concat "" (List.init 68 (fun _ -> "\xe2\x94\x80")) in Buffer.add_string b (bar ^ "\n"); (* The [defn] as it was written, which is the whole line and not the span: [floc] points at the name, and a reader wants the parameter list too. A function the checker lifted out of a [handler-bind] clause has no line of its own to show and says so. *) let decl = match Loc.source_line fn.Tast.floc with | Some l -> Some (String.trim l) | None -> None in line (Printf.sprintf "%s%s" (fsym fn.Tast.name) (match decl with | Some d when String.length d > 0 -> Printf.sprintf " %s %s" (if String.length d > 56 then String.sub d 0 55 ^ "…" else d) (Loc.to_string fn.Tast.floc) | _ -> (match fn.Tast.fparent with | Some parent -> Printf.sprintf " a clause lifted out of %s, which no one wrote as a \ function" parent | None -> " " ^ Loc.to_string fn.Tast.floc))); (* A function out of the prelude, or out of any file this process cannot open again, gets a frame map and no form headings at all: [Loc.snippet] has nothing to quote and says so rather than printing a column of bare positions. Worth saying once per function, because the absence is otherwise read as a bug in the annotation. *) if decl = None then para "The source this was compiled from is not readable from here, so the \ byte runs below carry no form headings — only this map."; line ""; (* The convention, stated where the function is rather than only in this file's header, because the header is not what a reader of a listing has in front of them. *) let nparams = List.length fn.Tast.params in let args = List.mapi (fun i at -> let nm = match fn.Tast.snames.(i) with Some n -> n | None -> "_" in Printf.sprintf "%s %s" nm (where_from at)) param_at in para (if nparams = 0 then "Takes nothing." else "Arguments: " ^ String.concat ", " args ^ "."); (match sret_at with | Some at -> para (Printf.sprintf "The result is an aggregate, so it comes back through a hidden sret pointer \ the caller allocated (%s) and hands that same pointer back in rax. Every \ aggregate goes by pointer here; nothing is classified and there is no \ eightbyte rule." (where_from at)) | None -> if is_void fn.Tast.ret then line "Returns nothing." else line (Printf.sprintf "Returns %s in %s." (Types.to_string fn.Tast.ret) (if is_float fn.Tast.ret then "xmm0" else "rax"))); para (Printf.sprintf "The transfer channel arrives last of all, %s. It is a pointer to the cell a \ callee writes its target into, and reading it is what every guard below \ does." (where_from xfer_at)); line ""; para (Printf.sprintf "The frame is 0x%x bytes below rbp. %s" total (if outgoing > 0 then Printf.sprintf "The lowest 0x%x of them are the outgoing argument area, reserved once \ here and written by whichever call in this function passes the most on \ the stack." outgoing else "No call in it passes an argument on the stack.")); line ""; let row off name ty what = line (Printf.sprintf " %-8s %-14s %-10s %s" (Printf.sprintf "-0x%x" (-off)) name ty what) in Array.iteri (fun i ty -> if not (is_void ty) then begin let name = match fn.Tast.snames.(i) with Some n -> n | None -> "" in let what = if i < nparams then Printf.sprintf "parameter %d, %s" (i + 1) (where_from (List.nth param_at i)) else if fn.Tast.snames.(i) = None then "a slot the compiler made, not one anyone named" else "a local" in let what = if is_agg ty then what ^ Printf.sprintf " — %d bytes, copied in" (sizeof md ty) else what in row slots.(i) name (Types.to_string ty) what end) fn.Tast.slots; row xfer_off "" "ptr" "the transfer channel this frame passes on"; if sret then row sret_off "" "ptr" "the caller's sret pointer, kept for the epilogue"; if (not sret) && not (is_void fn.Tast.ret) then row retval "" (Types.to_string fn.Tast.ret) "the return value the epilogue loads"; para (Printf.sprintf "Everything below -0x%x is a temporary. They are bump-allocated and reclaimed \ at the end of the form that made them, so a later form reuses the bytes and \ no one offset down there means one thing for long." fixed); Buffer.add_string b (bar ^ "\n"); Buffer.contents b let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) ?(slot = fun _ -> None) ?(hidden = false) ?(ann = 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; slot; dw; ann; adepth = 0; alast = "" } 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"; (* Where the named part of the frame ends and the nameless part begins. Read here rather than from [maxframe] afterwards, because [maxframe] is the high-water mark of the temporaries and this is the boundary below which they start. It is the frame map's last line. *) let fixed = f.frame in 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; if ann then set_ind f.b ""; note f "The transfer exit — spec-conditions.md §5. A transfer that found no restart-case \ in this frame leaves the way a return does, which is what runs the defers."; 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 bnote ann pb "The prologue: save rbp, take the frame in one sub, and spill every incoming \ register into its slot. rsp is written here and by leave and nowhere else, so rsp \ % 16 == 0 at every call site below is a property of that one rounded sub rather \ than an invariant each case has to keep."; 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. *) if ann then set_ind f.b ""; note f "The epilogue, and every return and every transfer out of this frame arrives here, \ so the frame is torn down once."; 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 if ann then Buffer.add_string out (frame_map md fn ~slots:f.slots ~fixed ~total:(frame_bytes f) ~outgoing:f.outgoing ~xfer_off:f.xfer_off ~sret_off:f.sret_off ~retval:f.retval ~sret ~sret_at ~param_at ~xfer_at); 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) ?(ann = false) (md : Emit.m) (fn : Tast.fn) = let b = create () in bnote ann b "C's main, which is the whole of the adapter between the loader and a Flan program. \ 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, so flan.main is called exactly the way every other Flan function \ is; and the exit goes through flan_exit rather than ret, because stdout is a FILE* \ and something has to flush it. The ud2 at the end is unreachable — flan_exit does \ not return."; 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) ?(ann = 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); slot = (fun _ -> None); dw = None; ann; adepth = 0; alast = "" } 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) ?(annotate = 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"; (* The legend, and the reason it is here rather than repeated: four of the five things below are emitted at hundreds of sites, and a comment that explains the transfer guard at every call site is noise by the third one. Each is named where it appears and explained once, here. *) if annotate then Buffer.add_string text "#\n\ # Annotated, because `flan emit --x86` exists to be read. Every comment\n\ # here is discarded by the assembler; the bytes are what a build emits,\n\ # unchanged and in the same order.\n\ #\n\ # How to read it\n\ #\n\ # Above each function is a frame map. Every value in this backend\n\ # lives in a frame slot, so -0x20(%rbp) is the whole vocabulary of the\n\ # listing and the map is its key: which displacement is which\n\ # parameter, which is which named local, where the compiler's own\n\ # three sit, and below which offset everything is an unnamed\n\ # temporary that later forms reuse.\n\ #\n\ # Inside a function, each run of bytes is headed by the Flan form that\n\ # produced it, with the file:line:col it was written at. Headings and\n\ # byte runs are indented by how deeply the form nests, so an\n\ # argument's code steps in and the call's steps back out.\n\ #\n\ # Literals, locals and globals are not headed: they would steal the\n\ # heading of the form that contains them, and the operand loads\n\ # belong under the operator.\n\ #\n\ # The five things the compiler adds that no form asked for\n\ #\n\ # The transfer guard. After every call to Flan code: load this\n\ # frame's channel pointer, load through it, test, and branch if it is\n\ # set. A callee that transferred wrote a frame address there and the\n\ # value in rax means nothing, so the branch goes to the innermost\n\ # restart-case, handler-bind or with-allocator landing pad, or to the\n\ # function's own transfer exit. Four instructions, touching only r11,\n\ # which is why it fits between the call and the store of the result.\n\ # spec-conditions.md §6.\n\ #\n\ # The bounds check. A compare and a not-taken branch on the fast\n\ # path; the slow path passes a location string, the index and the\n\ # length, and this frame's channel, to a runtime entry point that\n\ # signals. Because it signals rather than aborting, it is an ordinary\n\ # call with a guard after it, and the ud2 past the guard is where\n\ # nothing answered.\n\ #\n\ # The arithmetic guard, the same shape: a zero divisor, the one\n\ # overflowing division, and the range check on a float-to-integer\n\ # cast.\n\ #\n\ # rep movsb. An aggregate is copied and never aliased, so a struct\n\ # argument, a struct return and a struct assignment are each a block\n\ # copy. spec-memory.md's assignment rule.\n\ #\n\ # The indirection cell, in a --dev build only. A call by name loads\n\ # the cell first and calls through it, so that a redefinition\n\ # installed while the process runs is reached by the next call.\n\ #\n\ # What is not here are mnemonics. The bytes are a blob so that every\n\ # offset stays exactly known, and spike/x86/dump.sh puts objdump's\n\ # disassembly of this same object beside this file: that one says what,\n\ # and this one says why.\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 ~ann:annotate ?dw fn in Buffer.add_string text t; Buffer.add_string rodata r) p.Tast.fns; let ginit, gr = emit_globals_init ~cfi:debug ~ann:annotate 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 ~ann:annotate 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 A name the host was never built with.} There is no symbol to bind to and ELF has no way to grow one, so the address is asked for by string at install time -- [flan_dev_cell] for a function's cell, [flan_dev_global] for a global's storage -- and parked in a slot this module defines. [Lslot] is how every later reference reads it, and it is [Lgot]'s shape with the relocation swapped, so no call site and no place expression had to learn a third case. [Emit.cellptr] and [Emit.globalptr] are the same two slots on the LLVM side, spelled the same way here so the two are readable against each other. A new global's declared initial value travels with it, because [flan_dev_global] copies it onto the allocation the first time the name is seen and ignores it afterwards -- which is where "a reload must not reset the program's state" lives. [emit.ml] folds that value into an LLVM constant; it has a folder for the IR's own syntax and this file does not. So the image is built the way [emit_globals_init] builds a global's storage in a whole program: a module-local buffer, written by the initialiser expression lowered as ordinary code. A few instructions once, and no second evaluator that could disagree with the first about what a struct literal means. {b The scope, and it is still narrower than [Emit.redefinition]'s.} The transient [flan_reload_call] thunk is not built here, and is refused by name -- this file's idiom for a case it has not earned the right to compile. *) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) ?(retains = 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"; (* A thunk this module runs itself is excluded from all of the machinery below: [flan_reload_call] calls it directly, so it needs no cell, must not be published into one, and must not take a registry slot -- there are 4096 of those and an expression evaluated in a loop would exhaust them. Nothing pointing into the module is also what lets the agent unload it. *) let transient n = call = Some n in 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 (* The names this module introduces, each of which gets a slot below. A function's slot holds its cell's address and a global's holds its storage's, so the two are the same eight bytes and differ only in what fills them. *) let new_fns = List.filter (fun (f : Tast.fn) -> (not (known f.Tast.name)) && not (transient f.Tast.name)) siblings and new_globals = List.filter (fun (g : Tast.global) -> not (known g.Tast.gname)) p.Tast.globals in 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 (* And the third answer: a name that is nobody's symbol yet. Keyed by the spelling the reference uses -- a function is reached through its cell, so the key is [csym]; a global is reached by its own name, so it is [gsym]. The two can never collide, because a function and a global cannot share a name and [gsym] and [fsym] are the same string. *) let cellp n = asm_sym ("flan.cellp." ^ n) and gp n = asm_sym ("flan.gp." ^ n) in let slots = Hashtbl.create 8 in List.iter (fun (f : Tast.fn) -> Hashtbl.replace slots (csym f.Tast.name) (cellp f.Tast.name)) new_fns; List.iter (fun (g : Tast.global) -> Hashtbl.replace slots (gsym g.Tast.gname) (gp g.Tast.gname)) new_globals; let slot s = Hashtbl.find_opt slots 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 ~slot ~hidden:true f in Buffer.add_string text t; Buffer.add_string rodata r) (lifted @ targets); (* [flan_reload_install] is a function with a frame, not a run of loads and stores, and it has to be: it calls into the runtime, and a [call] made on an unaligned stack faults inside glibc's own [movaps] rather than anywhere a reader would look. A prologue is what makes rsp 16-aligned at every call below, since [frame_bytes] rounds. Its shape is [emit_globals_init]'s and for the same reasons, down to owning a null transfer cell that no caller hands it. *) let ib = create () in let f = { b = ib; md; fnname = ""; retlbl = new_label () "install"; 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 256; externs; fns = fnstbl; ext; slot; dw = None; ann = false; adepth = 0; alast = "" } in let chan = ptmp f in f.xfer_off <- ptmp f; f.xfer_lbl <- new_label f "ixfer"; (* A new global's initial value, written into a buffer of this module's own. [flan_dev_global] copies it the first time the name is interned and ignores it on every call after, so a second module mentioning the same name cannot reset the state the reload exists to preserve. Doing it before any lookup is deliberate: nothing outside this module can see these buffers, so they are not a publication and the order below is still "resolve everything, then publish". *) let images = List.map (fun (g : Tast.global) -> let size, align = Emit.lay md g.Tast.gty in let l = rodata_label f in scoped f (fun () -> lower f g.Tast.ginit (Lg (l, 0))); (g, l, max 1 size, max 1 align)) new_globals in (* The lookups, all of them, before a single body is published. Publishing first would expose a function whose slots are still null to anything that called it, and here that means every call site in the host. [emit.ml] says the same and [test_reload.ml] checks it there by grepping the IR text; there is no text to grep on this side, so the guarantee is this loop order and this comment. *) let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in List.iter (fun (fn : Tast.fn) -> cstr ("flan." ^ fn.Tast.name); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_dev_cell"; store_int f.b ~src:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8) new_fns; List.iter (fun ((g : Tast.global), l, size, _) -> cstr ("flan." ^ g.Tast.gname); movabs f.b ~dst:rsi (Int64.of_int size); lea f.b ~dst:rdx ~mm:(Sym (l, 0)); xor_rr f.b ~dst:rax ~src:rax; call_sym f.b "flan_dev_global"; store_int f.b ~src:rax ~mm:(Sym (gp g.Tast.gname, 0)) ~size:8) images; (* A [defconst] whose value the checker never folded is just bytes in the program's memory, so a new value is published the same way a new body is: one store, at the frame boundary the agent chose. One the checker did fold is in the shape of the program and never gets here -- the session refuses it before it asks for a module. *) List.iter (fun (g : Tast.global) -> if List.exists (String.equal g.Tast.gname) consts then scoped f (fun () -> lower f g.Tast.ginit (sym_loc f (gsym g.Tast.gname)))) p.Tast.globals; (* And now the bodies. A name the host has is published into its cell, whose address comes out of the GOT because the cell lives in the host; a name it does not is published through the slot the lookup above filled. Either way the body is this module's own and hidden, so its address is an ordinary pc-relative [lea]. *) List.iter (fun (fn : Tast.fn) -> if transient fn.Tast.name then () else begin if known fn.Tast.name then load_int f.b ~dst:rax ~mm:(Got (csym fn.Tast.name)) ~size:8 ~signed:false else load_int f.b ~dst:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8 ~signed:false; lea f.b ~dst:r11 ~mm:(Sym (fsym fn.Tast.name, 0)); store_int f.b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8 end) targets; (* Nothing a constant initialiser can do transfers, so this exit is unreachable and is emitted only when something claims to aim at 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; mov_rr pb ~dst:rbp ~src:rsp; let n = frame_bytes f in if n > 0 then sub_imm pb ~dst:rsp n; xor_rr pb ~dst:rax ~src:rax; store_int pb ~src:rax ~mm:(Frame chan) ~size:8; lea pb ~dst:rax ~mm:(Frame chan); store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8; lbl f.b f.retlbl; leave f.b; ret f.b; flush pb; flush f.b; 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 pb.out; Buffer.add_buffer text f.b.out; Buffer.add_string text "\t.size\tflan_reload_install, . - flan_reload_install\n\n"; (* An expression evaluation compiles to a function with nowhere to be called from, so the module says so and the agent runs it once -- after the install, on the game thread, so it sees both the bodies this module just published and a program state the program agrees is consistent. The thunk takes no parameter but the transfer channel, and no caller hands this wrapper one, so it owns a null cell on its own frame exactly as [emit_main] does. Sixteen bytes rather than eight keeps rsp 16-aligned at the call, which is the whole of what the ABI asks of a frame that makes one. *) (match call with | None -> () | Some fn -> let cb = create () in push_r cb rbp; mov_rr cb ~dst:rbp ~src:rsp; sub_imm cb ~dst:rsp 16; xor_rr cb ~dst:rax ~src:rax; store_int cb ~src:rax ~mm:(Frame (-8)) ~size:8; lea cb ~dst:rdi ~mm:(Frame (-8)); xor_rr cb ~dst:rax ~src:rax; call_sym cb (fsym fn); leave cb; ret cb; flush cb; Buffer.add_string text "\t.globl\tflan_reload_call\n\ \t.type\tflan_reload_call, @function\n\ flan_reload_call:\n"; Buffer.add_buffer text cb.out; Buffer.add_string text "\t.size\tflan_reload_call, . - flan_reload_call\n\n"); Buffer.add_buffer rodata f.rodata; let out = Buffer.create 8192 in Buffer.add_buffer out text; (* The slots, and the buffers holding a new global's initial value. Both are this module's own and neither is [.globl]: a second module introducing the same name gets its own slot and fills it from the registry with the same answer, which is exactly what makes two modules agree about a name that has no symbol. [.bss], because every one of them is written before it is read -- the slots by the lookups above, the images by the initialisers. *) if new_fns <> [] || new_globals <> [] then begin Buffer.add_string out "\n\t.bss\n"; List.iter (fun (fn : Tast.fn) -> Buffer.add_string out (Printf.sprintf "\t.align\t8\n\t.type\t%s, @object\n\ \t.size\t%s, 8\n%s:\n\t.zero\t8\n" (cellp fn.Tast.name) (cellp fn.Tast.name) (cellp fn.Tast.name))) new_fns; List.iter (fun ((g : Tast.global), l, size, align) -> let s = gp g.Tast.gname in Buffer.add_string out (Printf.sprintf "\t.align\t8\n\t.type\t%s, @object\n\ \t.size\t%s, 8\n%s:\n\t.zero\t8\n\ \t.align\t%d\n%s:\n\t.zero\t%d\n" s s s align l size)) images end; (* 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)); (* Nothing outside this module refers to anything in it once the call has returned -- no cell holds an address in its text, the registry has no slot for it, and the value it produced was copied out. So it says so, and the agent [dlclose]s it. A module that publishes a body can never say this: its whole purpose is to leave a pointer behind. [nstr = 0] is the third condition and it is about data, not text. A string literal is emitted into this module's own image, and an expression may store one anywhere it likes -- [(set msg "tuned")] on a string global leaves that global pointing into the mapping the agent is about to drop. The next thunk can be mapped at the same address, so the result is silent garbage rather than a fault. A module with no string constants has nothing in its image anyone could still be pointing at; one with any keeps its mapping, which costs a page and is the same bargain every redefinition already makes. [string_const] is where the count is kept, and the install function's own registry names go through it too -- which is right rather than incidental, since a module that interned a name left something behind. *) (match call with | Some fn when fns = [ fn ] && consts = [] && ((not retains) || md.Emit.nstr = 0) -> Buffer.add_string out "\n\t.data\n\t.globl\tflan_reload_transient\n\ \t.type\tflan_reload_transient, @object\n\ \t.size\tflan_reload_transient, 1\n\ flan_reload_transient:\n\t.byte\t1\n" | _ -> ()); 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