Joseph Ferano
22cc0bc1c2
Editing a defvar or a defn is a symbol the host exports. Adding one is not: there is nothing to bind to and ELF cannot grow a symbol. runtime/flan_dev.c is the two lookups that cover it - flan_dev_cell for a new function's cell, flan_dev_global for a new global's storage - both idempotent, so the second module to mention a name gets what the first one got. That is the whole point: two modules with their own copy of a new function would each call their own, and redefining it would update one of them. The compiler picks per name. A name the host has is a symbol and costs one load at a call site; a name it lacks is a registry lookup cached at install time in a module-local slot, and costs two. The common case pays nothing for the general one. The redefinition unit is now a list of top-level forms rather than one function. It has to be: v3 of the fixture adds a var and uses it from a redefined bump, and splitting that into two loads leaves a module referring to storage that does not exist yet. C-c C-c passes one name, C-c C-k passes a file's worth, one path either way. Four rules, each silent if broken. Every lookup resolves before any body is published, or a caller reaches a function whose slots are still null - asserted on the emitted flan_reload_install, since it cannot be race-tested. flan_dev_global refuses a size change, which is the layout-drift rule's first enforcement point rather than another exception to it. Nothing is ever dlclosed, because a cell holds an address inside a module's text. And the table is fixed capacity, because a module holds a cell's address for as long as it is loaded and a realloc would strand it. The test that separates this from a plausible wrong version is v4, which redefines a name v3 introduced at run time. v3's bump is already installed and is not rebuilt, so it picks v4 up only if its call goes through a cell both modules found by the same name. Had v3 cached the function's address instead, every other assertion would still pass and the transcript would read 246 instead of 432. Sizes are spelled LLVM's way, ptrtoint getelementptr null 1, rather than by a layout calculator in OCaml that would have to agree with LLVM's on every target.
1097 lines
44 KiB
OCaml
1097 lines
44 KiB
OCaml
(** Typed IR → LLVM IR, as text.
|
|
|
|
Text rather than libLLVM bindings, for the reasons in plan.org: the build
|
|
dependency is a clang on PATH instead of a version-pinned libLLVM with C++
|
|
linkage, the output is readable when something is wrong, and an LLVM
|
|
upgrade does not break the compiler. The only thing text loses is the
|
|
in-process JIT, and that was measured at ~13ms — below perception.
|
|
|
|
Layout — this is the whole of it, and it is deliberately C's:
|
|
|
|
{v
|
|
i8..i64 / u8..u64 i8..i64 signedness lives in the ops
|
|
f32 f64 float double
|
|
bool i1
|
|
[T] and string { ptr, i64 } ptr+len, non-owning
|
|
[n T] [n x T] inline, a value
|
|
(Ptr T) ptr opaque pointers
|
|
(Option T) { i8, T } tag 0 None, 1 Some
|
|
a struct a literal struct in declaration order
|
|
Unit and Never {} zero-sized, one value
|
|
v}
|
|
|
|
No object headers anywhere, which is the consequence that drives everything
|
|
(plan.org, Memory) — a Flan struct is exactly its C struct.
|
|
|
|
Two things fall out of the layout and are load-bearing:
|
|
|
|
- Every slot is an [alloca], so reading a local is a [load] and assigning is
|
|
a [store]. Aggregates are SSA values in LLVM, so a [store] of a struct or
|
|
a fixed array *is* the copy that spec-memory.md requires on assignment,
|
|
and a slice copies its view for the same reason. [addr] of a local is then
|
|
just the alloca. [mem2reg] removes the ones nobody took the address of.
|
|
- A place lowers to a pointer and a value to a load from it, which is the
|
|
split the interpreter would have had to make by hand: [(set (.pos c) ...)]
|
|
through a [(Ptr Cursor)] becomes a [getelementptr] on the pointer, not on
|
|
a copy of the struct. *)
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
|
|
Emission is all side effect — instructions, calls, branches to a [ret] — so
|
|
left-to-right is required, not a preference. Same rule as in Check. *)
|
|
let rec map_lr f = function
|
|
| [] -> []
|
|
| x :: rest -> let y = f x in y :: map_lr f rest
|
|
|
|
(* ── Names ─────────────────────────────────────────────────────────── *)
|
|
|
|
(* Flan names contain -, ?, > and /, so every emitted name is quoted. The
|
|
[flan.] prefix keeps the Flan [main] from colliding with C's. *)
|
|
let quoted s = "\"" ^ s ^ "\""
|
|
let fname n = "@" ^ quoted ("flan." ^ n)
|
|
let gname n = "@" ^ quoted ("flan." ^ n)
|
|
let sname n = "%" ^ quoted n
|
|
|
|
(* A dev build's redefinable calls go through a cell: a mutable global holding
|
|
the address of the function that is current. Redefinition is then one store,
|
|
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
|
|
have no cells and call the symbol directly. *)
|
|
let cellname n = "@" ^ quoted ("flan.cell." ^ n)
|
|
|
|
(* 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
|
|
[flan_dev_cell] / [flan_dev_global] and the answer is cached in one of these
|
|
module-local slots. One indirection more than a name the host has, which is
|
|
why the compiler picks per name rather than routing everything this way. *)
|
|
let cellptr n = "@" ^ quoted ("flan.cellp." ^ n)
|
|
let globalptr n = "@" ^ quoted ("flan.gp." ^ n)
|
|
|
|
(* ── Types ─────────────────────────────────────────────────────────── *)
|
|
|
|
let rec ll (t : Types.t) =
|
|
match t with
|
|
| Types.Int k -> "i" ^ string_of_int (Types.bits k)
|
|
| Types.Float Types.F32 -> "float"
|
|
| Types.Float Types.F64 -> "double"
|
|
| Types.Bool -> "i1"
|
|
| Types.String | Types.Slice _ -> "%slice"
|
|
| Types.Unit | Types.Never -> "{}"
|
|
| Types.Named n -> sname n
|
|
(* A C enum is an i32 — its own type in the checker, nothing at all here. *)
|
|
| Types.Enum _ -> "i32"
|
|
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
|
|
| Types.Ptr _ -> "ptr"
|
|
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
|
|
| Types.Map _ | Types.Fn _ | Types.Var _ ->
|
|
(* The checker rejects each of these by name — nothing reaches here. *)
|
|
failwith ("no layout for " ^ Types.to_string t)
|
|
|
|
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
|
|
|
|
(* ── Module-level state ────────────────────────────────────────────── *)
|
|
|
|
type m = {
|
|
out : Buffer.t;
|
|
strs : Buffer.t; (* string literal constants *)
|
|
structs : (string, Tast.structure) Hashtbl.t;
|
|
globals : (string, Types.t) Hashtbl.t;
|
|
(* Flan name -> C symbol, for the foreign functions. A call to one names the
|
|
symbol directly; there is no thunk. *)
|
|
externs : (string, string) Hashtbl.t;
|
|
checks : bool; (* emit bounds checks *)
|
|
dev : bool; (* call through cells (below) *)
|
|
(* Was this name in the build the running process came from? False only in a
|
|
redefinition module, and only for a name introduced since. *)
|
|
known : string -> bool;
|
|
mutable nstr : int;
|
|
}
|
|
|
|
let field_ty m sn i =
|
|
let s = Hashtbl.find m.structs sn in
|
|
(List.nth s.Tast.fields i).Tast.fty
|
|
|
|
(* ── Per-function state ────────────────────────────────────────────── *)
|
|
|
|
type f = {
|
|
md : m;
|
|
allocas : Buffer.t; (* the entry block: mem2reg only promotes these *)
|
|
b : Buffer.t;
|
|
mutable n : int;
|
|
mutable live : bool; (* is the current block still open? *)
|
|
ret : Types.t;
|
|
slots : string array;
|
|
slot_tys : Types.t array;
|
|
}
|
|
|
|
let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
|
|
let fresh_label f name = f.n <- f.n + 1; Printf.sprintf "%s%d" name f.n
|
|
|
|
(* Nothing may follow a terminator, so emission after one is dropped: the code
|
|
is unreachable and LLVM would reject it. *)
|
|
let ins f fmt =
|
|
Printf.ksprintf (fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n")) fmt
|
|
|
|
let term f fmt =
|
|
Printf.ksprintf
|
|
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n"); f.live <- false)
|
|
fmt
|
|
|
|
let label f name =
|
|
Buffer.add_string f.b (Printf.sprintf "\n%s:\n" name);
|
|
f.live <- true
|
|
|
|
let alloca f ty =
|
|
let name = fresh f in
|
|
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name (ll ty));
|
|
name
|
|
|
|
(* ── Constants ─────────────────────────────────────────────────────── *)
|
|
|
|
(* LLVM's hex form is exact, which decimal is not: a literal must mean the same
|
|
thing after a round trip through the .ll file. *)
|
|
let float_const (k : Types.fkind) x =
|
|
let x = match k with Types.F32 -> Int32.float_of_bits (Int32.bits_of_float x)
|
|
| Types.F64 -> x in
|
|
Printf.sprintf "0x%Lx" (Int64.bits_of_float x)
|
|
|
|
let escape s =
|
|
let b = Buffer.create (String.length s + 8) in
|
|
String.iter
|
|
(fun c ->
|
|
if c = '"' || c = '\\' || Char.code c < 0x20 || Char.code c > 0x7e then
|
|
Buffer.add_string b (Printf.sprintf "\\%02X" (Char.code c))
|
|
else Buffer.add_char b c)
|
|
s;
|
|
Buffer.contents b
|
|
|
|
(* The constant itself, as the pointer and length a caller needs separately —
|
|
a bounds message crosses to C as ptr+len like any other slice. *)
|
|
let string_bytes m s =
|
|
let id = Printf.sprintf "@\".str.%d\"" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
|
|
id (String.length s) (escape s));
|
|
id, String.length s
|
|
|
|
let string_const m s =
|
|
let id, n = string_bytes m s in
|
|
(* The value alone: LLVM takes the type from the operand's context. *)
|
|
Printf.sprintf "{ ptr %s, i64 %d }" id n
|
|
|
|
(* A NUL-terminated copy, for the two dev lookups that take a C string. Flan
|
|
strings are ptr+len and never NUL-terminated, so this is its own constant. *)
|
|
let cstring m s =
|
|
let id = Printf.sprintf "@\".name.%d\"" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\\00\"\n"
|
|
id (String.length s + 1) (escape s));
|
|
id
|
|
|
|
(* ── Bounds checks ───────────────────────────────────────────────────── *)
|
|
|
|
(* A failure is a branch to a [noreturn] call and then [unreachable] — the same
|
|
explicit shape as [return] and [some], so wasm32 needs no unwinding for it
|
|
either. Whether to check is its own flag, not the optimisation level: dev
|
|
builds trap, release builds do not (NEXT.md), and the acceptance table runs
|
|
at both -O0 and -O2 with the checks on either way.
|
|
|
|
Indices are i32 in Flan and sign-extended to i64 for the gep, so a negative
|
|
one arrives here as a huge unsigned value: an unsigned comparison catches
|
|
the negative and the too-large case in a single test. *)
|
|
let fail_block f (loc : Loc.t) ok emit_call =
|
|
let good = fresh_label f "inb" and bad = fresh_label f "oob" in
|
|
term f "br i1 %s, label %%%s, label %%%s" ok good bad;
|
|
label f bad;
|
|
let id, n = string_bytes f.md (Loc.to_string loc) in
|
|
emit_call id n;
|
|
term f "unreachable";
|
|
label f good
|
|
|
|
(* [at] is strict: the last valid index is len - 1. *)
|
|
let check_at f loc idx len =
|
|
if f.md.checks then begin
|
|
let ok = fresh f in
|
|
ins f "%s = icmp ult i64 %s, %s" ok idx len;
|
|
fail_block f loc ok (fun id n ->
|
|
ins f "call void @flan_bounds_fail(ptr %s, i64 %d, i64 %s, i64 %s)"
|
|
id n idx len)
|
|
end
|
|
|
|
(* [slice] is not: a slice ending at len — or an empty one at lo = len — is
|
|
legal, and its one-past-the-end gep is defined. [lo <= hi] is not redundant
|
|
with it, because a reversed range would otherwise yield hi - lo as a huge
|
|
unsigned length, which is a worse hole than the missing check. *)
|
|
let check_slice f loc lo hi len =
|
|
if f.md.checks then begin
|
|
let a = fresh f in
|
|
ins f "%s = icmp ule i64 %s, %s" a lo hi;
|
|
let b = fresh f in
|
|
ins f "%s = icmp ule i64 %s, %s" b hi len;
|
|
let ok = fresh f in
|
|
ins f "%s = and i1 %s, %s" ok a b;
|
|
fail_block f loc ok (fun id n ->
|
|
ins f "call void @flan_slice_fail(ptr %s, i64 %d, i64 %s, i64 %s, i64 %s)"
|
|
id n lo hi len)
|
|
end
|
|
|
|
(* ── Expressions ───────────────────────────────────────────────────── *)
|
|
|
|
let icmp_op signed = function
|
|
| Tast.Eq -> "eq" | Tast.Ne -> "ne"
|
|
| Tast.Lt -> if signed then "slt" else "ult"
|
|
| Tast.Le -> if signed then "sle" else "ule"
|
|
| Tast.Gt -> if signed then "sgt" else "ugt"
|
|
| Tast.Ge -> if signed then "sge" else "uge"
|
|
| _ -> assert false
|
|
|
|
let fcmp_op = function
|
|
| Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt"
|
|
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
|
|
| _ -> assert false
|
|
|
|
let rec value f (e : Tast.expr) : string =
|
|
match e.Tast.e with
|
|
| Tast.Int (n, _) -> Int64.to_string n
|
|
| Tast.Float (x, k) -> float_const k x
|
|
| Tast.Bool b -> if b then "true" else "false"
|
|
| Tast.Str s -> string_const f.md s
|
|
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
|
| Tast.Uninit _ -> "poison"
|
|
| Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
|
|
(* Everything that denotes a location is a load from its address. *)
|
|
load f (addr f e) e.Tast.ty
|
|
| Tast.Addr p -> fst (place f p)
|
|
| Tast.Prim (p, args) -> prim f e p args
|
|
| Tast.Call (name, args) ->
|
|
(match Hashtbl.find_opt f.md.externs name with
|
|
| Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
|
|
| None -> call f e.Tast.ty name args)
|
|
| Tast.Do body -> block f body
|
|
| Tast.Let (bs, body) ->
|
|
List.iter
|
|
(fun (slot, v) ->
|
|
let v' = value f v in
|
|
ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot))
|
|
bs;
|
|
block f body
|
|
| Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
|
|
| Tast.While (c, body) -> emit_while f c body; "zeroinitializer"
|
|
| Tast.Return v ->
|
|
(match v with
|
|
| None -> term f "ret %s zeroinitializer" (ll f.ret)
|
|
| Some v ->
|
|
let v' = value f v in
|
|
term f "ret %s %s" (ll f.ret) v');
|
|
"zeroinitializer"
|
|
| Tast.Set (p, v) ->
|
|
let ptr, ty = place f p in
|
|
let v' = value f v in
|
|
ins f "store %s %s, ptr %s" (ll ty) v' ptr;
|
|
"zeroinitializer"
|
|
| Tast.Make (_, fields) -> aggregate f e.Tast.ty fields
|
|
| Tast.Arr items -> aggregate f e.Tast.ty items
|
|
| Tast.Some_ v ->
|
|
let v' = value f v in
|
|
let t = ll e.Tast.ty in
|
|
let a = fresh f in
|
|
ins f "%s = insertvalue %s zeroinitializer, i8 1, 0" a t;
|
|
let b = fresh f in
|
|
ins f "%s = insertvalue %s %s, %s %s, 1" b t a (ll v.Tast.ty) v';
|
|
b
|
|
| Tast.Match (s, arms) -> emit_match f e.Tast.ty s arms
|
|
| Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v
|
|
|
|
(* Where a global's storage is. A global the host was built with is a symbol;
|
|
one introduced since lives wherever [flan_dev_global] put it. *)
|
|
and global_addr f n =
|
|
if (not f.md.dev) || f.md.known n then gname n
|
|
else begin
|
|
let p = fresh f in
|
|
ins f "%s = load ptr, ptr %s" p (globalptr n);
|
|
p
|
|
end
|
|
|
|
and load f ptr ty =
|
|
let t = fresh f in
|
|
ins f "%s = load %s, ptr %s" t (ll ty) ptr;
|
|
t
|
|
|
|
(* The address of an expression that denotes a location. Anything else is
|
|
spilled to a temporary first, so [(at (f) 0)] on a returned array works. *)
|
|
and addr f (e : Tast.expr) : string =
|
|
match e.Tast.e with
|
|
| Tast.Local i -> f.slots.(i)
|
|
| Tast.Global n -> global_addr f n
|
|
| Tast.Deref p -> value f p
|
|
| Tast.Field (target, i) -> field_addr f target i
|
|
| Tast.Prim (Tast.At, target :: idx) -> fst (element_addr f target idx)
|
|
| _ ->
|
|
let tmp = alloca f e.Tast.ty in
|
|
let v = value f e in
|
|
ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
|
|
tmp
|
|
|
|
and field_addr f (target : Tast.expr) i =
|
|
let base = addr f target in
|
|
let sn = match target.Tast.ty with
|
|
| Types.Named n -> n
|
|
| t -> failwith ("field of " ^ Types.to_string t)
|
|
in
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p (sname sn) base i;
|
|
p
|
|
|
|
(* One index per dimension, so [(at grid row col)] is two geps. Indices are
|
|
i32 in Flan and i64 in a gep. *)
|
|
and element_addr f (target : Tast.expr) idx =
|
|
let rec go ptr ty = function
|
|
| [] -> ptr, ty
|
|
| (i : Tast.expr) :: rest ->
|
|
let iv = value f i in
|
|
let i64 = fresh f in
|
|
ins f "%s = sext %s %s to i64" i64 (ll i.Tast.ty) iv;
|
|
(match ty with
|
|
| Types.Array (n, elem) ->
|
|
(* The bound is static; LLVM folds the check away for a literal index. *)
|
|
check_at f i.Tast.loc i64 (Int64.to_string n);
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
|
p (ll ty) ptr i64;
|
|
go p elem rest
|
|
| Types.Slice elem ->
|
|
(* A slice is ptr+len, so step through the pointer it holds. *)
|
|
let s = load f ptr ty in
|
|
let base = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" base s;
|
|
let len = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" len s;
|
|
check_at f i.Tast.loc i64 len;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
|
|
go p elem rest
|
|
| t -> failwith ("index into " ^ Types.to_string t))
|
|
in
|
|
go (addr f target) target.Tast.ty idx
|
|
|
|
and place f (p : Tast.place) : string * Types.t =
|
|
match p with
|
|
| Tast.Plocal i -> f.slots.(i), f.slot_tys.(i)
|
|
| Tast.Pglobal n -> global_addr f n, Hashtbl.find f.md.globals n
|
|
| Tast.Pfield (target, i) ->
|
|
let sn = match target.Tast.ty with
|
|
| Types.Named n -> n | t -> failwith ("field of " ^ Types.to_string t)
|
|
in
|
|
field_addr f target i, field_ty f.md sn i
|
|
| Tast.Pindex (target, idx) -> element_addr f target idx
|
|
| Tast.Pderef target ->
|
|
let t = match target.Tast.ty with
|
|
| Types.Ptr t -> t | t -> failwith ("deref of " ^ Types.to_string t)
|
|
in
|
|
value f target, t
|
|
| Tast.Pkey _ -> failwith "Map places are milestone 6"
|
|
|
|
(* A struct or fixed-array value, built field by field from zeroinitializer.
|
|
The checker already filled the omitted fields in with Zero, so this is
|
|
simply every field in declaration order. *)
|
|
and aggregate f ty parts =
|
|
let t = ll ty in
|
|
let acc = ref "zeroinitializer" in
|
|
List.iteri
|
|
(fun i (p : Tast.expr) ->
|
|
let v = value f p in
|
|
let next = fresh f in
|
|
ins f "%s = insertvalue %s %s, %s %s, %d" next t !acc (ll p.Tast.ty) v i;
|
|
acc := next)
|
|
parts;
|
|
!acc
|
|
|
|
and block f body =
|
|
match body with
|
|
| [] -> "zeroinitializer"
|
|
| _ ->
|
|
let last = ref "zeroinitializer" in
|
|
List.iter (fun e -> last := value f e) body;
|
|
!last
|
|
|
|
and call f ret flan args =
|
|
let vs = map_lr (fun (a : Tast.expr) ->
|
|
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
|
|
(* The cell is loaded *after* the arguments, so a redefinition that lands
|
|
between two calls still cannot land in the middle of one. *)
|
|
let callee =
|
|
if not f.md.dev then fname flan
|
|
else if f.md.known flan then begin
|
|
let p = fresh f in
|
|
ins f "%s = load ptr, ptr %s" p (cellname flan);
|
|
p
|
|
end else begin
|
|
(* The cell itself is not a symbol here; its address was looked up by
|
|
name at install time and cached. *)
|
|
let c = fresh f in
|
|
ins f "%s = load ptr, ptr %s" c (cellptr flan);
|
|
let p = fresh f in
|
|
ins f "%s = load ptr, ptr %s" p c;
|
|
p
|
|
end
|
|
in
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(%s)" t (ll ret) callee (String.concat ", " vs);
|
|
t
|
|
|
|
(* A foreign call, where the same rule applies as to the runtime shims: a slice
|
|
or a string crosses as ptr+len and never as a struct by value. Every other
|
|
argument type is a scalar, because [check.ml] rejects an extern signature
|
|
that would need an aggregate — that is the shim's job, in C, where clang
|
|
knows the target's calling convention. *)
|
|
and extern_call f ret name args =
|
|
let vs =
|
|
List.concat_map
|
|
(fun (a : Tast.expr) ->
|
|
match a.Tast.ty with
|
|
| Types.String | Types.Slice _ ->
|
|
let p, n = explode f a in
|
|
[ Printf.sprintf "ptr %s" p; Printf.sprintf "i64 %s" n ]
|
|
| ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
|
|
args
|
|
in
|
|
if is_void ret then begin
|
|
ins f "call void %s(%s)" name (String.concat ", " vs);
|
|
"zeroinitializer"
|
|
end else begin
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
|
|
t
|
|
end
|
|
|
|
and emit_if f ty c t e =
|
|
let cv = value f c in
|
|
let lt = fresh_label f "then" and le = fresh_label f "else"
|
|
and ld = fresh_label f "endif" in
|
|
let result = if is_void ty then None else Some (alloca f ty) in
|
|
term f "br i1 %s, label %%%s, label %%%s" cv lt le;
|
|
let arm lbl (branch : Tast.expr) =
|
|
label f lbl;
|
|
let v = value f branch in
|
|
(match result with
|
|
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
|
| _ -> ());
|
|
let reached = f.live in
|
|
term f "br label %%%s" ld;
|
|
reached
|
|
in
|
|
let a = arm lt t in
|
|
let b = arm le e in
|
|
if not (a || b) then begin
|
|
(* Both branches diverge, so there is no join: nothing follows. *)
|
|
f.live <- false;
|
|
"zeroinitializer"
|
|
end else begin
|
|
label f ld;
|
|
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
|
end
|
|
|
|
and emit_while f c body =
|
|
let lc = fresh_label f "loop" and lb = fresh_label f "body"
|
|
and le = fresh_label f "endloop" in
|
|
term f "br label %%%s" lc;
|
|
label f lc;
|
|
let cv = value f c in
|
|
term f "br i1 %s, label %%%s, label %%%s" cv lb le;
|
|
label f lb;
|
|
List.iter (fun e -> ignore (value f e)) body;
|
|
term f "br label %%%s" lc;
|
|
label f le
|
|
|
|
and emit_match f ty scrut arms =
|
|
let sv = value f scrut in
|
|
let sty = ll scrut.Tast.ty in
|
|
let tag = fresh f in
|
|
ins f "%s = extractvalue %s %s, 0" tag sty sv;
|
|
let payload_ty = match scrut.Tast.ty with
|
|
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
|
|
in
|
|
let ld = fresh_label f "endmatch" in
|
|
let result = if is_void ty then None else Some (alloca f ty) in
|
|
let reached = ref false in
|
|
let rec go = function
|
|
| [] -> term f "unreachable" (* the checker proved exhaustiveness *)
|
|
| (a : Tast.arm) :: rest ->
|
|
let lb = fresh_label f "arm" and ln = fresh_label f "next" in
|
|
(match a.Tast.acase with
|
|
| None -> term f "br label %%%s" lb
|
|
| Some c ->
|
|
let want = if c = "Some" then 1 else 0 in
|
|
let t = fresh f in
|
|
ins f "%s = icmp eq i8 %s, %d" t tag want;
|
|
term f "br i1 %s, label %%%s, label %%%s" t lb ln);
|
|
label f lb;
|
|
List.iter
|
|
(fun slot ->
|
|
let v = fresh f in
|
|
ins f "%s = extractvalue %s %s, 1" v sty sv;
|
|
ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot))
|
|
a.Tast.binds;
|
|
let v = block f a.Tast.abody in
|
|
(match result with
|
|
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
|
| _ -> ());
|
|
if f.live then reached := true;
|
|
term f "br label %%%s" ld;
|
|
if a.Tast.acase <> None then begin label f ln; go rest end
|
|
in
|
|
go arms;
|
|
if not !reached then begin f.live <- false; "zeroinitializer" end
|
|
else begin
|
|
label f ld;
|
|
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
|
end
|
|
|
|
(* (some x): unwrap Some, else return None from the enclosing function. The
|
|
early return is explicit — a branch to a ret, not platform unwinding, so
|
|
native and wasm32 do the same thing (plan.org, Compilation). *)
|
|
and emit_unwrap f ty v =
|
|
let ov = value f v in
|
|
let oty = ll v.Tast.ty in
|
|
let tag = fresh f in
|
|
ins f "%s = extractvalue %s %s, 0" tag oty ov;
|
|
let isnone = fresh f in
|
|
ins f "%s = icmp eq i8 %s, 0" isnone tag;
|
|
let ln = fresh_label f "none" and lc = fresh_label f "some" in
|
|
term f "br i1 %s, label %%%s, label %%%s" isnone ln lc;
|
|
label f ln;
|
|
term f "ret %s zeroinitializer" (ll f.ret);
|
|
label f lc;
|
|
let out = fresh f in
|
|
ins f "%s = extractvalue %s %s, 1" out oty ov;
|
|
ignore ty;
|
|
out
|
|
|
|
(* ── Primitives ────────────────────────────────────────────────────── *)
|
|
|
|
and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
|
match p, args with
|
|
| (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let op = match x.Tast.ty, p with
|
|
| Types.Float _, Tast.Add -> "fadd" | Types.Float _, Tast.Sub -> "fsub"
|
|
| Types.Float _, Tast.Mul -> "fmul" | Types.Float _, Tast.Div -> "fdiv"
|
|
| Types.Float _, _ -> "frem"
|
|
| Types.Int _, Tast.Add -> "add" | Types.Int _, Tast.Sub -> "sub"
|
|
| Types.Int _, Tast.Mul -> "mul"
|
|
| Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
|
|
| Types.Int k, _ -> if Types.signed k then "srem" else "urem"
|
|
| t, _ -> failwith ("arithmetic on " ^ Types.to_string t)
|
|
in
|
|
let t = fresh f in
|
|
(* No nsw/nuw: arithmetic wraps (plan.org, Types). *)
|
|
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
|
|
t
|
|
| (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let t = fresh f in
|
|
(match x.Tast.ty with
|
|
| Types.Float _ ->
|
|
ins f "%s = fcmp %s %s %s, %s" t (fcmp_op p) (ll x.Tast.ty) a b
|
|
| Types.Int k ->
|
|
ins f "%s = icmp %s %s %s, %s" t (icmp_op (Types.signed k) p)
|
|
(ll x.Tast.ty) a b
|
|
| t' -> failwith ("comparison on " ^ Types.to_string t'));
|
|
t
|
|
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let op = match x.Tast.ty, p with
|
|
| _, Tast.BitAnd -> "and" | _, Tast.BitOr -> "or"
|
|
| _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
|
|
| Types.Int k, _ -> if Types.signed k then "ashr" else "lshr"
|
|
| t, _ -> failwith ("bitwise on " ^ Types.to_string t)
|
|
in
|
|
(* The count is masked to the operand's width. LLVM makes an over-wide
|
|
shift poison, and a poison return at -O2 is a function that returns
|
|
nothing at all; masking is what the hardware does anyway, and LLVM folds
|
|
the [and] away whenever the count is a constant. [check] has already
|
|
rejected a literal that is out of range, so this only ever fires on a
|
|
computed count. *)
|
|
let b =
|
|
match x.Tast.ty, p with
|
|
| Types.Int k, (Tast.Shl | Tast.Shr) ->
|
|
let m = fresh f in
|
|
ins f "%s = and %s %s, %d" m (ll x.Tast.ty) b (Types.bits k - 1);
|
|
m
|
|
| _ -> b
|
|
in
|
|
let t = fresh f in
|
|
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
|
|
t
|
|
| Tast.Not, [ x ] ->
|
|
let a = value f x in
|
|
let t = fresh f in
|
|
ins f "%s = xor i1 %s, true" t a;
|
|
t
|
|
| Tast.Len, [ x ] ->
|
|
(match x.Tast.ty with
|
|
| Types.Array (n, _) -> Int64.to_string n
|
|
| _ ->
|
|
let v = value f x in
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
let t = fresh f in
|
|
ins f "%s = trunc i64 %s to i32" t n;
|
|
t)
|
|
| Tast.At, target :: idx ->
|
|
let p, elem = element_addr f target idx in
|
|
load f p elem
|
|
| Tast.Slice, [ target; lo; hi ] ->
|
|
(* lo is evaluated once and used twice — as the offset and as part of the
|
|
length — so it must not be emitted twice. *)
|
|
let lov = value f lo in
|
|
let hiv = value f hi in
|
|
let lo64 = fresh f in
|
|
ins f "%s = sext i32 %s to i64" lo64 lov;
|
|
let hi64 = fresh f in
|
|
ins f "%s = sext i32 %s to i64" hi64 hiv;
|
|
(* The source is read once, and the check goes between reading it and the
|
|
gep: the length it is checked against must be the one the gep uses. *)
|
|
let base =
|
|
match target.Tast.ty with
|
|
| Types.Array (n, _) ->
|
|
let a = addr f target in
|
|
check_slice f e.Tast.loc lo64 hi64 (Int64.to_string n);
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
|
p (ll target.Tast.ty) a lo64;
|
|
p
|
|
| Types.Slice elem ->
|
|
let v = value f target in
|
|
let q = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" q v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
check_slice f e.Tast.loc lo64 hi64 n;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) q lo64;
|
|
p
|
|
| Types.String ->
|
|
let v = value f target in
|
|
let q = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" q v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
check_slice f e.Tast.loc lo64 hi64 n;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
|
|
p
|
|
| t -> failwith ("slice of " ^ Types.to_string t)
|
|
in
|
|
let d = fresh f in
|
|
ins f "%s = sub i64 %s, %s" d hi64 lo64;
|
|
let a = fresh f in
|
|
ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a base;
|
|
let b = fresh f in
|
|
ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a d;
|
|
b
|
|
(* string and [u8] have the same layout, so bytes is the identity — a view,
|
|
no copy (plan.org, Milestone-2 primitives). *)
|
|
| Tast.Bytes, [ x ] -> value f x
|
|
| Tast.BytesToF64, [ x ] -> shim_in f "@flan_bytes_to_f64" "double" x
|
|
| Tast.BytesToI64, [ x ] -> shim_in f "@flan_bytes_to_i64" "i64" x
|
|
| Tast.F64ToBytes, [ x ] -> shim_out f "@flan_f64_to_bytes" x
|
|
| Tast.I64ToBytes, [ x ] -> shim_out f "@flan_i64_to_bytes" x
|
|
| Tast.WriteStdout, [ x ] ->
|
|
let p, n = explode f x in
|
|
ins f "call void @flan_write_stdout(ptr %s, i64 %s)" p n;
|
|
"zeroinitializer"
|
|
| Tast.Exit, [ x ] ->
|
|
let v = value f x in
|
|
ins f "call void @flan_exit(i32 %s)" v;
|
|
term f "unreachable";
|
|
"zeroinitializer"
|
|
| Tast.Argv, [] ->
|
|
let tmp = alloca f (Types.Slice Types.String) in
|
|
ins f "call void @flan_argv(ptr %s)" tmp;
|
|
load f tmp (Types.Slice Types.String)
|
|
| Tast.Cast target, [ x ] -> cast f x target
|
|
| _ -> failwith "malformed primitive"
|
|
|
|
(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
|
|
and explode f (x : Tast.expr) =
|
|
let v = value f x in
|
|
let p = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" p v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
p, n
|
|
|
|
and shim_in f name ret x =
|
|
let p, n = explode f x in
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(ptr %s, i64 %s)" t ret name p n;
|
|
t
|
|
|
|
and shim_out f name (x : Tast.expr) =
|
|
let v = value f x in
|
|
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
|
|
ins f "call void %s(%s %s, ptr %s)" name (ll x.Tast.ty) v tmp;
|
|
load f tmp (Types.Slice (Types.Int Types.U8))
|
|
|
|
and cast f (x : Tast.expr) target =
|
|
let v = value f x in
|
|
let src = x.Tast.ty in
|
|
if Types.equal src target then v
|
|
else
|
|
let op =
|
|
match src, target with
|
|
| Types.Int a, Types.Int b ->
|
|
if Types.bits b < Types.bits a then "trunc"
|
|
else if Types.bits b = Types.bits a then "bitcast"
|
|
else if Types.signed a then "sext" else "zext"
|
|
| Types.Int a, Types.Float _ -> if Types.signed a then "sitofp" else "uitofp"
|
|
| Types.Float _, Types.Int b -> if Types.signed b then "fptosi" else "fptoui"
|
|
| Types.Float a, Types.Float b ->
|
|
if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc"
|
|
| _ -> failwith "unsupported cast"
|
|
in
|
|
if op = "bitcast" then v
|
|
else begin
|
|
let t = fresh f in
|
|
ins f "%s = %s %s %s to %s" t op (ll src) v (ll target);
|
|
t
|
|
end
|
|
|
|
(* ── Functions ─────────────────────────────────────────────────────── *)
|
|
|
|
(* The one place a Flan function's LLVM signature is spelled. A [define] and
|
|
the [declare] a redefinition module needs for the same function have to
|
|
agree exactly, and the way they stop agreeing is one of them growing a case
|
|
for Unit or for a slice parameter that the other never gets. *)
|
|
let signature ~named (fn : Tast.fn) =
|
|
let params =
|
|
List.mapi
|
|
(fun i ty -> if named then Printf.sprintf "%s %%p%d" (ll ty) i else ll ty)
|
|
fn.Tast.params
|
|
in
|
|
Printf.sprintf "%s %s(%s)" (ll fn.Tast.ret) (fname fn.Tast.name)
|
|
(String.concat ", " params)
|
|
|
|
(* [hidden] on a redefinition's own body, and this is load-bearing. Default
|
|
visibility in a shared object is interposable: [@"flan.bump"] inside the
|
|
module would resolve to the *host's* copy, so the installer would publish
|
|
the function it was replacing and the reload would appear to do nothing. *)
|
|
let emit_fn m ?(hidden = false) (fn : Tast.fn) =
|
|
let n = Array.length fn.Tast.slots in
|
|
let f = {
|
|
md = m;
|
|
allocas = Buffer.create 256;
|
|
b = Buffer.create 1024;
|
|
n = 0;
|
|
live = true;
|
|
ret = fn.Tast.ret;
|
|
slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
|
|
slot_tys = fn.Tast.slots;
|
|
} in
|
|
(* Every slot is an alloca in the entry block, because [addr] may take the
|
|
address of any of them and mem2reg only promotes entry-block allocas. *)
|
|
Array.iteri
|
|
(fun i ty ->
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " %s = alloca %s\n" f.slots.(i) (ll ty)))
|
|
fn.Tast.slots;
|
|
(* Parameters arrive as SSA values and are stored into their slots at once,
|
|
which is also the copy a value struct gets on assignment. *)
|
|
List.iteri
|
|
(fun i ty ->
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
|
|
fn.Tast.params;
|
|
let last = ref "zeroinitializer" in
|
|
List.iter (fun e -> last := value f e) fn.Tast.body;
|
|
(* A Unit function's body may end on a form of any type — the value is
|
|
discarded, so the return is the Unit constant rather than that value. *)
|
|
if Types.equal fn.Tast.ret Types.Unit then last := "zeroinitializer";
|
|
term f "ret %s %s" (ll fn.Tast.ret) !last;
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "\ndefine %s%s {\nentry:\n%s%s}\n"
|
|
(if hidden then "hidden " else "") (signature ~named:true fn)
|
|
(Buffer.contents f.allocas) (Buffer.contents f.b))
|
|
|
|
(* ── Globals ───────────────────────────────────────────────────────── *)
|
|
|
|
(* A global's initialiser is a compile-time constant: literals live in
|
|
read-only memory and zeroed globals live in BSS and cost nothing to start
|
|
(plan.org, Data model). There is no init-at-startup path, by design. *)
|
|
let rec const m (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Int (n, _) -> Int64.to_string n
|
|
| Tast.Float (x, k) -> float_const k x
|
|
| Tast.Bool b -> if b then "true" else "false"
|
|
| Tast.Str s -> string_const m s
|
|
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
|
| Tast.Uninit _ -> "poison"
|
|
| Tast.Make (_, parts) | Tast.Arr parts ->
|
|
let inner =
|
|
map_lr (fun (p : Tast.expr) ->
|
|
Printf.sprintf "%s %s" (ll p.Tast.ty) (const m p)) parts
|
|
in
|
|
(match e.Tast.ty with
|
|
| Types.Array _ -> "[" ^ String.concat ", " inner ^ "]"
|
|
| _ -> "{ " ^ String.concat ", " inner ^ " }")
|
|
| Tast.Some_ v ->
|
|
Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m v)
|
|
| _ ->
|
|
fail e.Tast.loc
|
|
"a global's value must be a compile-time constant — this one is computed"
|
|
|
|
let emit_global m (g : Tast.global) =
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = %s %s %s\n" (gname g.Tast.gname)
|
|
(if g.Tast.gconst then "constant" else "global")
|
|
(ll g.Tast.gty) (const m g.Tast.ginit))
|
|
|
|
(* ── Program ───────────────────────────────────────────────────────── *)
|
|
|
|
let header = {|; Generated by flan. The layout is C's: no object headers anywhere,
|
|
; so a Flan struct is exactly its C struct and nothing marshals.
|
|
|
|
%slice = type { ptr, i64 }
|
|
|
|
declare void @flan_rt_init(i32, ptr)
|
|
declare void @flan_argv(ptr)
|
|
declare void @flan_write_stdout(ptr, i64)
|
|
declare void @flan_exit(i32)
|
|
declare double @flan_bytes_to_f64(ptr, i64)
|
|
declare i64 @flan_bytes_to_i64(ptr, i64)
|
|
declare void @flan_f64_to_bytes(double, ptr)
|
|
declare void @flan_i64_to_bytes(i64, ptr)
|
|
declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold
|
|
declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold
|
|
|}
|
|
|
|
(* C's main, adapting to whichever of the four shapes Flan's main has: argv and
|
|
the i32 status are each optional (plan.org, Milestone-2 primitives). *)
|
|
let emit_main m (fn : Tast.fn) =
|
|
let b = Buffer.create 256 in
|
|
Buffer.add_string b "\ndefine i32 @main(i32 %argc, ptr %argv) {\nentry:\n";
|
|
Buffer.add_string b " call void @flan_rt_init(i32 %argc, ptr %argv)\n";
|
|
let args =
|
|
if fn.Tast.params = [] then ""
|
|
else begin
|
|
Buffer.add_string b " %a = alloca %slice\n";
|
|
Buffer.add_string b " call void @flan_argv(ptr %a)\n";
|
|
Buffer.add_string b " %args = load %slice, ptr %a\n";
|
|
"%slice %args"
|
|
end
|
|
in
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %%r = call %s %s(%s)\n" (ll fn.Tast.ret)
|
|
(fname "main") args);
|
|
(* Flushing matters: stdout is a FILE* and the acceptance test reads it. *)
|
|
Buffer.add_string b " call void @flan_exit(i32 ";
|
|
Buffer.add_string b
|
|
(if Types.equal fn.Tast.ret (Types.Int Types.I32) then "%r" else "0");
|
|
Buffer.add_string b ")\n unreachable\n}\n";
|
|
Buffer.add_string m.out (Buffer.contents b)
|
|
|
|
(* Everything a module needs before its own definitions: the tables the
|
|
emitters look names up in, the struct types, and the foreign [declare]s.
|
|
Both entry points below start here, so a redefinition module cannot drift
|
|
from the whole-program one in how it names or lays out a type. *)
|
|
let new_module ~checks ~dev ~known (p : Tast.program) =
|
|
let m = {
|
|
out = Buffer.create 8192; strs = Buffer.create 512;
|
|
structs = Hashtbl.create 16; globals = Hashtbl.create 16;
|
|
externs = Hashtbl.create 32;
|
|
checks; dev; known; nstr = 0;
|
|
} in
|
|
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
|
|
p.Tast.structs;
|
|
List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
|
|
p.Tast.globals;
|
|
List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym)
|
|
p.Tast.externs;
|
|
List.iter
|
|
(fun (s : Tast.structure) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { %s }\n" (sname s.Tast.sname)
|
|
(String.concat ", "
|
|
(List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
|
|
p.Tast.structs;
|
|
Buffer.add_char m.out '\n';
|
|
(* The foreign declarations. Every struct that crosses this boundary was
|
|
flattened by a C shim, so each of these is scalars only and no calling
|
|
convention has to be reproduced here. *)
|
|
List.iter
|
|
(fun (e : Tast.extern) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "declare %s @%s(%s)\n"
|
|
(ll e.Tast.eret) e.Tast.esym
|
|
(String.concat ", "
|
|
(List.concat_map
|
|
(fun (t : Types.t) ->
|
|
match t with
|
|
| Types.String | Types.Slice _ -> [ "ptr"; "i64" ]
|
|
| t -> [ ll t ])
|
|
e.Tast.eparams))))
|
|
p.Tast.externs;
|
|
if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
|
|
m
|
|
|
|
let finish m = header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
|
|
|
|
(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
|
|
[slice], a release build is told to drop them. *)
|
|
let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
|
|
let m = new_module ~checks ~dev ~known:(fun _ -> true) p in
|
|
(* One cell per function, initialised to the function this build compiled.
|
|
Nothing has been redefined yet, so a dev build starts out behaving exactly
|
|
like a release one — the indirection is the only difference. *)
|
|
if dev then begin
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = global ptr %s\n" (cellname fn.Tast.name)
|
|
(fname fn.Tast.name)))
|
|
p.Tast.fns;
|
|
Buffer.add_char m.out '\n'
|
|
end;
|
|
List.iter (emit_global m) p.Tast.globals;
|
|
List.iter (emit_fn m) p.Tast.fns;
|
|
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
|
| Some fn -> emit_main m fn
|
|
| None -> ());
|
|
finish m
|
|
|
|
(* A list of top-level forms, compiled into their own module against a host
|
|
that is already running — the redefinition unit (NEXT.md, the dev loop).
|
|
[C-c C-c] passes one name, [C-c C-k] passes a file's worth; there is one
|
|
code path either way.
|
|
|
|
The difference from [program] is almost entirely in what this module *does
|
|
not* define:
|
|
|
|
- a global the host has is [external]. Defining it would give the loaded
|
|
object a second copy, and the whole point of reloading into a live process
|
|
is that the state survives: sand's grid is a global, and "edit the code,
|
|
keep the sand" is the demo. So a redefinition can change a function's body
|
|
and can never re-initialise the program's data.
|
|
- a function the host has is reached through its cell, which is the host's
|
|
symbol, so a redefined [settle] calls whatever [move-grain] is current
|
|
rather than carrying a private copy of it.
|
|
- there is no [main]; this module is loaded, not started.
|
|
|
|
A name the host does *not* have is the case ELF cannot express, since there
|
|
is no symbol to bind to and no way to grow one. Those go through
|
|
[flan_dev_cell] / [flan_dev_global], keyed by string, resolved once at
|
|
install time into a module-local slot. See runtime/flan_dev.c.
|
|
|
|
String literals still have to come along: they are this module's own
|
|
constants, and omitting them is an undefined [@.str.N] at link time. *)
|
|
let redefinition ?(checks = true) ?(dev = false) ?(known = fun _ -> true)
|
|
(p : Tast.program) ~fns : string =
|
|
let target name =
|
|
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
|
|
| Some f -> f
|
|
| None -> failwith (Printf.sprintf "no such function: %s" name)
|
|
in
|
|
let targets = List.map target fns in
|
|
let m = new_module ~checks ~dev ~known p in
|
|
let new_fns =
|
|
List.filter (fun (f : Tast.fn) -> not (known f.Tast.name)) p.Tast.fns
|
|
and new_globals =
|
|
List.filter (fun (g : Tast.global) -> not (known g.Tast.gname)) p.Tast.globals
|
|
in
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
Buffer.add_string m.out
|
|
(if known g.Tast.gname then
|
|
Printf.sprintf "%s = external %s %s\n" (gname g.Tast.gname)
|
|
(if g.Tast.gconst then "constant" else "global") (ll g.Tast.gty)
|
|
else
|
|
Printf.sprintf "%s = internal global ptr null\n"
|
|
(globalptr g.Tast.gname)))
|
|
p.Tast.globals;
|
|
if dev then begin
|
|
(* The cells are the host's, like the globals. Referencing one is how a
|
|
redefined function reaches its siblings, and storing into one is how it
|
|
replaces itself. A name the host lacks gets a slot instead, filled by
|
|
the installer below. *)
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
Buffer.add_string m.out
|
|
(if known f.Tast.name then
|
|
Printf.sprintf "%s = external global ptr\n" (cellname f.Tast.name)
|
|
else
|
|
Printf.sprintf "%s = internal global ptr null\n"
|
|
(cellptr f.Tast.name)))
|
|
p.Tast.fns;
|
|
if new_fns <> [] || new_globals <> [] then
|
|
Buffer.add_string m.out
|
|
"\ndeclare ptr @flan_dev_cell(ptr)\ndeclare ptr @flan_dev_global(ptr, i64)\n";
|
|
Buffer.add_char m.out '\n'
|
|
end
|
|
else
|
|
(* Without cells there is nothing to route a call through, so the siblings
|
|
are named directly and every one of them needs a declaration. *)
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
if not (List.exists (String.equal f.Tast.name) fns) then
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "declare %s\n" (signature ~named:false f)))
|
|
p.Tast.fns;
|
|
List.iter (fun f -> emit_fn m ~hidden:dev f) targets;
|
|
if dev then begin
|
|
(* Publishing is a separate, named function rather than a constructor: the
|
|
agent has to choose *when* the swap happens — at a frame boundary, on
|
|
the game thread — and a loader-run ctor would do it during dlopen, on
|
|
whatever thread called it, in the middle of a frame.
|
|
|
|
Order inside it is load-bearing. Every lookup is resolved before any
|
|
body is published, because publishing first exposes a function whose
|
|
slots are still null to anything that calls it. *)
|
|
let b = Buffer.create 512 in
|
|
let n = ref 0 in
|
|
let fresh () = incr n; Printf.sprintf "%%d%d" !n in
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
let t = fresh () in
|
|
Buffer.add_string b
|
|
(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)))
|
|
new_fns;
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
let t = fresh () in
|
|
(* sizeof, spelled the way LLVM spells it: the offset of element one
|
|
of a null pointer. Cheaper than a layout calculator in OCaml that
|
|
would have to agree with LLVM's on every target. *)
|
|
Buffer.add_string b
|
|
(Printf.sprintf
|
|
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64))\n \
|
|
store ptr %s, ptr %s\n"
|
|
t (cstring m ("flan." ^ g.Tast.gname)) (ll g.Tast.gty) t
|
|
(globalptr g.Tast.gname)))
|
|
new_globals;
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
if known f.Tast.name then
|
|
Buffer.add_string b
|
|
(Printf.sprintf " store ptr %s, ptr %s\n" (fname f.Tast.name)
|
|
(cellname f.Tast.name))
|
|
else begin
|
|
let t = fresh () in
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %s = load ptr, ptr %s\n store ptr %s, ptr %s\n"
|
|
t (cellptr f.Tast.name) (fname f.Tast.name) t)
|
|
end)
|
|
targets;
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "\ndefine void @flan_reload_install() {\nentry:\n%s ret void\n}\n"
|
|
(Buffer.contents b))
|
|
end;
|
|
finish m
|