From 0fbca40446bda4b5f13055aee09d227dd94a1eaf Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 09:12:55 +0700 Subject: [PATCH] One function goes from Tast to machine code and answers correctly x86.ml is an instruction selector for the part of Tast that fits in one integer register: literals, slots, let, if, arithmetic, comparison, and a call. Everything else raises with the node that defeated it, because an honest refusal is the measurement and a silently wrong answer would waste the exercise. The frontend is the real one -- Reader, Parse, Load, Check -- so what is lowered is the same Tast.fn the LLVM backend gets. Seven arithmetic results are compared against what the language says they should be; the disassembly proves nothing and is not the evidence. Nothing is wired into the build. No dune file under spike/, driven by hand with ocamlfind and clang as spike/embed already does. --- spike/backend/driver.ml | 124 +++++++++++++ spike/backend/jit_stubs.c | 105 +++++++++++ spike/backend/probe.flan | 24 +++ spike/backend/run.sh | 38 ++++ spike/backend/x86.ml | 363 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 654 insertions(+) create mode 100644 spike/backend/driver.ml create mode 100644 spike/backend/jit_stubs.c create mode 100644 spike/backend/probe.flan create mode 100644 spike/backend/run.sh create mode 100644 spike/backend/x86.ml diff --git a/spike/backend/driver.ml b/spike/backend/driver.ml new file mode 100644 index 0000000..355a748 --- /dev/null +++ b/spike/backend/driver.ml @@ -0,0 +1,124 @@ +(* The spike's harness: run the real frontend, lower the functions it produced + with [X86], put the bytes in executable memory, call them, and compare with + what the language says they should answer. + + The comparison is the whole point. Reading the bytes proves nothing -- a + disassembly that looks right and a program that returns the wrong number is + the normal outcome of hand-encoding, which is why the oracle here is the + arithmetic and not objdump. [oracle.sh] disassembles the same buffer, and + that is a debugging aid, not the evidence. *) + +external jit_alloc : int -> nativeint = "spike_jit_alloc" +external jit_write : nativeint -> string -> unit = "spike_jit_write" +external jit_protect : nativeint -> int -> unit = "spike_jit_protect" +external call1 : nativeint -> int64 -> int64 = "spike_call1" +external call2 : nativeint -> int64 -> int64 -> int64 = "spike_call2" +external sym : string -> nativeint = "spike_sym" + +let failures = ref 0 +let checks = ref 0 + +let check name got want = + incr checks; + if got = want then Printf.printf " ok %-28s = %Ld\n" name got + else begin + incr failures; + Printf.printf " FAIL %-28s = %Ld, want %Ld\n" name got want + end + +(* One page per function, so that a function that runs off its own end lands in + an unmapped page and segfaults at the fault rather than in the middle of the + next function. This is the crudest possible version of the code-object + question the whole exercise is really about. *) +let page = 4096 + +let install (code : string) : nativeint = + if String.length code > page then failwith "function exceeds one page"; + let p = jit_alloc page in + jit_write p code; + jit_protect p page; + p + +let run src = + let decls = + Flan.Load.program ~file:src (Flan.Parse.program_all (Flan.Reader.read_file src)) + in + let prog = Flan.Check.program_all decls.Flan.Load.decls in + Printf.printf "frontend: %d fns, %d globals, %d structs, %d externs\n" + (List.length prog.Flan.Tast.fns) (List.length prog.Flan.Tast.globals) + (List.length prog.Flan.Tast.structs) (List.length prog.Flan.Tast.externs); + + (* Two passes, because [spike-calls] calls functions whose addresses are not + known until they are installed. Pass one installs every function at a + fixed page; pass two emits the real code into it. A real backend does this + with relocations; the spike does it by emitting twice, which is the same + answer with none of the machinery. *) + let addrs : (string, nativeint) Hashtbl.t = Hashtbl.create 16 in + let unsupported = ref [] in + let lowerable = + List.filter + (fun (fd : Flan.Tast.fn) -> + try + ignore (X86.fn ~resolve:(fun _ -> 0L) fd); + true + with X86.Unsupported m -> + unsupported := (fd.Flan.Tast.name, m) :: !unsupported; + false) + prog.Flan.Tast.fns + in + List.iter + (fun (fd : Flan.Tast.fn) -> + Hashtbl.replace addrs fd.Flan.Tast.name (jit_alloc page)) + lowerable; + let resolve name = + match Hashtbl.find_opt addrs name with + | Some p -> Int64.of_nativeint p + | None -> + (* Not a Flan function: a runtime entry point, looked up the way a dev + build already reaches the host's symbols -- through the dynamic symbol + table, which --dev links with -rdynamic. *) + Int64.of_nativeint (sym name) + in + let bytes = Hashtbl.create 16 in + List.iter + (fun (fd : Flan.Tast.fn) -> + let code = X86.fn ~resolve fd in + Hashtbl.replace bytes fd.Flan.Tast.name code; + let p = Hashtbl.find addrs fd.Flan.Tast.name in + jit_write p code; + jit_protect p page) + lowerable; + + Printf.printf "lowered: %d of %d functions\n" + (List.length lowerable) (List.length prog.Flan.Tast.fns); + List.iter (fun (n, m) -> Printf.printf " skipped %-20s %s\n" n m) + (List.rev !unsupported); + Hashtbl.iter (fun n c -> Printf.printf " %-20s %4d bytes at %nx\n" + n (String.length c) (Hashtbl.find addrs n)) bytes; + + (* Dumped so oracle.sh can disassemble exactly the bytes that ran. *) + (try + let oc = open_out_bin (Filename.concat (Filename.dirname Sys.argv.(0)) "spike-add.bin") in + output_string oc (Hashtbl.find bytes "spike-add"); + close_out oc + with Not_found -> ()); + + print_endline "results:"; + let at n = Hashtbl.find addrs n in + check "spike-add 3 4" (call2 (at "spike-add") 3L 4L) 7L; + check "spike-add -5 2" (call2 (at "spike-add") (-5L) 2L) (-3L); + check "spike-arith 10 4" (call2 (at "spike-arith") 10L 4L) 19L; + check "spike-let 6" (call1 (at "spike-let") 6L) 1332L; + check "spike-if 1 2" (call2 (at "spike-if") 1L 2L) 1L; + check "spike-if 9 2" (call2 (at "spike-if") 9L 2L) 7L; + check "spike-calls 5" (call1 (at "spike-calls") 5L) 656L; + + Printf.printf "\n%d checks, %d failures\n" !checks !failures; + exit (if !failures = 0 then 0 else 1) + +(* The frontend's diagnostics printed rather than swallowed: a spike that says + [Fatal error: exception Errors(_)] costs an hour. *) +let () = + try run Sys.argv.(1) with + | Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 2 + | Flan.Loc.Errors ds -> prerr_endline (Flan.Loc.report_all ds); exit 2 diff --git a/spike/backend/jit_stubs.c b/spike/backend/jit_stubs.c new file mode 100644 index 0000000..76395b0 --- /dev/null +++ b/spike/backend/jit_stubs.c @@ -0,0 +1,105 @@ +/* The three things OCaml cannot do for itself: get executable memory, put + * bytes in it, and jump to them. Everything interesting is in x86.ml; this + * file is deliberately dumb. + * + * Shaped after lib/dynload_stubs.c's rule, which spike/embed took verbatim for + * the same reason: the boundary passes pointers and scalars, never an OCaml + * [value] into foreign storage. Nothing here keeps anything. + * + * RW then mprotect to R+X, never RWX in one mmap: a hardened kernel may refuse + * a writable-executable anonymous mapping outright, and a policy denial that + * comes back as a null pointer reads exactly like an encoding bug. */ + +#include +#include +#include +#include + +#include +#include +#include +#include +#include + +value spike_jit_alloc(value vlen) { + size_t len = (size_t)Long_val(vlen); + void *p = mmap(NULL, len, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (p == MAP_FAILED) caml_failwith("spike_jit_alloc: mmap failed"); + return caml_copy_nativeint((intnat)p); +} + +value spike_jit_write(value vp, value vbytes) { + char *p = (char *)Nativeint_val(vp); + memcpy(p, String_val(vbytes), caml_string_length(vbytes)); + return Val_unit; +} + +value spike_jit_protect(value vp, value vlen) { + void *p = (void *)Nativeint_val(vp); + if (mprotect(p, (size_t)Long_val(vlen), PROT_READ | PROT_EXEC) != 0) + caml_failwith("spike_jit_protect: mprotect failed"); + return Val_unit; +} + +/* Every Flan function's emitted signature is its parameters followed by the + * transfer channel (emit.ml, [signature]), so the trampolines below all pass a + * trailing pointer. Nothing in the spike transfers, so it is NULL. */ +typedef int64_t (*fn0)(void *); +typedef int64_t (*fn1)(int64_t, void *); +typedef int64_t (*fn2)(int64_t, int64_t, void *); + +value spike_call0(value vp) { + return caml_copy_int64(((fn0)Nativeint_val(vp))(NULL)); +} +value spike_call1(value vp, value a) { + return caml_copy_int64(((fn1)Nativeint_val(vp))(Int64_val(a), NULL)); +} +value spike_call2(value vp, value a, value b) { + return caml_copy_int64(((fn2)Nativeint_val(vp))(Int64_val(a), Int64_val(b), NULL)); +} + +value spike_sym(value vname) { + void *h = dlsym(RTLD_DEFAULT, String_val(vname)); + if (h == NULL) caml_failwith("spike_sym: not found"); + return caml_copy_nativeint((intnat)h); +} + +/* ── The C side of the ABI probes ──────────────────────────────────── */ + +/* Eight integers: six in registers, two on the stack, which is the case a + * register-only convention silently gets wrong. The answer is positional so a + * swapped pair cannot pass. */ +int64_t spike_probe8(int64_t a, int64_t b, int64_t c, int64_t d, + int64_t e, int64_t f, int64_t g, int64_t h) { + return a * 1 + b * 10 + c * 100 + d * 1000 + e * 10000 + f * 100000 + + g * 1000000 + h * 10000000; +} + +/* The alignment check, and it has to be done with an aligned load rather than + * by reading rsp, because that is how raylib finds out: the SysV ABI promises + * rsp % 16 == 0 at the call instruction, so on entry rsp+8 is aligned, and a + * callee that spills an __m128 to its frame faults when it is not. -O2 is what + * turns this into an actual movaps; without it the bug hides. */ +__attribute__((noinline)) +int64_t spike_probe_align(int64_t x) { + volatile double v[2] __attribute__((aligned(16))) = { 1.0, 2.0 }; + /* Reading rsp as well, so a failure says which of the two it was. */ + uintptr_t sp; + __asm__ volatile ("mov %%rsp, %0" : "=r"(sp)); + if ((sp % 16) != 8) return -1; /* entry rsp is call-site rsp minus 8 */ + return x + (int64_t)(v[0] + v[1]); +} + +/* A double in xmm0 alongside integers, and al = number of vector registers + * used is *not* required here because this is not variadic -- which is itself + * the thing to record. */ +double spike_probe_f(int64_t a, double x, int64_t b, double y) { + return (double)a + x * 2.0 + (double)b * 100.0 + y * 200.0; +} + +/* A small struct by value. BUILT.md's "Why the FFI goes through a C shim" + * says Flan never emits one of these -- the shim flattens it. This is here to + * measure what the shim is saving us from, not because the backend needs it. */ +typedef struct { float x, y; } spike_vec2; +float spike_probe_struct(spike_vec2 v, float s) { return v.x * s + v.y; } diff --git a/spike/backend/probe.flan b/spike/backend/probe.flan new file mode 100644 index 0000000..0fab0e6 --- /dev/null +++ b/spike/backend/probe.flan @@ -0,0 +1,24 @@ +;; The spike's input. Ordinary Flan, run through the ordinary frontend -- +;; Reader, Parse, Load, Check -- so that what the emitter below lowers is the +;; same Tast.fn the LLVM backend gets and not a literal someone typed to make +;; the exercise come out. + +(defn spike-add [a i64 b i64] i64 + (+ a b)) + +(defn spike-arith [a i64 b i64] i64 + (- (* a 3) (+ b 7))) + +(defn spike-let [a i64] i64 + (let [x (* a a) + y (+ x 1)] + (* x y))) + +(defn spike-if [a i64 b i64] i64 + (if (< a b) (- b a) (- a b))) + +(defn spike-calls [a i64] i64 + (spike-add (spike-arith a 2) (spike-let a))) + +(defn main [] i32 + 0) diff --git a/spike/backend/run.sh b/spike/backend/run.sh new file mode 100644 index 0000000..1ed4a01 --- /dev/null +++ b/spike/backend/run.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +# The spike, end to end: the real frontend produces a Tast, x86.ml turns it +# into bytes, the bytes go into an mmap, and the mmap gets called. +# +# Driven by hand with ocamlfind and clang against the flan.cmxa dune already +# builds, exactly as spike/embed does and for the same reason: nothing under +# spike/ is wired into the build, so there is no dune file here and `dune test` +# cannot see any of it. +set -u +here=$(cd "$(dirname "$0")" && pwd) +root=$(cd "$here/../.." && pwd) +cd "$root" || exit 1 + +dune build --root . lib/flan.cmxa 2>&1 | head -20 + +out=$(mktemp -d); trap 'rm -rf "$out"' EXIT + +# The C stubs. -O2 on purpose: spike_probe_align's aligned load only becomes a +# real movaps with optimisation on, and an alignment bug that only shows up in +# a release build is the one this is looking for. +clang -O2 -c -I"$(ocamlopt -where)" "$here/jit_stubs.c" -o "$out/jit_stubs.o" || exit 1 + +ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ + -I "$root/_build/default/lib/.flan.objs/byte" \ + -I "$root/_build/default/lib/.flan.objs/native" \ + -I "$out" -I "$here" \ + -o "$out/spike" \ + "$root/_build/default/lib/flan.cmxa" \ + -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ + "$out/jit_stubs.o" \ + "$here/x86.ml" "$here/driver.ml" 2>&1 | head -40 + +test -x "$out/spike" || { echo "build failed"; exit 1; } + +"$out/spike" "$here/probe.flan" +rc=$? +echo "exit: $rc" +exit $rc diff --git a/spike/backend/x86.ml b/spike/backend/x86.ml new file mode 100644 index 0000000..57a78b6 --- /dev/null +++ b/spike/backend/x86.ml @@ -0,0 +1,363 @@ +(* A spike: Tast -> x86-64 machine code, in memory, called. Not a backend. + The point is to find out what breaks, so the subset is deliberately tiny + and every case it cannot do raises with the node that defeated it -- an + honest [Unsupported] is the measurement, and a silently wrong answer is + the one outcome that would waste the exercise. + + Register allocation is the trivial one the brief allows: every slot is a + stack slot at [rbp - 8*(i+1)], every value is computed into rax, and a + binary operator pushes its left operand. Two registers are enough for + everything below and nothing is kept live across a statement. That is what + makes an instruction selector tractable in an afternoon; it is also why the + code it produces is four times the size of clang -O0's. + + Conventions, all of them SysV's, because raylib is called from this code: + - integer arguments in rdi rsi rdx rcx r8 r9, then right-to-left on the + stack; integer result in rax. + - rsp % 16 == 0 at the [call] instruction. raylib spills xmm registers + with movaps and faults far from the cause when this is wrong. + - rbx rbp r12-r15 are callee-saved. This emitter touches none of them + except rbp, which it saves. + - every Flan function takes the transfer channel as a trailing ptr + (emit.ml, [signature]), so a Flan function of n parameters is an n+1 + argument C function. *) + +exception Unsupported of string + +let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt + +(* ── Bytes ───────────────────────────────────────────────────────────── *) + +type buf = { mutable bytes : Buffer.t } + +let create () = { bytes = Buffer.create 256 } +let len b = Buffer.length b.bytes +let contents b = Buffer.contents b.bytes +let u8 b n = Buffer.add_char b.bytes (Char.chr (n land 0xff)) + +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 + +(* ── Registers and modrm ─────────────────────────────────────────────── *) + +(* The encoding order, not the ABI order: this numbering *is* the three bits + the modrm byte wants, which is why rsp is 4 and rbp is 5 rather than + anything more memorable. *) +let rax = 0 and rcx = 1 and rdx = 2 and _rbx = 3 +let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7 +let r8 = 8 and r9 = 9 + +(* REX.W is always set: everything here is 64-bit. R extends the reg field and + B the r/m field, which is the whole of what r8-r15 need. *) +let rex b ~r ~m = u8 b (0x48 lor (if r >= 8 then 4 else 0) lor (if m >= 8 then 1 else 0)) +let modrm b ~md ~r ~m = u8 b ((md lsl 6) lor ((r land 7) lsl 3) lor (m land 7)) + +(* reg, reg *) +let rr b op ~r ~m = rex b ~r ~m; u8 b op; modrm b ~md:3 ~r ~m + +(* reg, [rbp + disp32]. Always disp32 rather than the shorter disp8 form: a + frame can outgrow 128 bytes and a one-byte displacement that silently wraps + is exactly the bug this spike would not find. *) +let rm_rbp b op ~r ~disp = + rex b ~r ~m:rbp; u8 b op; modrm b ~md:2 ~r ~m:rbp; i32 b disp + +let mov_rr b ~dst ~src = rr b 0x89 ~r:src ~m:dst (* mov dst, src *) +let mov_load b ~dst ~disp = rm_rbp b 0x8b ~r:dst ~disp (* mov dst, [rbp+d] *) +let mov_store b ~src ~disp = rm_rbp b 0x89 ~r:src ~disp (* mov [rbp+d], src *) + +let movabs b ~dst (n : int64) = + rex b ~r:0 ~m:dst; u8 b (0xb8 lor (dst land 7)); u64 b n + +let push b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7)) +let pop b r = if r >= 8 then u8 b 0x41; u8 b (0x58 lor (r land 7)) + +let add_rr b ~dst ~src = rr b 0x01 ~r:src ~m:dst +let sub_rr b ~dst ~src = rr b 0x29 ~r:src ~m:dst +let and_rr b ~dst ~src = rr b 0x21 ~r:src ~m:dst +let or_rr b ~dst ~src = rr b 0x09 ~r:src ~m:dst +let xor_rr b ~dst ~src = rr b 0x31 ~r:src ~m:dst +let imul_rr b ~dst ~src = (* 0f af /r *) + rex b ~r:dst ~m:src; u8 b 0x0f; u8 b 0xaf; modrm b ~md:3 ~r:dst ~m:src +let cmp_rr b ~a ~bb = rr b 0x39 ~r:bb ~m:a (* cmp a, b *) + +let add_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:0 ~m:dst; i32 b n +let sub_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:5 ~m:dst; i32 b n + +let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm b ~md:3 ~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 + +(* setcc al, then movzx rax, al -- a compare's result is a bool, which is one + byte in Flan's layout (i1 in LLVM, and the ABI zero-extends it). *) +let setcc b cc = u8 b 0x0f; u8 b (0x90 lor cc); modrm b ~md:3 ~r:0 ~m:rax +let movzx_al b = u8 b 0x48; u8 b 0x0f; u8 b 0xb6; modrm b ~md:3 ~r:rax ~m:rax + +(* jcc rel32 and jmp rel32, patched once the target is known. *) +let jcc b cc = u8 b 0x0f; u8 b (0x80 lor cc); let at = len b in u32 b 0; at +let jmp b = u8 b 0xe9; let at = len b in u32 b 0; at + +let patch b ~at ~target = + let rel = target - (at + 4) in + let s = Buffer.contents b.bytes in + let s = Bytes.of_string s in + for i = 0 to 3 do + Bytes.set s (at + i) (Char.chr ((rel asr (i * 8)) land 0xff)) + done; + let nb = Buffer.create (Bytes.length s) in + Buffer.add_bytes nb s; + b.bytes <- nb + +(* ── Lowering ────────────────────────────────────────────────────────── *) + +type fnctx = { + b : buf; + nslots : int; + (* A symbol the code calls, resolved to an absolute address by the driver + before emission. movabs + call r is what a JIT does anyway: a rel32 call + cannot reach an arbitrary mmap, and the 2-byte indirect call is cheaper + than the relocation machinery a real backend would grow here. *) + resolve : string -> int64; +} + +let slot_disp i = -8 * (i + 1) + +(* Every type this spike handles is one 8-byte integer register. Everything + else is the real backend's problem and is enumerated in the verdict rather + than guessed at here. *) +let word_ty (t : Flan.Types.t) = + match t with + | Flan.Types.Int _ | Flan.Types.Bool | Flan.Types.Ptr _ -> true + | _ -> false + +let check_word what (t : Flan.Types.t) = + if not (word_ty t) then + unsupported "%s of type %s: not a single integer register" what + (Flan.Types.to_string t) + +let cc_of signed (p : Flan.Tast.prim) = + match p, signed with + | Flan.Tast.Eq, _ -> 0x4 | Flan.Tast.Ne, _ -> 0x5 + | Flan.Tast.Lt, true -> 0xc | Flan.Tast.Lt, false -> 0x2 + | Flan.Tast.Le, true -> 0xe | Flan.Tast.Le, false -> 0x6 + | Flan.Tast.Gt, true -> 0xf | Flan.Tast.Gt, false -> 0x7 + | Flan.Tast.Ge, true -> 0xd | Flan.Tast.Ge, false -> 0x3 + | _ -> assert false + +let arg_regs = [| rdi; rsi; rdx; rcx; r8; r9 |] + +(* Value into rax. Everything is a subexpression of something that will + immediately consume rax, so nothing is kept live and no allocator is + needed. *) +let rec value f (e : Flan.Tast.expr) : unit = + let b = f.b in + match e.Flan.Tast.e with + | Flan.Tast.Int (n, _) -> movabs b ~dst:rax n + | Flan.Tast.Bool v -> movabs b ~dst:rax (if v then 1L else 0L) + | Flan.Tast.Local i -> + check_word "local" e.Flan.Tast.ty; + if i >= f.nslots then unsupported "slot %d out of range" i; + mov_load b ~dst:rax ~disp:(slot_disp i) + | Flan.Tast.Do body -> block f body + | Flan.Tast.Let (binds, body) -> + List.iter + (fun (i, e) -> + value f e; + check_word "binding" e.Flan.Tast.ty; + mov_store b ~src:rax ~disp:(slot_disp i)) + binds; + block f body + | Flan.Tast.Set (Flan.Tast.Plocal i, rhs) -> + value f rhs; + check_word "assignment" rhs.Flan.Tast.ty; + mov_store b ~src:rax ~disp:(slot_disp i) + | Flan.Tast.If (c, t, e') -> emit_if f c t e' + | Flan.Tast.Return (Some x) -> + value f x; + leave b; ret b + | Flan.Tast.Return None -> leave b; ret b + | Flan.Tast.Prim (p, args) -> prim f e p args + | Flan.Tast.Call (name, args) -> call f (f.resolve name) args ~xfer:true + | Flan.Tast.Unit -> () + | k -> unsupported "expression: %s" (node_name k) + +and block f body = + match body with + | [] -> () + | [ last ] -> value f last + | x :: rest -> value f x; block f rest + +and prim f e (p : Flan.Tast.prim) args = + let b = f.b in + match p, args with + | (Flan.Tast.Add | Flan.Tast.Sub | Flan.Tast.Mul + | Flan.Tast.BitAnd | Flan.Tast.BitOr | Flan.Tast.BitXor), [ x; y ] -> + check_word "arithmetic" x.Flan.Tast.ty; + binop f x y; + (* left in rax, right in rcx *) + (match p with + | Flan.Tast.Add -> add_rr b ~dst:rax ~src:rcx + | Flan.Tast.Sub -> sub_rr b ~dst:rax ~src:rcx + | Flan.Tast.Mul -> imul_rr b ~dst:rax ~src:rcx + | Flan.Tast.BitAnd -> and_rr b ~dst:rax ~src:rcx + | Flan.Tast.BitOr -> or_rr b ~dst:rax ~src:rcx + | _ -> xor_rr b ~dst:rax ~src:rcx) + | (Flan.Tast.Eq | Flan.Tast.Ne | Flan.Tast.Lt | Flan.Tast.Le + | Flan.Tast.Gt | Flan.Tast.Ge), [ x; y ] -> + let signed = + match x.Flan.Tast.ty with + | Flan.Types.Int k -> Flan.Types.signed k + | Flan.Types.Bool -> false + | t -> unsupported "comparison on %s" (Flan.Types.to_string t) + in + binop f x y; + cmp_rr b ~a:rax ~bb:rcx; + setcc b (cc_of signed p); + movzx_al b + | Flan.Tast.Rt sym, args -> call f (f.resolve sym) args ~xfer:false + | _ -> unsupported "primitive in %s" (Flan.Types.to_string e.Flan.Tast.ty) + +(* Left into rax, right into rcx, with the left spilled across the right's + evaluation. Left-to-right, which emit.ml's [map_lr] is explicit about being + required rather than a preference -- a call in either operand has effects. + The push/pop pair keeps rsp 16-aligned in pairs, which matters only because + [call] below re-derives alignment from a counter rather than tracking rsp. *) +and binop f x y = + let b = f.b in + value f x; + push b rax; + value f y; + mov_rr b ~dst:rcx ~src:rax; + pop b rax + +and emit_if f c t e = + let b = f.b in + value f c; + (* cmp rax, 0: 48 83 f8 00 -- written out because the helper above takes + registers only and a zero-compare is the one immediate form worth having. *) + u8 b 0x48; u8 b 0x83; modrm b ~md:3 ~r:7 ~m:rax; u8 b 0x00; + let to_else = jcc b 0x4 in (* je *) + value f t; + let to_end = jmp b in + patch b ~at:to_else ~target:(len b); + value f e; + patch b ~at:to_end ~target:(len b) + +(* A call, and this is the part that has to be exactly right. + + [xfer] appends the transfer channel, which every Flan function's signature + carries and a C entry point does not. The spike passes NULL: nothing here + signals, and a real backend would pass the caller's own channel pointer. + + Alignment: rsp is 16-aligned at function entry minus the 8 the [call] + pushed, so after [push rbp] it is aligned again, and the frame is rounded to + a multiple of 16. Every push here is paired with a pop before the next call + can happen, so rsp is aligned at every call site by construction. Stack + arguments are pushed in pairs to keep it that way -- an odd count gets a + dummy push, which is what clang's [sub rsp, 8] is doing when you see it. *) +and call f (addr : int64) args ~xfer = + let b = f.b in + let n = List.length args + (if xfer then 1 else 0) in + if n > 6 then begin + (* The stack half. Evaluate every stacked argument first, right to left, + leaving them pushed, then fill the registers -- otherwise evaluating a + stacked argument would clobber a register already loaded. *) + let stacked = List.filteri (fun i _ -> i >= 6) args in + let nstack = List.length stacked + (if xfer then 1 else 0) in + if nstack land 1 = 1 then sub_imm32 b ~dst:rsp 8; + if xfer then (movabs b ~dst:rax 0L; push b rax); + List.iter (fun a -> value f a; push b rax) (List.rev stacked) + end; + (* The register half, and it needs a spill: rdi..r9 are argument registers + and rax is where every value lands, so an earlier argument would be + clobbered by a later one's evaluation. Push each, then pop them into + their registers in reverse. *) + let inreg = List.filteri (fun i _ -> i < 6) args in + List.iter (fun a -> value f a; push b rax) inreg; + let nreg = List.length inreg in + List.iteri (fun i _ -> pop b arg_regs.(nreg - 1 - i)) inreg; + if xfer && n <= 6 then movabs b ~dst:arg_regs.(nreg) 0L; + (* al = number of vector registers used. Required only for a variadic + callee, and set unconditionally because it is free and a wrong al on a + printf-shaped raylib entry point (TraceLog is one) is a crash that looks + like anything else. It must be set *after* the argument registers, since + al is rax's low byte. *) + u8 b 0xb0; u8 b 0x00; (* mov al, 0 *) + (* r11 always, never r9: r11 is the scratch register SysV reserves and is the + one 64-bit register guaranteed not to be carrying an argument. Picking the + target conditionally is how a call with six arguments gets quietly wrong. *) + u8 b 0x49; u8 b 0xbb; u64 b addr; (* movabs r11, addr *) + call_r b 11; + if n > 6 then begin + let nstack = List.length args - 6 + (if xfer then 1 else 0) in + let pop_bytes = 8 * (nstack + (nstack land 1)) in + add_imm32 b ~dst:rsp pop_bytes + end + +and node_name (k : Flan.Tast.expr_kind) = + match k with + | Flan.Tast.Int _ -> "Int" | Flan.Tast.Float _ -> "Float" + | Flan.Tast.Bool _ -> "Bool" | Flan.Tast.Str _ -> "Str" + | Flan.Tast.Unit -> "Unit" | Flan.Tast.Zero _ -> "Zero" + | Flan.Tast.Uninit _ -> "Uninit" | Flan.Tast.Local _ -> "Local" + | Flan.Tast.Global _ -> "Global" | Flan.Tast.Prim _ -> "Prim" + | Flan.Tast.Call _ -> "Call" | Flan.Tast.FnAddr _ -> "FnAddr" + | Flan.Tast.CallPtr _ -> "CallPtr" | Flan.Tast.Do _ -> "Do" + | Flan.Tast.Let _ -> "Let" | Flan.Tast.If _ -> "If" + | Flan.Tast.While _ -> "While" | Flan.Tast.Return _ -> "Return" + | Flan.Tast.Break _ -> "Break" | Flan.Tast.Continue _ -> "Continue" + | Flan.Tast.Set _ -> "Set" | Flan.Tast.Field _ -> "Field" + | Flan.Tast.Addr _ -> "Addr" | Flan.Tast.Deref _ -> "Deref" + | Flan.Tast.Make _ -> "Make" | Flan.Tast.MakeCase _ -> "MakeCase" + | Flan.Tast.CaseField _ -> "CaseField" | Flan.Tast.Arr _ -> "Arr" + | Flan.Tast.Some_ _ -> "Some" | Flan.Tast.None_ -> "None" + | Flan.Tast.Match _ -> "Match" | Flan.Tast.UnwrapSome _ -> "UnwrapSome" + | Flan.Tast.Signal _ -> "Signal" | Flan.Tast.Handled _ -> "Handled" + | Flan.Tast.RestartCase _ -> "RestartCase" + | Flan.Tast.WithAlloc _ -> "WithAlloc" + | Flan.Tast.InvokeRestart _ -> "InvokeRestart" + +(* ── A whole function ────────────────────────────────────────────────── *) + +let fn ~resolve (fd : Flan.Tast.fn) : string = + let b = create () in + let nslots = Array.length fd.Flan.Tast.slots in + let f = { b; nslots; resolve } in + push b rbp; + mov_rr b ~dst:rbp ~src:rsp; + (* Round the frame to 16 so that rsp is aligned at every call site. One + extra word for the transfer channel's slot, which is not a Flan slot and + has no index -- the spike never reads it, but a real backend must, and + leaving no room for it is the kind of thing that is cheap now and + expensive later. *) + let frame = (nslots + 1) * 8 in + let frame = (frame + 15) land lnot 15 in + if frame > 0 then sub_imm32 b ~dst:rsp frame; + (* Parameters arrive in registers and are stored into their slots at once, + which is also emit.ml's rule: slots 0..n-1 are the parameters, in order. *) + let np = List.length fd.Flan.Tast.params in + if np > 6 then unsupported "more than six parameters"; + List.iteri + (fun i ty -> + check_word "parameter" ty; + mov_store b ~src:arg_regs.(i) ~disp:(slot_disp i)) + fd.Flan.Tast.params; + (* The transfer channel is the last argument and goes just past the slots. *) + if np < 6 then mov_store b ~src:arg_regs.(np) ~disp:(slot_disp nslots); + block f fd.Flan.Tast.body; + leave b; ret b; + (* Anything that falls off the end of a Never-returning body lands here and + traps rather than running into the next function. LLVM's [unreachable] is + undefined behaviour; ud2 is a defined SIGILL, and the difference is one of + the audit's findings. *) + ud2 b; + contents b