JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

An x86-64 encoder and frame model, not yet wired to anything

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-13 09:43:15 +07:00
commit 344e571c8c
3 changed files with 590 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -69,3 +69,4 @@ test/web-files-out.txt
__pycache__/
*.pyc
/forms.so
_hist/

502
lib/x86.ml Normal file
View File

@ -0,0 +1,502 @@
(** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one.
Grown out of [spike/backend/x86.ml], which proved the shape. What is new
here is everything the spike enumerated and did not do: aggregates, floats,
globals, string literals, the transfer channel, and a whole program rather
than one function.
{1 The internal calling convention}
The spike's report (DISCUSS.md item 15) called the internal convention the
sharpest obstacle, because LLVM's answer for a first-class struct is an
implementation detail discoverable only by disassembly — a 24-byte struct
comes back in [rax]:[rdx]:[rcx], and [rcx] is a register SysV never uses
for a return value.
That obstacle does not exist here, and the reason is worth stating because
it is the whole licence for this module: {b a dev build is compiled
entirely by this backend and a release build entirely by LLVM, and the two
never meet in one process.} A dev build's [.ll] is not emitted at all when
this backend runs. So the convention is ours to pick, and we pick the
simplest one that exists:
- {b Scalars} — integers, [bool], pointers, enums, handles, allocators,
function pointers — go in SysV's integer registers [rdi rsi rdx rcx r8
r9], then right-to-left on the stack. [bool] is one byte, zero-extended.
- {b Floats} go in [xmm0]-[xmm7], then on the stack.
- {b Every aggregate goes by pointer.} An argument is a pointer to a copy
the caller made; a return is a hidden [sret] pointer in the {e first}
integer register, with everything else shifted along, and the same
pointer comes back in [rax]. Nothing is classified, nothing is split
across register classes, and there is no eightbyte rule.
- {b The transfer channel} is the last argument of all, a pointer, in the
integer sequence — [emit.ml]'s [signature] rule, unchanged.
{b Where this must match SysV exactly, it does}, and that is the C
boundary: [flan_rt.c], [flan_dev.c], the generated FFI shim. [check.ml]
rejects an aggregate in a [declare] signature and the shim flattens every
struct, so a string or slice crosses as [ptr]+[len] and no Flan-emitted
call ever hands C an aggregate. There is therefore no aggregate classifier
in this file, and per item 15 there does not need to be one.
{1 The frame, and why the spike's worst bug cannot happen here}
The spike found its one real bug in a call written inside a binary
operator: the evaluator spilled the left operand with [push], so [rsp] was
8 out at the call and a C callee doing an aligned spill returned garbage.
It fixed that with a depth counter.
This module does not have a depth counter, because it does not push.
{b Every intermediate value is a frame temporary}, bump-allocated below
[rbp] with a high-water mark, and the outgoing-argument area is reserved
once in the prologue. [rsp] is written exactly twice — in the prologue and
by [leave] — so [rsp % 16 == 0] at every call site is a property of one
rounded [sub] rather than an invariant every case has to maintain. The bug
class is removed rather than guarded against.
That costs instructions and no correctness. A debug build does not
optimise; this is the trade the brief asks for.
{1 Layout}
[Emit.lay] / [lay_fields] / [payload_lay], reused rather than rewritten.
They are acceptance-tested against LLVM's own [getelementptr], so there is
one layout calculator in this compiler and this backend is a caller of it.
{1 The container}
Output is an assembly file: [.byte] blobs for the instructions, with the
few fields that need a relocation written as assembler expressions
([call sym], [.long lbl - . - 4]). Byte offsets stay exactly known, which
is what the introspection this backend exists for will need; what we give
up is writing ELF ourselves, which is several hundred lines that produce
no Flan progress and in which a bug looks exactly like an encoding bug.
Reversible: the encoder below hands out bytes, and who packages them is a
separate question. *)
exception Unsupported of string
let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt
(* ── The byte buffer ─────────────────────────────────────────────────── *)
(* Raw bytes accumulate in [pend] and are flushed as one [.byte] directive;
anything the assembler has to resolve goes out as a directive with a known
size, so [n] is the exact offset of the next byte either way. *)
type buf = { out : Buffer.t; mutable pend : int list; mutable n : int }
let create () = { out = Buffer.create 4096; pend = []; n = 0 }
let flush b =
if b.pend <> [] then begin
Buffer.add_string b.out "\t.byte ";
Buffer.add_string b.out
(String.concat "," (List.rev_map (Printf.sprintf "0x%02x") b.pend));
Buffer.add_char b.out '\n';
b.pend <- []
end
let u8 b x =
b.pend <- (x land 0xff) :: b.pend;
b.n <- b.n + 1
let u32 b n = for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done
let i32 b (n : int) =
if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n;
u32 b n
let u64 b (n : int64) =
for i = 0 to 7 do
u8 b
(Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL))
done
let dir b s size =
flush b;
Buffer.add_string b.out ("\t" ^ s ^ "\n");
b.n <- b.n + size
let text b s = flush b; Buffer.add_string b.out s
let lbl b l = flush b; Buffer.add_string b.out (l ^ ":\n")
(* ── Registers ───────────────────────────────────────────────────────── *)
(* The encoding numbering, not the ABI's: these three bits are what modrm
wants, which is why rsp is 4 and rbp is 5. *)
let rax = 0 and rcx = 1 and rdx = 2
let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7
let r8 = 8 and r9 = 9 and r11 = 11
let xmm0 = 0
let int_args = [| rdi; rsi; rdx; rcx; r8; r9 |]
let n_int_args = 6
let n_sse_args = 8
(* REX. [force] is for the 8-bit forms, where without a REX byte registers 4-7
name ah/ch/dh/bh rather than spl/bpl/sil/dil — a store of a bool from rsi
would otherwise write the wrong half of rdx. *)
let rex ?(force = false) b ~w ~r ~x ~m =
let v =
(if w then 8 else 0)
lor (if r >= 8 then 4 else 0)
lor (if x >= 8 then 2 else 0)
lor (if m >= 8 then 1 else 0)
in
if v <> 0 || force then u8 b (0x40 lor v)
let modrm_r b ~r ~m = u8 b (0xc0 lor ((r land 7) lsl 3) lor (m land 7))
(* [base + disp32], always disp32: a frame outgrows 128 bytes and a disp8 that
silently wraps is precisely the bug this would not find. r12 and rsp need a
SIB byte because 4 in the r/m field means "SIB follows". *)
let modrm_m b ~r ~base ~disp =
u8 b (0x80 lor ((r land 7) lsl 3) lor (base land 7));
if base land 7 = 4 then u8 b 0x24;
i32 b disp
(* [rip + disp32], where the displacement is a relocation the assembler fills
in. modrm mod=00 r/m=101 is the rip-relative form. *)
let modrm_rip b ~r ~sym ~addend =
u8 b (((r land 7) lsl 3) lor 5);
dir b
(Printf.sprintf ".long %s%s - . - 4" sym
(if addend = 0 then "" else Printf.sprintf "+%d" addend))
4
(* ── Instructions ────────────────────────────────────────────────────── *)
type mem = Frame of int | Reg of int * int | Sym of string * int
let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) =
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
List.iter (u8 b) pfx;
(match mm with
| Sym _ -> rex b ~w ~r ~x:0 ~m:0
| _ -> rex b ~w ~r ~x:0 ~m:base);
List.iter (u8 b) op;
match mm with
| Frame d -> modrm_m b ~r ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r ~sym:s ~addend:a
let mov_rr b ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b 0x89; modrm_r b ~r:src ~m:dst
let movabs b ~dst (n : int64) =
rex b ~w:true ~r:0 ~x:0 ~m:dst;
u8 b (0xb8 lor (dst land 7));
u64 b n
let lea b ~dst ~(mm : mem) = mem_op b ~r:dst ~op:[ 0x8d ] ~w:true ~pfx:[] ~mm
(* An integer load of [size] bytes, widened to the full 64-bit register the
way the operand's own signedness says. Everything downstream then works in
64 bits and narrows only at a store, which is what makes one set of
arithmetic encodings cover eight integer types. *)
let load_int b ~dst ~mm ~size ~signed =
match size, signed with
| 8, _ -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:true ~pfx:[] ~mm
| 4, false -> mem_op b ~r:dst ~op:[ 0x8b ] ~w:false ~pfx:[] ~mm
| 4, true -> mem_op b ~r:dst ~op:[ 0x63 ] ~w:true ~pfx:[] ~mm
| 2, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb7 ] ~w:true ~pfx:[] ~mm
| 2, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbf ] ~w:true ~pfx:[] ~mm
| 1, false -> mem_op b ~r:dst ~op:[ 0x0f; 0xb6 ] ~w:true ~pfx:[] ~mm
| 1, true -> mem_op b ~r:dst ~op:[ 0x0f; 0xbe ] ~w:true ~pfx:[] ~mm
| n, _ -> unsupported "integer load of %d bytes" n
let store_int b ~src ~mm ~size =
match size with
| 8 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:true ~pfx:[] ~mm
| 4 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[] ~mm
| 2 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[ 0x66 ] ~mm
| 1 ->
(* The one place a REX byte is needed for its own sake. *)
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
rex ~force:(src >= 4) b ~w:false ~r:src ~x:0 ~m:base;
u8 b 0x88;
(match mm with
| Frame d -> modrm_m b ~r:src ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r:src ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a)
| n -> unsupported "integer store of %d bytes" n
let alu_rr b ~op ~dst ~src =
rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b op; modrm_r b ~r:src ~m:dst
let add_rr b ~dst ~src = alu_rr b ~op:0x01 ~dst ~src
let sub_rr b ~dst ~src = alu_rr b ~op:0x29 ~dst ~src
let and_rr b ~dst ~src = alu_rr b ~op:0x21 ~dst ~src
let or_rr b ~dst ~src = alu_rr b ~op:0x09 ~dst ~src
let xor_rr b ~dst ~src = alu_rr b ~op:0x31 ~dst ~src
let cmp_rr b ~a ~c = alu_rr b ~op:0x39 ~dst:a ~src:c
let imul_rr b ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xaf; modrm_r b ~r:dst ~m:src
let grp1_imm b ~ext ~dst n =
rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0x81; modrm_r b ~r:ext ~m:dst; i32 b n
let add_imm b ~dst n = grp1_imm b ~ext:0 ~dst n
let sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n
let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n
let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst
let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst
let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a
(* cqo then idiv, or xor rdx,rdx then div: the sign of the operands decides
which pair, and getting that wrong is a wrong answer rather than a fault. *)
let cqo b = u8 b 0x48; u8 b 0x99
let idiv_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:7 ~m:src
let div_r b ~src = rex b ~w:true ~r:0 ~x:0 ~m:src; u8 b 0xf7; modrm_r b ~r:6 ~m:src
(* Shifts by cl. The count is masked to the operand width by the hardware,
which is the rule the language already defines (item 15's audit). *)
let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
let setcc b ~cc ~dst =
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
u8 b 0x0f; u8 b (0x90 lor cc); modrm_r b ~r:0 ~m:dst
let movzx8 b ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0xb6; modrm_r b ~r:dst ~m:src
let jmp_lbl b l = u8 b 0xe9; dir b (Printf.sprintf ".long %s - . - 4" l) 4
let jcc_lbl b ~cc l = u8 b 0x0f; u8 b (0x80 lor cc); dir b (Printf.sprintf ".long %s - . - 4" l) 4
let call_sym b s = flush b; dir b (Printf.sprintf "call %s" s) 5
let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm_r b ~r:2 ~m:r
let leave b = u8 b 0xc9
let ret b = u8 b 0xc3
let ud2 b = u8 b 0x0f; u8 b 0x0b
let push_r b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7))
(* rep movsb: rdi, rsi, rcx. Nothing is ever live in a register across a
statement here, so the crudest block copy in the instruction set is also
the correct one, and a struct assignment *is* the copy spec-memory.md
requires. *)
let rep_movsb b = u8 b 0xf3; u8 b 0xa4
let rep_stosb b = u8 b 0xf3; u8 b 0xaa
(* ── SSE ─────────────────────────────────────────────────────────────── *)
let sse_rm b ~pfx ~op ~r ~mm = mem_op b ~r ~op:[ 0x0f; op ] ~w:false ~pfx:[ pfx ] ~mm
let sse_rr b ~pfx ~op ~r ~m =
u8 b pfx; rex b ~w:false ~r ~x:0 ~m; u8 b 0x0f; u8 b op; modrm_r b ~r ~m
let movsd_load b ~dst ~mm = sse_rm b ~pfx:0xf2 ~op:0x10 ~r:dst ~mm
let movsd_store b ~src ~mm = sse_rm b ~pfx:0xf2 ~op:0x11 ~r:src ~mm
let movss_load b ~dst ~mm = sse_rm b ~pfx:0xf3 ~op:0x10 ~r:dst ~mm
let movss_store b ~src ~mm = sse_rm b ~pfx:0xf3 ~op:0x11 ~r:src ~mm
let fload b ~dst ~mm ~f64 = if f64 then movsd_load b ~dst ~mm else movss_load b ~dst ~mm
let fstore b ~src ~mm ~f64 = if f64 then movsd_store b ~src ~mm else movss_store b ~src ~mm
let farith b ~op ~f64 ~dst ~src = sse_rr b ~pfx:(if f64 then 0xf2 else 0xf3) ~op ~r:dst ~m:src
let ucomis b ~f64 ~a ~c =
if f64 then u8 b 0x66;
rex b ~w:false ~r:a ~x:0 ~m:c; u8 b 0x0f; u8 b 0x2e; modrm_r b ~r:a ~m:c
(* Conversions. REX.W selects the 64-bit integer side in each direction. *)
let cvtsi2f b ~f64 ~dst ~src =
u8 b (if f64 then 0xf2 else 0xf3);
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2a; modrm_r b ~r:dst ~m:src
let cvttf2si b ~f64 ~dst ~src =
u8 b (if f64 then 0xf2 else 0xf3);
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x2c; modrm_r b ~r:dst ~m:src
let cvtsd2ss b ~dst ~src = sse_rr b ~pfx:0xf2 ~op:0x5a ~r:dst ~m:src
let cvtss2sd b ~dst ~src = sse_rr b ~pfx:0xf3 ~op:0x5a ~r:dst ~m:src
let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modrm_r b ~r:dst ~m:dst
(* ── Types ───────────────────────────────────────────────────────────── *)
(* [Emit.m] carries the struct and union tables [Emit.lay] reads. Built here
rather than imported so that this module adds no line to [emit.ml]: the
record has no signature hiding it and every field it needs is inert. *)
let layout_ctx (p : Tast.program) : Emit.m =
let structs = Hashtbl.create 16 and unions = Hashtbl.create 16 in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
p.Tast.structs;
List.iter (fun (u : Tast.union) -> Hashtbl.replace unions u.Tast.uname u)
p.Tast.unions;
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; unions;
globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks = false;
dev = false; known = (fun _ -> true); dbg = None; sanitize = false;
nstr = 0; nfi = 0 }
let sizeof md t = fst (Emit.lay md t)
let alignof md t = snd (Emit.lay md t)
(* The one classification this backend makes, and it has two answers rather
than SysV's eight. *)
let is_agg (t : Types.t) =
match t with
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _
| Types.Alloc | Types.Handle _ | Types.Fn _ -> false
| Types.Unit | Types.Never -> false
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
| Types.Pool _ | Types.Option _ | Types.Named _ -> true
| Types.Var v -> unsupported "type variable %s" v
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false
let f64_of (t : Types.t) = match t with Types.Float Types.F32 -> false | _ -> true
(* Signedness for a load and for a comparison. A pointer, a handle and an enum
are each unsigned machine words; [bool] is a zero-extended byte. *)
let signed_of (t : Types.t) =
match t with
| Types.Int k -> Types.signed k
| Types.Enum _ -> true
| _ -> false
(* ── Mangling ────────────────────────────────────────────────────────── *)
(* The same names [emit.ml] gives, so a build made here links against the same
runtime and a disassembly reads with the same symbols. A Flan name can hold
characters an assembler will not take bare, so every symbol is quoted. *)
let asm_sym s = "\"" ^ s ^ "\""
let fsym n = asm_sym ("flan." ^ n)
let gsym n = asm_sym ("flan." ^ n)
(* ── Function context ────────────────────────────────────────────────── *)
type fnctx = {
b : buf;
md : Emit.m;
fnname : 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 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. *)
mutable loops : (string * string) list;
(* The innermost landing pad a transfer found after a call should jump to.
Empty means the function's own transfer exit. *)
mutable pads : string list;
(* 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
(* Bump-allocate a frame temporary and answer its rbp-relative offset. The
offset is negative, so the running total is rounded *up* to the alignment;
rbp is 16-aligned, so that is the alignment the value actually gets. *)
let alloc f size align =
let a = if align <= 1 then 1 else align in
f.frame <- f.frame + (if size <= 0 then 1 else size);
f.frame <- (f.frame + a - 1) / a * a;
if f.frame > f.maxframe then f.maxframe <- f.frame;
-f.frame
let tmp f (t : Types.t) = alloc f (max 1 (sizeof f.md t)) (alignof f.md t)
let ptmp f = alloc f 8 8
(* Temporaries are reclaimed at the end of the expression that made them; the
destination is allocated by the caller and therefore outlives the reset. *)
let scoped f g =
let save = f.frame in
let r = g () in
f.frame <- save;
r
(* ── Moving values ───────────────────────────────────────────────────── *)
(* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else
is its own width, widened on load. *)
let load_scalar f ~reg ~off (t : Types.t) =
if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t)
let store_scalar f ~reg ~off (t : Types.t) =
if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
store_int f.b ~src:reg ~mm:(Frame off) ~size
(* Through a pointer rather than a frame offset: the same two, with the
address already in a register. *)
let load_scalar_at f ~reg ~base ~disp (t : Types.t) =
if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t)
let store_scalar_at f ~reg ~base ~disp (t : Types.t) =
if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t)
else
let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in
store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size
(* n bytes from the address in rsi to the address in rdi. *)
let blockcopy f n =
if n > 0 then begin
movabs f.b ~dst:rcx (Int64.of_int n);
rep_movsb f.b
end
let copy_frames f ~dst ~src n =
if n > 0 then begin
lea f.b ~dst:rdi ~mm:(Frame dst);
lea f.b ~dst:rsi ~mm:(Frame src);
blockcopy f n
end
let zero_frame f ~dst n =
if n > 0 then begin
lea f.b ~dst:rdi ~mm:(Frame dst);
xor_rr f.b ~dst:rax ~src:rax;
movabs f.b ~dst:rcx (Int64.of_int n);
rep_stosb f.b
end
(* ── Constants in .rodata ────────────────────────────────────────────── *)
let rodata_label f =
f.nconst <- f.nconst + 1;
Printf.sprintf ".Lc%s%d" (String.concat "" (String.split_on_char '.' "k")) f.nconst
let escape_bytes s =
String.concat ","
(List.map (fun c -> Printf.sprintf "0x%02x" (Char.code c))
(List.init (String.length s) (String.get s)))
let string_const f s =
let l = rodata_label f in
Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l);
if String.length s > 0 then
Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s));
(* A trailing NUL nobody reads through the length, so that a pointer handed
to C by a shim is still a C string if anything ever treats it as one. *)
Buffer.add_string f.rodata "\t.byte 0x00\n";
l
let float_const f (x : float) ~f64 =
let l = rodata_label f in
if f64 then
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 8\n%s:\n\t.quad 0x%Lx\n" l (Int64.bits_of_float x))
else
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 4\n%s:\n\t.long 0x%lx\n" l (Int32.bits_of_float x));
l

87
spike/backend/hist.ml Normal file
View File

@ -0,0 +1,87 @@
(* Histogram of Tast expr_kind constructors over the reachable program. A
measurement, not a backend: it answers "what would a whole-program x86
build actually have to lower for this input", which is the question that
decides whether whole-program coverage is reachable at all. *)
let tbl : (string, int) Hashtbl.t = Hashtbl.create 64
let bump k =
Hashtbl.replace tbl k (1 + (try Hashtbl.find tbl k with Not_found -> 0))
let name (k : Flan.Tast.expr_kind) =
match k with
| Int _ -> "Int" | Float _ -> "Float" | Bool _ -> "Bool" | Str _ -> "Str"
| Unit -> "Unit" | Zero _ -> "Zero" | Uninit _ -> "Uninit"
| Local _ -> "Local" | Global _ -> "Global" | Prim _ -> "Prim"
| Call _ -> "Call" | FnAddr _ -> "FnAddr" | CallPtr _ -> "CallPtr"
| Do _ -> "Do" | Let _ -> "Let" | If _ -> "If" | While _ -> "While"
| Return _ -> "Return" | Break _ -> "Break" | Continue _ -> "Continue"
| Set _ -> "Set" | Field _ -> "Field" | Addr _ -> "Addr" | Deref _ -> "Deref"
| Make _ -> "Make" | MakeCase _ -> "MakeCase" | CaseField _ -> "CaseField"
| Arr _ -> "Arr" | Some_ _ -> "Some" | None_ -> "None" | Match _ -> "Match"
| UnwrapSome _ -> "UnwrapSome" | Signal _ -> "Signal" | Handled _ -> "Handled"
| RestartCase _ -> "RestartCase" | WithAlloc _ -> "WithAlloc"
| InvokeRestart _ -> "InvokeRestart"
let pname (p : Flan.Tast.prim) =
match p with
| Add -> "Add" | Sub -> "Sub" | Mul -> "Mul" | Div -> "Div" | Rem -> "Rem"
| Eq -> "Eq" | Ne -> "Ne" | Lt -> "Lt" | Le -> "Le" | Gt -> "Gt" | Ge -> "Ge"
| Not -> "Not" | BitAnd -> "BitAnd" | BitOr -> "BitOr" | BitXor -> "BitXor"
| Shl -> "Shl" | Shr -> "Shr" | Len -> "Len" | At -> "At" | Slice -> "Slice"
| Bytes -> "Bytes" | BytesToF64 -> "BytesToF64" | BytesToI64 -> "BytesToI64"
| F64ToBytes -> "F64ToBytes" | I64ToBytes -> "I64ToBytes"
| StrOfBytes -> "StrOfBytes" | U64ToBytes -> "U64ToBytes"
| EscapeBytes -> "EscapeBytes" | WriteStdout -> "WriteStdout" | Exit -> "Exit"
| Argv -> "Argv" | Rt s -> "Rt:" ^ s | SizeOf _ -> "SizeOf"
| AlignOf _ -> "AlignOf" | AddrOf -> "AddrOf" | Cast _ -> "Cast"
let rec ex (e : Flan.Tast.expr) =
bump (name e.e);
match e.e with
| Prim (p, xs) -> bump ("prim/" ^ pname p); List.iter ex xs
| Call (_, xs) | Arr xs -> List.iter ex xs
| Make (_, xs) | MakeCase (_, _, xs) -> List.iter ex xs
| CallPtr (f, xs) -> ex f; List.iter ex xs
| Do xs | Handled (_, xs) -> List.iter ex xs
| Let (bs, body) -> List.iter (fun (_, x) -> ex x) bs; List.iter ex body
| If (a, b, c) -> ex a; ex b; ex c
| While (c, b, l) -> ex c; List.iter ex b; List.iter ex l
| Return (Some x) | Some_ x | Deref x | UnwrapSome x | Field (x, _)
| CaseField (x, _, _) | Signal (_, _, x) -> ex x
| Set (p, x) -> pl p; ex x
| Addr p -> pl p
| Match (x, arms) ->
ex x;
List.iter (fun (a : Flan.Tast.arm) -> List.iter ex a.abody) arms
| RestartCase (cs, x) ->
List.iter (fun (c : Flan.Tast.rclause) -> List.iter ex c.rbody) cs; ex x
| WithAlloc (a, b) -> ex a; List.iter ex b
| InvokeRestart (_, _, xs, _, _, _) -> List.iter ex xs
| _ -> ()
and pl (p : Flan.Tast.place) =
match p with
| Plocal _ -> bump "place/Plocal"
| Pglobal _ -> bump "place/Pglobal"
| Pfield (x, _) -> bump "place/Pfield"; ex x
| Pindex (x, ys) -> bump "place/Pindex"; ex x; List.iter ex ys
| Pderef x -> bump "place/Pderef"; ex x
let () =
let src = Sys.argv.(1) in
let l =
Flan.Load.program ~file:src
(Flan.Parse.program_all (Flan.Reader.read_file src))
in
let p = Flan.Check.program_all l.Flan.Load.decls in
let p, _, _ = Flan.Reach.link l p in
List.iter
(fun (f : Flan.Tast.fn) -> List.iter ex f.body; List.iter ex f.fdefers)
p.Flan.Tast.fns;
List.iter (fun (g : Flan.Tast.global) -> ex g.Flan.Tast.ginit)
p.Flan.Tast.globals;
Printf.printf "%s: %d reachable fns\n" (Filename.basename src)
(List.length p.Flan.Tast.fns);
let rows = Hashtbl.fold (fun k v a -> (k, v) :: a) tbl [] in
let rows = List.sort (fun (a, _) (b, _) -> compare a b) rows in
List.iter (fun (k, v) -> Printf.printf " %-24s %d\n" k v) rows