From 2155c41465de9f351f7e087474acb867e4ca66e3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 14:56:14 +0700 Subject: [PATCH 1/5] A whole program goes through the hand-written backend and runs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit x86.ml was an encoder and a frame model with nothing calling it. It now lowers a whole Tast.program to an assembly file, and `flan build --x86` hands that file to the same clang invocation the LLVM path uses, against the same runtime objects. The flag is off by default; LLVM stays the release backend and the default one. Three programs, built both ways and compared by what they print and what they exit with rather than by reading bytes: exit 0; a dotimes that prints; and a fizz over a call, an if, a remainder and two string literals. All three agree with the LLVM build. The measurement decided the target. hist.ml over the fizz program shows no Signal, no Handled, no RestartCase — a loop that prints does not drag conditions in. What does is the bounds check and the allocator, and neither is in the reachable set of a program that prints a number. That is why there is no transfer guard here, and check_no_transfer is what makes the omission sound rather than hopeful: if nothing reachable can write the channel, no call can return with it set. It is a whole-program property, so it is checked once per build and the build stops with the node's name when it fails. --- bin/main.ml | 15 +- lib/build.ml | 30 +- lib/x86.ml | 1095 +++++++++++++++++++++++++++++++++- spike/x86/p1-exit.flan | 2 + spike/x86/p2-loop-print.flan | 5 + spike/x86/p3-fizz.flan | 11 + 6 files changed, 1142 insertions(+), 16 deletions(-) create mode 100644 spike/x86/p1-exit.flan create mode 100644 spike/x86/p2-loop-print.flan create mode 100644 spike/x86/p3-fizz.flan diff --git a/bin/main.ml b/bin/main.ml index 11496ac..5958151 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -100,8 +100,16 @@ let sanitize_flag = "--sanitize" preference, and it goes away with the transport it drives. *) let two_process_flag = "--two-process" +(* The hand-written x86-64 backend (lib/x86.ml) instead of LLVM. The dev + backend from DISCUSS.md item 15, off by default and named explicitly: + LLVM stays the release path and the default one. It covers a subset of the + IR and refuses the rest by name, so a build that succeeds is one it really + compiled. *) +let x86_flag = "--x86" + let flags = - [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag ] + [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag; + x86_flag ] (* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike the flags above, a target @@ -422,6 +430,7 @@ let () = let dev = List.mem dev_flag rest in let debug = List.mem debug_flag rest in let sanitize = List.mem sanitize_flag rest in + let x86 = List.mem x86_flag rest in let target = target_of rest in let out = match List.filter (fun a -> not (is_flag a)) rest with @@ -453,7 +462,7 @@ let () = let p, csrcs, lflags = Flan.Reach.link ~dev l p in ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; dev; debug; sanitize; - target } + target; x86 } ~csrcs ~lflags ~pnames:(if debug then param_names l else []) p ~out)) (* The daemon an editor talks to: one session, the program it belongs to @@ -536,7 +545,7 @@ let () = \ flan import-c [package.flan...] [clang flags...]\n\ \ flan generate-c \n\ \ flan build [-o out] [--no-bounds-checks] [--dev] \ - [--debug] [--sanitize] [--target=wasm32-wasi|web]\n\ + [--debug] [--sanitize] [--x86] [--target=wasm32-wasi|web]\n\ \ flan run [args...]\n\ \ flan reload [-o out.so]\n\ \ flan dev [-s socket]"; diff --git a/lib/build.ml b/lib/build.ml index 986d8d4..bd462ce 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -147,6 +147,13 @@ type opts = { language's arithmetic means; without the exclusion every program trips on its first [+]. Nothing else is excluded. *) sanitize : bool; + (* The dev backend: lower the typed IR to x86-64 assembly here instead of + handing LLVM IR to clang. Off by default and off everywhere but the one + flag that asks for it — LLVM stays the release backend and the default + one. It refuses rather than degrades: a program holding a node [x86.ml] + does not lower yet stops the build with that node's name, so a build that + succeeds is one this backend really compiled. *) + x86 : bool; } (* Checks are deliberately independent of [opt]: the acceptance table runs the @@ -155,7 +162,7 @@ type opts = { checks. Dropping them is a release decision, not an optimisation one. *) let default = { target = None; opt = "-O2"; keep = false; checks = true; dev = false; - debug = false; sanitize = false } + debug = false; sanitize = false; x86 = false } (* The flags that are neither [opt] nor the target, spelled once so that the compile command and the object-cache key cannot disagree. They did before: @@ -725,11 +732,26 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) ?(pnames = []) does not do this: see [opts]. *) let opts = if opts.debug then { opts with opt = "-O0" } else opts in let tflags = target_flags opts in + if opts.x86 && (wasm_target opts || opts.dev || opts.debug || opts.sanitize) + then + failwith + "--x86 is the native dev backend on its own: it emits no DWARF, has no \ + indirection cells for a REPL to redefine through, and there is no \ + sanitizer pass over hand-written assembly"; let dir = workdir () in - let ll = Filename.concat dir (Filename.basename out ^ ".ll") in + (* The one fork in this function. The x86 backend hands clang an assembly + file where LLVM hands it IR text; clang takes either on its command line, + so everything past this point — the runtime objects, the shim, the + package C, the linker arguments — is the same build. *) + let ll = + Filename.concat dir + (Filename.basename out ^ if opts.x86 then ".s" else ".ll") + in write ll - (Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames - ~sanitize:opts.sanitize p); + (if opts.x86 then X86.program p + else + Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames + ~sanitize:opts.sanitize p); (* [flan_dev.c] is compiled into every build, not only a dev one. Nothing in a release build calls into it — the compiler only emits a registry lookup for a name the host was not built with, which cannot arise without cells — diff --git a/lib/x86.ml b/lib/x86.ml index ebe2095..799e171 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -371,15 +371,17 @@ 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 *) - xfer_off : int; (* the incoming transfer channel pointer *) - sret_off : int; (* where the hidden return pointer was put *) - retval : int; (* the scalar return value's temporary *) + 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 *) - mutable nlbl : int; (* 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. *) @@ -390,12 +392,18 @@ type fnctx = { (* Collected while lowering: string literals and float constants both need a labelled constant in .rodata, and both are discovered mid-expression. *) rodata : Buffer.t; - mutable nconst : int; externs : (string, string) Hashtbl.t; fns : (string, unit) Hashtbl.t; } -let new_label f tag = f.nlbl <- f.nlbl + 1; Printf.sprintf ".L%s%d" tag f.nlbl +(* 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 (* 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; @@ -472,9 +480,7 @@ let zero_frame f ~dst n = (* ── Constants in .rodata ────────────────────────────────────────────── *) -let rodata_label f = - f.nconst <- f.nconst + 1; - Printf.sprintf ".Lc%s%d" (String.concat "" (String.split_on_char '.' "k")) f.nconst +let rodata_label _f = incr uniq; Printf.sprintf ".Lk%d" !uniq let escape_bytes s = String.concat "," @@ -500,3 +506,1074 @@ let float_const f (x : float) ~f64 = 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 *) + | 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) + | 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) + | 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)) + | 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 + +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 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 -> unsupported "no struct %s" sn + +(* 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" + +(* [ucomis] sets the flags the *unsigned* codes read, whichever way the + operands are signed, so a float comparison never uses l/g. *) +let float_cc (p : Tast.prim) = + match p with + | Tast.Eq -> cc_e | Tast.Ne -> cc_ne + | Tast.Lt -> cc_b | Tast.Le -> cc_be + | Tast.Gt -> cc_a | Tast.Ge -> cc_ae + | _ -> unsupported "not a comparison" + +let is_cmp (p : Tast.prim) = + match p with + | Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true + | _ -> false + +(* ── The calling convention, as the header states it ─────────────────── *) + +(* One argument as it will actually be handed over. [Aptr] is an aggregate, + which always crosses as the address of a copy the caller made; [Alen] is the + second word of a slice being exploded for a C callee. *) +type arg = + | Aint of loc * Types.t + | Aflt of loc * Types.t + | Aptr of loc + | Alen of loc + +(* The C boundary, and the one place this backend must match SysV rather than + pick. [check.ml] rejects an aggregate in a [declare] signature and the shim + flattens every struct, so the only aggregates that reach here are the ones + [emit.ml]'s own shim rules already spell out: a slice as ptr+len, and a + move-only container by address. *) +let classify_c (l : loc) (t : Types.t) = + match t with + | Types.String | Types.Slice _ -> [ Aint (l, Types.Ptr Types.Unit); Alen l ] + | Types.Unit | Types.Never -> [] + | Types.Vec _ | Types.Map _ | Types.Pool _ -> [ Aptr l ] + | _ when is_agg t -> + unsupported "aggregate %s across the C boundary" (Types.to_string t) + | _ when is_float t -> [ Aflt (l, t) ] + | _ -> [ Aint (l, t) ] + +(* Hand the arguments over. Everything has already been evaluated into frame + temporaries, so loading the registers cannot disturb anything: every load + below reads from rbp, and rbp does not move. Answers how many SSE registers + were used, which is what [al] has to say to a variadic callee. *) +let emit_args f (args : arg list) = + let ints = ref 0 and sses = ref 0 and stack = ref 0 in + let placed = + List.map + (fun a -> + match a with + | Aflt _ when !sses < n_sse_args -> incr sses; `Sse (!sses - 1, a) + | Aflt _ -> let k = !stack in stack := k + 8; `Stack (k, a) + | _ when !ints < n_int_args -> incr ints; `Int (!ints - 1, a) + | _ -> let k = !stack in stack := k + 8; `Stack (k, a)) + args + in + if !stack > f.outgoing then f.outgoing <- !stack; + let into ~reg a = + match a with + | Aint (l, t) -> load_loc f ~reg l t + | Aflt (l, t) -> fload f.b ~dst:reg ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t) + | Aptr l -> addr_into f ~reg l + | Alen l -> + load_int f.b ~dst:reg ~mm:(lmem f (shift l 8) ~scratch:r11) ~size:8 + ~signed:true + in + (* The stack half first, because it uses rax as its courier and a register + argument must not already be sitting in rax while that happens. *) + List.iter + (function + | `Stack (k, a) -> + (match a with + | Aflt (l, t) -> + fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of t); + fstore f.b ~src:xmm0 ~mm:(Reg (rsp, k)) ~f64:(f64_of t) + | _ -> + into ~reg:rax a; + store_int f.b ~src:rax ~mm:(Reg (rsp, k)) ~size:8) + | _ -> ()) + placed; + List.iter + (function + | `Int (i, a) -> into ~reg:int_args.(i) a + | `Sse (i, a) -> into ~reg:i a + | `Stack _ -> ()) + placed; + !sses + +(* ── Lowering ────────────────────────────────────────────────────────── *) + +(* The destination a void expression is handed and never reads. rbp+0 is the + saved rbp; nothing below stores through a destination it was told was + void, so the address is a name and not a target. *) +let sink = Lf 0 + +let rec lower f (e : Tast.expr) (dst : loc) : unit = + let t = e.Tast.ty in + match e.Tast.e with + | Tast.Int (n, _) -> imm_into f ~reg:rax n; store_loc f ~reg:rax dst t + | Tast.Bool b -> + imm_into f ~reg:rax (if b then 1L else 0L); + store_loc f ~reg:rax dst Types.Bool + | Tast.Float (x, k) -> + let f64 = (k = Types.F64) in + let l = float_const f x ~f64 in + fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64; + fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 + | Tast.Str s -> + (* A string and a [u8] slice are the same two words, which is why [Bytes] + below is a non-instruction. *) + let l = string_const f s in + lea f.b ~dst:rax ~mm:(Sym (l, 0)); + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; + imm_into f ~reg:rax (Int64.of_int (String.length s)); + store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 + | Tast.Unit -> () + | Tast.Zero ty -> zero_value f dst ty + | Tast.None_ -> zero_value f dst t + (* Reading an uninitialised value gives whatever the slot held: stable + garbage rather than LLVM's [poison]. The one construct where the two + backends are meant to differ — DISCUSS.md item 15, question 4. *) + | Tast.Uninit _ -> () + | Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ -> + let src = lvalue f e in + move f ~dst ~src t + | Tast.Addr p -> + let l = place f p in + addr_into f ~reg:rax l; + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 + (* Not the indirection cell: this backend owns the whole build and nothing + is redefined into it, so a function's address is its symbol. When it + stops being true, [Fnval] is the case that grows a load. *) + | Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n) -> + lea f.b ~dst:rax ~mm:(Sym (fsym n, 0)); + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8 + | Tast.FnAddr (Tast.Rtfn n) -> + lea f.b ~dst:rax ~mm:(Sym (n, 0)); + 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 -> call_flan f ~target:(`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.Match _ | Tast.MakeCase _ | Tast.CaseField _ -> + unsupported "union values, in %s" f.fnname + | Tast.Signal _ | Tast.Handled _ | Tast.RestartCase _ + | Tast.InvokeRestart _ | Tast.WithAlloc _ -> + unsupported "conditions, in %s" f.fnname + +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 -> Lg (gsym n, 0) + | 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 + | _ -> eval f e + +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 -> Lg (gsym n, 0) + | 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 + | Tast.Pindex (x, [ i ]) -> element f (lvalue f x) x.Tast.ty i + | Tast.Pindex _ -> unsupported "multi-dimensional index" + +(* 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 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 + (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 | `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)); + (match callee with + | `Sym s -> call_sym f.b s + | `Loc o -> + load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false; + call_r f.b r11); + 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 + +and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~args ~rty dst + +and call_native f ~sym ~(args : Tast.expr list) ~rty dst = + let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in + let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals 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 not (is_void rty) then begin + if is_agg rty then unsupported "aggregate return from %s" sym; + store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty + end + +(* ── Primitives ──────────────────────────────────────────────────────── *) + +and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = + let t = e.Tast.ty in + match p, args with + | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem + | Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ a; b ] -> + let la = eval f a in + let lb = eval f b in + if is_float t then begin + let f64 = f64_of t in + fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64; + fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64; + let op = + match p with + | Tast.Add -> 0x58 | Tast.Sub -> 0x5c + | Tast.Mul -> 0x59 | Tast.Div -> 0x5e + | _ -> unsupported "that operator on %s" (Types.to_string t) + in + farith f.b ~op ~f64 ~dst:xmm0 ~src:1; + fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 + end else begin + let signed = signed_of t in + load_loc f ~reg:rax la a.Tast.ty; + load_loc f ~reg:rcx lb b.Tast.ty; + (match p with + | Tast.Add -> add_rr f.b ~dst:rax ~src:rcx + | Tast.Sub -> sub_rr f.b ~dst:rax ~src:rcx + | Tast.Mul -> imul_rr f.b ~dst:rax ~src:rcx + | Tast.BitAnd -> and_rr f.b ~dst:rax ~src:rcx + | Tast.BitOr -> or_rr f.b ~dst:rax ~src:rcx + | Tast.BitXor -> xor_rr f.b ~dst:rax ~src:rcx + (* The count is masked to the operand width by the hardware, which is + the rule the language already defines. *) + | Tast.Shl -> shl_cl f.b ~dst:rax + | Tast.Shr -> if signed then sar_cl f.b ~dst:rax else shr_cl f.b ~dst:rax + | Tast.Div | Tast.Rem -> + 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 + fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64; + fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64; + ucomis f.b ~f64 ~a:xmm0 ~c:1; + setcc f.b ~cc:(float_cc p) ~dst:rax + 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; i ] -> + let l = element f (lvalue f a) a.Tast.ty i 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 + (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 + (* string and [u8] are the same two words, so both directions are views and + not copies — the same non-instruction [emit.ml] emits. *) + | (Tast.Bytes | Tast.StrOfBytes), [ a ] -> lower f a dst + | Tast.I64ToBytes, [ a ] -> shim_out f "flan_i64_to_bytes" a dst + | Tast.U64ToBytes, [ a ] -> shim_out f "flan_u64_to_bytes" a dst + | Tast.F64ToBytes, [ a ] -> shim_out f "flan_f64_to_bytes" a dst + | Tast.EscapeBytes, [ a ] -> + let l = eval f a in + slice_in_out f "flan_escape_bytes" l dst + | Tast.BytesToI64, [ a ] -> + call_rt f ~sym:"flan_bytes_to_i64" ~args:[ a ] ~rty:t dst + | Tast.BytesToF64, [ a ] -> + call_rt f ~sym:"flan_bytes_to_f64" ~args:[ a ] ~rty:t dst + | Tast.WriteStdout, [ a ] -> + call_rt f ~sym:"flan_write_stdout" ~args:[ a ] ~rty:Types.Unit sink + | Tast.Exit, [ a ] -> + call_rt f ~sym:"flan_exit" ~args:[ a ] ~rty:Types.Unit sink; + ud2 f.b + | Tast.Argv, [] -> addr_into f ~reg:rdi dst; 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 + | Tast.Rt sym, _ -> call_rt f ~sym ~args ~rty:t dst + | Tast.Cast target, [ a ] -> cast f a target dst + | _ -> unsupported "primitive with %d arguments" (List.length args) + +(* [void shim(T, flan_slice *out)] — a scalar in, a slice written through a + hidden out pointer. The three number printers, and nothing else. *) +and shim_out f sym (a : Tast.expr) dst = + let l = eval f a in + if is_float a.Tast.ty then begin + fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of a.Tast.ty); + addr_into f ~reg:rdi dst; + imm_into f ~reg:rax 1L + end else begin + load_loc f ~reg:rdi l a.Tast.ty; + addr_into f ~reg:rsi dst; + imm_into f ~reg:rax 0L + end; + call_sym f.b sym + +(* [void shim(ptr, i64, flan_slice *out)] — a slice in, a slice out. *) +and slice_in_out f sym (src : loc) dst = + load_int f.b ~dst:rdi ~mm:(lmem f src ~scratch:r11) ~size:8 ~signed:false; + load_int f.b ~dst:rsi ~mm:(lmem f (shift src 8) ~scratch:r11) ~size:8 + ~signed:true; + addr_into f ~reg:rdx dst; + xor_rr f.b ~dst:rax ~src:rax; + call_sym f.b sym + +(* Every conversion, and there are only four shapes of them. Integer to + integer is already the load and store rules: a load widens the way the + source's own signedness says, and a store narrows to the destination's + width, so one pair covers all sixty-four pairings. *) +and cast f (a : Tast.expr) (target : Types.t) dst = + let concrete (t : Types.t) = + match t with Types.Enum _ -> Types.Int Types.I32 | t -> t + in + let src_t = concrete a.Tast.ty and dst_t = concrete target in + let l = eval f a in + match is_float src_t, is_float dst_t with + | false, false -> + load_loc f ~reg:rax l src_t; + store_loc f ~reg:rax dst dst_t + | true, true -> + fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t); + if f64_of src_t && not (f64_of dst_t) then cvtsd2ss f.b ~dst:xmm0 ~src:xmm0 + else if (not (f64_of src_t)) && f64_of dst_t then + cvtss2sd f.b ~dst:xmm0 ~src:xmm0; + fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) + | false, true -> + load_loc f ~reg:rax l src_t; + cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax; + fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) + | true, false -> + fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t); + cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0; + store_loc f ~reg:rax dst dst_t + +(* ── A function ──────────────────────────────────────────────────────── *) + +(* The frame is rounded to 16 and reserves the outgoing-argument area in the + same [sub]. [push rbp] takes entry's [rsp ≡ 8 (mod 16)] to [rsp ≡ 0], so + [rbp ≡ 0] and — because [rsp] is written exactly here and by [leave] — + [rsp ≡ 0] at every call site in the body. That is the whole licence for + having no depth counter, and it is one rounded subtraction rather than an + invariant every case has to maintain. *) +let frame_bytes f = ((f.maxframe + f.outgoing + 15) / 16) * 16 + +(* Where each argument arrives, in the order the header lays down: a hidden + [sret] first when the result is an aggregate, then the parameters, then the + transfer channel. Answers one entry per incoming value — a register number, + or a positive [rbp] displacement for the ones that came on the stack. *) +type incoming = Ireg of int | Isse of int | Istk of int + +let incoming_of ~sret (params : Types.t list) = + let ints = ref 0 and sses = ref 0 and stk = ref 0 in + let next_int () = + if !ints < n_int_args then (incr ints; Ireg int_args.(!ints - 1)) + else (let k = !stk in stk := k + 8; Istk (16 + k)) + in + let next_sse () = + if !sses < n_sse_args then (incr sses; Isse (!sses - 1)) + else (let k = !stk in stk := k + 8; Istk (16 + k)) + in + let sret_at = if sret then Some (next_int ()) else None in + let ps = + List.map + (fun ty -> + if is_void ty then Istk (-1) + else if is_agg ty then next_int () + else if is_float ty then next_sse () + else next_int ()) + params + in + sret_at, ps, next_int () + +let emit_fn (md : Emit.m) ~externs ~fns (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 = []; rodata = Buffer.create 64; externs; fns } + 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"; + 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 is not built, and nothing can reach it: no node in this + program signals or invokes a restart (checked before any of this runs), so + [fdefers] has no second path to run on. *) + if fn.Tast.fdefers <> [] then + unsupported "%s has defers on the transfer path" fn.Tast.name; + + (* The prologue, now that the frame size is known. *) + 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; + (match sret_at with + | Some (Ireg r) -> store_int pb ~src:r ~mm:(Frame f.sret_off) ~size:8 + | Some (Istk d) -> + load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; + store_int pb ~src:rax ~mm:(Frame f.sret_off) ~size:8 + | _ -> ()); + List.iteri + (fun i ty -> + let at = List.nth param_at i and sp = List.nth spills i in + let slot = f.slots.(i) in + match at, sp with + | Ireg r, Some p -> store_int pb ~src:r ~mm:(Frame p) ~size:8 + | Ireg r, None -> + if is_void ty then () + else store_int pb ~src:r ~mm:(Frame slot) + ~size:(match ty with Types.Bool -> 1 + | _ -> max 1 (fst (Emit.lay md ty))) + | Isse i', _ -> + fstore pb ~src:i' ~mm:(Frame slot) ~f64:(f64_of ty) + | Istk d, _ -> + if is_agg ty then begin + (* The caller put a pointer there, not the aggregate. *) + load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; + store_int pb ~src:rax ~mm:(Frame (match sp with Some p -> p | None -> slot)) + ~size:8 + end else if not (is_void ty) then begin + load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:(signed_of ty); + store_int pb ~src:rax ~mm:(Frame slot) + ~size:(match ty with Types.Bool -> 1 + | _ -> max 1 (fst (Emit.lay md ty))) + end) + fn.Tast.params; + (match xfer_at with + | Ireg r -> store_int pb ~src:r ~mm:(Frame f.xfer_off) ~size:8 + | Istk d -> + load_int pb ~dst:rax ~mm:(Frame d) ~size:8 ~signed:false; + store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8 + | Isse _ -> unsupported "the channel in an SSE register"); + (* And now the aggregate copies, with every incoming register safely in the + frame. A struct parameter *is* a copy — spec-memory.md's assignment rule, + made by the caller and taken again here so the callee owns it. *) + List.iteri + (fun i ty -> + match List.nth spills i with + | Some p -> + lea pb ~dst:rdi ~mm:(Frame f.slots.(i)); + load_int pb ~dst:rsi ~mm:(Frame p) ~size:8 ~signed:false; + movabs pb ~dst:rcx (Int64.of_int (fst (Emit.lay md ty))); + rep_movsb pb + | None -> ()) + fn.Tast.params; + + (* The epilogue, in exactly one place. *) + lbl f.b f.retlbl; + if sret then load_int f.b ~dst:rax ~mm:(Frame f.sret_off) ~size:8 ~signed:false + else if not (is_void fn.Tast.ret) then + load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax) + ~off:f.retval fn.Tast.ret; + leave f.b; + ret f.b; + flush pb; + flush f.b; + let sym = fsym fn.Tast.name in + let out = Buffer.create 1024 in + Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym); + Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym); + Buffer.add_string out (sym ^ ":\n"); + Buffer.add_string out (Buffer.contents pb.out); + Buffer.add_string out (Buffer.contents f.b.out); + 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 (md : Emit.m) (fn : Tast.fn) = + let b = create () in + push_r b rbp; + mov_rr b ~dst:rbp ~src:rsp; + sub_imm b ~dst:rsp 48; + 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); + 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; + 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"; + Buffer.add_string out (Buffer.contents b.out); + 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 (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 = []; + rodata = Buffer.create 64; externs; fns } + in + f.xfer_off <- ptmp f; + List.iter + (fun (g : Tast.global) -> + scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0)))) + globals; + 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; + (* No caller hands this one a channel, so it gets a null one of its own. *) + xor_rr pb ~dst:rax ~src:rax; + 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; + let out = Buffer.create 512 in + Buffer.add_string out + (Printf.sprintf "\t.type\t%s, @function\n%s:\n" init_sym init_sym); + Buffer.add_string out (Buffer.contents pb.out); + Buffer.add_string out (Buffer.contents f.b.out); + 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 ─────────────────────────────────────────────────────── *) + +(* The guard that makes the missing transfer guard sound. [emit.ml] emits a + check of the channel after every call; this backend emits none, and the + reason it may is a whole-program one: if nothing in the reachable set can + ever *write* the channel, no call can ever come back with it set. That is a + property of the program and not of the backend, so it is checked here rather + than assumed — and when it fails the build stops with the node that broke + it rather than running with a guard that is not there. *) +let check_no_transfer (p : Tast.program) = + let bad what = unsupported "%s needs the transfer channel, which this \ + backend does not emit a guard for" 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" + | Tast.WithAlloc _ -> bad "with-allocator" + | Tast.Prim (Tast.Rt s, _) + when String.equal s "flan_vec_at" || String.equal s "flan_vec_as_slice" -> + bad ("(" ^ s ^ ")") + | _ -> ()); + 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 (fn : Tast.fn) -> List.iter ex fn.Tast.body; List.iter ex fn.Tast.fdefers) + p.Tast.fns; + List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals + +(* A whole program as one assembly file. *) +let program (p : Tast.program) : string = + check_no_transfer p; + let md = layout_ctx 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 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\ + \t.text\n\n"; + List.iter + (fun (fn : Tast.fn) -> + let t, r = emit_fn md ~externs ~fns fn in + Buffer.add_string text t; + Buffer.add_string rodata r) + p.Tast.fns; + let ginit, gr = emit_globals_init 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 md fn) + | None -> unsupported "no main"); + 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. *) + Buffer.add_string out + (Printf.sprintf "\t.section\t.init_array,\"aw\",@init_array\n\t.align\t8\n\ + \t.quad\t%s\n\n" init_sym); + 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; + Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; + Buffer.contents out diff --git a/spike/x86/p1-exit.flan b/spike/x86/p1-exit.flan new file mode 100644 index 0000000..3e60919 --- /dev/null +++ b/spike/x86/p1-exit.flan @@ -0,0 +1,2 @@ +(defn main [] i32 + 0) diff --git a/spike/x86/p2-loop-print.flan b/spike/x86/p2-loop-print.flan new file mode 100644 index 0000000..e5e5d13 --- /dev/null +++ b/spike/x86/p2-loop-print.flan @@ -0,0 +1,5 @@ +(defn main [] i32 + (dotimes [i 5] + (print i) + (println "")) + 0) diff --git a/spike/x86/p3-fizz.flan b/spike/x86/p3-fizz.flan new file mode 100644 index 0000000..852e594 --- /dev/null +++ b/spike/x86/p3-fizz.flan @@ -0,0 +1,11 @@ +(defn fizz? [n i32] bool + (= 0 (% n 3))) + +(defn main [] i32 + (dotimes [i 15] + (let [n (+ i 1)] + (if (fizz? n) + (print "fizz") + (print n)) + (println ""))) + 0) From 786656dfee00969d933805ca976919ce313c5fc4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 15:03:41 +0700 Subject: [PATCH 2/5] (at a i) on the left of a set has to reach the array MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The corpus sweep found it, and it found it the way item 15 said this work fails: array-ctor.flan crashed, and the assembly around the crash read correctly. (set (.x (at pts 0)) 1.5) went through lvalue, lvalue had no case for At, and the fallback evaluates — so the store landed in a copy of the element and the array kept its zeros. emit.ml has this as addr's own At case. One line here, and the program matches the LLVM build. Two more programs beside the fizz: one for the internal calling convention the fizz does not touch at all — a struct argument, a struct return through the hidden pointer, f32 in the SSE half, eight integer arguments so two go on the stack, and a slice by pointer — and one for the rest of the core: a global with an initialiser, recursion, break, continue, the bitwise family, unsigned shifts and the conversions both ways. Both agree with LLVM. al is now zero at every call this backend makes, including the three in main that were reaching flan_rt_init, flan_argv and flan_exit without it. Inert on a fixed callee; the point is that there is no exception to the rule to remember. --- lib/x86.ml | 17 ++++++++++++- spike/x86/p4-convention.flan | 27 +++++++++++++++++++++ spike/x86/p5-core.flan | 46 ++++++++++++++++++++++++++++++++++++ 3 files changed, 89 insertions(+), 1 deletion(-) create mode 100644 spike/x86/p4-convention.flan create mode 100644 spike/x86/p5-core.flan diff --git a/lib/x86.ml b/lib/x86.ml index 799e171..4a84ba5 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -898,6 +898,12 @@ and lvalue f (e : Tast.expr) : loc = | Tast.Global n -> Lg (gsym n, 0) | 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; i ]) -> element f (lvalue f a) a.Tast.ty i | _ -> eval f e and field_loc f (base : loc) (ty : Types.t) i = @@ -1149,7 +1155,10 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = | 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; call_sym f.b "flan_argv" + | 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 @@ -1399,6 +1408,10 @@ let emit_main (md : Emit.m) (fn : Tast.fn) = push_r b rbp; mov_rr b ~dst:rbp ~src:rsp; 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; @@ -1407,6 +1420,7 @@ let emit_main (md : Emit.m) (fn : Tast.fn) = | [] -> 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) @@ -1415,6 +1429,7 @@ let emit_main (md : Emit.m) (fn : Tast.fn) = 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; diff --git a/spike/x86/p4-convention.flan b/spike/x86/p4-convention.flan new file mode 100644 index 0000000..58ca7f0 --- /dev/null +++ b/spike/x86/p4-convention.flan @@ -0,0 +1,27 @@ +;; The internal calling convention, which the fizz program does not touch at +;; all: an aggregate argument, an aggregate return, a float in the SSE half, +;; and more integer arguments than there are registers for. + +(defstruct V3 [x f32 y f32 z f32]) + +(defn scale [v V3 k f32] V3 + (V3 {.x (* (.x v) k) .y (* (.y v) k) .z (* (.z v) k)})) + +(defn sum3 [v V3] f32 + (+ (+ (.x v) (.y v)) (.z v))) + +(defn eight [a i64 b i64 c i64 d i64 e i64 f i64 g i64 h i64] i64 + (+ (+ (+ a b) (+ c d)) (+ (+ e f) (+ g h)))) + +(defn taglen [s [u8]] i64 + (i64 (len s))) + +(defn main [] i32 + (let [v (V3 {.x 1.0 .y 2.0 .z 3.0}) + w (scale v 2.0)] + (print (sum3 v)) (println "") + (print (sum3 w)) (println "") + (print (eight 1 2 3 4 5 6 7 8)) (println "") + (print (taglen (bytes "hello"))) (println "") + (print (.z w)) (println "")) + 0) diff --git a/spike/x86/p5-core.flan b/spike/x86/p5-core.flan new file mode 100644 index 0000000..e540f5a --- /dev/null +++ b/spike/x86/p5-core.flan @@ -0,0 +1,46 @@ +;; The rest of the core: a global with an initialiser, recursion, break and +;; continue, the bitwise family, unsigned arithmetic and shifts, and the +;; conversions in both directions. + +(defvar counter i64 0) + +(defconst limit i32 6) + +(defn fib [n i64] i64 + (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) + +(defn main [] i32 + (print (fib 20)) (println "") + + (let [i 0] + (while (< i 100) + (set i (+ i 1)) + (when (= i 7) (break))) + (print i) (println "")) + + (let [j 0 seen 0] + (while (< j 10) + (set j (+ j 1)) + (when (= (% j 2) 0) (continue)) + (set seen (+ seen j))) + (print seen) (println "")) + + (dotimes [k limit] + (set counter (+ counter (i64 k)))) + (print counter) (println "") + + (let [a (bit-xor (u32 0x0F0F0F0F) (u32 0xFFFFFFF)) + b (u32 0x0F0F0F0F)] + (print (bit-or a b)) (println "") + (print (bit-and a b)) (println "") + (print (bit-xor a (u32 65535))) (println "") + (print (>> a 4)) (println "") + (print (<< b 4)) (println "")) + + (let [x (i32 -9)] + (print (/ x 2)) (println "") + (print (% x 2)) (println "") + (print (f64 x)) (println "") + (print (i32 (f64 3.9))) (println "") + (print (f32 1.5)) (println "")) + 0) From fcdaa105af060bf1a69877da7952f62d63a56262 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 15:06:31 +0700 Subject: [PATCH 3/5] Unions and a two-index (at), which the corpus asked for by name MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The sweep over test/programs named its own next two nodes. (at grid r c) is one node with two indices and not two nodes — an array of arrays is contiguous, so the second index walks into the element the first landed on — and machine.flan is the program that says so. Then unions: MakeCase, CaseField and Match. The payload offset comes from lay_fields over the same two fields Emit.lay measures a union as, and a case's field offsets from lay_fields over that case's own fields, so there is still one layout calculator and this file is still a caller of it. match reads the tag and compares, an Option reads an i8 at offset 0 and a declared union an i32, and everything past the tag and the binds is shared — the arrangement emit.ml settled on, for the same reason. An exhausted match falls through to ud2 rather than to whatever follows. The checker proved it cannot happen; a defined SIGILL at the instruction that fell through costs two bytes and is the cheap half of item 15's question 4. machine.flan, bytes2.flan, array-ctor.flan and destructure.flan all agree with the LLVM build now. --- lib/x86.ml | 161 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 154 insertions(+), 7 deletions(-) diff --git a/lib/x86.ml b/lib/x86.ml index 4a84ba5..acad01b 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -599,6 +599,37 @@ let field_offsets f (sn : string) = offs | None -> unsupported "no struct %s" sn +(* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay] + measures it as — so the payload's offset is whatever [lay_fields] puts the + second one at, and not a rule spelled a second time here. A union whose + cases are all payload-less is a bare tag and has no second field. *) +let union_payload_off f (u : Tast.union) = + let size, align = Emit.payload_lay f.md u in + if size = 0 then 0 + else + let _, _, offs = + Emit.lay_fields f.md + [ Types.Int Types.I32; + Types.Array (Int64.of_int (size / align), + Types.Int (Emit.int_kind (align * 8))) ] + in + List.nth offs 1 + +let union_of f n = + match Hashtbl.find_opt f.md.Emit.unions n with + | Some u -> u + | None -> unsupported "no union %s" n + +(* The offsets of one case's fields inside the payload blob. The single place + in this backend that knows how a payload is read, so [match]'s binds, + [CaseField] and [MakeCase] cannot come to different conclusions about it. *) +let case_offsets f (c : Tast.variant) = + let _, _, offs = + Emit.lay_fields f.md + (List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields) + in + offs + (* An Option is { i8 tag, T }, the same two fields [Emit.lay] measures it as. *) let option_lay f (t : Types.t) = let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I8; t ] in @@ -861,8 +892,28 @@ let rec lower f (e : Tast.expr) (dst : loc) : unit = jmp_lbl f.b f.retlbl; lbl f.b lsome; move f ~dst ~src:(shift src ov) payload - | Tast.Match _ | Tast.MakeCase _ | Tast.CaseField _ -> - unsupported "union values, in %s" f.fnname + | Tast.MakeCase (uname, case, fields) -> + let u = union_of f uname in + let i, c = + match Tast.case_index u case with + | Some (i, c) -> i, c + | None -> unsupported "no case %s of %s" case uname + in + (* Zeroed first: an omitted field is ZII and the payload blob is wider + than this case, so the bytes past its last field have to be something + rather than whatever the frame held. *) + zero_loc f dst (sizeof f.md t); + imm_into f ~reg:rax (Int64.of_int i); + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:4; + let poff = union_payload_off f u in + let offs = case_offsets f c in + List.iteri + (fun k (x : Tast.expr) -> + scoped f (fun () -> lower f x (shift dst (poff + List.nth offs k)))) + fields + | Tast.CaseField (target, case, i) -> + move f ~dst ~src:(case_field f target case i) t + | Tast.Match (scrut, arms) -> emit_match f scrut arms dst t | Tast.Signal _ | Tast.Handled _ | Tast.RestartCase _ | Tast.InvokeRestart _ | Tast.WithAlloc _ -> unsupported "conditions, in %s" f.fnname @@ -903,9 +954,91 @@ and lvalue f (e : Tast.expr) : loc = 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; i ]) -> element f (lvalue f a) a.Tast.ty i + | Tast.Prim (Tast.At, a :: is) when is <> [] -> + elements f (lvalue f a) a.Tast.ty is + | Tast.CaseField (target, case, i) -> case_field f target case i | _ -> eval f e +(* The address of one field of one case of a union value. Only ever reached + under an arm that proved the tag — [match] is the only thing that proves + it — or from the structural printer, which compares the same tag first. *) +and case_field f (target : Tast.expr) case i = + let uname = + match target.Tast.ty with + | Types.Named n -> n + | ty -> unsupported "case field of %s" (Types.to_string ty) + in + let u = union_of f uname in + let c = + match Tast.case_index u case with + | Some (_, c) -> c + | None -> unsupported "no case %s of %s" case uname + in + shift (lvalue f target) (union_payload_off f u + List.nth (case_offsets f c) i) + +(* [match]. The two subjects are the same shape and are read differently: an + [Option] is an i8 tag and a payload at a known offset, a declared union is + an i32 tag and a blob the arm's case reinterprets. Everything past the tag + and the binds is shared, which is the arrangement [emit.ml] settled on for + the same reason. *) +and emit_match f (scrut : Tast.expr) (arms : Tast.arm list) dst t = + let base = lvalue f scrut in + let tag_size, tag_of, bind_at = + match scrut.Tast.ty with + | Types.Named n when Hashtbl.mem f.md.Emit.unions n -> + let u = union_of f n in + let poff = union_payload_off f u in + ( 4, + (fun case -> + match Tast.case_index u case with + | Some (i, _) -> i + | None -> unsupported "no case %s of %s" case n), + fun case k -> + match Tast.case_index u case with + | Some (_, c) -> + shift base (poff + List.nth (case_offsets f c) k), + (List.nth c.Tast.vfields k).Tast.fty + | None -> unsupported "no case %s of %s" case n ) + | Types.Option el -> + (* [lay_fields] puts the i8 tag at 0, so [base] is the tag's address the + way it is for a union. *) + let _, ov = option_lay f el in + ( 1, + (fun case -> if String.equal case "Some" then 1 else 0), + fun _case _k -> shift base ov, el ) + | ty -> unsupported "match on %s" (Types.to_string ty) + in + let lend = new_label f "endmatch" in + let rec go = function + | [] -> + (* The checker proved exhaustiveness, so nothing reaches here. A trap + rather than a fallthrough: [ud2] is a defined SIGILL at the + instruction that fell through, which is the cheap half of item 15's + question 4. *) + ud2 f.b + | (a : Tast.arm) :: rest -> + let lnext = new_label f "arm" in + (match a.Tast.acase with + | None -> () + | Some case -> + load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:tag_size + ~signed:false; + cmp_imm f.b ~dst:rax (tag_of case); + jcc_lbl f.b ~cc:cc_ne lnext); + List.iteri + (fun k slot -> + let src, fty = + bind_at (match a.Tast.acase with Some c -> c | None -> "") k + in + move f ~dst:(Lf f.slots.(slot)) ~src fty) + a.Tast.binds; + block f a.Tast.abody dst t; + jmp_lbl f.b lend; + if a.Tast.acase <> None then (lbl f.b lnext; go rest) + in + go arms; + lbl f.b lend + and field_loc f (base : loc) (ty : Types.t) i = match ty with | Types.Named sn -> shift base (List.nth (field_offsets f sn) i) @@ -927,13 +1060,27 @@ and place f (p : Tast.place) : loc = | Tast.Pglobal n -> Lg (gsym n, 0) | 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 - | Tast.Pindex (x, [ i ]) -> element f (lvalue f x) x.Tast.ty i - | Tast.Pindex _ -> unsupported "multi-dimensional index" + (* [(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 + and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc = let elem = match ty with @@ -1107,8 +1254,8 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = ~signed:true | ty -> unsupported "len of %s" (Types.to_string ty)); store_loc f ~reg:rax dst t - | Tast.At, [ a; i ] -> - let l = element f (lvalue f a) a.Tast.ty i in + | 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 = From 58b1f49cf248cc3c55eb6d273c6ad58d0eb18ad3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 15:08:38 +0700 Subject: [PATCH 4/5] A discarded value was being stored over the return address MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit edn.flan crashed by jumping into .rodata, several statements after the mistake, and the assembly at the jump read correctly. Item 15 said this is how hand-encoding fails, and it is: the crash and the cause were in different functions. The cause is one line of design. A form whose value is thrown away was handed the sink, and the sink was spelled as an address — rbp+0. That is the saved rbp, and rbp+8 is the return address, so a non-void form in statement position stored its value straight over both. A 16-byte slice did it in one rep movsb. The sink is now compared by identity and never used as an address: anything with a value that is handed it gets a frame temporary instead, reclaimed immediately. The point is not the temporary, it is that the store has somewhere legal to go. edn.flan matches the LLVM build now — 60 lines of a hand-written EDN reader, unions, options, nested collections and all. --- lib/x86.ml | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/lib/x86.ml b/lib/x86.ml index acad01b..fd5135d 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -741,12 +741,29 @@ let emit_args f (args : arg list) = (* ── Lowering ────────────────────────────────────────────────────────── *) -(* The destination a void expression is handed and never reads. rbp+0 is the - saved rbp; nothing below stores through a destination it was told was - void, so the address is a name and not a target. *) +(* 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 = + if dst == sink && not (is_void e.Tast.ty) then + scoped f (fun () -> + let o = tmp f e.Tast.ty in + lower f e (Lf o)) + else lower_at f e dst + +and lower_at f (e : Tast.expr) (dst : loc) : unit = let t = e.Tast.ty in match e.Tast.e with | Tast.Int (n, _) -> imm_into f ~reg:rax n; store_loc f ~reg:rax dst t From fc4e51a1068c5cb25a2d6ee0b848b797fa3ef449 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 15:14:33 +0700 Subject: [PATCH 5/5] =?UTF-8?q?The=20dev=20backend,=20wired=20=E2=80=94=20?= =?UTF-8?q?and=20conditions=20were=20never=20in=20the=20way?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit DISCUSS.md item 16, in item 15's form. The headline is a measurement that contradicts what everyone expected, this report included: a program that loops and prints carries no Signal, no Handled and no RestartCase. Zero of each, measured with hist.ml before a line was written. What drags conditions in is the bounds check and the allocator — check_at signals, and signalling needs the channel and the guard — and neither is a Tast node, which is why a histogram cannot see either and why the guess was off. 41 of the 111 programs in test/programs build through --x86 and 40 print exactly what the LLVM build prints. The 41st is bounds.flan and it diverges on purpose: --x86 is silently a --no-bounds-checks build, and that is named as a divergence rather than left in a code comment. The other 40 are refused by name. check_no_transfer is what makes the missing guard sound instead of hopeful — if nothing reachable can write the channel, no call can return with it set — so the build stops with the node and the function rather than compiling forty programs wrongly. Both bugs found along the way are the shape item 15 predicted: the crash and the cause in different functions, and correct-reading assembly beside a wrong answer. The frame model is the thing that did not go wrong. --- DISCUSS.md | 183 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 183 insertions(+) diff --git a/DISCUSS.md b/DISCUSS.md index e1c391b..cb37870 100644 --- a/DISCUSS.md +++ b/DISCUSS.md @@ -913,3 +913,186 @@ language has, and that rule is worth having whether or not a backend is ever wri 3. **Choose option 1 or option 2 from question 3**, deliberately. Everything else follows from it. 4. **Only then**, and only if 3 says so, grow `spike/backend/x86.ml` from the node table in question 2 — floats first, because they gate most of the prelude, and conditions last, because they are the only row with no plan. + +## 16. The dev backend, wired: a whole program compiles through `x86.ml` and runs, and conditions were never in the way + +Item 15's step 4, taken. `lib/x86.ml` was 502 lines of encoder and frame model with nothing calling it. It now lowers a +whole `Tast.program` to an assembly file, and `flan build --x86` hands that file to the same clang invocation the LLVM +path uses, against the same runtime objects, the same generated shim and the same linker arguments. The flag is off by +default and refused in combination with `--dev`, `--debug`, `--sanitize` and every wasm target. **LLVM stays the release +backend and the default one; nothing on the existing path changed.** `dune test --root .` is green either side. + +**41 programs out of `test/programs` build through it, and 40 of them print exactly what the LLVM build prints.** The +41st is `bounds.flan`, and it diverges on purpose — see question 4. + +### Question 1 — which program, and what did it actually cost + +Measured with `spike/backend/hist.ml` before anything was written, over candidates, not guessed. The one picked is +`spike/x86/p3-fizz.flan` — a `dotimes`, a call, an `if`, a remainder, two string literals and `print`/`println`: + +``` +p3-fizz.flan: 2 reachable fns + Call 1 Do 4 If 1 Int 15 Let 2 Local 7 Prim 14 + Set 1 Str 3 While 1 place/Plocal 1 + prim/Add 2 prim/Bytes 3 prim/Cast 1 prim/Eq 1 + prim/I64ToBytes 1 prim/Lt 1 prim/Rem 1 prim/WriteStdout 4 +``` + +Nineteen rows, two reachable functions after `Reach` prunes, and **no `Signal`, no `Handled`, no `RestartCase`, no +`Make`, no `Field`, no allocator**. The same is true of a program that only loops and prints: zero of each. + +That is worth stating flatly because the expectation going in was the opposite — that the smallest useful program +carries one of each condition node, and that printing a single value drags in `Str`, `Make`, `Field` and `Call` because +the prelude builds a slice to do it. **It does not.** Printing an integer is `Cast` → `I64ToBytes` → `WriteStdout`, +three prims and no call at all; `flan_i64_to_bytes` renders into a static buffer in `flan_rt.c` and hands back a slice. +Printing a string literal is `Str` → `Bytes` → `WriteStdout`, and `Bytes` is a non-instruction because a string and a +`[u8]` are the same two words. + +**What does drag conditions in is the bounds check and the allocator, and neither is a `Tast` node.** `check_at` and +`check_slice` call `flan_bounds_error` with the transfer channel and then `guard`; `Rt flan_vec_at` takes the channel +too. So it is `m.checks` and the container runtime that make a program need the condition machinery, not looping and +not printing — and because both are *emit-time* constructs rather than IR nodes, `hist.ml` cannot see either. That is +the correction to item 15's node table: the "no plan" row is not reached by writing a loop, it is reached by writing +`(at a i)`. + +### Question 2 — what runs + +| program | what it is for | +|---|---| +| `spike/x86/p1-exit.flan` | `main` returns 0. The assembly path, the runtime link, a real executable. | +| `spike/x86/p2-loop-print.flan` | a `dotimes` that prints — the smallest program that does something | +| `spike/x86/p3-fizz.flan` | the measured target: a call, an `if`, `%`, two string literals | +| `spike/x86/p4-convention.flan` | the *internal calling convention*, which p3 does not touch at all | +| `spike/x86/p5-core.flan` | a global with an initialiser, recursion, `break`, `continue`, the bitwise family, unsigned shifts, both directions of every conversion | + +p4 is the one that matters most, because item 15 named the internal aggregate convention as the sharpest obstacle in +the whole report. It passes a struct by value, returns a struct by value, puts an `f32` through the SSE half, calls an +eight-argument function so that two arguments go on the stack, and passes a slice — and it agrees with LLVM. **The +obstacle really did dissolve the way the header claims**: a dev build is compiled entirely here and a release build +entirely by LLVM, the two never meet in one process, so the convention is ours to pick. Every aggregate goes by +pointer, an aggregate return is a hidden pointer in the first integer register returned in `rax`, and there is no +classifier in the file. Nothing had to be discovered by disassembling clang. + +Over `test/programs` (111 files): + +| | n | +|---|---| +| built through `--x86` and **matched** the LLVM build's output and exit status | **40** | +| built and diverged — `bounds.flan`, by design | 1 | +| refused by name: a node this backend does not lower | 40 | +| no `main` (package and library fixtures) | 6 | +| do not compile at all (the checker-error fixtures) | 22 | +| never terminate on their own (`dev-loop`, `dev-watch`) | 2 | + +So of the 81 programs that compile, have a `main` and finish, **41 went through the hand-written backend and 40 were +byte-identical in output.** That includes `edn.flan` — sixty lines of output from a hand-written EDN reader with +unions, options, nested collections and a fixed-depth balance stack. + +Proved by comparing output, never by reading bytes. The script builds both ways and diffs stdout and the exit status; +`objdump` was used only after a program already had the wrong answer. Item 15 is right that this is the only honest +order. + +### Question 3 — the two bugs, and both are the shape item 15 predicted + +**A `(set (.x (at pts 0)) 1.5)` wrote into a copy.** `lvalue` had no case for `At`, so it fell through to "evaluate it", +and the store landed in a temporary while the array kept its zeros. `emit.ml` has this as `addr`'s own `At` case. One +line. `array-ctor.flan` found it, and it found it as a segfault several statements later. + +**A discarded value was stored over the return address.** This is the better one. A form whose value is thrown away was +handed a sink, and the sink was spelled as an address — `rbp+0`. That is the saved `rbp`, and `rbp+8` is the return +address, so a non-void form written in statement position stored straight over both; a 16-byte slice did it in one +`rep movsb`. `edn.flan` crashed by jumping into `.rodata`, **several statements after the mistake and in a different +function**, and the assembly at the jump read perfectly. The sink is now compared by identity and never used as an +address: anything with a value that is handed it gets a frame temporary instead. + +The second bug cannot exist on the LLVM path, and that is the general point. LLVM has no notion of "store this value +nowhere" — an unused SSA value is simply unused. Every construct this backend has that LLVM does not is a place where +a bug can live that the LLVM backend's own testing can never have covered. + +Against that, the thing item 15 was most worried about did *not* happen: **nothing went wrong with the frame or the +stack alignment.** `rsp` is written exactly twice — one rounded `sub` in the prologue that covers the temporaries and +the outgoing-argument area together, and `leave` — so `rsp % 16 == 0` at every call site is a property of one +subtraction rather than an invariant every case maintains. The spike's worst bug has no door to come in by, and p4 +calls an eight-argument function to prove it. + +### Question 4 — where the two backends now differ, and it is three named places + +Item 15's question 4 listed nine undefined cases. Three of them are now *real* divergences with a build on each side, +and they should be written down before anyone uses this for anything. + +| | LLVM | here | +|---|---|---| +| **A bounds violation** | `flan_bounds_error` signals; a `restart-case` can catch it; `bounds.flan` exits 134 | **no check at all**; `bounds.flan` exits 139 | +| `(uninit)` | `poison`, and the optimiser may reason from it | whatever the stack slot held — stable garbage | +| an exhausted `match`, a `noreturn` call | `unreachable`, undefined | `ud2` — a defined SIGILL at the instruction that fell through | + +**The first is the one that matters, and it is not a footnote: `--x86` is silently a `--no-bounds-checks` build.** It is +silent because it is not a decision the backend made — `check_at` signals, signalling needs the channel and the guard, +and there is no guard here, so there is no check. `bounds.flan` is the direct evidence and `edn.flan`'s 33-brackets- +against-a-32-deep-stack case is the second. Anyone reaching for this flag on a program that indexes anything should +know that the trap is gone. + +The other two are improvements and cost nothing. `ud2` in particular is two bytes and turns a class of miscompile into +a crash with an address. + +### Question 5 — conditions, which is still the row with no plan + +**They were not reached, and converting that into a checked precondition is the most useful thing in this report.** + +There is no transfer guard after a call here, no landing pad and no transfer exit. `emit.ml` emits a guard after *every* +call; this emits none. What makes that sound is a whole-program argument rather than a hope: **if nothing in the +reachable set can ever write the channel, no call can ever return with it set.** So `check_no_transfer` walks the +linked program once per build and stops it — with the node's name and the function it is in — the moment it finds a +`signal`, an `invoke-restart`, a `restart-case`, a `handler-bind`, a `with-allocator`, or the two `Rt` symbols whose +bounds check signals. + +That is what the 40 refusals are: + +``` +27 restart-case 4 handler-bind 1 with-allocator + 7 signal 1 defers on the transfer path +``` + +Forty programs refused by name rather than miscompiled, and one line of build output says which node and where. A +backend that quietly omitted the guard would have compiled all forty and been wrong in a way no test distinguishes +from a race. + +What this does *not* do is measure what conditions cost. That is still unknown, and it is still the only row of item +15's table with nothing behind it. What is now known is the shape of the bill: the guard is per call site, the pad is +per `restart-case` activation, `fdefers` needs a second exit path that no form in `body` can reach, and **any function +with `fdefers` at all is refused today** — which is most of the prelude's file and container code, and is why the +programs that use a `Vec` are not in the 40. + +### The honest no-plan bucket + +Everything below is refused by name at build time, not silently wrong. + +- **Conditions, entire** — the guard, the landing pad, `emit_restart_case`, `emit_with_alloc`, the transfer exit, and + `fdefers` on it. Several hundred lines of `emit.ml` reimplemented from `spec-conditions.md` rather than ported. +- **Bounds checks**, which are the same work: `check_at` and `check_slice` cannot exist without the guard. +- **`Rt` with an aggregate return**, and with it most of the container runtime; `Vec`, `Map` and `Pool` have not been + exercised at all. +- **`Fnval`'s indirection cell.** `FnAddr (Fnval n)` emits the symbol, which is correct for a whole-program build and + wrong the instant anything is redefined into it. This backend has no cells and no `--dev`; that is a deliberate + restriction and not an oversight, but it is exactly item 15's question 5 waiting where it was left. +- **`f64` → `i64` out of range**, and **`INT64_MIN / -1`**. `idiv` raises `SIGFPE` where LLVM says undefined, and + `cvttsd2si` answers the integer-indefinite value. Unchanged from item 15: these want a language decision, not a + backend. +- **Debug information.** None. `--x86` and `--debug` together are refused. +- **Code size and speed.** Not measured. Every value is in memory, every intermediate is a frame temporary, and a + block copy is `rep movsb`; that is the trade the brief asks for and nobody has put a number on it. + +### The verdict + +**The wiring is done and it was the easy half. What is left is conditions, and the measurement moved them from "first +obstacle" to "the only obstacle".** + +The order item 15 recommended was floats first and conditions last. Floats turned out to be one afternoon's encodings +and they are done. Conditions are still last and are now the *whole* remainder: they are what stands between 41 +programs and the corpus, they are what a bounds check is made of, and `check_no_transfer` is the line that says so out +loud on every build until someone writes them. + +Two things are worth doing before that, and both are cheap. Decide what a bounds violation means in a build with no +handler — because "no check" is what it means today and nothing says so. And take item 15's question 4 seriously now +that there are two backends to disagree: `(uninit)` and `unreachable` already differ, deliberately, and the difference +is currently documented only in a comment in `x86.ml`.