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

One field list per runtime struct, one spelling per symbol prefix

Browse Source 
The %handler, %restart, %fninfo and %flanframe shapes were written twice:
as LLVM type strings in emit.ml and as hand-computed byte offsets in x86.ml,
with the two %fninfo initialisers spelled a third and fourth time. Emit.Rt
now holds one field list per struct and derives all four — the type string
and the getelementptr index for LLVM, the offset and the size for x86, and
the initialiser for both. The derived numbers were checked against every old
constant before the call sites moved.

The flan. prefixes were spelled in four files, including both backends
hand-writing "flan." ^ name for a DWARF linkage name instead of calling
their own helper. Mangle now holds them unquoted; each backend adds its own
sigil. The ABI markers stay apart on purpose: flan.abi.llvm and flan.abi.x86
differing is what makes the loader refuse a crossed pair.

The float-to-integer cast bounds and the division-check elision policy are
Emit.cast_range and Emit.div_checks. The second is a language decision and
had been byte-identical in both files; the first had drifted cosmetically.

emit and emit --x86 output for all 166 test/programs, at -O0 release, --dev,
--debug and --dev --debug, stdout and stderr, is byte-identical to the
pre-change compiler.
This commit is contained in:
Joseph Ferano 2026-09-20 13:00:52 +07:00
parent 26439dc22e
commit 1829cd43b6
5 changed files with 320 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/dev.ml
View File

@ -2773,7 +2773,7 @@ let render_listing ~sym insns =
Buffer.contents b Buffer.contents b
let asm_of ~obj name = let asm_of ~obj name =
let sym = "flan." ^ name in let sym = Mangle.sym name in
let code, text = let code, text =
run_capture run_capture
(String.concat " " (String.concat " "

278
lib/emit.ml
View File

@ -47,10 +47,12 @@ let rec map_lr f = function
(* ── Names ─────────────────────────────────────────────────────────── *) (* ── Names ─────────────────────────────────────────────────────────── *)
(* Flan names contain -, ?, > and /, so every emitted name is quoted. The (* Flan names contain -, ?, > and /, so every emitted name is quoted. The
[flan.] prefix keeps the Flan [main] from colliding with C's. *) prefix each of these applies is [Mangle]'s, spelled there once for both
backends and for the macro loader; the [@] and the quotes are LLVM's and
are applied here. *)
let quoted s = "\"" ^ s ^ "\"" let quoted s = "\"" ^ s ^ "\""
let fname n = "@" ^ quoted ("flan." ^ n) let fname n = "@" ^ quoted (Mangle.sym n)
let gname n = "@" ^ quoted ("flan." ^ n) let gname n = "@" ^ quoted (Mangle.sym n)
let sname n = "%" ^ quoted n let sname n = "%" ^ quoted n
(* A dev build's redefinable calls go through a cell: a mutable global holding (* A dev build's redefinable calls go through a cell: a mutable global holding
@ -58,7 +60,7 @@ let sname n = "%" ^ quoted n
and every existing call site follows it — which is the whole point, since a and every existing call site follows it — which is the whole point, since a
call bound at link time cannot be made to notice a new body. Release builds call bound at link time cannot be made to notice a new body. Release builds
have no cells and call the symbol directly. *) have no cells and call the symbol directly. *)
let cellname n = "@" ^ quoted ("flan.cell." ^ n) let cellname n = "@" ^ quoted (Mangle.cell n)
(* A name the host was never built with — a defn or a defvar typed in after the (* A name the host was never built with — a defn or a defvar typed in after the
process started — has no symbol to bind to, so it is keyed by string through process started — has no symbol to bind to, so it is keyed by string through
@ -75,8 +77,8 @@ let xfer_param = "%xfer"
let struct_name_of (t : Types.t) = let struct_name_of (t : Types.t) =
match t with Types.Named n -> n | _ -> "a condition" match t with Types.Named n -> n | _ -> "a condition"
let cellptr n = "@" ^ quoted ("flan.cellp." ^ n) let cellptr n = "@" ^ quoted (Mangle.cellptr n)
let globalptr n = "@" ^ quoted ("flan.gp." ^ n) let globalptr n = "@" ^ quoted (Mangle.globalptr n)
(* Which backend built this image. A dev build defines its own marker and a (* Which backend built this image. A dev build defines its own marker and a
redefinition module emits a data relocation against the one it was built redefinition module emits a data relocation against the one it was built
@ -89,6 +91,130 @@ let globalptr n = "@" ^ quoted ("flan.gp." ^ n)
let abi_marker = "flan.abi.llvm" let abi_marker = "flan.abi.llvm"
let abi_marker_sym = "@" ^ quoted abi_marker let abi_marker_sym = "@" ^ quoted abi_marker
(* ── The runtime's own structs ───────────────────────────────────────── *)
(* Four structs that are not Flan types: they are declared in C, in
runtime/flan_rt.c and runtime/flan_dev.c, and both backends have to agree
with that C and with each other about every field. This backend needs the
LLVM type string and the field *index* a [getelementptr] takes; [x86.ml]
needs the byte *offset* and the total size. All four are derived here from
one list per struct, so that adding a field to [flan_restart] in the C is
one edit on this side rather than three.
The rules are C's, which is what makes the derivation legal at all: fields
in declaration order, each at the next offset its own alignment allows, the
whole rounded up to the strictest alignment in it. The general case of that
is [lay_fields] below, over Flan types; these four hold only pointers and
fixed-width integers, so they are measured here without a module context —
which is what lets [x86.ml] ask for an offset before it has one. *)
module Rt = struct
(* Every field any of them has. A pointer is 8 bytes on the one target both
backends emit for; [i32] and [i64] are what the C spells. *)
type kind = Ptr | I32 | I64
type t = { sname : string; fields : (string * kind) list }
let ll_of = function Ptr -> "ptr" | I32 -> "i32" | I64 -> "i64"
let size_of = function Ptr | I64 -> 8 | I32 -> 4
(* A handler frame: the one it displaced, the condition type it matches, and
the lifted function that runs. *)
let handler =
{ sname = "handler"; fields = [ "prev", Ptr; "type", I32; "fn", Ptr ] }
(* A restart frame. The first four fields are what the runtime's own
[flan_restart] declares and their offsets do not move; the rest are §3's
parameter passing, described where the type is written into the header. *)
let restart =
{ sname = "restart";
fields =
[ "prev", Ptr; "name_id", I32; "name", Ptr; "namelen", I64;
"args", Ptr; "arity", I32; "sig_id", I32; "armed", I32;
"sig", Ptr; "siglen", I64 ] }
(* The static description of a function, and the shadow-stack frame that
points at one. Dev builds only (runtime/flan_dev.c). *)
let fninfo =
{ sname = "fninfo";
fields =
[ "name", Ptr; "namelen", I64; "loc", Ptr; "loclen", I64;
"nslots", I32; "slots_fp", I32; "refs_fp", I32 ] }
let flanframe =
{ sname = "flanframe"; fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr ] }
let align_up n a = (n + a - 1) / a * a
(* Size, and the offset of every field, by C's rules. *)
let layout s =
let off = ref 0 and al = ref 1 and rev = ref [] in
List.iter
(fun (n, k) ->
let sz = size_of k in
off := align_up !off sz;
rev := (n, !off) :: !rev;
off := !off + sz;
if sz > !al then al := sz)
s.fields;
align_up !off !al, List.rev !rev
let size s = fst (layout s)
let field s n =
match List.assoc_opt n (snd (layout s)) with
| Some o -> o
| None -> failwith (Printf.sprintf "no field %s in %%%s" n s.sname)
(* The [getelementptr] index of a field, which is this backend's handle on
it — LLVM counts fields where the assembler counts bytes. *)
let index s n =
let rec go i = function
| [] -> failwith (Printf.sprintf "no field %s in %%%s" n s.sname)
| (f, _) :: rest -> if String.equal f n then i else go (i + 1) rest
in
go 0 s.fields
(* The type declaration this file's header carries. *)
let ll_type s =
Printf.sprintf "%%%s = type { %s }" s.sname
(String.concat ", " (List.map (fun (_, k) -> ll_of k) s.fields))
(* An initialised constant of one of them, given one operand per field in
declaration order. Both backends build the same [%fninfo] this way, which
is the whole point: the field list decides the order and the widths, and
neither spelling can be updated without the other. *)
let ll_init s vals =
Printf.sprintf "%%%s { %s }" s.sname
(String.concat ", "
(List.map2 (fun (_, k) v -> ll_of k ^ " " ^ v) s.fields vals))
(* The same constant as assembler directives. All padding is explicit,
inside and at the end, because the assembler adds none: a [.align] before
the label says where the object starts, not how the fields sit in it nor
how long it is, and the next object would otherwise begin inside this
one's tail. Every field is 4 or 8 bytes wide, so a trailing gap is always
a whole number of [.long]s; an interior one is whatever C's rule leaves
and is written as bytes. *)
let asm_init s vals =
let b = Buffer.create 128 in
let gap n = if n > 0 then Buffer.add_string b (Printf.sprintf "\t.zero\t%d\n" n) in
let raw =
List.fold_left2
(fun off (_, k) v ->
let sz = size_of k in
let at = align_up off sz in
gap (at - off);
Buffer.add_string b
(Printf.sprintf "\t%s\t%s\n" (if sz = 8 then ".quad" else ".long") v);
at + sz)
0 s.fields vals
in
for _ = 1 to (size s - raw) / 4 do
Buffer.add_string b "\t.long\t0\n"
done;
Buffer.contents b
end
(* ── Types ─────────────────────────────────────────────────────────── *) (* ── Types ─────────────────────────────────────────────────────────── *)
let rec ll (t : Types.t) = let rec ll (t : Types.t) =
@ -1124,10 +1250,12 @@ let fninfo m (fn : Tast.fn) ~nslots =
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
m.nfi <- m.nfi + 1; m.nfi <- m.nfi + 1;
Buffer.add_string m.strs Buffer.add_string m.strs
(Printf.sprintf (Printf.sprintf "%s = private unnamed_addr constant %s\n" id
"%s = private unnamed_addr constant %%fninfo { ptr %s, i64 %d, ptr %s, i64 %d, i32 %d, i32 %d, i32 %d }\n" (Rt.ll_init Rt.fninfo
id nid nlen lid llen nslots (slot_fingerprint fn) [ nid; string_of_int nlen; lid; string_of_int llen;
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn)); string_of_int nslots; string_of_int (slot_fingerprint fn);
string_of_int
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn) ]));
id id
(* ── Bounds checks ───────────────────────────────────────────────────── *) (* ── Bounds checks ───────────────────────────────────────────────────── *)
@ -1224,6 +1352,47 @@ let widen f (k : Types.ikind) v =
(* The most negative value of a signed kind, as the decimal LLVM wants. *) (* The most negative value of a signed kind, as the decimal LLVM wants. *)
let int_min k = Int64.neg (Int64.shift_left 1L (Types.bits k - 1)) let int_min k = Int64.neg (Int64.shift_left 1L (Types.bits k - 1))
(* Which of the two arithmetic guards a division actually needs. This is a
decision about the language and not about either instruction set, so both
backends ask it here: a divisor that is a literal the test cannot fire on
carries no test at all, and (/ x 2) — the common case — is then exactly the
divide it reads as. The overflow test exists only for signed kinds, where
[min / -1] is the one pair whose quotient does not fit.
A literal the checker folded is what [lit] carries; [None] is anything else,
including a constant the folder could not see, and pays both tests. *)
let div_checks ~lit (k : Types.ikind) =
let need_zero = match lit with Some n -> Int64.equal n 0L | None -> true in
let need_ovf =
Types.signed k
&& (match lit with Some n -> Int64.equal n (-1L) | None -> true)
in
need_zero, need_ovf
(* The bounds a float-to-integer cast is checked against, for both backends.
The pair of floats is the open interval the source value has to be in, and
both ends are exact in a double: a power of two is, and [ldexp] of it is
the only spelling that cannot round. The high end is the first value
*above* the range rather than the last one in it, because 2^63 - 1 is not
representable and 2^63 is — so the test is [< hi] and never [<= hi].
The pair of integers is the range the failure message reports, which is the
integer range itself: what a programmer wants told is "u8 holds 0 to 255",
not the two floats the guard compared. *)
let cast_range (k : Types.ikind) =
let n = Types.bits k in
let signed = Types.signed k in
let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in
let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in
let lo_i = if signed then int_min k else 0L in
let hi_i =
if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L
else if n = 64 then -1L
else Int64.sub (Int64.shift_left 1L n) 1L
in
lo_f, hi_f, lo_i, hi_i
(* A divide or a remainder. [is_rem] only picks which pair of codes is used; (* A divide or a remainder. [is_rem] only picks which pair of codes is used;
the tests are identical, because `srem` overflows on exactly the operands the tests are identical, because `srem` overflows on exactly the operands
`sdiv` does — the intermediate quotient is the thing that does not fit. `sdiv` does — the intermediate quotient is the thing that does not fit.
@ -1234,11 +1403,7 @@ let int_min k = Int64.neg (Int64.shift_left 1L (Types.bits k - 1))
let check_div f ~guard loc ~is_rem (k : Types.ikind) ~lit a b = let check_div f ~guard loc ~is_rem (k : Types.ikind) ~lit a b =
if f.md.checks then begin if f.md.checks then begin
let ty = ll (Types.Int k) in let ty = ll (Types.Int k) in
let need_zero = match lit with Some n -> Int64.equal n 0L | None -> true in let need_zero, need_ovf = div_checks ~lit k in
let need_ovf =
Types.signed k
&& (match lit with Some n -> Int64.equal n (-1L) | None -> true)
in
if need_zero || need_ovf then begin if need_zero || need_ovf then begin
(* [false] rather than an emitted instruction when a test is elided: an (* [false] rather than an emitted instruction when a test is elided: an
LLVM operand may be a constant, and the [or] and the [select] below LLVM operand may be a constant, and the [or] and the [select] below
@ -1310,18 +1475,7 @@ let check_cast f ~guard loc (src : Types.fkind) (k : Types.ikind) v =
ins f "%s = fpext float %s to double" t v; ins f "%s = fpext float %s to double" t v;
t t
in in
let n = Types.bits k in let lo_f, hi_f, lo_i, hi_i = cast_range k in
let signed = Types.signed k in
(* The first value below the range and the first value above it, and then
the range the condition reports, which is the last value *in* it. *)
let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in
let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in
let lo_i = if signed then int_min k else 0L in
let hi_i =
if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L
else if n = 64 then -1L
else Int64.sub (Int64.shift_left 1L n) 1L
in
(* LLVM takes a double constant as the hex of its bits, which is the only (* LLVM takes a double constant as the hex of its bits, which is the only
spelling that cannot lose anything on the way through. *) spelling that cannot lose anything on the way through. *)
let dbl x = Printf.sprintf "0x%016Lx" (Int64.bits_of_float x) in let dbl x = Printf.sprintf "0x%016Lx" (Int64.bits_of_float x) in
@ -1579,11 +1733,11 @@ and value_at f (e : Tast.expr) : string =
collision between two different signatures harmless in practice — and collision between two different signatures harmless in practice — and
it is also the cheaper half. *) it is also the cheaper half. *)
let arity = fresh f in let arity = fresh f in
ins f "%s = load i32, ptr %s" arity (restart_field f t 5); ins f "%s = load i32, ptr %s" arity (restart_field f t "arity");
let a_ok = fresh f in let a_ok = fresh f in
ins f "%s = icmp eq i32 %s, %d" a_ok arity (List.length args); ins f "%s = icmp eq i32 %s, %d" a_ok arity (List.length args);
let want = fresh f in let want = fresh f in
ins f "%s = load i32, ptr %s" want (restart_field f t 6); ins f "%s = load i32, ptr %s" want (restart_field f t "sig_id");
let s_ok = fresh f in let s_ok = fresh f in
ins f "%s = icmp eq i32 %s, %d" s_ok want sg_id; ins f "%s = icmp eq i32 %s, %d" s_ok want sg_id;
let both = fresh f in let both = fresh f in
@ -1593,9 +1747,9 @@ and value_at f (e : Tast.expr) : string =
(* What the frame says it takes is read off the frame, because only the (* What the frame says it takes is read off the frame, because only the
frame knows; what was given is this call site's own spelling. *) frame knows; what was given is this call site's own spelling. *)
let wp = fresh f in let wp = fresh f in
ins f "%s = load ptr, ptr %s" wp (restart_field f t 8); ins f "%s = load ptr, ptr %s" wp (restart_field f t "sig");
let wl = fresh f in let wl = fresh f in
ins f "%s = load i64, ptr %s" wl (restart_field f t 9); ins f "%s = load i64, ptr %s" wl (restart_field f t "siglen");
let gid, gn = string_bytes f.md sg in let gid, gn = string_bytes f.md sg in
ins f ins f
"call void @flan_restart_args_fail(ptr %s, i64 %d, ptr %s, i64 %d, \ "call void @flan_restart_args_fail(ptr %s, i64 %d, ptr %s, i64 %d, \
@ -1605,7 +1759,7 @@ and value_at f (e : Tast.expr) : string =
signature just agreed on. *) signature just agreed on. *)
if vals <> [] then begin if vals <> [] then begin
let buf = fresh f in let buf = fresh f in
ins f "%s = load ptr, ptr %s" buf (restart_field f t 4); ins f "%s = load ptr, ptr %s" buf (restart_field f t "args");
let sty = let sty =
"{ " ^ String.concat ", " (List.map (fun (_, ty) -> ll ty) vals) ^ " }" "{ " ^ String.concat ", " (List.map (fun (_, ty) -> ll ty) vals) ^ " }"
in in
@ -1616,7 +1770,7 @@ and value_at f (e : Tast.expr) : string =
p sty buf i; p sty buf i;
ins f "store %s %s, ptr %s" (ll ty) v p) ins f "store %s %s, ptr %s" (ll ty) v p)
vals; vals;
ins f "store i32 1, ptr %s" (restart_field f t 7) ins f "store i32 1, ptr %s" (restart_field f t "armed")
end; end;
ins f "store ptr %s, ptr %s" t xfer_param; ins f "store ptr %s, ptr %s" t xfer_param;
term f "br label %%%s" (current_pad f); term f "br label %%%s" (current_pad f);
@ -1947,12 +2101,12 @@ and emit_handled f frames body =
(fun (h : Tast.hframe) -> (fun (h : Tast.hframe) ->
let slot = alloca_raw f "%handler" in let slot = alloca_raw f "%handler" in
let ty = fresh f in let ty = fresh f in
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 1" ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 %d"
ty slot; ty slot (Rt.index Rt.handler "type");
ins f "store i32 %d, ptr %s" h.Tast.htype ty; ins f "store i32 %d, ptr %s" h.Tast.htype ty;
let fp = fresh f in let fp = fresh f in
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 2" ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 %d"
fp slot; fp slot (Rt.index Rt.handler "fn");
(* The clause's body address, deliberately, and not a cell load: (* The clause's body address, deliberately, and not a cell load:
plan.org makes a top-level function value a stable trampoline over plan.org makes a top-level function value a stable trampoline over
its cell, but a handler frame is not one — nothing can name it, and its cell, but a handler frame is not one — nothing can name it, and
@ -2008,9 +2162,10 @@ and emit_handled f frames body =
and args_type (c : Tast.rclause) = and args_type (c : Tast.rclause) =
"{ " ^ String.concat ", " (List.map (fun (_, t) -> ll t) c.Tast.rparams) ^ " }" "{ " ^ String.concat ", " (List.map (fun (_, t) -> ll t) c.Tast.rparams) ^ " }"
and restart_field f slot i = and restart_field f slot name =
let p = fresh f in let p = fresh f in
ins f "%s = getelementptr inbounds %%restart, ptr %s, i32 0, i32 %d" p slot i; ins f "%s = getelementptr inbounds %%restart, ptr %s, i32 0, i32 %d" p slot
(Rt.index Rt.restart name);
p p
(* (with-allocator A BODY...) — spec-memory.md's "Allocators". (* (with-allocator A BODY...) — spec-memory.md's "Allocators".
@ -2076,33 +2231,33 @@ and emit_restart_case f ty clauses body =
map_lr map_lr
(fun (c : Tast.rclause) -> (fun (c : Tast.rclause) ->
let slot = alloca_raw f "%restart" in let slot = alloca_raw f "%restart" in
ins f "store i32 %d, ptr %s" c.Tast.rname_id (restart_field f slot 1); ins f "store i32 %d, ptr %s" c.Tast.rname_id (restart_field f slot "name_id");
(* The name itself, beside the hash. A hash is all that matching (* The name itself, beside the hash. A hash is all that matching
needs, but a break loop has to *show* someone their choices, and needs, but a break loop has to *show* someone their choices, and
nothing at run time can turn a hash back into a name. *) nothing at run time can turn a hash back into a name. *)
let sid, slen = string_bytes f.md c.Tast.rname in let sid, slen = string_bytes f.md c.Tast.rname in
ins f "store ptr %s, ptr %s" sid (restart_field f slot 2); ins f "store ptr %s, ptr %s" sid (restart_field f slot "name");
ins f "store i64 %d, ptr %s" slen (restart_field f slot 3); ins f "store i64 %d, ptr %s" slen (restart_field f slot "namelen");
(* §3's signature, which every frame carries whether it takes (* §3's signature, which every frame carries whether it takes
parameters or not: an [invoke-restart] compares against whatever parameters or not: an [invoke-restart] compares against whatever
frame the name found, and a clause taking none has to be able to frame the name found, and a clause taking none has to be able to
refuse arguments as loudly as one taking two of the wrong type. *) refuse arguments as loudly as one taking two of the wrong type. *)
ins f "store i32 %d, ptr %s" ins f "store i32 %d, ptr %s"
(List.length c.Tast.rparams) (restart_field f slot 5); (List.length c.Tast.rparams) (restart_field f slot "arity");
ins f "store i32 %d, ptr %s" c.Tast.rsig_id (restart_field f slot 6); ins f "store i32 %d, ptr %s" c.Tast.rsig_id (restart_field f slot "sig_id");
let gid, glen = string_bytes f.md c.Tast.rsig in let gid, glen = string_bytes f.md c.Tast.rsig in
ins f "store ptr %s, ptr %s" gid (restart_field f slot 8); ins f "store ptr %s, ptr %s" gid (restart_field f slot "sig");
ins f "store i64 %d, ptr %s" glen (restart_field f slot 9); ins f "store i64 %d, ptr %s" glen (restart_field f slot "siglen");
let args = let args =
if c.Tast.rparams = [] then None if c.Tast.rparams = [] then None
else begin else begin
let buf = alloca_raw f (args_type c) in let buf = alloca_raw f (args_type c) in
ins f "store ptr %s, ptr %s" buf (restart_field f slot 4); ins f "store ptr %s, ptr %s" buf (restart_field f slot "args");
(* Nothing has filled it in yet. Whoever aims a transfer at this (* Nothing has filled it in yet. Whoever aims a transfer at this
frame without going through an [invoke-restart] — the break frame without going through an [invoke-restart] — the break
loop, today — leaves this zero, and the clause traps rather loop, today — leaves this zero, and the clause traps rather
than running on values no one supplied. *) than running on values no one supplied. *)
ins f "store i32 0, ptr %s" (restart_field f slot 7); ins f "store i32 0, ptr %s" (restart_field f slot "armed");
Some buf Some buf
end end
in in
@ -2151,7 +2306,7 @@ and emit_restart_case f ty clauses body =
| None -> () | None -> ()
| Some buf -> | Some buf ->
let armed = fresh f in let armed = fresh f in
ins f "%s = load i32, ptr %s" armed (restart_field f slot 7); ins f "%s = load i32, ptr %s" armed (restart_field f slot "armed");
let ok = fresh f in let ok = fresh f in
ins f "%s = icmp ne i32 %s, 0" ok armed; ins f "%s = icmp ne i32 %s, 0" ok armed;
(* Aimed here by something that supplied no arguments — there is no such (* Aimed here by something that supplied no arguments — there is no such
@ -3021,9 +3176,13 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
" prev); " prev);
List.iter List.iter
(fun line -> Buffer.add_string f.allocas (" " ^ line ^ "\n")) (fun line -> Buffer.add_string f.allocas (" " ^ line ^ "\n"))
[ "%frame.i = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 1"; [ Printf.sprintf
"%%frame.i = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "info");
Printf.sprintf "store ptr %s, ptr %%frame.i" info; Printf.sprintf "store ptr %s, ptr %%frame.i" info;
"%frame.s = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 2"; Printf.sprintf
"%%frame.s = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "slots");
Printf.sprintf "store ptr %s, ptr %%frame.s" Printf.sprintf "store ptr %s, ptr %%frame.s"
(match f.slotv with Some v -> v | None -> "null"); (match f.slotv with Some v -> v | None -> "null");
"store ptr %frame, ptr @flan_frame_head" ]; "store ptr %frame, ptr @flan_frame_head" ];
@ -3093,8 +3252,8 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
in in
dput d sub dput d sub
(Printf.sprintf (Printf.sprintf
"distinct !DISubprogram(name: \"%s\", linkageName: \"flan.%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})" "distinct !DISubprogram(name: \"%s\", linkageName: \"%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})"
(dstr fn.Tast.name) (dstr fn.Tast.name) file file f.dline sty f.dline (dstr fn.Tast.name) (dstr (Mangle.sym fn.Tast.name)) file file f.dline sty f.dline
d.dcu d.dcu
(String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars))); (String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars)));
at_loc f fn.Tast.floc at_loc f fn.Tast.floc
@ -3367,7 +3526,7 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
%map = type { ptr, i64, i64, ptr, i64 } %map = type { ptr, i64, i64, ptr, i64 }
; A handler frame: the one it displaced, the condition type it matches, and ; A handler frame: the one it displaced, the condition type it matches, and
; the lifted function that runs. Allocated on the establishing frame's stack. ; the lifted function that runs. Allocated on the establishing frame's stack.
%handler = type { ptr, i32, ptr } |} ^ Rt.ll_type Rt.handler ^ {|
; A restart frame: the one it displaced and the name it offers. There is no ; A restart frame: the one it displaced and the name it offers. There is no
; target field, because the frame's own address *is* the target — which makes ; target field, because the frame's own address *is* the target — which makes
; a transfer's aim exact, and makes re-entering a restart-case work with ; a transfer's aim exact, and makes re-entering a restart-case work with
@ -3379,13 +3538,12 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
; filled the buffer in, and that spelling itself for the message when the two ; filled the buffer in, and that spelling itself for the message when the two
; ends disagree. The first four fields are what the runtime's own ; ends disagree. The first four fields are what the runtime's own
; [flan_restart] declares and their offsets do not move. ; [flan_restart] declares and their offsets do not move.
%restart = type { ptr, i32, ptr, i64, ptr, i32, i32, i32, ptr, i64 } |} ^ Rt.ll_type Rt.restart ^ {|
; A shadow-stack frame and the static description of the function that pushed ; A shadow-stack frame and the static description of the function that pushed
; it (runtime/flan_dev.c). Dev builds only: [emit_fn] pushes one on entry and ; it (runtime/flan_dev.c). Dev builds only: [emit_fn] pushes one on entry and
; every [ret] restores the head, the transfer path included. A release build ; every [ret] restores the head, the transfer path included. A release build
; emits neither, and the head below is then a symbol nothing in the .ll names. ; emits neither, and the head below is then a symbol nothing in the .ll names.
%fninfo = type { ptr, i64, ptr, i64, i32, i32, i32 } |} ^ Rt.ll_type Rt.fninfo ^ "\n" ^ Rt.ll_type Rt.flanframe ^ {|
%flanframe = type { ptr, ptr, ptr }
@flan_frame_head = external global ptr @flan_frame_head = external global ptr
declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg) declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg)
@ -3908,7 +4066,7 @@ let macro_thunk m (fn : Tast.fn) =
\ store %s %%r, ptr %%out\n\ \ store %s %%r, ptr %%out\n\
\ ret void\n\ \ ret void\n\
}\n\n" }\n\n"
(quoted ("flan.macro." ^ name)) (quoted (Mangle.macro name))
ret (fname name) ret) ret (fname name) ret)
(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or (* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
@ -4167,7 +4325,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
let t = fresh () in let t = fresh () in
Buffer.add_string b Buffer.add_string b
(Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n" (Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n"
t (cstring m ("flan." ^ f.Tast.name)) t (cellptr f.Tast.name))) t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
new_fns; new_fns;
List.iter List.iter
(fun (g : Tast.global) -> (fun (g : Tast.global) ->
@ -4204,7 +4362,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
(Printf.sprintf (Printf.sprintf
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \ " %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \
store ptr %s, ptr %s\n" store ptr %s, ptr %s\n"
t (cstring m ("flan." ^ g.Tast.gname)) (ll g.Tast.gty) init t t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
(globalptr g.Tast.gname))) (globalptr g.Tast.gname)))
new_globals; new_globals;
(* A constant whose value the checker never consumed is just bytes in the (* A constant whose value the checker never consumed is just bytes in the

2
lib/macro.ml
View File

@ -294,7 +294,7 @@ let compile (names : string list) (extra : Form.t list) : loaded =
end; end;
let handle = Dynload.dl_open out in let handle = Dynload.dl_open out in
{ handle; { handle;
fns = List.map (fun n -> (n, Dynload.dl_sym handle ("flan.macro." ^ n))) names } fns = List.map (fun n -> (n, Dynload.dl_sym handle (Mangle.macro n))) names }
(* ── Where the call site is ──────────────────────────────────────── (* ── Where the call site is ────────────────────────────────────────
The one thing a macro cannot find out for itself and the one it needs to The one thing a macro cannot find out for itself and the one it needs to

42
lib/mangle.ml Normal file
View File

@ -0,0 +1,42 @@
(* The symbol names a Flan build puts into an object, spelled once.
Both backends emit the same names — that is not a nicety, it is the link:
an [--x86] host and a redefinition module built by LLVM bind against each
other, so [@"flan.cell.<n>"] has to be byte-for-byte the same string on
both sides or the dlopen fails and the piece served nothing. The macro
loader and the daemon's disassembler look up the same names from outside
the backends entirely.
So the prefixes live here, unquoted and without a sigil. Quoting is each
backend's own — LLVM writes [@"..."], the assembler writes ["..."] — and a
Flan name holds -, ?, > and /, which is why every emitted name is quoted
at all. This module only decides *which string* is quoted.
Not here: the ABI marker. [Emit.abi_marker] is ["flan.abi.llvm"] and
[X86.abi_marker] is ["flan.abi.x86"], and the two must stay distinct —
a crossed pair is refused at [dlopen] precisely because the marker one
image defines is not the one the other references. Sharing that string
would delete the mechanism. *)
(* The prefix itself. It keeps the Flan [main] from colliding with C's, and
it is what makes every Flan symbol recognisable in a disassembly. *)
let prefix = "flan."
(* A function or a global. One namespace, because the language has one: a
[defn] and a [defvar] cannot share a name, so nothing here has to keep
them apart. The compiler's own names go through this too — [.init-globals]
and [.init-data] start with a dot no reader token can produce. *)
let sym n = prefix ^ n
(* A dev build's indirection cell: a mutable global holding the address of the
function that is currently this name's body. *)
let cell n = prefix ^ "cell." ^ n
(* The two module-local caches a name the host was never built with is reached
through — one for a function, one for a global. *)
let cellptr n = prefix ^ "cellp." ^ n
let globalptr n = prefix ^ "gp." ^ n
(* A compiled macro's entry point, which the expander dlsyms by this name out
of the module [Build.macro_module] wrote. *)
let macro n = prefix ^ "macro." ^ n

111
lib/x86.ml
View File

@ -510,11 +510,13 @@ let signed_of (t : Types.t) =
(* ── Mangling ────────────────────────────────────────────────────────── *) (* ── Mangling ────────────────────────────────────────────────────────── *)
(* The same names [emit.ml] gives, so a build made here links against the same (* 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 runtime and a disassembly reads with the same symbols. That agreement is
characters an assembler will not take bare, so every symbol is quoted. *) [Mangle]'s, which holds the prefixes for both backends; the quotes are this
one's, because a Flan name can hold characters an assembler will not take
bare. *)
let asm_sym s = "\"" ^ s ^ "\"" let asm_sym s = "\"" ^ s ^ "\""
let fsym n = asm_sym ("flan." ^ n) let fsym n = asm_sym (Mangle.sym n)
let gsym n = asm_sym ("flan." ^ n) let gsym n = asm_sym (Mangle.sym n)
(* The indirection cell: a mutable global holding the address of the function (* The indirection cell: a mutable global holding the address of the function
that is currently this name's body. Spelled exactly as [Emit.cellname] that is currently this name's body. Spelled exactly as [Emit.cellname]
@ -522,7 +524,7 @@ let gsym n = asm_sym ("flan." ^ n)
redefinition module is still built by LLVM, and it binds redefinition module is still built by LLVM, and it binds
[@"flan.cell.<n>" = external global ptr] against whatever built the host. [@"flan.cell.<n>" = external global ptr] against whatever built the host.
Byte-for-byte or the link fails and the piece served nothing. *) Byte-for-byte or the link fails and the piece served nothing. *)
let csym n = asm_sym ("flan.cell." ^ n) let csym n = asm_sym (Mangle.cell n)
(* The marker that says which backend built an image, and it is the whole of (* The marker that says which backend built an image, and it is the whole of
the answer to the one way these two backends can be mixed and be wrong. the answer to the one way these two backends can be mixed and be wrong.
@ -1043,12 +1045,15 @@ let fninfo f (fn : Tast.fn) ~nslots =
let l = rodata_label f in let l = rodata_label f in
Buffer.add_string f.rodata Buffer.add_string f.rodata
(Printf.sprintf (Printf.sprintf
"\t.section\t.data.rel.ro,\"aw\"\n\t.align 8\n%s:\n\ "\t.section\t.data.rel.ro,\"aw\"\n\t.align 8\n%s:\n%s\t.section\t.rodata\n"
\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\ l
\t.long\t%d\n\t.long\t%d\n\t.long\t%d\n\t.long\t0\n\ (Emit.Rt.asm_init Emit.Rt.fninfo
\t.section\t.rodata\n" [ nlbl; string_of_int nlen; llbl; string_of_int llen;
l nlbl nlen llbl llen nslots (Emit.slot_fingerprint fn) string_of_int nslots;
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem f.md.Emit.globals) fn)); string_of_int (Emit.slot_fingerprint fn);
string_of_int
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem f.md.Emit.globals)
fn) ]));
l l
(* The store that says "this slot is bound now", and it is the address rather (* The store that says "this slot is bound now", and it is the address rather
@ -1415,30 +1420,32 @@ let agg_tmp f (ty : Types.t) =
(* ── The runtime's two dynamic stacks ────────────────────────────────── *) (* ── The runtime's two dynamic stacks ────────────────────────────────── *)
(* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the (* [emit.ml]'s [%handler] and [%restart] types, measured in bytes rather than
same rules the runtime's own structs get, and the same [Emit.lay] applies to in fields, which is the only difference between what that backend needs of
everything else. Both live as frame temporaries of the function that them and what this one does. The field lists are [Emit.Rt]'s, shared so
establishes them, which is the point: the *address* of a frame is the that a field added to [flan_restart] in the C moves the offsets here
identity a transfer carries, so re-entering the same restart-case gets a without anyone's remembering to retype them; the rules are C's, the same
different one and a module loaded later cannot collide with it. *) ones [Emit.lay] applies to everything else.
(* { ptr prev, i32 type_id, ptr fn } *) Both live as frame temporaries of the function that establishes them, which
let h_size = 24 is the point: the *address* of a frame is the identity a transfer carries,
let h_type = 8 so re-entering the same restart-case gets a different one and a module
let h_fn = 16 loaded later cannot collide with it. *)
let h_size = Emit.Rt.size Emit.Rt.handler
let h_type = Emit.Rt.field Emit.Rt.handler "type"
let h_fn = Emit.Rt.field Emit.Rt.handler "fn"
(* { ptr prev, i32 name_id, ptr name, i64 namelen, ptr args, let r_size = Emit.Rt.size Emit.Rt.restart
i32 arity, i32 sig_id, i32 armed, ptr sig, i64 siglen } *) let r_field = Emit.Rt.field Emit.Rt.restart
let r_size = 72 let r_name_id = r_field "name_id"
let r_name_id = 8 let r_name = r_field "name"
let r_name = 16 let r_namelen = r_field "namelen"
let r_namelen = 24 let r_args = r_field "args"
let r_args = 32 let r_arity = r_field "arity"
let r_arity = 40 let r_sig_id = r_field "sig_id"
let r_sig_id = 44 let r_armed = r_field "armed"
let r_armed = 48 let r_sig = r_field "sig"
let r_sig = 56 let r_siglen = r_field "siglen"
let r_siglen = 64
(* ── The calling convention, as the header states it ─────────────────── *) (* ── The calling convention, as the header states it ─────────────────── *)
@ -2522,16 +2529,10 @@ and check_cast f (loc : Loc.t) (src : Types.fkind) (k : Types.ikind) =
"The range check on a float-to-integer cast. Two compares, written in the \ "The range check on a float-to-integer cast. Two compares, written in the \
directions that make a NaN fail both of them."; directions that make a NaN fail both of them.";
let f64 = (src = Types.F64) in let f64 = (src = Types.F64) in
let n = Types.bits k in (* The same four bounds [emit.ml] compares against, from the same place:
let signed = Types.signed k in the interval is the type's and both backends have to refuse the same
let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in values of it. Only the instructions below are this file's. *)
let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in let lo_f, hi_f, lo_i, hi_i = Emit.cast_range k in
let lo_i = if signed then Int64.neg (Int64.shift_left 1L (n - 1)) else 0L in
let hi_i =
if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L
else if n = 64 then -1L
else Int64.sub (Int64.shift_left 1L n) 1L
in
let klo = float_const f lo_f ~f64 and khi = float_const f hi_f ~f64 in let klo = float_const f lo_f ~f64 and khi = float_const f hi_f ~f64 in
scoped f (fun () -> scoped f (fun () ->
let so = ptmp f and sa = ptmp f and sb = ptmp f in let so = ptmp f and sa = ptmp f and sb = ptmp f in
@ -3493,7 +3494,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
if md.Emit.dev then begin if md.Emit.dev then begin
if nslots > 0 && Array.exists (fun n -> n <> None) fn.Tast.snames then if nslots > 0 && Array.exists (fun n -> n <> None) fn.Tast.snames then
f.dslotv <- Some (alloc f (8 * nslots) 8); f.dslotv <- Some (alloc f (8 * nslots) 8);
f.dframe <- Some (alloc f 24 8) f.dframe <- Some (alloc f (Emit.Rt.size Emit.Rt.flanframe) 8)
end; end;
f.retlbl <- new_label f "ret"; f.retlbl <- new_label f "ret";
f.xfer_lbl <- new_label f "xfer"; f.xfer_lbl <- new_label f "xfer";
@ -3599,11 +3600,15 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
load_int f.b ~dst:rax ~mm:(lmem f head ~scratch:r11) ~size:8 ~signed:false; load_int f.b ~dst:rax ~mm:(lmem f head ~scratch:r11) ~size:8 ~signed:false;
store_int f.b ~src:rax ~mm:(Frame fr) ~size:8; store_int f.b ~src:rax ~mm:(Frame fr) ~size:8;
addr_into f ~reg:rax (Lg (fninfo f fn ~nslots:(if f.dslotv = None then 0 else nslots), 0)); addr_into f ~reg:rax (Lg (fninfo f fn ~nslots:(if f.dslotv = None then 0 else nslots), 0));
store_int f.b ~src:rax ~mm:(Frame (fr + 8)) ~size:8; store_int f.b
~src:rax ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "info"))
~size:8;
(match f.dslotv with (match f.dslotv with
| Some sv -> lea f.b ~dst:rax ~mm:(Frame sv) | Some sv -> lea f.b ~dst:rax ~mm:(Frame sv)
| None -> xor_rr f.b ~dst:rax ~src:rax); | None -> xor_rr f.b ~dst:rax ~src:rax);
store_int f.b ~src:rax ~mm:(Frame (fr + 16)) ~size:8; store_int f.b
~src:rax ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "slots"))
~size:8;
lea f.b ~dst:rax ~mm:(Frame fr); lea f.b ~dst:rax ~mm:(Frame fr);
store_int f.b ~src:rax ~mm:(lmem f head ~scratch:r11) ~size:8; store_int f.b ~src:rax ~mm:(lmem f head ~scratch:r11) ~size:8;
(* The parameters are bound before the body starts, so they are recorded (* The parameters are bound before the body starts, so they are recorded
@ -3869,8 +3874,8 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
this backend's rule only while this was the only backend that ran this backend's rule only while this was the only backend that ran
initialisers, and a refusal that is about the language belongs where both initialisers, and a refusal that is about the language belongs where both
backends meet it. *) backends meet it. *)
let data_sym = "\"flan..init-data\"" let data_sym = asm_sym (Mangle.sym ".init-data")
let init_sym = "\"flan..init-globals\"" let init_sym = asm_sym (Mangle.sym ".init-globals")
(* ── C's main ────────────────────────────────────────────────────────── *) (* ── C's main ────────────────────────────────────────────────────────── *)
@ -4275,7 +4280,7 @@ let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend =
"\t.uleb128 2\n\t.asciz\t\"%s\"\n\t.asciz\t\"%s\"\n\ "\t.uleb128 2\n\t.asciz\t\"%s\"\n\t.asciz\t\"%s\"\n\
\t.uleb128 %d\n\t.uleb128 %d\n\t.quad\t%s\n\t.quad\t%s - %s\n" \t.uleb128 %d\n\t.uleb128 %d\n\t.quad\t%s\n\t.quad\t%s - %s\n"
(asm_str s.sname) (asm_str s.sname)
(asm_str ("flan." ^ s.sname)) (asm_str (Mangle.sym s.sname))
s.sfile s.sline s.ssym s.send s.ssym)) s.sfile s.sline s.ssym s.send s.ssym))
(List.rev dw.dsubs); (List.rev dw.dsubs);
Buffer.add_string out "\t.byte\t0\n.Ldwinfo_end:\n"; Buffer.add_string out "\t.byte\t0\n.Ldwinfo_end:\n";
@ -4658,8 +4663,8 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
the key is [csym]; a global is reached by its own name, so it is [gsym]. the key is [csym]; a global is reached by its own name, so it is [gsym].
The two can never collide, because a function and a global cannot share a The two can never collide, because a function and a global cannot share a
name and [gsym] and [fsym] are the same string. *) name and [gsym] and [fsym] are the same string. *)
let cellp n = asm_sym ("flan.cellp." ^ n) let cellp n = asm_sym (Mangle.cellptr n)
and gp n = asm_sym ("flan.gp." ^ n) in and gp n = asm_sym (Mangle.globalptr n) in
let slots = Hashtbl.create 8 in let slots = Hashtbl.create 8 in
List.iter (fun (f : Tast.fn) -> List.iter (fun (f : Tast.fn) ->
Hashtbl.replace slots (csym f.Tast.name) (cellp f.Tast.name)) new_fns; Hashtbl.replace slots (csym f.Tast.name) (cellp f.Tast.name)) new_fns;
@ -4736,14 +4741,14 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
List.iter List.iter
(fun (fn : Tast.fn) -> (fun (fn : Tast.fn) ->
cstr ("flan." ^ fn.Tast.name); cstr (Mangle.sym fn.Tast.name);
xor_rr f.b ~dst:rax ~src:rax; xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dev_cell"; call_sym f.b "flan_dev_cell";
store_int f.b ~src:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8) store_int f.b ~src:rax ~mm:(Sym (cellp fn.Tast.name, 0)) ~size:8)
new_fns; new_fns;
List.iter List.iter
(fun ((g : Tast.global), l, size, _) -> (fun ((g : Tast.global), l, size, _) ->
cstr ("flan." ^ g.Tast.gname); cstr (Mangle.sym g.Tast.gname);
movabs f.b ~dst:rsi (Int64.of_int size); movabs f.b ~dst:rsi (Int64.of_int size);
(match l with (match l with
| Some l -> lea f.b ~dst:rdx ~mm:(Sym (l, 0)) | Some l -> lea f.b ~dst:rdx ~mm:(Sym (l, 0))