JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/lib/emit.ml
Joseph Ferano d1443808c6 Review follow-ups: the park had the original bug inside it 
- SA_NODEFER. sigaction without it blocks the handler's own signal for the
  whole handler, and here the handler is the park — it never returns. A
  hardware SIGSEGV delivered while SIGSEGV is blocked is not handled: the
  kernel forces the default action. Fault, park, eval something at the
  break loop that faults, daemon gone, exactly the author's session one
  level in. Measured both ways; flan_crash_entered is cleared before the
  hook so each break-loop fault still gets its line, and the case is pinned
  (trap_park ~refault:true), confirmed to fail without the flag.
- Scope the handler to the thread it was armed on. A disposition is per
  process and a merged dev session is one process, so this was shadowing
  OCaml's SIGSEGV handler — and Stack_overflow — for the daemon's whole
  life. Other threads chain to what was installed before. Arming per run
  would leave the parked prompt's evaluations unprotected, since those are
  program code too; the comment says so. Also makes the per-thread
  sigaltstack honest.
- Sweep dyn-view.flan and string-eq.flan, which dev-loop added after the
  first sweep. string-eq:46 wanted the aliasing outright: its comment is
  about two slices sharing a base pointer.
- A StorageExhausted row for bytes, asserting the retry copies once and
  whole rather than re-evaluating its argument.
- Gate the flan_dev_crash_enable declare to dev builds, so this lane adds
  no dev-only text to a release module. flan_bytes_dup stays ungated: a
  release build really calls it.
- Guard the section for wasm32, which compiles this file and has no
  signals.
2026-09-20 23:35:03 +07:00

4649 lines
217 KiB
OCaml
Raw Blame History

(** 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
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 fname n = "@" ^ quoted (Mangle.sym n)
let gname n = "@" ^ quoted (Mangle.sym 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 (Mangle.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. *)
(* The transfer channel's parameter, the one name that is not a Flan name. It
is not a slot: nothing in the language can address it, and it is read and
written only by the guards this file emits. *)
let xfer_param = "%xfer"
(* The condition's own name, for the message an unhandled [error] prints. The
checker has already refused anything that is not a struct. *)
let struct_name_of (t : Types.t) =
match t with Types.Named n -> n | _ -> "a condition"
let cellptr n = "@" ^ quoted (Mangle.cellptr n)
let globalptr n = "@" ^ quoted (Mangle.globalptr n)
(* 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
for, so a crossed pair — an LLVM module in an [--x86] host, or the reverse —
is refused by the loader at [dlopen] instead of running until the first call
into a redefined function that takes or returns a struct, which is where the
two conventions disagree and where the crossed pair was measured dying with
SIGSEGV. See [X86.abi_marker], which is the same mechanism spelled for the
other backend, and docs/handoffs/HANDOFF-x86-abi-marker.md. *)
let abi_marker = "flan.abi.llvm"
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 ─────────────────────────────────────────────────────────── *)
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"
(* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a
copy of one: see Types. Opaque here in the same sense [ptr] is. *)
| Types.Alloc -> "ptr"
(* A function value is a code address and nothing else. There is no
environment beside it — capture does not exist (check.ml refuses it by
name) — so it is one pointer, the same width as any other, and a backend
needs to know no more about it than that. *)
| Types.Fn _ -> "ptr"
(* ptr + len + cap + allocator, and two more words the runtime owns: see
flan_rt.c's (Vec T) header for why they are in every build. Nothing in
this file reads a field of one — every operation is a runtime call taking
the Vec's address — so the shape is here only so that a slot, a struct
field and a copy in the IR are the right number of bytes. *)
| Types.Vec _ -> "%vec"
(* data + len + log2cap + allocator + gen + epoch. Six words, exactly as the
Vec's, and read here for exactly the same reason: nothing in this file
touches a field of one — every operation is a runtime call taking the
map's address — so the shape exists only so that a slot, a struct field
and a copy in the IR are the right number of bytes. *)
| Types.Map _ -> "%map"
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
(* One word, and [i64] rather than a pointer type: runtime/flan_dyn.h says
[typedef uint64_t flan_dyn], and the IR agreeing with that typedef is the
whole of what keeps the two sides linkable. Nothing here ever loads
through it — a dyn word is only ever passed to a flan_dyn_* call — so the
integer spelling costs no casts and keeps the emitter honest about not
knowing whether the bits are a pointer. *)
| Types.Dyn -> "i64"
| Types.Var _ ->
(* The checker rejects it 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
(* -- Debug info ----------------------------------------------------- *)
(* DWARF, as LLVM metadata. This is only worth the lines it takes because of
the layout above: a Flan struct *is* its C struct, every slot is an alloca
and there are no tag words, so the debug info describes machine types
directly and lldb has to learn nothing about Flan. The compile unit says
DW_LANG_C99 for that reason -- it is less a claim about the source language
than the truth about the data model, and it is what makes lldb's own
struct-printing correct here.
Metadata is a flat numbered pool with no ordering requirement, so a node can
be allocated an id, referred to, and written out later -- which is what
makes a recursive struct (a field of type [(Ptr Self)]) expressible. *)
type dbg = {
mutable dn : int; (* next metadata id *)
dout : Buffer.t; (* the [!N = ...] lines *)
dfiles : (string, int) Hashtbl.t; (* path -> !DIFile *)
dtys : (string, int) Hashtbl.t; (* Types.to_string -> a type node *)
dlocs : (string, int) Hashtbl.t; (* scope:line:col -> !DILocation *)
mutable dcu : int;
}
let dalloc d = let n = d.dn in d.dn <- n + 1; n
let dput d n body = Buffer.add_string d.dout (Printf.sprintf "!%d = %s\n" n body)
let dnode d body = let n = dalloc d in dput d n body; n
(* Metadata strings are C strings in the .ll grammar, so the two characters
that could end one have to be escaped. Flan names contain - ? > and /, none
of which do. *)
let dstr s =
let b = Buffer.create (String.length s + 2) in
String.iter
(fun c ->
if c = '"' || c = '\\' then (Buffer.add_char b '\\'; Buffer.add_char b c)
else Buffer.add_char b c)
s;
Buffer.contents b
let dfile d path =
match Hashtbl.find_opt d.dfiles path with
| Some n -> n
| None ->
let abs =
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path
in
let n =
dnode d
(Printf.sprintf "!DIFile(filename: \"%s\", directory: \"%s\")"
(dstr (Filename.basename abs)) (dstr (Filename.dirname abs)))
in
Hashtbl.replace d.dfiles path n;
n
(* -- Layout ----------------------------------------------------------
DWARF wants member offsets as integer literals: [!DIDerivedType(tag:
DW_TAG_member, offset: N)] takes a constant and nothing else, so the
[ptrtoint (ptr getelementptr ...)] form this file uses elsewhere for a size
is not accepted there and these have to be computed. That makes this the one
place in the backend where a layout number is worked out rather than handed
to LLVM, and it is exactly where a wrong answer shows up as a plausible
value printed for the wrong field. So the acceptance test checks every
offset against LLVM's own [getelementptr] answer for the same struct type,
not against a table written by the same hand as the code.
The rules are C's, which is what LLVM gives a non-packed literal struct:
natural alignment, each member at the next aligned offset, tail padding out
to the struct's own alignment. The numbers are the host's -- [ptr] is 8
bytes -- which is why [Build] refuses a debug build for wasm32. *)
let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a
(* ── Module-level state ────────────────────────────────────────────── *)
type m = {
out : Buffer.t;
strs : Buffer.t; (* string literal constants *)
structs : (string, Tast.structure) Hashtbl.t;
(* The declared data types, by name. [Types.Named] covers both a struct and a
data type, so which table the name is in is the only thing that says which
this is — the same arrangement the checker uses, and for the same reason:
a data type is a type like any other everywhere except at its layout, its
construction and its match. *)
datas : (string, Tast.data) Hashtbl.t;
(* The untagged unions, by name. A third table for the same [Types.Named],
on the same principle as the second: the name says which, and the members
are a field list whose offsets are all zero. *)
unions : (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;
(* [Some] in a debug build. It lives on the module rather than being passed
down because every emitter that can produce an instruction has to be able
to hang a location on it. *)
dbg : dbg option;
(* True in a sanitized build, and the whole of what ASan needs from us.
AddressSanitizer is an LLVM *pass*, but it instruments only functions
carrying the [sanitize_address] attribute — which clang's C frontend adds
and nothing adds to IR written by hand. Passing -fsanitize=address to the
clang run over this .ll therefore instruments the runtime's C and not one
instruction of Flan; measured, not assumed (see NEXT.md). So every
[define] here names attribute group #0 and [finish] writes it out.
There is no equivalent for UndefinedBehaviorSanitizer: its checks are
emitted by the C frontend as branches to __ubsan_handle_*, and no
attribute asks a pass to produce them. UBSan over this .ll covers the C
and nothing else. *)
sanitize : bool;
mutable nstr : int;
(* The frame descriptors a dev build's shadow stack points at, counted apart
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
whether an expression thunk's module may be unloaded — a string literal in
the module image is something the program may still be pointing at after
the thunk returns. A frame descriptor is not: the frames that named it
were popped on the way out, and the break loop copies the bytes it shows
rather than keeping the pointer. Counting these in [nstr] would silently
stop every C-x C-e module from ever being unloaded. *)
mutable nfi : int;
(* The per-type dyn descriptors this module has had to name, by symbol. The
value is the byte offsets of the dyn words inside one instance and the
instance's size — runtime/flan_dyn.h's [flan_desc], in the two numbers a
backend needs to write it out.
A table and not a buffer, because the two backends write the same data in
two syntaxes: this is what they agree about, and each renders it at the
end of its own module. Keyed by [Types.to_string] — which is an identity,
since two types are the same type exactly when their printed forms agree
— and never by the symbol, which is a mangle and therefore many-to-one.
The value carries the symbol the backend writes it under, so a type asked
for twice is emitted once.
Not counted in [nstr], and for [nfi]'s reason rather than by oversight. A
string literal in a module image is something the program may still be
pointing at after a thunk returns, which is why [nstr] gates unloading. A
descriptor is not: nothing but the collector's root stack ever holds one,
the entries that named it came off when the frames that pushed them did,
and no value of any type points at one. A redefinition module naming a
type the base program already named therefore gets its own copy, which is
harmless — a descriptor is read-only and has no identity. *)
descs : (string, string * int list * int) Hashtbl.t;
}
(* The attribute group every emitted function names, empty unless sanitizing.
Spelled once so the [define] sites and [finish] cannot disagree. *)
let attrs m = if m.sanitize then " #0" else ""
(* The type of one member, of a struct or of a union alike — the index means
the same thing in both, and only the offset it lands at differs. *)
let field_ty m sn i =
let s =
match Hashtbl.find_opt m.structs sn with
| Some s -> s
| None -> Hashtbl.find m.unions sn
in
(List.nth s.Tast.fields i).Tast.fty
(* Size and alignment in bytes. *)
let rec lay m (t : Types.t) : int * int =
match t with
| Types.Int k -> let n = Types.bits k / 8 in n, n
| Types.Float Types.F32 -> 4, 4
| Types.Float Types.F64 -> 8, 8
(* [i1] occupies a byte in memory. *)
| Types.Bool -> 1, 1
| Types.String | Types.Slice _ -> 16, 8
| Types.Unit | Types.Never -> 0, 1
| Types.Enum _ -> 4, 4
| Types.Ptr _ -> 8, 8
| Types.Alloc -> 8, 8
| Types.Fn _ -> 8, 8
| Types.Vec _ | Types.Map _ -> 40, 8
(* [n x T] adds no padding of its own: T's size already carries its tail. *)
| Types.Array (n, e) -> let s, a = lay m e in Int64.to_int n * s, a
| Types.Option e -> let s, a, _ = lay_fields m [ Types.Int Types.I8; e ] in s, a
| Types.Named n ->
(match Hashtbl.find_opt m.structs n with
| Some st ->
let s, a, _ =
lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields)
in
s, a
| None ->
match Hashtbl.find_opt m.datas n with
| Some u ->
(* The tag then the payload, as one struct, so the answer is the same
arithmetic every other aggregate here gets rather than a second
rule that could drift from it. *)
let size, align = payload_lay m u in
if size = 0 then 4, 4
else
let s, a, _ =
lay_fields m
[ Types.Int Types.I32;
Types.Array (Int64.of_int (size / align),
Types.Int (int_kind (align * 8))) ]
in
s, a
| None ->
match Hashtbl.find_opt m.unions n with
| Some u -> union_lay m u
| None -> failwith ("no layout for struct " ^ n))
| Types.Dyn -> 8, 8
| Types.Var _ -> failwith ("no layout for " ^ Types.to_string t)
(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
let off = ref 0 and al = ref 1 and rev = ref [] in
List.iter
(fun t ->
let s, a = lay m t in
let a = if a < 1 then 1 else a in
off := align_up !off a;
rev := !off :: !rev;
off := !off + s;
if a > !al then al := a)
tys;
align_up !off !al, !al, List.rev !rev
(* C's union rule, and it is the only thing about this type that is not a
struct's: room for the largest member, the alignment the strictest member
needs, and the size rounded up to that alignment so an array of the union
keeps every element aligned. Written through [lay] and [align_up] rather
than with arithmetic of its own, so it cannot drift from the payload
measurement below — which is the same rule over a data type's cases, and
was here first. *)
and union_lay m (u : Tast.structure) : int * int =
let align = ref 1 and size = ref 0 in
List.iter
(fun (fl : Tast.field) ->
let s, a = lay m fl.Tast.fty in
let a = if a < 1 then 1 else a in
if a > !align then align := a;
if s > !size then size := s)
u.Tast.fields;
align_up !size !align, !align
(* The size and alignment of a data type's payload: room for the largest case, with
the alignment the widest member of any case needs, and the size rounded up
to it so the blob divides evenly into [k x iA]. A data type of payload-less
cases has a zero-size payload and is a bare tag. *)
and payload_lay m (u : Tast.data) : int * int =
let align = ref 1 and size = ref 0 in
List.iter
(fun (c : Tast.variant) ->
let s, a, _ =
lay_fields m (List.map (fun (f : Tast.field) -> f.Tast.fty) c.Tast.vfields)
in
if a > !align then align := a;
if s > !size then size := s)
u.Tast.cases;
align_up !size !align, !align
(* The integer kind of a given width, for the payload blob's element type. *)
and int_kind = function
| 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64
| n -> failwith ("no integer type of " ^ string_of_int n ^ " bits")
(* ── Per-type dyn descriptors ────────────────────────────────────────
*
* Where the dyn words are inside one instance of a type, in bytes from its
* first, ascending. This is the whole of what runtime/flan_dyn.h's [flan_desc]
* holds, and the whole of what the collector needs in order to mark a struct
* that has dyn fields in it.
*
* Flattened, not a graph: a struct held by value inside another contributes
* its own offsets shifted by where it sits, and a fixed array contributes its
* element's offsets once per element. So nesting costs nothing at run time —
* there is no second descriptor to follow and no recursion in the marker — at
* the price of a descriptor whose length grows with an array's length, which
* [Check] caps so that the price is one a program can be told about.
*
* Everything that is not a struct, an array or a dyn answers with no offsets,
* and for the container cases that is a refusal upstream rather than a guess
* here: a [(Vec S)] whose element has a dyn field is storage this descriptor
* cannot describe — the length is not static — and [Check] says so by name.
* The typed-container view of the M2 queue's item 3 is what grows a descriptor
* that can, and it will read [size] below as its stride.
*
* [seen] is belt and braces. A struct cannot contain itself by value and be
* laid out at all, so [lay] would already have recursed forever; this makes
* the walk terminate on its own terms rather than on that assumption. *)
and dyn_offsets m (t : Types.t) : int list =
let rec go seen base (t : Types.t) acc =
match t with
| Types.Dyn -> base :: acc
| Types.Array (n, e) ->
let s, _ = lay m e in
let acc = ref acc in
for i = Int64.to_int n - 1 downto 0 do
acc := go seen (base + i * s) e !acc
done;
!acc
| Types.Named nm when not (List.mem nm seen) ->
(match Hashtbl.find_opt m.structs nm with
| Some st ->
let tys = List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields in
let _, _, offs = lay_fields m tys in
List.fold_left2
(fun acc ty off -> go (nm :: seen) (base + off) ty acc)
acc tys offs
(* A data type's payload is a union of its cases and a union's members
all start at the same byte, so which words are dyn depends on the tag
— which is a run-time question a static descriptor cannot answer.
Refused in [Check] rather than described wrongly here. *)
| None -> acc)
(* [Types.Option], [Types.Vec] and [Types.Map] fall through here with no
arm of their own and answer no offsets, which is correct only because
nothing reaches this function holding one with a dyn inside it:
[Check.hidden_dyn] refuses that at every global, parameter, return and
frame slot first. If that gate is ever relaxed — the typed-container
view the M2 queue's item 3 is building is exactly the kind of change
that would relax it for [Vec]/[Map] — this arm has to grow alongside
it, the way the array and struct arms above already walk their own
storage; until then a silent [] here would be an unrooted dyn, not a
refusal. *)
| _ -> acc
in
List.sort_uniq compare (go [] 0 t [])
(* The readable half of a descriptor's symbol: the type's printed form with
every character an assembler would not take replaced. It is a *label* and
not an identity — the mangle is many-to-one, because a Flan name may hold
[-], [+], [*], [?] and [/], all of which come out as the same character
here, so [row-a] and [row+a] mangle alike. The identity is the printed form
itself, which is what [descs] is keyed by; the number [desc_of] appends is
what keeps two types that mangle alike from sharing a symbol.
That was a real defect and not a hypothetical: keyed by the mangle, the
first of the two registered won, the second was pushed with the first's
descriptor, and the collector read at offsets belonging to another type —
past the end of the object when the first was the larger, and never at the
offset where the second's dyn actually sat. The same corruption [root_plan]
pools its temporaries to avoid, arriving through the name instead. *)
let desc_mangle (t : Types.t) =
let b = Buffer.create 32 in
String.iter
(fun c ->
if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
|| (c >= '0' && c <= '9') || c = '_'
then Buffer.add_char b c
else Buffer.add_char b '.')
(Types.to_string t);
Buffer.contents b
(* The descriptor for a type, recorded on the module and named. [None] when the
type holds no dyn, which is the answer for almost every type in almost every
program and is what keeps a dyn-free program's output byte for byte what it
was.
Keyed by [Types.to_string], which is an identity: two types are the same
type exactly when their printed forms agree. The symbol carries a counter so
that two distinct types cannot collide however they mangle; it is stable for
a given program because registration order is emission order and emission
order is deterministic. Private or local in both backends, so a redefinition
module naming the same type as the program it patches is not a duplicate
symbol. *)
let desc_of m (t : Types.t) : string option =
match dyn_offsets m t with
| [] -> None
| offs ->
let key = Types.to_string t in
match Hashtbl.find_opt m.descs key with
| Some (sym, _, _) -> Some sym
| None ->
let sym =
Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs)
in
Hashtbl.replace m.descs key (sym, offs, fst (lay m t));
Some sym
(* A DWARF type node for a Flan type, memoised by the type's printed form so
the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int =
let key = Types.to_string t in
match Hashtbl.find_opt d.dtys key with
| Some n -> n
| None ->
let basic name bits enc =
dnode d
(Printf.sprintf "!DIBasicType(name: \"%s\", size: %d, encoding: %s)"
(dstr name) bits enc)
in
(* A struct-shaped node, with its id claimed before the members are built:
a field of type [(Ptr Self)] comes back through here. *)
let composite name members =
let id = dalloc d in
Hashtbl.replace d.dtys key id;
let size, al, offs = lay_fields m (List.map snd members) in
let ms =
List.map2
(fun (mname, mty) off ->
let fs, fa = lay m mty in
let base = dty m d mty in
dnode d
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: %d)"
(dstr mname) base (fs * 8) (fa * 8) (off * 8)))
members offs
in
dput d id
(Printf.sprintf
"!DICompositeType(tag: DW_TAG_structure_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
(dstr name) (size * 8) (al * 8)
(String.concat ", " (List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id
in
let n =
match t with
| Types.Int k ->
(* DW_ATE_signed / DW_ATE_unsigned, not the _char variants: an i8 is a
number in Flan, and lldb prints a character for a char. *)
basic (Types.to_string t) (Types.bits k)
(if Types.signed k then "DW_ATE_signed" else "DW_ATE_unsigned")
| Types.Float k -> basic (Types.to_string t) (Types.bits_f k) "DW_ATE_float"
| Types.Bool -> basic "bool" 8 "DW_ATE_boolean"
| Types.Enum e -> basic e 32 "DW_ATE_signed"
| Types.Unit | Types.Never -> composite (Types.to_string t) []
| Types.Ptr e ->
let id = dalloc d in
Hashtbl.replace d.dtys key id;
(* [(Ptr Unit)] and [(Ptr Never)] are the opaque pointer, and a DWARF
pointer with no base type is exactly C's void *. *)
let base =
match e with
| Types.Unit | Types.Never -> "null"
| e -> Printf.sprintf "!%d" (dty m d e)
in
dput d id
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_pointer_type, baseType: %s, size: 64)" base);
id
| Types.Array (n, e) ->
let base = dty m d e in
let size, al = lay m t in
let sub = dnode d (Printf.sprintf "!DISubrange(count: %Ld)" n) in
dnode d
(Printf.sprintf
"!DICompositeType(tag: DW_TAG_array_type, baseType: !%d, size: %d, align: %d, elements: !{!%d})"
base (size * 8) (al * 8) sub)
(* ptr+len, and shown as ptr+len. There is no hidden owner and no
capacity, so two members are the whole truth about a slice. *)
| Types.String ->
composite "string"
[ ("ptr", Types.Ptr (Types.Int Types.U8)); ("len", Types.Int Types.I64) ]
| Types.Slice e ->
composite (Types.to_string t)
[ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64) ]
| Types.Option e ->
composite (Types.to_string t)
[ ("tag", Types.Int Types.U8); ("value", e) ]
| Types.Named sn ->
(match Hashtbl.find_opt m.structs sn with
| Some st ->
composite sn
(List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty))
st.Tast.fields)
| None ->
match Hashtbl.find_opt m.datas sn with
(* The truth about the bytes, and nothing cleverer: a tag and a blob.
DWARF 5 has DW_TAG_variant_part for exactly this, and lldb's C
support does not use it — a debugger that was handed one would
show less, not more. The reader who wants the payload reads it
through the case's own type, which is emitted beside this. *)
| Some u ->
let size, align = payload_lay m u in
composite sn
([ ("tag", Types.Int Types.U32) ]
@ (if size = 0 then []
else
[ ("payload",
Types.Array (Int64.of_int (size / align),
Types.Int (int_kind (align * 8)))) ]))
| None ->
(* DW_TAG_union_type, which is the one place a DWARF tag says
exactly what the Flan type is — every member at offset zero,
each with its own type. lldb's C support reads this and prints
every member of a union side by side, which is the only honest
thing to show: the debugger cannot know which one is live
either. *)
match Hashtbl.find_opt m.unions sn with
| Some u ->
let id = dalloc d in
Hashtbl.replace d.dtys key id;
let size, al = union_lay m u in
let ms =
List.map
(fun (fl : Tast.field) ->
let fs, fa = lay m fl.Tast.fty in
let base = dty m d fl.Tast.fty in
dnode d
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: 0)"
(dstr fl.Tast.fname) base (fs * 8) (fa * 8)))
u.Tast.fields
in
dput d id
(Printf.sprintf
"!DICompositeType(tag: DW_TAG_union_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
(dstr sn) (size * 8) (al * 8)
(String.concat ", "
(List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id
| None -> failwith ("no debug type for struct " ^ sn))
(* An opaque pointer under lldb, which is the truth: the allocator's
fields are the runtime's C and lldb already has that type from
flan_rt.c's own debug info. *)
| Types.Alloc ->
dnode d
"!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)"
(* Shown as what it is. The epoch word is in the layout and so it is
here too: a debugger that showed four fields of a five-field struct
would put the reader's offsets out by one. *)
| Types.Vec e ->
composite (Types.to_string t)
[ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64);
("cap", Types.Int Types.I64); ("allocator", Types.Alloc);
("epoch", Types.Int Types.I64) ]
(* Five fields again, and shown as five for the same reason: a debugger
that showed fewer would put the reader's offsets out. [log2cap] is
shown rather than a capacity because that is what is stored — the
capacity is 1 << it, and a debugger that invented the shift would be
describing a field that is not there. *)
| Types.Map (k, v) ->
composite (Types.to_string t)
[ ("data", Types.Ptr (Types.Int Types.U8));
("len", Types.Int Types.I64); ("log2cap", Types.Int Types.I64);
("allocator", Types.Alloc); ("epoch", Types.Int Types.I64) ]
|> fun n -> ignore k; ignore v; n
(* A pointer to code, and lldb is told exactly that and no more. DWARF
has DW_TAG_subroutine_type for the signature behind it, and spelling
one out here would buy a reader nothing they cannot get from the
function it points at — [p f] answers with an address either way, and
the address is what resolves to a symbol. The name carries the
signature, which is where it is actually legible. *)
| Types.Fn _ ->
dnode d
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_pointer_type, name: \"%s\", \
baseType: null, size: 64)"
(Types.to_string t))
(* An unsigned word, which is what the typedef says it is. Telling lldb
it is a pointer would be a guess about the encoding the compiler has
deliberately not made, and telling it nothing would leave [p x] on a
dyn local with no answer at all. A raw word is the true and useful
reading: it prints, and the person reading it can hand it to the
runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ ->
failwith ("no debug type for " ^ Types.to_string t)
in
Hashtbl.replace d.dtys key n;
n
(* ── 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;
(* The transfer channel's landing blocks, spec-conditions.md §6. A guard
after a call branches to the innermost one; each pops whatever frames it
established and either catches the transfer or forwards it outward. The
innermost is first, and with none open a transfer leaves the function
through [unwind], which runs its defers (§5) and returns early. The flag
says the block was branched to, so an unused one is not emitted. *)
mutable pads : (string * bool ref) list;
(* The loops being emitted, innermost first: for each, the label a [break]
branches to and the label a [continue] branches to. Exactly the shape
[pads] has, and for the same reason — a jump names its target by how far
out it is, so the stack is the lookup. [Tast.Break] carries that distance
already, so this is indexed and never searched. *)
mutable loops : (string * string) list;
unwind : string;
mutable unwound : bool;
defers : Tast.expr list;
(* The function's !DISubprogram, in a debug build, and the line it was
declared on -- the fallback for a node the checker made up. *)
dsub : int option;
dline : int;
(* The value the shadow-stack head held when this function was entered, in a
dev build: [Some %fprev]. Every [ret] restores it — see [ret] — which is
what makes the pop happen on the transfer path as well as the normal one.
[None] in a release build, where there is no frame at all. *)
mutable frame : string option;
(* How many dyn roots this function pushed at entry, and so how many one
[flan_dyn_root_pop] at each exit takes off. Zero for every function with
no dyn in it, which is every function in every program written so far —
and zero means *nothing is emitted at all*, neither push nor pop nor a
pop of zero. That is what keeps a fully annotated program's IR byte for
byte what it was before dyn existed, which is the thing [--no-gc]
promises and is tested for.
It is a count and not a saved depth because the ABI offers
[flan_dyn_root_pop(n)] and no way to read the stack's height; it can be a
count, rather than needing one, because the number is a static property of
the function that [dyn_roots] works out before a line of the body is
emitted. That matters: [ret] runs *during* emission, and a count
accumulated as roots were discovered would be short at every early
return. *)
mutable droots : int;
(* The root slots' addresses, in push order: the dyn slots first and then one
per dyn-producing runtime call, minted by [dyn_tmp] as the body is
emitted. Both kinds are entry-block allocas, so the addresses are good for
the function's whole extent — which is why rooting is per function here
and not per scope. A slot that is not live any more holds a value the
collector keeps one cycle longer than it must, and that is the safe
direction to be wrong in. *)
mutable droot_ns : string list;
(* The aggregate root slots, pooled by type: every entry under one type is
interchangeable, so [agg_tmp] takes the head of the right pool and order
within a pool never matters. See [root_plan] for why this is by type and
not a single positional list. *)
mutable aroot_ns : (string * string list) list;
(* Where a dev build records each slot's address, so that a stopped frame's
locals can be read. [None] in a release build and in a function with no
named slot at all. Only *named* slots are recorded: a slot the compiler
invented has no name to show, and leaving its alloca unrecorded leaves it
promotable, which is where most of the cost of this would otherwise be.
An entry is null until the binding that fills the slot has run — that is
how "not bound yet at this point" is told from "bound", with no liveness
analysis and no bitmap. *)
mutable slotv : string option;
snames : string option array;
(* The [, !dbg !N] suffix every instruction in this function carries, or "".
Uniform rather than only on the instructions that want a line: LLVM's
verifier rejects a call without a location inside a function that has
debug info, and this file emits calls from a dozen places -- the bounds
failure, the handler push and pop, the transfer guards -- none of which
would remember to ask. *)
mutable dloc : string;
}
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 ^ f.dloc ^ "\n")) fmt
(* A fixed array has no padding between elements, so its zero value is exactly
a run of zero bytes. Naming that operation lets LLVM choose its bulk-clear
implementation instead of expanding a large aggregate store into one store
per element. Keep small arrays as typed stores: their inline code is
cheaper than a call on targets which do not inline the intrinsic. *)
let bulk_zero_min_bytes = 64
let emit_bulk_zero f ptr ty =
match ty with
| Types.Array _ ->
let size, align = lay f.md ty in
if size >= bulk_zero_min_bytes then begin
ins f
"call void @llvm.memset.p0.i64(ptr align %d %s, i8 0, i64 %d, i1 false)"
align ptr size;
true
end else false
| _ -> false
(* ── The dead-beef pattern ─────────────────────────────────────────────
[(dead-beef)] writes DE AD BE EF in ascending address order, so [xxd] over
the filled storage reads "deadbeef" and not "efbeadde". That is the whole
reason the builtin exists, so the byte order is the specification and not
an implementation detail.
[(dead-beef V)] writes V's four bytes under the same rule, and the rule is
what makes the two arities one thing: *a pattern's ascending bytes are its
big-endian bytes*, which is exactly how the hex literal reads left to
right. So [(dead-beef 0xBAADF00D)] lays down BA AD F0 0D. Nothing here
knows about the bare form: the checker writes [Tast.dead_beef_default] in
where the argument would have been, so this file only ever sees a pattern.
On a little-endian machine the word a 4-byte store must leave is therefore
the byte reversal of the pattern, which is all [word_of_pattern] is. Both
backends go through here — x86 through [rep stosd] with this word in [eax],
this file through a store of it — and the acceptance program reads the
bytes back by index to keep them honest.
A run whose size is not a multiple of four ends on a prefix of the
ascending bytes: one over is DE, two is DE AD, three is DE AD BE. *)
(* The pattern's bytes in the order they land in memory, which is
most-significant first — the order the literal is written in. *)
let bytes_of_pattern (v : int32) =
List.map
(fun k ->
Int32.to_int
(Int32.logand (Int32.shift_right_logical v (8 * k)) 0xFFl))
[ 3; 2; 1; 0 ]
(* The i32 a little-endian store leaves those bytes as: the same list folded
back the other way, so one definition answers for both and a change to the
byte order cannot reach only half of it. *)
let word_of_pattern (v : int32) =
List.fold_left
(fun acc b -> Int32.logor (Int32.shift_right_logical acc 8)
(Int32.shift_left (Int32.of_int b) 24))
0l (bytes_of_pattern v)
let term f fmt =
Printf.ksprintf
(fun s ->
if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n");
f.live <- false)
fmt
let label f name =
Buffer.add_string f.b (Printf.sprintf "\n%s:\n" name);
f.live <- true
(* Every [ret] in a function body goes through here, which is the whole of how
the shadow stack's pop is got right. There are five of them — an explicit
[return] with a value and without, the [none] arm of [(some x)], the tail of
the body, and the landing block a transfer leaves through — and the last of
those is the one that matters: a condition handled further out unwinds past
this frame, so a pop written only on the normal path leaves a dead frame on
the stack after every handled error, and the next backtrace is a lie. Same
lesson [emit_with_alloc] learned about the context allocator. *)
(* How many dyn roots a function will push, worked out before any of it is
emitted. One per dyn slot — a parameter or a local of that type — and one per
runtime call that answers a dyn, because the word a call hands back is live
from the moment it exists and the next allocation may be the one that
collects it.
Rooting every dyn-producing call, rather than only the ones whose value
outlives a call, is conservative and is the only thing available: this file
has no liveness and no lexical scope, both of which the checker resolved
away into flat slot indices long before anything got here. The cost is real
and is the cost of a precise collector with an address-registration ABI
rather than stack maps — a rooted alloca has its address escape through
[flan_dyn_root_push], so mem2reg cannot promote it, and every dyn value
becomes a stack slot with a store at every optimisation level.
A count rather than a running tally for the reason [droots] gives: [ret] is
reached while the body is still being emitted.
Since the per-type descriptors there is a second kind of root beside the
bare dyn word: an aggregate — a struct with a dyn field, a struct holding
one of those, a fixed array of either — whose descriptor says where its dyn
words are. It goes on the same stack and comes off in the same pop, so the
count below is still the number the epilogue takes off; what changed is that
the plan has to say, per entry, which kind it is. *)
(* Which expressions [addr] can answer without copying. Shared with [addr]
itself rather than repeated, because the counter below has to make exactly
the same call: a place has an address already and needs no root, and
everything else is copied into a temporary that does. *)
let addr_is_place (e : Tast.expr) =
match e.Tast.e with
| Tast.Local _ | Tast.Global _ | Tast.Deref _ | Tast.Field _
| Tast.Prim (Tast.At, _ :: _) -> true
| _ -> false
(* A function's roots, worked out before a line of it is emitted, and the one
thing both backends read rather than each deriving it. [rslots] is the frame
slots, in slot order; [rdyn] is how many bare dyn temporaries the body
mints; [ragg] is the aggregate temporaries, as their types.
The aggregate temporaries are *pooled by type* rather than handed out in
mint order, which is the one design decision here worth the sentence. A
positional supply that drifted from the emission would pair an address with
the wrong type's descriptor, and reading arbitrary offsets off a base and
marking whatever is there is memory corruption rather than a missed root —
a worse failure than the one [dyn_tmp]'s fallback already admits. Pooled by
type, every temporary in a pool is interchangeable, so the only thing that
can go wrong is running out, and running out falls back to an unrooted
slot.
Why pooling cannot alias two live values: the count is per *node* and each
node draws exactly once, and two values that are live at the same time are
always two nodes. A node inside a loop draws one slot and reuses it across
iterations, which is right — the previous iteration's value is dead, and
where it is not, it is dead here and live in the named slot that kept it,
which is rooted on its own. *)
type rootplan = {
rslots : (int * Types.t) list; (* slot index and its type, in slot order *)
rdyn : int;
ragg : Types.t list; (* sorted, with multiplicity *)
}
let root_plan m (fn : Tast.fn) : rootplan =
let rslots = ref [] in
Array.iteri
(fun i t ->
if t = Types.Dyn || dyn_offsets m t <> [] then
rslots := (i, t) :: !rslots)
fn.Tast.slots;
let dyn = ref 0 and agg = ref [] in
let want (t : Types.t) = t <> Types.Dyn && dyn_offsets m t <> [] in
let count (e : Tast.expr) =
match e.Tast.e with
| Tast.Prim (Tast.Rt _, _) when e.Tast.ty = Types.Dyn -> incr dyn
(* A Flan call answering a dyn, which wants the same slot a dyn-producing
runtime call gets and did not have one until the descriptors went in.
The hazard is the aggregate's exactly: the callee rooted the word and
popped it in its epilogue, so between the return and the caller's store
the only copy is a register. *)
| Tast.Call (_, _) | Tast.CallPtr (_, _) when e.Tast.ty = Types.Dyn ->
incr dyn
(* A call answering an aggregate with a dyn in it. The value comes back in
a register or through an sret buffer the frame is about to hand out
again, and either way the dyn word inside it was last rooted by the
frame that has just popped its roots and returned. *)
| Tast.Call (_, _) | Tast.CallPtr (_, _) when want e.Tast.ty ->
agg := e.Tast.ty :: !agg
(* The two places a non-place expression's *address* is taken and then
given to something that can allocate: the condition a signal crosses on
(the handler runs, and a handler allocates) and an explicit address-of.
Every other [addr] on a non-place is a copy a load or a store consumes
on the next instruction, with no allocation in between. *)
| Tast.Signal (_, _, c) when (not (addr_is_place c)) && want c.Tast.ty ->
agg := c.Tast.ty :: !agg
| Tast.Prim (Tast.AddrOf, [ x ])
when (not (addr_is_place x)) && want x.Tast.ty ->
agg := x.Tast.ty :: !agg
| _ -> ()
in
List.iter (Tast.walk count) fn.Tast.body;
(* And the transfer path's copy of the defers, which is a second list of the
same expressions and is emitted as well — so it mints a second set of
temporaries, and counting only [body] left every one of them in a slot the
collector never heard of. The fallback in [dyn_tmp] meant that was silent:
the pushes and the pops still balanced, and four dyn values in a defer
reached on a handled condition were simply invisible. Found by emitting
one and counting [%dx] in the IR, which is the only thing that can see it
while the runtime is a stub that never collects. *)
List.iter (Tast.walk count) fn.Tast.fdefers;
{ rslots = List.rev !rslots;
rdyn = !dyn;
(* Sorted so the pools are built in an order both backends agree on: an
asm listing and an IR listing put the same value at the same depth. *)
ragg =
List.sort (fun a b -> String.compare (Types.to_string a) (Types.to_string b))
!agg }
let dyn_roots m (fn : Tast.fn) =
let p = root_plan m fn in
List.length p.rslots + p.rdyn + List.length p.ragg
(* The next pre-made root slot for a dyn temporary. They are all minted, zeroed
and pushed in the entry block before a line of the body is emitted, and this
only hands them out — which is what makes the pushes and the pops balance by
construction rather than by the body being walked the same way twice.
[dyn_roots] counts the same nodes the emission visits, so the supply runs
out only if those two disagree. If it ever does, the fallback is an ordinary
unrooted slot: one temporary the collector cannot see is a bug to find,
where a root stack that pops more than it pushed is memory corruption. *)
(* The same for an aggregate temporary, out of the pool for its type. A pool
that runs dry falls back to an ordinary unrooted alloca, exactly as
[dyn_tmp] does and for the same reason — the safe direction to be wrong in
is a temporary the collector cannot see, never a root stack out of step. *)
let agg_tmp f (ty : Types.t) =
let key = Types.to_string ty in
match List.assoc_opt key f.aroot_ns with
| Some (n :: rest) ->
f.aroot_ns <- (key, rest) :: List.remove_assoc key f.aroot_ns;
n
| _ ->
let name = Printf.sprintf "%%ax%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas
(Printf.sprintf " %s = alloca %s\n" name (ll ty));
name
let dyn_tmp f =
match f.droot_ns with
| n :: rest -> f.droot_ns <- rest; n
| [] ->
let name = Printf.sprintf "%%dx%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca i64\n" name);
name
let ret f v =
(match f.frame with
| Some prev -> ins f "store ptr %s, ptr @flan_frame_head" prev
| None -> ());
(* The pop, on every path out, for exactly the reason the shadow stack's is
here: a condition handled further out unwinds through the landing block,
and a pop written only on the normal path would leave this function's
roots on the stack after every handled error. The [unreachable]
terminators emit none, and are right not to — each of them dies inside C
and the process does not come back. *)
if f.droots > 0 then
ins f "call void @flan_dyn_root_pop(i64 %d)" f.droots;
term f "ret %s %s" (ll f.ret) v
(* The store that says "this slot is bound now". Emitted at each binding of a
named slot — a [let], a match arm, a restart clause's parameters — and at
entry for the parameters, which are bound before any of the body runs.
It is deliberately the *address* and not a flag: the reader needs the
address anyway, so one store carries both facts, and a slot that has not
been reached yet reads as null rather than as a plausible value at an
address nobody wrote. *)
let bind_slot f i =
match f.slotv with
| None -> ()
| Some v ->
if i < Array.length f.snames && f.snames.(i) <> None then begin
let p = fresh f in
ins f "%s = getelementptr inbounds ptr, ptr %s, i32 %d" p v i;
ins f "store ptr %s, ptr %s" f.slots.(i) p
end
let alloca f ty =
let name = fresh f in
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name (ll ty));
name
(* For the few slots whose LLVM type is not a Flan type: a handler frame is the
runtime's shape, not something [Types] can name. *)
let alloca_raw f lltype =
let name = fresh f in
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name lltype);
name
(* [(filled b)] over storage this file already has the address of. One
[llvm.memset] with the byte in a register, which is exactly what the
intrinsic is for and the reason the single-byte fill is the cheap one: the
same call the zero fill above makes, with an operand instead of a zero. *)
let emit_byte_fill f ptr ty (byte : string) =
let size, align = lay f.md ty in
if size > 0 then
ins f
"call void @llvm.memset.p0.i64(ptr align %d %s, i8 %s, i64 %d, i1 false)"
align ptr byte size
(* [(dead-beef PATTERN)] over the same. [llvm.memset] takes one repeated i8
and nothing else, so a four-byte pattern cannot be a call and has to be a
loop — the snag DISCUSS.org named before this was built, and the reason the
two builtins are two and not one with a wider operand.
The word is either a folded constant or an SSA value, and [word] below is
just its spelling: a literal pattern is byte-reversed here at compile time
and a computed one by [llvm.bswap.i32] at run time, after which the loop
and the tail are the same instructions either way. That is deliberate —
the case a constant-only implementation would quietly get wrong is a
computed pattern over a length that is not a multiple of four, and there
is only one tail here for it to get wrong.
The counter is an entry-block alloca, which is how every local in this file
is spelled and what [mem2reg] promotes; the loop is the same
header/body/exit shape [emit_while] writes. The size is a compile-time
constant, so the trip count is one too and LLVM unrolls what it wants to.
Every store is [align 1]: the pattern is laid down over bytes, and the
storage's own alignment may be 1 — a [7 u8] array is a legal thing to fill.
The tail is the first up-to-three bytes of the *stored word*, lowest
address first, which is byte k = (word >> 8k) & 0xFF. For a constant that
folds to [bytes_of_pattern]'s list; for a computed word it is a shift and
a truncate, ~tail~ times, unrolled because the count is known here. *)
let emit_dead_beef f ptr ty ~(word : string) ~(folded : int32 option) =
let size, _ = lay f.md ty in
let words = size / 4 and tail = size mod 4 in
if words > 0 then begin
let i = alloca_raw f "i64" in
let lc = fresh_label f "fill" and lb = fresh_label f "fillbody"
and le = fresh_label f "fillend" in
ins f "store i64 0, ptr %s" i;
term f "br label %%%s" lc;
label f lc;
let c = fresh f in
ins f "%s = load i64, ptr %s" c i;
let t = fresh f in
ins f "%s = icmp ult i64 %s, %d" t c words;
term f "br i1 %s, label %%%s, label %%%s" t lb le;
label f lb;
let off = fresh f in
ins f "%s = mul i64 %s, 4" off c;
let p = fresh f in
ins f "%s = getelementptr i8, ptr %s, i64 %s" p ptr off;
ins f "store i32 %s, ptr %s, align 1" word p;
let n = fresh f in
ins f "%s = add i64 %s, 1" n c;
ins f "store i64 %s, ptr %s" n i;
term f "br label %%%s" lc;
label f le
end;
for k = 0 to tail - 1 do
let p = fresh f in
ins f "%s = getelementptr i8, ptr %s, i64 %d" p ptr (words * 4 + k);
match folded with
| Some v ->
ins f "store i8 %d, ptr %s, align 1" (List.nth (bytes_of_pattern v) k) p
| None ->
let sh = fresh f in
ins f "%s = lshr i32 %s, %d" sh word (8 * k);
let b = fresh f in
ins f "%s = trunc i32 %s to i8" b sh;
ins f "store i8 %s, ptr %s, align 1" b p
done
(* ── 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
(* ── The shadow stack's descriptors ──────────────────────────────────── *)
(* One [flan_fninfo] per function in a dev build: the name and the location,
as bytes and lengths, plus how many slots the frame has. It is static data —
nothing about a function changes between two calls to it — so a frame stores
a pointer to this and not six fields of its own.
The strings go through [m.nfi] rather than [string_bytes], which is the
whole of why that counter exists; see [m.nfi]. *)
let fi_bytes m s =
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
m.nfi <- m.nfi + 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
(* What the two ends compare about a frame's slots, since neither can see the
other. Same idea as a restart frame's [rsig_id], and for the same reason: a
frame on the stack was compiled from *some* body, the session holds
whatever body it last accepted, and installing while stopped is deliberately
allowed — so the two can be different bodies of the same function, and a
slot count alone does not notice a rename or a reordering. Pairing [q] with
[p]'s value and saying nothing is exactly the "visible rather than correct"
failure this project has already named once.
Over the names *and* the spellings of the types, because either can change
on its own. Computed here and read from here by [Dev], so there is one
definition of it and it cannot drift. *)
let slot_fingerprint (fn : Tast.fn) =
let b = Buffer.create 128 in
Array.iteri
(fun i ty ->
(match
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None
with
| Some n -> Buffer.add_string b n
| None -> ());
Buffer.add_char b ':';
Buffer.add_string b (Types.to_string ty);
Buffer.add_char b ';')
fn.Tast.slots;
Hashtbl.hash (Buffer.contents b) land 0x3fffffff
let fninfo m (fn : Tast.fn) ~nslots =
let nid, nlen = fi_bytes m fn.Tast.name in
let lid, llen = fi_bytes m (Loc.to_string fn.Tast.floc) in
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant %s\n" id
(Rt.ll_init Rt.fninfo
[ nid; string_of_int nlen; lid; string_of_int llen;
string_of_int nslots; string_of_int (slot_fingerprint fn);
string_of_int
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn) ]));
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.
This is the *trapping* shape and it still has three users: the restart
lookups and the unarmed-clause check, none of which is recoverable — there
is nowhere to resume a transfer whose target does not exist. The two bounds
checks moved off it; see [signal_block]. *)
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
(* The same branch, for a failure that *signals* rather than dying. The call is
an ordinary one — it returns when a handler or the break loop transferred —
so it is followed by a guard, and the fall-through past the guard is what is
unreachable: nothing answered, so the runtime already died inside the call.
[guard] is passed in rather than called directly because [guard] is part of
the expression emitter's recursive group and this is defined above it. It is
the same [guard f] every call site emits, so a bounds failure that is
answered leaves the function through the innermost pad — a restart-case's,
or the function's own unwind block, which runs its defers and returns.
**That is the answer to "does a trap run defers": an answered one does, an
unanswered one still does not, because the unanswered one is still a die
inside C.** *)
let signal_block f (loc : Loc.t) ~guard 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;
guard ();
term f "unreachable";
label f good
(* ── Arithmetic with no answer ─────────────────────────────────────────
Three situations that had no defined behaviour until now, and they share a
helper for the same reason the two bounds checks share one: they are one
condition, ArithError, and a handler should write one clause and not five.
The shape is [signal_block]'s and not [fail_block]'s, so an answered
failure leaves through the innermost pad and runs the defers on its way
out, exactly as an answered bad index does.
The thing worth knowing about the divide guard is that it is a branch
*before* the instruction rather than anything after it. A SIGFPE cannot be
caught and resumed, so there is no version of this that tests afterwards;
the branch is the price of the operation having a defined behaviour at all,
not the price of that behaviour being a condition. Which is also why the
overflow test rides along for nearly nothing: the zero test has already
put a compare and a branch on the path, and (/ min -1) is two more compares
folded into the same one. *)
(* The codes flan_arith_fail switches on, and the ones the prelude's
ArithError documents. They are named here rather than written as bare
numbers at the call sites, because a bare number at a call site is exactly
the kind of agreement that drifts. *)
let arith_div_zero = 0
let arith_rem_zero = 1
let arith_div_overflow = 2
let arith_rem_overflow = 3
let arith_cast_range = 4
(* ArithError's fields are i64 and an operand may be narrower, so every
operand is widened on the way into the condition — signed or not according
to its own type, so that (-1 : i8) reads back as -1 and (255 : u8) reads
back as 255. A u64 above 2^63 still reinterprets as negative, which the
prelude says out loud and which a fourth field is not worth fixing. *)
let widen f (k : Types.ikind) v =
if Types.bits k = 64 then v
else begin
let t = fresh f in
ins f "%s = %s %s %s to i64" t
(if Types.signed k then "sext" else "zext") (ll (Types.Int k)) v;
t
end
(* 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))
(* 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;
the tests are identical, because `srem` overflows on exactly the operands
`sdiv` does — the intermediate quotient is the thing that does not fit.
Both tests are elided when the divisor is a literal that cannot trigger
them, which matters more than it looks: (/ x 2) is the common case, and
without this every one of them would carry a branch forever. *)
let check_div f ~guard loc ~is_rem (k : Types.ikind) ~lit a b =
if f.md.checks then begin
let ty = ll (Types.Int k) in
let need_zero, need_ovf = div_checks ~lit k in
if need_zero || need_ovf then begin
(* [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
then fold to nothing without a special case for either shape. *)
let bad_zero =
if need_zero then begin
let t = fresh f in
ins f "%s = icmp eq %s %s, 0" t ty b;
t
end
else "false"
in
let bad =
if need_ovf then begin
let lo = fresh f in
ins f "%s = icmp eq %s %s, %Ld" lo ty a (int_min k);
let neg1 = fresh f in
ins f "%s = icmp eq %s %s, -1" neg1 ty b;
let ovf = fresh f in
ins f "%s = and i1 %s, %s" ovf lo neg1;
let t = fresh f in
ins f "%s = or i1 %s, %s" t bad_zero ovf;
t
end
else bad_zero
in
let ok = fresh f in
ins f "%s = xor i1 %s, true" ok bad;
(* Which of the two it was is decided with a [select] rather than with a
second branch, so the hot path keeps the single compare-and-branch the
zero test already cost. The select is dead on the fall-through and any
optimiser sinks it into the cold block; at -O0 it is one instruction
nobody is going to notice next to a division. *)
let code = fresh f in
ins f "%s = select i1 %s, i32 %d, i32 %d" code bad_zero
(if is_rem then arith_rem_zero else arith_div_zero)
(if is_rem then arith_rem_overflow else arith_div_overflow);
let aw = widen f k a and bw = widen f k b in
signal_block f loc ~guard ok (fun id n ->
ins f
"call void @flan_arith_error(ptr %s, i64 %d, i32 %s, i64 %s, i64 %s, \
ptr %s)"
id n code aw bw xfer_param)
end
end
(* A float to integer cast whose value does not fit. The two bounds are exact
in a double for every integer kind up to 64 bits — both are powers of two —
so the test is exact rather than approximate, and it is written as
[lo <= v < hi] with an *open* top because the top bound is 2^(n-1) or 2^n
itself, which is the first value that does not fit rather than the last one
that does.
Ordered comparisons, which is what makes NaN fail both of them. That is
wanted: a NaN cast to an integer is as undefined as a value out of range
and would otherwise walk straight through the guard.
An f32 source is extended to a double first. The extension is exact and
costs an instruction, and it buys writing one set of bounds instead of two
and never having to ask whether 2^63 is representable in the narrower
type. *)
let check_cast f ~guard loc (src : Types.fkind) (k : Types.ikind) v =
if f.md.checks then begin
let v =
match src with
| Types.F64 -> v
| Types.F32 ->
let t = fresh f in
ins f "%s = fpext float %s to double" t v;
t
in
let lo_f, hi_f, lo_i, hi_i = cast_range k in
(* LLVM takes a double constant as the hex of its bits, which is the only
spelling that cannot lose anything on the way through. *)
let dbl x = Printf.sprintf "0x%016Lx" (Int64.bits_of_float x) in
let a = fresh f in
ins f "%s = fcmp oge double %s, %s" a v (dbl lo_f);
let b = fresh f in
ins f "%s = fcmp olt double %s, %s" b v (dbl hi_f);
let ok = fresh f in
ins f "%s = and i1 %s, %s" ok a b;
signal_block f loc ~guard ok (fun id nn ->
ins f
"call void @flan_arith_error(ptr %s, i64 %d, i32 %d, i64 %Ld, i64 %Ld, \
ptr %s)"
id nn arith_cast_range lo_i hi_i xfer_param)
end
(* [at] is strict: the last valid index is len - 1. *)
let check_at f ~guard 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;
signal_block f loc ~guard ok (fun id n ->
ins f "call void @flan_bounds_error(ptr %s, i64 %d, i64 %s, i64 %s, ptr %s)"
id n idx len xfer_param)
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.
Two tests, and they are not the same kind of test, which is the whole of
what this function has to get right. [hi <= len] is a bounds check: it asks
whether the range the caller wrote fits inside the thing being sliced, and
the answer depends entirely on a length that is nothing to do with the
result's representation. Dropping it is what [--no-bounds-checks] is for —
a release decision, taken by someone who has decided their indices are
right and will accept undefined behaviour if they are not.
[lo <= hi] is not that. The value this expression builds is a [%slice],
which is {ptr, i64}, and the i64 is a *count*: the sub below computes it as
hi - lo, and every consumer in the language and in the runtime reads it as
a non-negative number of elements. A reversed range does not produce an
out-of-range slice, it produces a slice that is not a slice — (slice s 2 1)
writes -1 into the length word, and -1 as an unsigned count is
18446744073709551615. That value is not a bounds error anyone can opt out
of; it is a malformed value of the type, and it goes on to be passed,
stored, re-sliced and handed to C. So the test rides ahead of the flag: it
is emitted in every build, at -O0, at -O2, with checks on and with checks
off, exactly the way flan_vec_as_slice in the runtime validates [l > h]
unconditionally and for the same reason.
Two [signal_block]s and not one [and], so that the unchecked build emits
exactly one compare and the checked build emits the two it always did. Both
report through @flan_slice_error with the same three numbers, because from
a handler's point of view there is still one condition here — a range that
was refused — and which half of it was violated is in the text. *)
let check_slice f ~guard loc lo hi len =
let fail ok =
signal_block f loc ~guard ok (fun id n ->
ins f
"call void @flan_slice_error(ptr %s, i64 %d, i64 %s, i64 %s, i64 %s, \
ptr %s)"
id n lo hi len xfer_param)
in
let a = fresh f in
ins f "%s = icmp ule i64 %s, %s" a lo hi;
fail a;
if f.md.checks then begin
let b = fresh f in
ins f "%s = icmp ule i64 %s, %s" b hi len;
fail b
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
(* Every [Tast] node already carries the position it was read from, and until
now nothing wrote them out. The location is set for the duration of a node's
own emission and restored afterwards, so instructions a parent emits *after*
a child -- the branch at the end of an [if], the store of a [set] -- are
attributed to the parent and not to whatever ran last inside it. *)
let rec value f (e : Tast.expr) : string =
match f.dsub with
| None -> value_at f e
| Some _ ->
let saved = f.dloc in
at_loc f e.Tast.loc;
let v = value_at f e in
f.dloc <- saved;
v
(* The [!DILocation] for a position, memoised: a loop body emits the same few
lines over and over and each would otherwise make its own node. *)
and at_loc f (loc : Loc.t) =
match f.md.dbg, f.dsub with
| Some d, Some sub ->
(* Line 0 is [Loc.unknown] -- a node the checker made up rather than one
anyone wrote. It is attributed to the function's own line instead, since
a zero line in DWARF means "no line" and would make lldb step over the
whole construct. *)
let line = if loc.Loc.line = 0 then f.dline else loc.Loc.line in
let key = Printf.sprintf "%d:%d:%d" sub line loc.Loc.col in
let id =
match Hashtbl.find_opt d.dlocs key with
| Some id -> id
| None ->
let id =
dnode d
(Printf.sprintf "!DILocation(line: %d, column: %d, scope: !%d)"
line loc.Loc.col sub)
in
Hashtbl.replace d.dlocs key id; id
in
f.dloc <- Printf.sprintf ", !dbg !%d" id
| _ -> ()
and value_at 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"
(* A fill is a write over storage, so in value position it needs storage to
write over: a temporary, filled and then loaded out of. Every fill the
source actually writes is the value of a [set] or of a [let] binding, and
[Set] below takes the place's own address and skips this; the temporary
is what makes the node mean something everywhere else — a fill passed
straight to a call, say — rather than being a form with a position rule
nobody stated. *)
| Tast.Fill (ty, b) ->
let bv = value f b in
let tmp = alloca f ty in
emit_byte_fill f tmp ty bv;
load f tmp ty
| Tast.DeadBeef (ty, pat) ->
let word, folded = dead_beef_word f pat in
let tmp = alloca f ty in
emit_dead_beef f tmp ty ~word ~folded;
load f tmp ty
| 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
(* The symbol itself, not a load from it: a function's address is a link-time
constant. The same spelling the handler frames use for a lifted clause. *)
| Tast.FnAddr (Tast.Flanfn n) -> fname n
| Tast.FnAddr (Tast.Rtfn n) -> "@" ^ n
(* A function value someone wrote, which is the one [FnAddr] that is not the
symbol. In a dev build it is the cell's contents, so that a value taken
after a redefinition is the new body — the same load a direct call to the
same name would do, at the point the *address* is taken rather than at the
call. What that does not give is a value taken before a redefinition and
called after it: that one is still the old body, because there is nothing
left to re-resolve once the address is in a slot. Named in docs/BUILT.md rather
than papered over with a trampoline. *)
| Tast.FnAddr (Tast.Fnval n) -> body_of f n
| 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.CallPtr (callee, args) -> call_ptr f e.Tast.ty callee 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);
bind_slot f slot)
bs;
block f body
| Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
| Tast.While (c, body, latch) -> emit_while f c body latch; "zeroinitializer"
(* A plain branch, and then the block is dead — [term] closes it and [ins]
drops whatever the checker still had to walk past. The checker proved the
target exists and is one this jump may reach; here it is an index. *)
| Tast.Break n ->
term f "br label %%%s" (fst (List.nth f.loops n));
"zeroinitializer"
| Tast.Continue n ->
term f "br label %%%s" (snd (List.nth f.loops n));
"zeroinitializer"
| Tast.Return v ->
(match v with
| None -> ret f "zeroinitializer"
| Some v ->
let v' = value f v in
ret f v');
"zeroinitializer"
| Tast.Set (p, v) ->
let ptr, ty = place f p in
(match v.Tast.e with
| Tast.Zero _ when emit_bulk_zero f ptr ty -> ()
(* The shape the source writes: the fill goes straight at the place,
with no temporary and no aggregate load in between. Same short-circuit
the bulk zero above takes, and the reason [(set grid (filled 0xFF))]
is one memset. *)
| Tast.Fill (_, b) -> emit_byte_fill f ptr ty (value f b)
| Tast.DeadBeef (_, pat) ->
let word, folded = dead_beef_word f pat in
emit_dead_beef f ptr ty ~word ~folded
| _ ->
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.MakeCase (dname, case, fields) ->
emit_make_case f dname case fields
| Tast.CaseField (target, case, i) ->
load f (case_field_addr f target case i) e.Tast.ty
| 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
(* The condition crosses as a pointer: a handler runs while the signalling
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
let p = addr_rooted f c in
ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
guard f;
"zeroinitializer"
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
unreachable. It cannot be marked noreturn for that reason — it does
return, on exactly one path. *)
| Tast.Signal (Tast.Serror, id, c) ->
let p = addr_rooted f c in
let name = struct_name_of c.Tast.ty in
let nid, nn = string_bytes f.md name in
ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
id p xfer_param nid nn;
guard f;
term f "unreachable";
"zeroinitializer"
| Tast.Handled (frames, body) -> emit_handled f frames body
| Tast.RestartCase (clauses, body) -> emit_restart_case f e.Tast.ty clauses body
| Tast.WithAlloc (a, body) -> emit_with_alloc f e.Tast.ty a body
(* §4's lookup, then the transfer itself: the frame that was found goes into
the channel and this function leaves through its landing block. Type
Never, so nothing follows. *)
| Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) ->
(* The arguments are already in slots — the checker put them there, so an
argument that transferred on its own has been guarded before anything
here runs. *)
let vals = List.map (fun a -> (value f a, a.Tast.ty)) args in
let t = fresh f in
ins f "%s = call ptr @flan_find_restart(i32 %d)" t id;
let ok = fresh f in
ins f "%s = icmp ne ptr %s, null" ok t;
(* No frame offers the name. That is a runtime error at the invoke site —
not an unwind past everything — because there is nowhere to resume. *)
fail_block f rloc ok (fun id n ->
let nid, nn = string_bytes f.md name in
ins f "call void @flan_restart_fail(ptr %s, i64 %d, ptr %s, i64 %d)"
id n nid nn);
(* §3's run-time check. A restart is found by name on a dynamic stack, so
what it takes is not knowable here: the frame carries its parameter
count and the hash of how they are spelled, and both are compared.
The count is not redundant with the hash — it is what makes a 32-bit
collision between two different signatures harmless in practice — and
it is also the cheaper half. *)
let arity = fresh f in
ins f "%s = load i32, ptr %s" arity (restart_field f t "arity");
let a_ok = fresh f in
ins f "%s = icmp eq i32 %s, %d" a_ok arity (List.length args);
let want = fresh f in
ins f "%s = load i32, ptr %s" want (restart_field f t "sig_id");
let s_ok = fresh f in
ins f "%s = icmp eq i32 %s, %d" s_ok want sg_id;
let both = fresh f in
ins f "%s = and i1 %s, %s" both a_ok s_ok;
fail_block f rloc both (fun id n ->
let nid, nn = string_bytes f.md name in
(* 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. *)
let wp = fresh f in
ins f "%s = load ptr, ptr %s" wp (restart_field f t "sig");
let wl = fresh f in
ins f "%s = load i64, ptr %s" wl (restart_field f t "siglen");
let gid, gn = string_bytes f.md sg in
ins f
"call void @flan_restart_args_fail(ptr %s, i64 %d, ptr %s, i64 %d, \
ptr %s, i64 %s, ptr %s, i64 %d)" id n nid nn wp wl gid gn);
(* Into the buffer the target frame owns, field by field: this frame is
about to go, and the clause runs after it has. The layout is the one the
signature just agreed on. *)
if vals <> [] then begin
let buf = fresh f in
ins f "%s = load ptr, ptr %s" buf (restart_field f t "args");
let sty =
"{ " ^ String.concat ", " (List.map (fun (_, ty) -> ll ty) vals) ^ " }"
in
List.iteri
(fun i (v, ty) ->
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
p sty buf i;
ins f "store %s %s, ptr %s" (ll ty) v p)
vals;
ins f "store i32 1, ptr %s" (restart_field f t "armed")
end;
ins f "store ptr %s, ptr %s" t xfer_param;
term f "br label %%%s" (current_pad f);
"zeroinitializer"
(* 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 word a [(dead-beef PATTERN)] store must leave, and whether it is known
here. A literal pattern is reversed at compile time and reaches the loop as
an immediate, which is what keeps the default's code exactly what it was
before the pattern became an operand. Anything else is evaluated and
reversed by [llvm.bswap.i32] — the pattern is a u32 the program computed,
and the byte order it is written in is not a property of how it was
spelled. The [int32] comes back so the tail can fold too. *)
and dead_beef_word f (pat : Tast.expr) : string * int32 option =
match pat.Tast.e with
| Tast.Int (n, _) ->
let v = word_of_pattern (Int64.to_int32 n) in
(Printf.sprintf "%ld" v, Some (Int64.to_int32 n))
| _ ->
let v = value f pat in
let t = fresh f in
ins f "%s = call i32 @llvm.bswap.i32(i32 %s)" t v;
(t, None)
(* 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
(* [addr], for the two callers whose address outlives the next instruction:
the condition a [signal] crosses on, which a handler reads while allocating,
and an explicit address-of, which is handed to a runtime that may. A place
already has an address and it is one something else rooted; everything else
is copied, and the copy goes into a slot the collector was told about.
Every other caller of [addr] hands the address to the load or the store on
the next line, with no allocation in between, and wants the cheaper
unrooted copy. [root_plan] counts exactly these two callers. *)
and addr_rooted f (e : Tast.expr) : string =
if addr_is_place e || e.Tast.ty = Types.Dyn
|| dyn_offsets f.md e.Tast.ty = [] then addr f e
else begin
let tmp = agg_tmp 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
end
and field_addr f (target : Tast.expr) i =
let base = addr f target in
(* A union's members all start where the union starts, so the address of one
is the address of the whole thing and there is no gep to do. The member's
own type is what the load or the store that follows uses, which is what
makes the read a reinterpretation of the bytes — with opaque pointers
that is the entire implementation of punning, and the [i32] and the [f32]
views of one storage differ in nothing but the instruction that reads
them. *)
match target.Tast.ty with
| Types.Named n when Hashtbl.mem f.md.unions n -> base
| _ ->
(* An Option is { i8, T } and has no declared name to gep through, so its
layout is spelled out instead. Nothing in the surface language reaches a
field of one -- [match] and [some] are how an Option is opened -- but the
structural printer does, to read the tag without unwrapping a None. *)
let sty = match target.Tast.ty with
| Types.Named n -> sname n
| Types.Option _ as t -> ll t
| 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 sty 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 ~guard:(fun () -> guard 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 ~guard:(fun () -> guard 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
(* 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. *)
(* A data type value, built in memory rather than with [insertvalue], because the
payload's declared type is a blob of integers and the case's fields are not:
the two views of the same bytes are what a gep expresses and what a chain of
[insertvalue] cannot. The alloca is what [mem2reg] removes when nobody takes
an address of it. *)
and emit_make_case f dname case fields =
let ty = Types.Named dname in
let u = Hashtbl.find f.md.datas dname in
let tag = match Tast.case_index u case with
| Some (i, _) -> i
| None -> failwith ("no case " ^ case ^ " of " ^ dname)
in
let tmp = alloca f ty in
ins f "store %s zeroinitializer, ptr %s" (ll ty) tmp;
let tp = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname dname) tmp;
ins f "store i32 %d, ptr %s" tag tp;
if fields <> [] then begin
let pp = payload_addr f dname tmp in
let cty = sname (dname ^ "." ^ case) in
List.iteri
(fun i (p : Tast.expr) ->
let v = value f p in
let fp = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" fp cty pp i;
ins f "store %s %s, ptr %s" (ll p.Tast.ty) v fp)
fields
end;
load f tmp ty
(* The payload blob's address. A data type with no payload has no field 1, so this
is only ever reached for one that has fields to reach. *)
and payload_addr f dname base =
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 1" p (sname dname) base;
p
(* The address of one field of one case of a data type value. The single place in
this backend that knows how a payload is read, so [match]'s binds and the
structural printer cannot come to different conclusions about it. *)
and case_field_addr f (target : Tast.expr) case i =
let dname = match target.Tast.ty with
| Types.Named n -> n
| t -> failwith ("case field of " ^ Types.to_string t)
in
let base = addr f target in
let pp = payload_addr f dname base in
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
p (sname (dname ^ "." ^ case)) pp i;
p
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
(* The current body of a named Flan function, as something callable. A release
build is the symbol; a dev build is whatever the indirection cell holds, and
there are two spellings of that because a function this module emitted has
its cell as a symbol and one it does not has only a cached address. *)
and body_of f flan =
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
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 = body_of f flan in
call_through f ret callee vs
(* A call through a function value. Identical to the direct case once the
callee is in hand — a Flan function's signature is its parameters followed
by the transfer channel whether it was reached by name or by pointer — so
the guard after it is the same guard, and a [return] out of a callee taken
as a value transfers exactly as one out of a callee named does.
The callee is evaluated *before* the arguments, which is the order it is
written in and the order a reader expects; the direct case is the other way
round for a reason that does not apply here (there is no cell to keep out of
the middle of an argument list). *)
and call_ptr f ret callee args =
let c = value f callee in
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
call_through f ret c vs
and call_through f ret callee vs =
let t = fresh f in
ins f "%s = call %s %s(%s)" t (ll ret) callee
(String.concat ", " (vs @ [ "ptr " ^ xfer_param ]));
guard f;
(* An aggregate with a dyn in it is spilled into a rooted slot the instant it
arrives, the same move a dyn word gets in [prim] and for a sharper reason:
the callee rooted that dyn word in its own frame and popped it on the way
out, so between this instruction and the next allocation the only copy of
it anywhere is an SSA value, which a collector that finds its roots by
address cannot see. The spill is a shadow the collector reads and the
program never does — the value carries on being used as a register — and
marking through it keeps the object alive, which is all that is wanted.
[root_plan] counted this node, so the slot is one the entry block has
already zeroed and pushed. *)
if ret = Types.Dyn then begin
let slot = dyn_tmp f in
ins f "store i64 %s, ptr %s" t slot
end
else if dyn_offsets f.md ret <> [] then begin
let slot = agg_tmp f ret in
ins f "store %s %s, ptr %s" (ll ret) t slot
end;
t
(* The check after a call, which is the whole of §6's lowering at a call site:
a load, a compare and a branch that reads like ordinary code. A foreign call
gets none — a transfer cannot cross a C frame, so there is nothing a guard
there could find. *)
and guard f =
if f.live then begin
let t = fresh f in
ins f "%s = load ptr, ptr %s" t xfer_param;
let c = fresh f in
ins f "%s = icmp ne ptr %s, null" c t;
let cont = fresh_label f "on" in
let pad = current_pad f in
term f "br i1 %s, label %%%s, label %%%s" c pad cont;
label f cont
end
and current_pad f =
match f.pads with
| (p, used) :: _ -> used := true; p
| [] -> f.unwound <- true; f.unwind
(* 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
(* Establishing a handler is two stores and a push, per spec-conditions.md §2,
and the frame lives on this function's own stack. Popping is by frame rather
than by count: restoring what this one displaced is right even if something
below it left the stack out of step.
The body may not [return] — the checker rejects that — so the pops here are
on the only path out. *)
and emit_handled f frames body =
let allocated =
List.map
(fun (h : Tast.hframe) ->
let slot = alloca_raw f "%handler" in
let ty = fresh f in
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 %d"
ty slot (Rt.index Rt.handler "type");
ins f "store i32 %d, ptr %s" h.Tast.htype ty;
let fp = fresh f in
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 %d"
fp slot (Rt.index Rt.handler "fn");
(* The clause's body address, deliberately, and not a cell load:
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
it lives only for this body. A reload landing while it is on the
stack finds what it pushed still valid, which is what "old code is
never unloaded" means. See NEXT.md, conditions step 1. *)
ins f "store ptr %s, ptr %s" (fname h.Tast.hfn) fp;
ins f "call void @flan_handler_push(ptr %s)" slot;
slot)
frames
in
let pop () =
(* Innermost first, which is the order they were pushed in reverse. *)
List.iter
(fun slot -> ins f "call void @flan_handler_pop(ptr %s)" slot)
(List.rev allocated)
in
let ld = fresh_label f "endhandled" in
let pad = fresh_label f "hxfer" and used = ref false in
f.pads <- (pad, used) :: f.pads;
let last = block f body in
f.pads <- List.tl f.pads;
let reached = f.live in
if f.live then begin pop (); term f "br label %%%s" ld end;
(* A transfer passing through: these frames are on the establishing
function's stack and must come off before it goes any further, and this is
the only path out that the checker's refusal of [return] leaves. Nothing
here calls Flan, so the channel can stay as it is. *)
if !used then begin
label f pad;
pop ();
term f "br label %%%s" (current_pad f)
end;
if not reached then begin f.live <- false; "zeroinitializer" end
else begin
label f ld;
(* The body's own value, and no [phi] or slot to carry it, unlike
[emit_with_alloc] next door: [ld] has exactly one predecessor. The pad
terminates at [current_pad] and never at [ld], so the only edge into it
is the [br] above, and [last] is computed in the block that ends with
that [br] — it dominates every use here.
This used to answer "zeroinitializer" and drop [last] on the floor, from
when the checker typed this form [unit] and no caller was supposed to be
able to ask. One could, and the constant zero is what it got. *)
last
end
(* A clause's parameters, as one LLVM struct: what the invoker stores into and
what the clause loads out of. The two ends never see each other, so the
layout is agreed by the signature hash they compare first — same types in
the same order is the same struct. *)
and args_type (c : Tast.rclause) =
"{ " ^ String.concat ", " (List.map (fun (_, t) -> ll t) c.Tast.rparams) ^ " }"
and restart_field f slot name =
let p = fresh f in
ins f "%s = getelementptr inbounds %%restart, ptr %s, i32 0, i32 %d" p slot
(Rt.index Rt.restart name);
p
(* (with-allocator A BODY...) — spec-memory.md's "Allocators".
Save, run, restore, and *restore again at the pad*. The second restore is
the whole reason this is a node rather than a let and two calls: a body that
errors, or one a handler transfers out of, leaves through [current_pad], and
a context allocator left pointing into a region nobody outside the body has
heard of would be wrong in the break loop, which is exactly where someone is
about to allocate to render a condition.
It releases nothing, per the spec: the region this names is released, if
ever, by an explicit [free-all] somewhere else. *)
and emit_with_alloc f ty (a : Tast.expr) body =
let av = value f a in
let prev = fresh f in
ins f "%s = call ptr @flan_context_set(ptr %s)" prev av;
let result = if is_void ty then None else Some (alloca f ty) in
let ld = fresh_label f "endwith" in
let pad = fresh_label f "wxfer" and used = ref false in
let reached = ref false in
f.pads <- (pad, used) :: f.pads;
let v = block f body in
f.pads <- List.tl f.pads;
if f.live then begin
ins f "call void @flan_context_restore(ptr %s)" prev;
(match result with
| Some r -> ins f "store %s %s, ptr %s" (ll ty) v r
| None -> ());
reached := true;
term f "br label %%%s" ld
end;
label f pad;
ins f "call void @flan_context_restore(ptr %s)" prev;
term f "br label %%%s" (current_pad f);
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
(* (restart-case BODY (name [p T] BODY-1) ...) — §3, §4 and §6 together.
One frame per clause, so that the frame a transfer names says which clause
to run: the address is the identity, which is exact where a number would
have to be unique against every module the running program might later load.
§4's "innermost offering the name" falls out of the stack walk, and
re-entering a restart-case works because each activation allocates its own
frames.
§5's defers between here and the invoke have already run — each function on
the way out ran its own before returning. What is left here is to take these
frames off, copy §3's parameters out of the buffer the invoker filled, and
start the clause.
The parameters live in a buffer this frame owns, not the invoker's: by the
time a clause runs, every frame between the two has returned, so anything on
the invoking side is gone. The invoker stores into it while both are alive,
which is the one moment they are. *)
and emit_restart_case f ty clauses body =
let result = if is_void ty then None else Some (alloca f ty) in
let frames =
map_lr
(fun (c : Tast.rclause) ->
let slot = alloca_raw f "%restart" in
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
needs, but a break loop has to *show* someone their choices, and
nothing at run time can turn a hash back into a name. *)
let sid, slen = string_bytes f.md c.Tast.rname in
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 "namelen");
(* §3's signature, which every frame carries whether it takes
parameters or not: an [invoke-restart] compares against whatever
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. *)
ins f "store i32 %d, ptr %s"
(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 "sig_id");
let gid, glen = string_bytes f.md c.Tast.rsig in
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 "siglen");
let args =
if c.Tast.rparams = [] then None
else begin
let buf = alloca_raw f (args_type c) in
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
frame without going through an [invoke-restart] — the break
loop, today — leaves this zero, and the clause traps rather
than running on values no one supplied. *)
ins f "store i32 0, ptr %s" (restart_field f slot "armed");
Some buf
end
in
ins f "call void @flan_restart_push(ptr %s)" slot;
(slot, args))
clauses
in
let args_of slot = List.assoc slot frames in
let frames = List.map fst frames in
let pop () =
List.iter
(fun slot -> ins f "call void @flan_restart_pop(ptr %s)" slot)
(List.rev frames)
in
let ld = fresh_label f "endrestart" in
let pad = fresh_label f "rxfer" and used = ref false in
let reached = ref false in
let yield v =
if f.live then begin
(match result with
| Some r -> ins f "store %s %s, ptr %s" (ll ty) v r
| None -> ());
reached := true;
term f "br label %%%s" ld
end
in
f.pads <- (pad, used) :: f.pads;
let v = value f body in
f.pads <- List.tl f.pads;
if f.live then pop ();
yield v;
label f pad;
let tgt = fresh f in
ins f "%s = load ptr, ptr %s" tgt xfer_param;
(* Cleared before the clause runs, and put back if this transfer turns out to
be aimed further out. A clause body is ordinary code and its calls are
guarded like any other; it must not start with the channel still set. *)
ins f "store ptr null, ptr %s" xfer_param;
pop ();
(* §3's parameters, copied out of the frame's buffer into the clause's own
slots before its body starts. The frame is still addressable — it is an
alloca of *this* function — and the buffer is whatever the invoker left
there. *)
let bind_params slot (c : Tast.rclause) =
match args_of slot with
| None -> ()
| Some buf ->
let armed = fresh f in
ins f "%s = load i32, ptr %s" armed (restart_field f slot "armed");
let ok = fresh f in
ins f "%s = icmp ne i32 %s, 0" ok armed;
(* Aimed here by something that supplied no arguments — there is no such
path from an [invoke-restart], so this is the break loop taking a
restart it cannot yet fill in. Refused with the reason, rather than
running the clause on a buffer nobody wrote. *)
fail_block f (List.hd c.Tast.rbody).Tast.loc ok (fun id n ->
let nid, nn = string_bytes f.md c.Tast.rname in
let gid, gn = string_bytes f.md c.Tast.rsig in
ins f
"call void @flan_restart_unarmed(ptr %s, i64 %d, ptr %s, i64 %d, \
ptr %s, i64 %d)" id n nid nn gid gn);
List.iteri
(fun i (slot_i, ty) ->
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
p (args_type c) buf i;
let v = load f p ty in
ins f "store %s %s, ptr %s" (ll ty) v f.slots.(slot_i);
bind_slot f slot_i)
c.Tast.rparams
in
let rec dispatch = function
| [] ->
ins f "store ptr %s, ptr %s" tgt xfer_param;
term f "br label %%%s" (current_pad f)
| (slot, (c : Tast.rclause)) :: rest ->
let hit = fresh_label f "restart" and next = fresh_label f "outer" in
let t = fresh f in
ins f "%s = icmp eq ptr %s, %s" t tgt slot;
term f "br i1 %s, label %%%s, label %%%s" t hit next;
label f hit;
bind_params slot c;
yield (block f c.Tast.rbody);
label f next;
dispatch rest
in
dispatch (List.combine frames clauses);
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
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
(* Four blocks, not three: the *latch* between the body and the test is what a
[continue] branches to, and it is where [dotimes] puts its increment. Folded
onto the end of the body instead, a continue would jump past it and the loop
would never advance. A [while] has an empty latch and the block is one
branch, which every optimiser folds away. *)
and emit_while f c body latch =
let lc = fresh_label f "loop" and lb = fresh_label f "body"
and ll = fresh_label f "latch" 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;
(* Pushed around the body only: the condition and the latch are not inside
the loop as far as a jump is concerned, and nothing in either is ever a
break in any case. *)
f.loops <- (le, ll) :: f.loops;
List.iter (fun e -> ignore (value f e)) body;
f.loops <- List.tl f.loops;
term f "br label %%%s" ll;
label f ll;
List.iter (fun e -> ignore (value f e)) latch;
term f "br label %%%s" lc;
label f le
and emit_match f ty scrut arms =
(* The two subjects are the same shape and are read differently: an [Option]
is an SSA aggregate with an i8 tag and its payload in field 1, a declared
data type is read through its address because its payload is a blob that has
to be reinterpreted. So the tag and the binds are each produced by one of
two small functions and everything else below is shared. *)
let dname =
match scrut.Tast.ty with
| Types.Named n when Hashtbl.mem f.md.datas n -> Some n
| Types.Option _ -> None
| t -> failwith ("match on " ^ Types.to_string t)
in
let tag, read_tag, bind_of =
match dname with
| None ->
let sv = value f scrut in
let sty = ll scrut.Tast.ty in
let payload_ty = match scrut.Tast.ty with
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
in
let tag = fresh f in
ins f "%s = extractvalue %s %s, 0" tag sty sv;
(tag, (fun c -> ("i8", if c = "Some" then 1 else 0)),
fun _case _i 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);
bind_slot f slot)
| Some n ->
let u = Hashtbl.find f.md.datas n in
(* Evaluated once, into a place, so that a scrutinee that is a call is
not re-run per arm. [addr] already spills a non-place for us. *)
let base = addr f scrut in
let tp = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname n) base;
let tag = fresh f in
ins f "%s = load i32, ptr %s" tag tp;
(tag,
(fun c ->
match Tast.case_index u c with
| Some (i, _) -> ("i32", i)
| None -> failwith ("no case " ^ c ^ " of " ^ n)),
fun case i slot ->
let pp = payload_addr f n base in
let fp = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
fp (sname (n ^ "." ^ case)) pp i;
let fty =
match Tast.case_index u case with
| Some (_, c) -> (List.nth c.Tast.vfields i).Tast.fty
| None -> failwith ("no case " ^ case ^ " of " ^ n)
in
let v = load f fp fty in
ins f "store %s %s, ptr %s" (ll fty) v f.slots.(slot);
bind_slot f slot)
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 ity, want = read_tag c in
let t = fresh f in
ins f "%s = icmp eq %s %s, %d" t ity tag want;
term f "br i1 %s, label %%%s, label %%%s" t lb ln);
label f lb;
List.iteri
(fun i slot ->
bind_of (match a.Tast.acase with Some c -> c | None -> "") i 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;
ret f "zeroinitializer";
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
(* A divide or a remainder by zero, and the one division that overflows,
signal ArithError. Integers only: IEEE says x / 0.0 is an infinity and
that is a defined answer somebody may want — the prelude's own
[rand-f32] divides by a float constant — so guarding a float division
would be refusing a result the language already promises.
A literal divisor is handed through so that the guard can be dropped
when it cannot fire, which is nearly every division anyone writes. *)
(match x.Tast.ty, p with
| Types.Int k, (Tast.Div | Tast.Rem) ->
let lit = match y.Tast.e with Tast.Int (n, _) -> Some n | _ -> None in
check_div f ~guard:(fun () -> guard f) e.Tast.loc
~is_rem:(p = Tast.Rem) k ~lit a b
| _ -> ());
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
(* An enum is an i32 at run time, and [Types.is_comparable] says so by
admitting one — the checker was stating an intent the backend never
honoured, so [(= k :a)] type checked and then died here with no source
location. Signed, because a member may be declared negative. *)
| Types.Enum _ ->
ins f "%s = icmp %s %s %s, %s" t (icmp_op true p) (ll x.Tast.ty) a b
(* A string is ptr+len at this boundary, not a machine word, so there is
no [icmp] to reach for — the comparison itself is [flan_str_eq]
(runtime/flan_rt.c), bytewise with a length and a same-pointer fast
path. [check.ml] only ever builds [Eq]/[Ne] here: [<] and friends are
refused on a string before a Tast node exists (Types.is_comparable
says no), so the [failwith] below is unreachable except as a checker
bug, and stays as the same tripwire the Enum case above already is. *)
| Types.String ->
let ap = fresh f in
ins f "%s = extractvalue %%slice %s, 0" ap a;
let al = fresh f in
ins f "%s = extractvalue %%slice %s, 1" al a;
let bp = fresh f in
ins f "%s = extractvalue %%slice %s, 0" bp b;
let bl = fresh f in
ins f "%s = extractvalue %%slice %s, 1" bl b;
let r = fresh f in
ins f "%s = call i8 @flan_str_eq(ptr %s, i64 %s, ptr %s, i64 %s)"
r ap al bp bl;
let cc = match p with
| Tast.Eq -> "ne" | Tast.Ne -> "eq"
| _ -> failwith ("comparison on " ^ Types.to_string x.Tast.ty)
in
ins f "%s = icmp %s i8 %s, 0" t cc r
| 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 ~guard:(fun () -> guard 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 ~guard:(fun () -> guard 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 ~guard:(fun () -> guard 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
(* (slice-from-ptr p n): the two words a %slice already is, with the pointer
the caller handed over and the length the caller promised. No new
representation — a Slice _ is {ptr, i64} here and in x86.ml, which is
exactly ptr+len, so this is an insertvalue pair and no more.
The check is the *length itself*, not a range: there is nothing to compare
it against, because the only thing that knows how many elements live
behind that pointer is the caller. So what is checked is the one half that
can be — that the promise is not absurd. It is signed, and it has to be:
[check_slice]'s comparisons are unsigned, and a negative i32 sign-extended
to i64 is a huge unsigned value that [ule] waves straight through.
It goes through [signal_block] for the reason the other two bounds checks
do — a bad length signals BoundsError and is answerable. It is *not*
behind [f.md.checks], and the argument that it should be was the argument
this paragraph used to make: that dropping bounds checks is a release
decision, so this goes off with the rest of them. That reads well and is
a category error. A bounds check compares a caller's index against a
length the compiler knows; this has no length to compare against — the
paragraph above says so in its first sentence — so there is nothing here
for [--no-bounds-checks] to be dropping. What it tests is that the word
about to be written into the [%slice]'s length field is a count and not a
negative number reinterpreted as an enormous one. That is [check_slice]'s
[lo <= hi], spelled the other way round, and it holds in every build for
the same reason: a slice with a negative length is not an unchecked slice,
it is not a slice.
It has its own runtime function, @flan_slice_promise_error, and that is
the whole of what it needed. It used to borrow @flan_slice_error — the
violated condition is 0 <= n, which is a reversed range spelled the other
way — and the sentence that came out named a range and a length the
caller never wrote. Since this is the one form whose real condition the
compiler cannot check, its refusal is the place the caller's promise has
to be stated, and it was the one place it was not. The signalled
BoundsError is unchanged: same three fields, so a handler writes one
clause for every bad index in the language. *)
| Tast.SliceFromPtr, [ p; n ] ->
let pv = value f p in
let nv = value f n in
let n64 = fresh f in
ins f "%s = sext i32 %s to i64" n64 nv;
let ok = fresh f in
ins f "%s = icmp sge i64 %s, 0" ok n64;
signal_block f e.Tast.loc ~guard:(fun () -> guard f) ok (fun id len ->
ins f
"call void @flan_slice_promise_error(ptr %s, i64 %d, i64 %s, ptr %s)"
id len n64 xfer_param);
let a = fresh f in
ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a pv;
let b = fresh f in
ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a n64;
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
(* (string b), and the same non-instruction for the same reason: String and
Slice _ are both %slice. See check.ml's "string" case. *)
| Tast.StrOfBytes, [ 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
(* The second argument is the caller's buffer — a frame slot the checker gave
this call site, so that two conversions in one expression are two buffers.
See check.ml's [to_bytes]. *)
| Tast.F64ToBytes, [ x; b ] -> shim_out f "@flan_f64_to_bytes" x b
| Tast.I64ToBytes, [ x; b ] -> shim_out f "@flan_i64_to_bytes" x b
| Tast.U64ToBytes, [ x; b ] -> shim_out f "@flan_u64_to_bytes" x b
| Tast.EscapeBytes, [ x ] -> shim_in_out f "@flan_escape_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)
(* One arm for every runtime entry point the allocator and container runtime
has. The result type is the node's own and the argument types are the
arguments' own, so nothing here has to know which symbol it is calling. *)
(* The allocation registry's notes are the one family in here a release
build drops on the floor, and the drop has to happen before the arguments
are walked rather than after: a note takes the address of the container it
is describing, and emitting that address only to discard the call would
leave an escaped alloca behind for mem2reg to refuse. So this is a
[Types.t] the checker built and the backend declines to use, which is the
same arrangement the indirection cells and the shadow stack have — the
checker does not know whether this is a dev build and does not have to. *)
| Tast.Rt sym, _
when (not f.md.dev)
&& String.length sym > 17
&& String.equal (String.sub sym 0 17) "flan_dev_reg_note" ->
"zeroinitializer"
| Tast.Rt sym, args ->
let vs =
List.concat
(map_lr
(fun (a : Tast.expr) ->
match a.Tast.ty with
| Types.String | Types.Slice _ ->
let p, n = explode f a in
[ "ptr " ^ p; "i64 " ^ n ]
| Types.Unit | Types.Never -> []
(* A Vec and a Map are move-only and never copied, so each
crosses to the runtime as its address — which is also what
lets an operation mutate the caller's container in place.
Passing the header by value here would hand the runtime a
copy to grow and leave the caller's untouched. *)
| Types.Vec _ | Types.Map _ -> [ "ptr " ^ addr f a ]
(* A fixed array crossing into a dyn view (M2 item 3) needs its
address for the same reason a Vec or a Map does here — the
view reads through it live, and passing the value would hand
the runtime a copy nothing writes back through. Every other
[Rt] caller of an array argument is [flan_dyn_view_flat],
which takes the address and never mutates the array's shape,
so this is not the move-only argument Vec/Map's comment is
about — it is simply the only way to view rather than copy. *)
| Types.Array _ -> [ "ptr " ^ addr f a ]
| t -> [ ll t ^ " " ^ value f a ])
args)
in
(* The two runtime entry points whose bounds check signals. They are the
only [Rt] symbols that can transfer, so they are the only ones that take
the channel and the only ones guarded — everything else in this family
is arithmetic over a container header and cannot reach a handler. A Vec
is checked inside the runtime rather than in emitted IR (docs/BUILT.md), so
this is where (at v i) gets what (at arr i) gets from [check_at]. *)
let signals =
String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice"
in
let vs = if signals then vs @ [ "ptr " ^ xfer_param ] else vs in
let args' = String.concat ", " vs in
if is_void e.Tast.ty then begin
ins f "call void @%s(%s)" sym args';
if signals then guard f;
"zeroinitializer"
end else begin
let t = fresh f in
ins f "%s = call %s @%s(%s)" t (ll e.Tast.ty) sym args';
if signals then guard f;
(* A dyn word is spilled into a rooted slot the instant it exists. It is
an SSA value otherwise, and an SSA value is invisible to a collector
that finds its roots by address — the next allocation could be the one
that frees what this is holding. [dyn_roots] counted this call, so the
slot below is one the entry block has already pushed.
The value carries on being used as a register: the store is what the
collector reads, and reading it back would only make the IR longer. *)
if e.Tast.ty = Types.Dyn then begin
let slot = dyn_tmp f in
ins f "store i64 %s, ptr %s" t slot
end;
t
end
| Tast.SizeOf t, [] -> Printf.sprintf "%d" (fst (lay f.md t))
| Tast.AlignOf t, [] -> Printf.sprintf "%d" (snd (lay f.md t))
| Tast.AddrOf, [ x ] -> addr_rooted f x
| Tast.Cast target, [ x ] -> cast f ~guard:(fun () -> guard 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) (buf : Tast.expr) =
let v = value f x in
let b = value f buf in
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
ins f "call void %s(%s %s, ptr %s, ptr %s)" name (ll x.Tast.ty) v b tmp;
load f tmp (Types.Slice (Types.Int Types.U8))
(* Slice in, slice out: [shim_in] returns a scalar and [shim_out] takes one, so
a shim that transforms bytes into bytes is neither. *)
and shim_in_out f name (x : Tast.expr) =
let p, n = explode f x in
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
ins f "call void %s(ptr %s, i64 %s, ptr %s)" name p n tmp;
load f tmp (Types.Slice (Types.Int Types.U8))
and cast f ~guard (x : Tast.expr) target =
let v = value f x in
(* An enum is an i32 at run time and its own type only in the checker, so a
cast involving one is a cast on that i32. Nothing in the surface language
produces this — a keyword resolves against the enum and never widens — but
the REPL's renderer needs an enum's number when it falls outside the
declared members. *)
let concrete (t : Types.t) =
match t with
| Types.Enum _ -> Types.Int Types.I32
| t -> t
in
let src = concrete x.Tast.ty and target = concrete target in
let src_loc = x.Tast.loc 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"
(* The one cast that can have no answer. LLVM calls an out-of-range
fptosi undefined and will fold it to anything; x86 produces a fixed
"integer indefinite". Neither is a result, so the value is tested
against the destination's range first and signals ArithError when it
misses. See [check_cast], which is also where NaN is dealt with. *)
| Types.Float a, Types.Int b ->
check_cast f ~guard src_loc a b v;
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"
(* Nothing in the surface language writes this: [check.ml] has no cast
between pointer types. The locals thunk does — it is handed a slot's
address as a raw pointer and has to read it as the type the slot
holds — and under opaque pointers there is no instruction to emit for
it, both sides being [ptr]. *)
| Types.Ptr _, Types.Ptr _ -> "bitcast"
(* Also not written in the surface language. [resolve] needs it: the
runtime answers a pointer or NULL and the Option is built in the
checker, so the null test is one integer compare on the address. *)
| Types.Ptr _, Types.Int Types.I64 -> "ptrtoint"
(* Not written in the surface language either — this language has no
conversion between bool and a number, and deliberately. The dyn
boundary needs both halves: runtime/flan_dyn.h takes and answers a
bool as an [int32_t], because a C signature saying [_Bool] is a width
question nobody wants, and [bool] is an [i1] here.
The truncation is safe in the one direction it runs: what comes back
from [flan_dyn_need_bool] is 0 or 1, because the runtime has already
decided the value was a bool, so the discarded bits are zero. *)
| Types.Bool, Types.Int _ -> "zext"
| Types.Int _, Types.Bool -> "trunc"
| _ -> 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
(* The transfer channel, spec-conditions.md §6: one [ptr] appended to every
signature, written by an [invoke-restart] and checked after every call.
Uniform rather than only on the functions that need it — the spec's escape
analysis is an optimisation, and in a dev build a cell can hold anything,
so the honest answer to "what can this call?" is "anything". *)
let params = params @ [ (if named then "ptr " ^ xfer_param else "ptr") ] 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. *)
(* The name a slot goes into the debug info under. [Tast.fn.snames] carries the
source name of every slot the source named, parameters included, so that is
the answer wherever there is one.
A slot with no name is one the compiler invented -- [dotimes]'s hidden
bound, the pair (min) and (max) evaluate their operands into -- and it keeps
[s<index>], which is what it actually is. That is deliberate rather than a
fallback: a synthesized slot has no source name to print, and inventing a
plausible one would put a variable in the debugger that the programmer
cannot find in the file. [s4] is honest about being the frame's fourth slot.
[snames] is indexed defensively because a driver may build a frame by
appending arrays ([Session]'s evaluation thunk does), and a short [snames]
should cost a name, not raise. *)
let slot_name ~pnames ~snames ~nparams i =
let named = if i < Array.length snames then snames.(i) else None in
match named with
| Some n when n <> "" -> n
| _ ->
if i < nparams then
match List.nth_opt pnames i with
| Some n when n <> "" -> n
| _ -> Printf.sprintf "p%d" i
else Printf.sprintf "s%d" i
let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
let n = Array.length fn.Tast.slots in
(* The subprogram's id is claimed before the body is emitted, because every
instruction in the body refers to it, and the node itself is written at
the end once the retained variables are known. *)
let dsub = match m.dbg with None -> None | Some d -> Some (dalloc d) 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;
pads = []; loops = []; unwind = "unwind"; unwound = false;
defers = fn.Tast.fdefers;
frame = None; slotv = None; snames = fn.Tast.snames;
droots = 0; droot_ns = []; aroot_ns = [];
dsub;
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
dloc = "";
} 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;
(* The dyn roots, and this is not gated on [m.dev]: the shadow stack below is
a debugging convenience and a release build does without it, while a
collector that cannot find its roots is a collector that frees live
values. Every build pays this, and only a function that has a dyn in it
pays anything — [dyn_roots] is zero otherwise and not a line is emitted,
which is what makes an annotated program's IR identical with and without
--no-gc.
The dyn *slots* are already allocas from the loop above, so they are
pushed where they are; the temporaries need slots of their own, and they
are minted here, in order, so that [dyn_tmp] only has to hand them out.
Zeroed because the push happens at entry and the call that fills one may
be inside a branch that never runs — runtime/flan_dyn.h says a rooted slot
holding 0 is not a value.
An aggregate root is the same idea with a descriptor beside the address:
only the dyn words the descriptor names are zeroed, which is all the
collector ever reads through that entry and is a great deal cheaper than
clearing a whole struct. *)
let plan = root_plan m fn in
let nroots =
List.length plan.rslots + plan.rdyn + List.length plan.ragg
in
if nroots > 0 then begin
let nparams = List.length fn.Tast.params in
(* Zeroing the dyn words at [base], which is the whole of the contract
runtime/flan_dyn.h states for a pushed root. *)
let zero_dyn base (ty : Types.t) =
if ty = Types.Dyn then
Buffer.add_string f.allocas (Printf.sprintf " store i64 0, ptr %s\n" base)
else
List.iter
(fun off ->
let p = Printf.sprintf "%%z%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas
(Printf.sprintf " %s = getelementptr inbounds i8, ptr %s, i64 %d\n"
p base off);
Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" p))
(dyn_offsets m ty)
in
let push base (ty : Types.t) =
match (if ty = Types.Dyn then None else desc_of m ty) with
| None ->
Buffer.add_string f.allocas
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" base)
| Some sym ->
Buffer.add_string f.allocas
(Printf.sprintf
" call void @flan_dyn_root_push_desc(ptr %s, ptr @\"%s\")\n"
base sym)
in
(* The slots first, in slot order. A parameter's slot was filled from [%pN]
a few lines above and must not be zeroed over the top of it — which
matters more for an aggregate than it ever did for a dyn word, because
zeroing an aggregate parameter's dyn fields destroys the argument in
silence. Every other slot holds whatever the stack held until its
binding runs, and the binding may be inside a branch that does not. *)
List.iter
(fun (i, ty) -> if i >= nparams then zero_dyn f.slots.(i) ty)
plan.rslots;
let dtemps =
List.init plan.rdyn (fun i ->
let name = Printf.sprintf "%%dr%d" i in
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca i64\n" name);
Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" name);
name)
in
let atemps =
List.mapi
(fun i ty ->
let name = Printf.sprintf "%%ar%d" i in
Buffer.add_string f.allocas
(Printf.sprintf " %s = alloca %s\n" name (ll ty));
zero_dyn name ty;
(ty, name))
plan.ragg
in
List.iter (fun (i, ty) -> push f.slots.(i) ty) plan.rslots;
List.iter (fun n -> push n Types.Dyn) dtemps;
List.iter (fun (ty, n) -> push n ty) atemps;
f.droots <- nroots;
f.droot_ns <- dtemps;
f.aroot_ns <-
List.fold_left
(fun acc (ty, n) ->
let key = Types.to_string ty in
(key, n :: (try List.assoc key acc with Not_found -> []))
:: List.remove_assoc key acc)
[] (List.rev atemps)
end;
(* The shadow stack's push, in the entry block, and the pop is at every
[ret] (see [ret]). plan.org has had *Frames: shadow stack* in the dev
column since the beginning; this is it, and it is dev-only, so a shipped
game pays nothing for it.
Inline rather than a call in either direction: this is on every call in a
dev build, and a call to record a call would be most of what it costs. The
record is four words on this frame's own stack, of which two are stored
from static data and two are reserved for the slots [locals] needs -- they
are written, not left as whatever the stack held, because a frame with a
garbage [slots] pointer is one the break loop could follow.
A lifted handler-bind clause pushes one like any other function, which is
right: it really is on the stack, and a backtrace that skipped it would
show a gap exactly where the handler ran. *)
if m.dev then begin
(* The slot table, and it is the whole of what [locals] reads. One [ptr]
per slot, null until the slot is bound; the frame points at it.
Only a function with at least one *named* slot gets one, and only named
slots are ever recorded in it. That is not a saving of stores — the
nulls are written either way — it is a saving of *optimisation*: a slot
whose address is stored anywhere escapes, and an escaped alloca is one
mem2reg cannot promote. The slots that would hurt most to demote are
exactly the ones with no name to show: [dotimes]'s hidden bound, the
temporaries (min) and (max) evaluate their operands into, the walk's own
scratch in a render thunk. *)
let named = Array.exists (fun n -> n <> None) fn.Tast.snames in
if named && n > 0 then begin
let v = fresh f in
Buffer.add_string f.allocas
(Printf.sprintf " %s = alloca [%d x ptr]\n" v n);
(* Every entry, not only the named ones: "null means not bound" has to
hold at every index, or a reader has to know which indices it may
trust, and that is a second thing to keep in step. *)
for i = 0 to n - 1 do
let p = fresh f in
Buffer.add_string f.allocas
(Printf.sprintf " %s = getelementptr inbounds ptr, ptr %s, i32 %d\n"
p v i);
Buffer.add_string f.allocas
(Printf.sprintf " store ptr null, ptr %s\n" p)
done;
f.slotv <- Some v
end;
let info = fninfo m fn ~nslots:(if f.slotv = None then 0 else n) in
let prev = fresh f in
Buffer.add_string f.allocas " %frame = alloca %flanframe
";
Buffer.add_string f.allocas
(Printf.sprintf " %s = load ptr, ptr @flan_frame_head
" prev);
Buffer.add_string f.allocas
(Printf.sprintf " store ptr %s, ptr %%frame
" prev);
List.iter
(fun line -> Buffer.add_string f.allocas (" " ^ line ^ "\n"))
[ 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
"%%frame.s = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "slots");
Printf.sprintf "store ptr %s, ptr %%frame.s"
(match f.slotv with Some v -> v | None -> "null");
"store ptr %frame, ptr @flan_frame_head" ];
f.frame <- Some prev;
(* The parameters are bound before the body starts, so they are recorded
here rather than at a binding site there is none of. *)
List.iteri (fun i _ ->
match f.slotv with
| None -> ()
| Some v ->
if i < Array.length fn.Tast.snames && fn.Tast.snames.(i) <> None then begin
let p = fresh f in
Buffer.add_string f.allocas
(Printf.sprintf " %s = getelementptr inbounds ptr, ptr %s, i32 %d\n"
p v i);
Buffer.add_string f.allocas
(Printf.sprintf " store ptr %s, ptr %s\n" f.slots.(i) p)
end)
fn.Tast.params
end;
(* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it
describes. This is the whole of what lldb needs to print a local: the slot
is ordinary stack storage of an ordinary machine type, so there is no
accessor to describe and no header to skip. *)
(match m.dbg, dsub with
| Some d, Some sub ->
let file = dfile d fn.Tast.floc.Loc.file in
let nparams = List.length fn.Tast.params in
let vars =
Array.to_list
(Array.mapi
(fun i ty ->
let arg =
(* [arg:] is 1-based over the LLVM formals, and the transfer
channel is appended after all of them, so a parameter's
index is its Flan index either way. The channel itself gets
no variable: nothing in the language can name it. *)
if i < nparams then Printf.sprintf ", arg: %d" (i + 1) else ""
in
dnode d
(Printf.sprintf
"!DILocalVariable(name: \"%s\"%s, scope: !%d, file: !%d, line: %d, type: !%d)"
(dstr (slot_name ~pnames ~snames:fn.Tast.snames ~nparams i))
arg sub file f.dline
(dty m d ty)))
fn.Tast.slots)
in
let dl =
dnode d
(Printf.sprintf "!DILocation(line: %d, column: 1, scope: !%d)" f.dline sub)
in
List.iteri
(fun i v ->
Buffer.add_string f.allocas
(Printf.sprintf
" call void @llvm.dbg.declare(metadata ptr %s, metadata !%d, metadata !DIExpression()), !dbg !%d\n"
f.slots.(i) v dl))
vars;
let sty =
dnode d
(Printf.sprintf "!DISubroutineType(types: !{%s})"
(String.concat ", "
((if is_void fn.Tast.ret then "null"
else Printf.sprintf "!%d" (dty m d fn.Tast.ret))
:: List.map (fun t -> Printf.sprintf "!%d" (dty m d t))
fn.Tast.params)))
in
dput d sub
(Printf.sprintf
"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 (Mangle.sym fn.Tast.name)) file file f.dline sty f.dline
d.dcu
(String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars)));
at_loc f fn.Tast.floc
| _ -> ());
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";
ret f !last;
(* The transfer exit, spec-conditions.md §5 and §6. A transfer that reached
the top of this function without a restart-case to catch it leaves the
same way a [return] does — which is what reuses the existing return path,
and with it the defers, for free. The value returned is meaningless: the
caller's guard sees the channel set and never looks at it. *)
if f.unwound then begin
label f f.unwind;
let cleanup = "unwind.cleanup" and used = ref false in
if f.defers <> [] then begin
(* The channel is cleared while the defers run and put back after. A
defer makes ordinary calls and each one is guarded; with the channel
still set the first of them would branch straight back here. *)
let tgt = fresh f in
ins f "%s = load ptr, ptr %s" tgt xfer_param;
ins f "store ptr null, ptr %s" xfer_param;
f.pads <- [ (cleanup, used) ];
List.iter (fun e -> ignore (value f e)) f.defers;
f.pads <- [];
ins f "store ptr %s, ptr %s" tgt xfer_param
end;
ret f "zeroinitializer";
(* A defer that starts a *second* transfer while the first is unwinding.
§6's per-frame slot nests, but nothing here does: the first transfer's
target is in hand and the defers are half run. Refused loudly rather
than resolved to one of them. *)
if !used then begin
label f cleanup;
let id, n = string_bytes f.md (Loc.to_string fn.Tast.floc) in
ins f "call void @flan_transfer_fail(ptr %s, i64 %d)" id n;
term f "unreachable"
end
end;
Buffer.add_string m.out
(Printf.sprintf "\ndefine %s%s%s%s {\nentry:\n%s%s}\n"
(if hidden then "hidden " else "") (signature ~named:true fn) (attrs m)
(match dsub with None -> "" | Some n -> Printf.sprintf " !dbg !%d" n)
(Buffer.contents f.allocas) (Buffer.contents f.b))
(* ── Globals ───────────────────────────────────────────────────────── *)
(* The value the linker writes into the image: literals live in read-only
memory and zeroed globals live in BSS and cost nothing to start (plan.org,
Data model).
This used to be the whole of what a global could be, and said so — "there is
no init-at-startup path, by design". There is one now, and it is a call:
[Check] lifts a computed initialiser into a function and [emit_startup]
below stores its result before [main] runs. So what reaches here is what
needs no code — every [defvar] whose initialiser [Tast.const_init] accepts,
and every [defconst], because a defconst's initialiser is one of those too:
the checker refuses a computed one outright (2026-09-20). A constant is what
the linker writes, and a value that has to be computed is not one. *)
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)
(* No program reaches this. A [defvar] whose initialiser is computed never
asks — it was lifted into a function and this one is only called for the
constant ones — and a computed [defconst] is refused by
[Check.const_defconst_init], which is where the two messages that used to
be here now live: the one about a data type case needing a byte-level
encoder, and the general one about a constant having nowhere to run. So
this is an internal assertion in the file's own idiom rather than a
diagnostic, and it fires only if that refusal and [Tast.const_init] stop
agreeing about the same set. *)
| _ ->
failwith
("no constant image for " ^ Types.to_string e.Tast.ty ^ " at "
^ Loc.to_string e.Tast.loc)
(* A dev build emits a [defconst] as a mutable [global]. Two things follow, and
both are wanted: LLVM can no longer fold a read of it, and a redefinition
module can store a new value into it — so tuning a constant live works,
which it cannot when its only copy is immutable in .rodata. A release build
emits [constant] and gets all the folding back.
A computed initialiser starts the global zeroed and is stored by
[emit_startup]: Odin does exactly this, giving the ones that constant-fold a
real LLVM initialiser and zeroing the rest (src/llvm_backend.cpp). Zero and
not [poison], even though the store is the first thing that runs: BSS costs
nothing, and a program that dies between the loader and the store is easier
to read with zeroes in it than with whatever was there. *)
let emit_global m ?(hidden = false) (g : Tast.global) =
Buffer.add_string m.out
(Printf.sprintf "%s = %s%s %s %s\n" (gname g.Tast.gname)
(if hidden then "hidden " else "")
(if g.Tast.gconst && not m.dev then "constant" else "global")
(ll g.Tast.gty)
(* The initialiser decides, and the form no longer has to be asked: a
[defconst]'s initialiser is always one [const] can write, because the
checker refuses a computed one. So a zeroinitializer here is always a
[defvar] waiting for the startup function. *)
(if Tast.const_init g.Tast.ginit then const m g.Tast.ginit
else "zeroinitializer"))
(* ── Startup ───────────────────────────────────────────────────────── *)
(* The globals whose value has to be computed, stored before the program runs.
The same name on both backends, because it is the same function: a
whole-program build defines it, [main] calls it, and a redefinition module
has neither — a reload must not re-run an initialiser, since re-running one
would wipe the live state reloading exists to preserve.
An explicit call from [main] rather than a constructor, which is Odin's
shape ([lb_create_startup_runtime] builds [__$startup_runtime] and
base/runtime/entry_unix.odin calls it; there is not one [llvm.global_ctors]
in the Odin tree). Two things follow from that and both are the point. The
runtime is up: [flan_rt_init] has run, so an initialiser that prints or asks
for [args] sees what every other line of the program sees, and sees the same
thing under [--x86], where the constructor that writes the constant image
still runs earlier. And the order is expressible — a constructor's is the
link's. *)
let startup_sym = fname ".init-globals"
(* The startup function runs once per *process* in a release build, because a
release build's [main] is entered once. The dev daemon's re-run enters it
again: [flan_merged_park] waits for [program_asked] and the loop around it
calls [flan_program_main] from the top, so every line of [main] above runs a
second time, this call included.
What that must mean is decided by the defining form, not by the daemon. A
[defvar] is Common Lisp's [defvar]: its initialiser runs only if the
variable is not already initialised, so its value survives a re-run — which
is what the daemon has always promised ("the globals are as it left them")
and what a plain zeroed [defvar] already got for free, since .bss is
untouched by a second call. A computed one used to be the exception, wiped
back to its initial value every re-run. A [defconst] whose initialiser is a
compile-time constant is not reached from here at all: it is the linker's
image on one backend and [.init-data]'s stores on the other, and a re-run
reaches neither.
The split is [Tast.const_init]'s, and it is over the *initialiser* and not
over the form — nothing below asks [gconst], and nothing has to: since
2026-09-20 a [defconst]'s initialiser is always a compile-time constant,
because [Check.const_defconst_init] refuses a computed one on the way in.
The two therefore coincide for a constant and no [defconst] reaches the
plan below. Until then they did not, and the backends disagreed about that
one program: [const] refused a computed [defconst] by name while the x86
backend guarded it here like any [defvar]. One refusal in the checker is
what ended it.
So each computed initialiser guards itself with a flag of its own. Per
global and not per startup function, because the rule belongs to the form:
a global whose initialiser is added by a later build, or a future form that
*does* recompute, decides its own case without the other globals' having to
agree.
Dev builds only. A release build has no re-run to guard against and pays
nothing — the body below is then the bare store it always was, byte for
byte. The flag is a global of its own rather than a sentinel value in the
variable, because there is no value a [defvar] cannot hold.
Writing the flag *after* the store is what makes a failed initialiser retry
rather than be skipped. [Check.no_transfer_in_init] refuses a [signal] or an
[invoke-restart] written *in* the initialiser, but it is syntactic and over
that expression only: the initialiser is lifted into a function of its own,
and a callee of that function can still transfer out — not by signalling
unhandled, which is a no-op, but through a handler invoking a restart or
through the break hook aiming the channel. The guarded
branch then leaves through the call's transfer edge with the store not done
and the flag still false — which is the behaviour to want, because the next
run will try the initialiser again instead of proceeding with a global that
was never given its value.
The flag's name is mangled with a [~], which the reader treats as a
terminator and so cannot appear in any symbol a program can write — the same
trick [destructure~N] uses. A [.]-separated name would not do: [.] is an
ordinary symbol constituent, so [(defvar .init-once.x ...)] beside a
computed [x] used to emit the same symbol twice and the dev build died at
the assembler. *)
let init_flag n = ".init~once." ^ n
(* The computed globals, the flags that guard them, and the body of the
startup function — built here so that the two backends cannot disagree
about any of the three. [flags] is empty in a release build. *)
let startup_plan m (globals : Tast.global list) =
let computed =
List.filter
(fun (g : Tast.global) -> not (Tast.const_init g.Tast.ginit))
globals
in
let flags =
if not m.dev then []
else
List.map
(fun (g : Tast.global) ->
{ Tast.gname = init_flag g.Tast.gname; gty = Types.Bool;
ginit =
{ Tast.e = Tast.Bool false; ty = Types.Bool;
loc = g.Tast.ginit.Tast.loc };
gconst = false; gfolded = false })
computed
in
(* Registered so that [place] and the x86 backend's [lower] can find a
flag's type the same way they find any other global's. Not added to the
program's own [globals] list: nothing the programmer wrote names one, and
the daemon's [globals] op answers from the program. *)
List.iter
(fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
flags;
let body =
List.map2
(fun (g : Tast.global) (flag : Tast.global option) ->
let loc = g.Tast.ginit.Tast.loc in
let store =
{ Tast.e = Tast.Set (Tast.Pglobal g.Tast.gname, g.Tast.ginit);
ty = Types.Unit; loc }
in
match flag with
| None -> store
| Some f ->
let mark =
{ Tast.e =
Tast.Set
(Tast.Pglobal f.Tast.gname,
{ Tast.e = Tast.Bool true; ty = Types.Bool; loc });
ty = Types.Unit; loc }
in
{ Tast.e =
Tast.If
({ Tast.e = Tast.Global f.Tast.gname; ty = Types.Bool; loc },
{ Tast.e = Tast.Unit; ty = Types.Unit; loc },
{ Tast.e = Tast.Do [ store; mark ]; ty = Types.Unit; loc });
ty = Types.Unit; loc })
computed
(if flags = [] then List.map (fun _ -> None) computed
else List.map (fun f -> Some f) flags)
in
(computed, flags, body)
let emit_startup m ?(hidden = false) (globals : Tast.global list) =
match startup_plan m globals with
| [], _, _ -> false
| computed, flags, body ->
(* One guarded store per global and nothing else: the initialiser itself
was lifted into a function of its own, so this frame holds no slots and
the [let] a programmer wrote inside an initialiser has a frame of its
own to live in. *)
List.iter (emit_global m ~hidden) flags;
emit_fn m ~hidden
{ Tast.name = ".init-globals"; params = []; slots = [||]; snames = [||];
ret = Types.Unit; body; fdefers = []; fparent = None;
floc = (List.hd computed).Tast.ginit.Tast.loc };
true
(* ── 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 }
; (Vec T), spec-memory.md. The element type is nowhere in it: the runtime is
; type-erased and every operation is handed size and align at its call site.
%vec = type { ptr, i64, i64, ptr, i64 }
; (Map K V), spec-memory.md — Odin's open-addressed Robin Hood map. Neither key
; nor value type appears in it, for the same reason: one type-erased runtime,
; handed the two sizes and a hash/equality pair at each call site.
%map = type { ptr, i64, i64, ptr, i64 }
; 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.
|} ^ Rt.ll_type Rt.handler ^ {|
; 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
; a transfer's aim exact, and makes re-entering a restart-case work with
; nothing extra, since each activation allocates its own.
;
; Then §3's parameters: the buffer the clause reads them out of — owned by the
; restart-case, because the invoker's frame is gone by the time a clause runs —
; how many there are, the hash of how they are spelled, whether anything has
; 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
; [flan_restart] declares and their offsets do not move.
|} ^ Rt.ll_type Rt.restart ^ {|
; 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
; 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.
|} ^ Rt.ll_type Rt.fninfo ^ "\n" ^ Rt.ll_type Rt.flanframe ^ {|
@flan_frame_head = external global ptr
declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg)
declare i32 @llvm.bswap.i32(i32)
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, ptr)
declare void @flan_i64_to_bytes(i64, ptr, ptr)
declare void @flan_u64_to_bytes(i64, ptr, ptr)
declare void @flan_escape_bytes(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(i32, ptr, ptr)
declare void @flan_error(i32, ptr, ptr, ptr, i64)
declare void @flan_restart_push(ptr)
declare void @flan_restart_pop(ptr)
declare ptr @flan_find_restart(i32)
declare void @flan_restart_fail(ptr, i64, ptr, i64) noreturn cold
declare void @flan_restart_args_fail(ptr, i64, ptr, i64, ptr, i64, ptr, i64) noreturn cold
declare void @flan_restart_unarmed(ptr, i64, ptr, i64, ptr, i64) noreturn cold
declare void @flan_transfer_fail(ptr, i64) noreturn cold
; Not noreturn: each signals BoundsError and returns when something answered
; it, which is the one path out. The trailing ptr is the transfer channel.
declare void @flan_bounds_error(ptr, i64, i64, i64, ptr) cold
declare void @flan_slice_error(ptr, i64, i64, i64, i64, ptr) cold
declare void @flan_slice_promise_error(ptr, i64, i64, ptr) cold
; The same shape and the same reason: it signals ArithError and returns when
; something answered it. The i32 is the op code and the two i64s are the
; operands, or the destination's range for a cast.
declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_temp()
declare ptr @flan_heap_allocator()
declare ptr @flan_context_set(ptr)
declare void @flan_context_restore(ptr)
declare ptr @flan_arena_new(i64)
declare void @flan_arena_destroy(ptr)
declare void @flan_alloc_free_all(ptr, ptr, i64)
declare void @flan_vec_region_only(ptr, ptr, i64)
declare void @flan_map_region_only(ptr, ptr, i64)
declare i8 @flan_alloc_can_free(ptr)
declare i8 @flan_alloc_can_free_all(ptr)
declare i64 @flan_alloc_epoch(ptr)
declare i64 @flan_alloc_live_blocks(ptr)
declare i64 @flan_alloc_id(ptr)
declare i64 @flan_alloc_fail_bytes()
declare i64 @flan_alloc_fail_align()
declare i64 @flan_alloc_fail_id()
declare i64 @flan_alloc_budget(ptr)
declare void @flan_alloc_set_budget(ptr, i64)
; The dynamic runtime, runtime/flan_dyn.h. A flan_dyn is one machine word and
; is spelled i64 here because the typedef says uint64_t; nothing in this file
; ever looks inside one, so every operation on a dyn value is one of these.
declare i64 @flan_dyn_nil()
declare i64 @flan_dyn_from_i64(i64)
declare i64 @flan_dyn_from_f64(double)
declare i64 @flan_dyn_from_bool(i32)
declare i64 @flan_dyn_from_bytes(ptr, i64)
declare i64 @flan_dyn_vec_new()
declare i64 @flan_dyn_map_new()
declare i64 @flan_dyn_map_new_class(i64)
declare i64 @flan_dyn_class_of(i64)
declare void @flan_dyn_class_def(i64, ptr, i64)
declare i64 @flan_dyn_kw(ptr, i64)
declare i64 @flan_dyn_map_get(i64, i64)
declare void @flan_dyn_map_set(i64, i64, i64)
declare i64 @flan_dyn_map_contains(i64, i64)
; The nine that trap carry the site as ptr+len, the way the bounds and
; arithmetic traps in flan_rt.c do: a dyn type error IS the type error in a
; dynamic program, and it used to print with no file and no line. [eq] never
; traps, so it has nowhere to put one.
declare i64 @flan_dyn_add(i64, i64, ptr, i64)
declare i64 @flan_dyn_sub(i64, i64, ptr, i64)
declare i64 @flan_dyn_mul(i64, i64, ptr, i64)
declare i64 @flan_dyn_div(i64, i64, ptr, i64)
declare i64 @flan_dyn_rem(i64, i64, ptr, i64)
declare i64 @flan_dyn_lt(i64, i64, ptr, i64)
declare i64 @flan_dyn_le(i64, i64, ptr, i64)
declare i64 @flan_dyn_gt(i64, i64, ptr, i64)
declare i64 @flan_dyn_ge(i64, i64, ptr, i64)
declare i64 @flan_dyn_eq(i64, i64)
declare i64 @flan_dyn_len(i64)
declare i64 @flan_dyn_at(i64, i64)
declare void @flan_dyn_set_at(i64, i64, i64)
declare void @flan_dyn_push(i64, i64)
declare void @flan_dyn_print(i64)
declare i64 @flan_dyn_need_i64(i64)
declare double @flan_dyn_need_f64(i64)
declare i32 @flan_dyn_need_bool(i64)
; A numeric cast written on a dyn answers which numeric tag the box holds;
; check.ml's [cast_dyn] branches on it and each arm is an ordinary need plus
; the ordinary cast. The two slices are the site's location and the target's
; name, each crossing as ptr+len.
declare i32 @flan_dyn_cast_kind(i64, ptr, i64, ptr, i64, i32)
; nil <-> None at an (Option T) boundary, and (Some nil)'s run-time half —
; M2 queue item 4, check.ml's [box_option]/[unbox_option] and the [Some]
; builtin.
declare i32 @flan_dyn_is_nil(i64)
declare i64 @flan_dyn_need_not_nil(i64)
declare i32 @flan_dyn_truthy(i64)
declare i64 @flan_dyn_view_vec(ptr, i32)
declare i64 @flan_dyn_view_flat(ptr, i64, i32)
declare void @flan_dyn_root_push(ptr)
declare void @flan_dyn_root_push_desc(ptr, ptr)
declare void @flan_dyn_root_pop(i64)
declare void @flan_dyn_root_globals_begin()
declare void @flan_dyn_root_globals_end()
declare void @flan_gc_init()
declare void @flan_dev_reg_enable()
declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64)
declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_vec_clone(ptr, ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_bytes_dup(ptr, ptr, ptr, i64, ptr, i64)
declare i64 @flan_vec_len(ptr, ptr, i64)
; These two take the transfer channel as well, because a Vec's bounds check is
; inside the runtime rather than emitted here and (at v i) has to signal the
; same condition (at arr i) does.
declare ptr @flan_vec_at(ptr, i32, i64, ptr, i64, ptr)
declare void @flan_vec_as_slice(ptr, ptr, i32, i32, i64, ptr, i64, ptr)
declare void @flan_vec_free(ptr, i64, i64, ptr, i64)
; (Map K V). The two ptr arguments before the location on put/get/clone are the
; hash and equality pair, which the checker emits per key type and passes here
; the way Odin hangs them off Map_Info.
declare i8 @flan_map_init(ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_map_put(ptr, ptr, ptr, i64, i64, ptr, ptr, ptr, i64)
declare i8 @flan_map_get(ptr, ptr, ptr, i64, i64, ptr, ptr, ptr, i64)
declare i8 @flan_map_has(ptr, ptr, i64, i64, ptr, ptr, ptr, i64)
declare i8 @flan_map_remove(ptr, ptr, ptr, i64, i64, ptr, ptr, ptr, i64)
declare i8 @flan_map_reserve(ptr, i64, i64, i64, ptr, ptr, i64)
declare i8 @flan_map_clone(ptr, ptr, ptr, i64, i64, ptr, ptr, i64)
declare i64 @flan_map_len(ptr, ptr, i64)
; The cursor step. No hash and no equality pair: walking the block asks
; nothing about a key, which is why this is the one map entry point whose
; signature does not carry them.
declare i8 @flan_map_next(ptr, ptr, ptr, ptr, i64, i64, ptr, i64)
declare void @flan_map_free(ptr, i64, i64, ptr, i64)
; The pointer forms, whose signatures end with the transfer channel because a
; hash emitted for a struct key is an ordinary Flan function. Only ever taken
; as an address, never called directly from here.
declare i64 @flan_hash_flat(ptr, i64, i64, ptr)
declare i8 @flan_eq_flat(ptr, ptr, i64, ptr)
declare i64 @flan_hash_str(ptr, i64, i64, ptr)
declare i8 @flan_eq_str(ptr, ptr, i64, ptr)
; The direct forms, which an emitted struct hasher calls per field.
declare i64 @flan_key_hash_flat(ptr, i64, i64)
declare i8 @flan_key_eq_flat(ptr, ptr, i64)
declare i64 @flan_key_hash_str(ptr, i64, i64)
declare i8 @flan_key_eq_str(ptr, ptr, i64)
; Typed (= a b) / (!= a b) on two strings: ptr+len apiece, not the address of
; a slice the way the key pair above takes them, because that is the shape a
; [Types.String] operand is already in at this call site.
declare i8 @flan_str_eq(ptr, i64, ptr, i64)
declare i64 @flan_hash_combine(i64, i64)
; The filesystem. flan_file_read is not here: nothing Flan emits calls it —
; only flan_slurp_into does, from C — and flan_slurp_into is runtime glue
; rather than a fourth host call. See flan_rt.c for why the widening stops
; here. `embed` needs none of these: it is a compile-time constant.
declare i8 @flan_file_size(ptr, i64, ptr)
declare i8 @flan_file_write(ptr, i64, ptr, i64)
; The three that change the filesystem. flan_file_stat is not here for the
; reason flan_file_read is not: nothing emitted calls it. It is reached from
; the prelude through a `declare`, because file-exists? and file-size answer a
; value rather than signalling and so need none of the guard machinery these
; three do.
declare i8 @flan_file_delete(ptr, i64)
declare i8 @flan_file_rename(ptr, i64, ptr, i64)
declare i8 @flan_file_mkdir(ptr, i64)
declare i64 @flan_file_fail_reason()
declare i8 @flan_slurp_into(ptr, ptr, i64, i64, ptr, i64)
|}
(* Whether the program has a dyn in it anywhere, which is the one question
[main] asks before calling [flan_gc_init]. Asked of the whole program rather
than assumed, so that a program with no dyn emits no call and its [main] is
byte for byte the [main] it was before any of this existed.
Every shape a dyn can take is one of these: a global of that type, a
signature that mentions it, a slot that holds one, or an expression that
produces one. *)
let uses_dyn (p : Tast.program) =
let structs = Hashtbl.create 16 in
List.iter
(fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
p.Tast.structs;
(* A struct with a dyn field counts, and counts even if no expression in the
program ever has the type [dyn] on it — a zero-initialised one has a dyn
word in it that the collector will be asked to mark, and asking it before
[flan_gc_init] has run is the one thing [main] is ordering here. *)
let rec carries seen (t : Types.t) =
match t with
| Types.Dyn -> true
| Types.Array (_, e) -> carries seen e
| Types.Named n when not (List.mem n seen) ->
(match Hashtbl.find_opt structs n with
| Some st ->
List.exists
(fun (fl : Tast.field) -> carries (n :: seen) fl.Tast.fty)
st.Tast.fields
| None -> false)
| _ -> false
in
let found = ref false in
let note t = if carries [] t then found := true in
List.iter (fun (g : Tast.global) -> note g.Tast.gty) p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iter note fn.Tast.params;
note fn.Tast.ret;
Array.iter note fn.Tast.slots;
List.iter (Tast.walk (fun (e : Tast.expr) -> note e.Tast.ty)) fn.Tast.body)
p.Tast.fns;
!found
(* 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 ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.fn) =
let b = Buffer.create 256 in
Buffer.add_string b
(Printf.sprintf "\ndefine i32 @main(i32 %%argc, ptr %%argv)%s {\nentry:\n"
(attrs m));
Buffer.add_string b " call void @flan_rt_init(i32 %argc, ptr %argv)\n";
(* Immediately after the host runtime and before anything that could box: a
dyn global's initialiser runs in the startup function below, and the very
first thing it does is allocate. *)
if gc then Buffer.add_string b " call void @flan_gc_init()\n";
(* The dyn globals, rooted here and never popped, which is the whole of what
a global's extent means. They go on the stack *before* the startup
function runs, because that function is what fills them and its first
allocation may be the one that collects — and before any of it pushes a
root of its own, because every pop in the program takes the top of the
stack and these are the ones that must never be at the top.
Zero is what a global holds until its initialiser has run: BSS gives that
for free, and runtime/flan_dyn.h says a rooted slot holding 0 is not a
value.
Bracketed, and the bracket is what tells the collector which entries at
the bottom of its stack are these. It buys two things. A merged dev
build's [main] is re-entered — the dev daemon's [rerun] — and [begin]
empties the stack first, so the second entry re-roots these globals rather
than pushing a second copy of each. And a run that finishes parks with
every frame's roots dropped but these kept, which is what makes a global
still readable, and still collectable-through, in a park that runs
evaluated thunks. runtime/flan_dyn.h's [flan_dyn_root_reset] has the rest.
Nothing between the two may allocate: the globals are unrooted in that
window while still holding what a previous run left. Only the pushes are
in it. *)
if dyn_globals <> [] then
Buffer.add_string b " call void @flan_dyn_root_globals_begin()\n";
List.iter
(fun (g, ty) ->
match (if ty = Types.Dyn then None else desc_of m ty) with
| None ->
Buffer.add_string b
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" (gname g))
(* A global struct with a dyn field goes on the same stack with its
descriptor beside it, and [.bss] gives the zero the push wants. *)
| Some sym ->
Buffer.add_string b
(Printf.sprintf
" call void @flan_dyn_root_push_desc(ptr %s, ptr @\"%s\")\n"
(gname g) sym))
dyn_globals;
if dyn_globals <> [] then
Buffer.add_string b " call void @flan_dyn_root_globals_end()\n";
(* The program's own end of the transfer channel. Nothing can be transferring
when [main] returns: a restart is found by name on the restart stack, and
an [invoke-restart] that finds none fails at the invoke site rather than
unwinding past everything. *)
Buffer.add_string b (Printf.sprintf " %s = alloca ptr\n" xfer_param);
Buffer.add_string b
(Printf.sprintf " store ptr null, ptr %s\n" xfer_param);
(* The computed globals, before anything the programmer wrote and after the
runtime is up. No guard after it: a transfer out of an initialiser is
refused in the checker, because nothing has established a handler or a
restart this early and there would be nowhere for one to land. *)
if startup then
Buffer.add_string b
(Printf.sprintf " call void %s(ptr %s)\n" startup_sym xfer_param);
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")
(if args = "" then "ptr " ^ xfer_param else args ^ ", ptr " ^ xfer_param));
(* 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. *)
(* Which file the compile unit is about. Every subprogram carries its own
[!DIFile], so this only decides what a debugger calls the unit as a whole;
the first function anyone actually wrote is the honest answer. *)
let cu_file (p : Tast.program) =
match
List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
with
| Some f -> f.Tast.floc.Loc.file
| None -> "<flan>"
let new_dbg (p : Tast.program) =
let d =
{ dn = 0; dout = Buffer.create 4096; dfiles = Hashtbl.create 8;
dtys = Hashtbl.create 32; dlocs = Hashtbl.create 256; dcu = 0 }
in
let file = dfile d (cu_file p) in
d.dcu <- dalloc d;
(* [isOptimized: false] is not decoration: it is what a debug build is, and
[Build] sets -O0 to make it true. DW_LANG_C99 because the layout is C's
and lldb's C support is then exactly right for it. *)
dput d d.dcu
(Printf.sprintf
"distinct !DICompileUnit(language: DW_LANG_C99, file: !%d, producer: \"flan\", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false)"
file);
d
let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
(p : Tast.program) =
let m = {
out = Buffer.create 8192; strs = Buffer.create 512;
structs = Hashtbl.create 16; datas = Hashtbl.create 16;
unions = Hashtbl.create 16;
globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; dev; known; nstr = 0; nfi = 0; sanitize;
descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None);
} in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
p.Tast.structs;
List.iter (fun (u : Tast.data) -> Hashtbl.replace m.datas u.Tast.dname u)
p.Tast.datas;
List.iter (fun (u : Tast.structure) -> Hashtbl.replace m.unions u.Tast.sname u)
p.Tast.unions;
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;
(* A union is its blob and nothing else: [k x iA], where A is the alignment
the strictest member needs and k*A is the size of the largest. LLVM has no
union type, and this is the shape clang gives one — the same shape the
data type payload below uses, for the same reason, which is that it makes
LLVM align the storage without an explicit [align] anywhere. Nothing geps
into it: a member is read through the union's own address. *)
List.iter
(fun (u : Tast.structure) ->
let size, align = union_lay m u in
Buffer.add_string m.out
(Printf.sprintf "%s = type { [%d x i%d] }\n" (sname u.Tast.sname)
(if align = 0 then 0 else size / align) (align * 8)))
p.Tast.unions;
(* A data type is a tag and a blob, and each of its cases is a struct laid over
the blob. Both are emitted as named types so that every reader — a
construction, a match arm, the structural printer — geps rather than
computing byte offsets of its own.
The blob is [k x iA] where A is the alignment the widest member of any
case needs: that is what makes LLVM align the payload without an explicit
[align] on a type, and it is what makes the whole agree with C's
[struct { int tag; union { ... } u; }] byte for byte. That agreement is
the point — the macro expander's [Form] has to be the same bytes in the
compiler and in the dlopened macro. *)
List.iter
(fun (u : Tast.data) ->
List.iter
(fun (c : Tast.variant) ->
Buffer.add_string m.out
(Printf.sprintf "%s = type { %s }\n"
(sname (u.Tast.dname ^ "." ^ c.Tast.vname))
(String.concat ", "
(List.map (fun (f : Tast.field) -> ll f.Tast.fty)
c.Tast.vfields))))
u.Tast.cases)
p.Tast.datas;
List.iter
(fun (u : Tast.data) ->
let size, align = payload_lay m u in
Buffer.add_string m.out
(Printf.sprintf "%s = type { i32%s }\n" (sname u.Tast.dname)
(if size = 0 then ""
else Printf.sprintf ", [%d x i%d]" (size / align) (align * 8))))
p.Tast.datas;
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
(* The two named metadata nodes without which none of the above survives:
LLVM drops every scrap of debug metadata, silently and with no diagnostic,
if "Debug Info Version" is absent. A build that "works" and shows nothing in
the debugger is that flag. *)
let dmodule d =
let b = Buffer.create 512 in
Buffer.add_string b
"\ndeclare void @llvm.dbg.declare(metadata, metadata, metadata)\n\n";
let dv = dalloc d and div = dalloc d in
dput d dv "!{i32 7, !\"Dwarf Version\", i32 5}";
dput d div "!{i32 2, !\"Debug Info Version\", i32 3}";
Buffer.add_string b (Printf.sprintf "!llvm.dbg.cu = !{!%d}\n" d.dcu);
Buffer.add_string b
(Printf.sprintf "!llvm.module.flags = !{!%d, !%d}\n\n" dv div);
Buffer.add_buffer b d.dout;
Buffer.contents b
(* The per-type dyn descriptors, as runtime/flan_dyn.h's [flan_desc] laid out
by hand: two i64s and a pointer to the offset table. [private] because a
redefinition module may name a type the program it patches already named,
and a private constant has no symbol for the two to collide over. Sorted, so
the .ll is reproducible build to build. *)
let descriptors m =
let b = Buffer.create 256 in
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c)
|> List.iter
(fun (_, (sym, offs, size)) ->
Buffer.add_string b
(Printf.sprintf
"@\"%s.offs\" = private unnamed_addr constant [%d x i64] [%s]\n"
sym (List.length offs)
(String.concat ", "
(List.map (Printf.sprintf "i64 %d") offs)));
Buffer.add_string b
(Printf.sprintf
"@\"%s\" = private unnamed_addr constant { i64, i64, ptr } \
{ i64 %d, i64 %d, ptr @\"%s.offs\" }\n"
sym size (List.length offs) sym));
Buffer.contents b
(* The same table in the other backend's syntax. It lives here rather than in
x86.ml so that the two renderings sit beside each other and the layout the
runtime reads is agreed in one place. [.L] so the labels never reach the
symbol table, which is what lets a redefinition module name a type the
program it patches already named. *)
let descriptors_asm m =
let b = Buffer.create 256 in
let rows =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c)
in
if rows <> [] then
Buffer.add_string b
"\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\
# size of one instance, how many dyn words it holds, and where they are.\n\
# Read by the collector through flan_dyn_root_push_desc and by nothing\n\
# else; no value points at one.\n\
#\n\
# .data.rel.ro and not .rodata, because a descriptor holds the address\n\
# of its own offset table. That is a relocation, and a relocation in a\n\
# read-only section is one the dynamic linker can only apply by making\n\
# the section writable — a DT_TEXTREL, which ld warns about in a PIE\n\
# and refuses outright in a shared object. .data.rel.ro is the section\n\
# for exactly this: relocated at load and read-only from then on.\n\
\t.section\t.data.rel.ro,\"aw\",@progbits\n";
List.iter
(fun (_, (sym, offs, size)) ->
Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym);
List.iter
(fun o -> Buffer.add_string b (Printf.sprintf "\t.quad\t%d\n" o))
offs;
Buffer.add_string b
(Printf.sprintf
"\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t.L%s.offs\n"
sym size (List.length offs) sym))
rows;
Buffer.contents b
let finish m =
header ^ Buffer.contents m.strs ^ descriptors m ^ "\n" ^ Buffer.contents m.out
^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "")
^ (match m.dbg with None -> "" | Some d -> dmodule d)
(* ── The macro boundary ────────────────────────────────────────────── *)
(* One thunk per macro, and the only shape the compiler reaches a macro
through. A macro is [(defn name [args [Form]] Form)], so its own signature
takes a [%slice] by value and returns a [%"Form"] by value — and LLVM's
convention for an aggregate passed or returned by value in hand-written IR
is not promised to be clang's C ABI for the equivalent struct. The unions
lane verified the *memory* layout of a union against clang, which is a
different claim, so memory is the agreement that actually exists.
So nothing but pointers and scalars crosses:
void @"flan.macro.NAME"(ptr %args, i64 %n, ptr %out, ptr %xfer)
The thunk builds the slice from (args, n) on this side of the boundary,
calls the macro, and stores the result through %out. Every aggregate stays
LLVM-to-LLVM, and the compiler's side is a four-pointer C call. *)
let macro_thunk m (fn : Tast.fn) =
let name = fn.Tast.name in
let ret = ll fn.Tast.ret in
Buffer.add_string m.out
(Printf.sprintf
"define void @%s(ptr %%args, i64 %%n, ptr %%out, ptr %%xfer) {\n\
entry:\n\
\ %%s0 = insertvalue %%slice zeroinitializer, ptr %%args, 0\n\
\ %%s1 = insertvalue %%slice %%s0, i64 %%n, 1\n\
\ %%r = call %s %s(%%slice %%s1, ptr %%xfer)\n\
\ store %s %%r, ptr %%out\n\
\ ret void\n\
}\n\n"
(quoted (Mangle.macro name))
ret (fname name) ret)
(* [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.
[macros] names the functions that also get a thunk. It is a list of names
and not a flag because a macro module carries the whole prelude with it —
only the handful of functions that were written [defmacro] are reachable
from outside.
[hidden] takes every Flan definition in the module out of the dynamic symbol
table, and it exists for the one build that is dlopened into a process that
already has Flan in it: the macro module, loaded into [flan dev]'s merged
binary. That binary is the program *and* the compiler, linked [-rdynamic] so
a redefinition module can reach its cells, and [-rdynamic] exports every
[flan.*] body it has. ELF gives an executable precedence over a shared
object, so without this the macro module's own copy of a prelude function is
interposed by the host's — and the two copies are not interchangeable. Twice
measured, in two different ways:
- The host's [flan.rl/with-drawing] is the package's [defmacro] compiled as
an ordinary function, whose body was qualified at the [Ast] level after
the quasiquote had already become a string literal. Expanding through the
host's copy produced an unqualified [begin-drawing] the checker refused.
- Under [flan dev --x86] the host's bodies are the dev backend's and the
macro module's caller is LLVM's, which is the crossed pair: a SIGSEGV
inside [flan.\[clamp\]] during the first expansion, before the program had
started.
The thunks stay at default visibility, because [dlsym] is how the compiler
reaches them and a hidden symbol is not in the table it searches. Nothing
else in the module is anybody's to call. The C the module links — the
runtime, the shims — is untouched by this and goes on binding to the host's
copy where there is one, which is what keeps [flan_exit_hook] the merged
build installed in reach of a trap raised inside an expansion. *)
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
?(sanitize = false) ?(macros = []) ?(hidden = false)
(p : Tast.program) : string =
(* [hidden] and [dev] are opposites and the refusal is here so that they
cannot be written together by accident. A dev build's whole point is that
its cells, its globals and [flan.abi.*] are in the dynamic symbol table
for a redefinition module to bind against; hiding them would leave a host
that links, runs, and silently installs nothing. There is no such thing as
a reloadable macro module, so nothing is lost by saying so out loud. *)
if hidden && dev then
failwith
"Emit.program ~hidden ~dev: a dev build exports its cells so that a \
redefinition module can reach them, and hiding them would break every \
reload. [hidden] is the macro module's flag and a macro module is not a \
dev build.";
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize 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
(* The ABI marker, defined here so a redefinition module can bind against
it, and only in a dev build: a release build has no cells and nothing to
load into one, so it keeps exactly the module text it had before this
existed. [-rdynamic] is what puts it in the executable's dynamic symbol
table, and a dev build is the only build that gets that either. *)
Buffer.add_string m.out
(Printf.sprintf "%s = global i64 0\n" abi_marker_sym);
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;
(* And the allocation registry is armed, which is the whole of what makes
it a dev-build feature at run time. A constructor rather than a line in
[main]: the notes are emitted into every function, and a note that
arrived before the flag was set would be a block the table never heard
of. That used to be an argument about a [defvar] initialiser allocating
before [main] ran, which it no longer does — [emit_startup] is called
from [main] now. What survives is the weaker and sufficient version:
arming has to precede the first allocation, a constructor is the only
slot that precedes every one of them whatever the entry point is, and a
program linked into a C host has no [main] of ours to put a line at the
top of. Priority 65535 is the default slot; nothing here needs to beat
another constructor, only to beat the program. *)
(* And the crash handler, in the same slot and for a cousin of the same
reason: a dev-build segfault must park the program in front of the
daemon instead of taking the whole session down silently, and the
handler has to be installed before any program code can fault. Only in
a dev build — the constructor is emitted here and nowhere else — so a
release build dies exactly the way it always did. *)
Buffer.add_string m.out
"@llvm.global_ctors = appending global [2 x { i32, ptr, ptr }] \
[{ i32, ptr, ptr } { i32 65535, ptr @flan_dev_reg_enable, ptr null }, \
{ i32, ptr, ptr } { i32 65535, ptr @flan_dev_crash_enable, ptr null }]\n";
(* Declared here rather than in the preamble, which is the one place a
declare is worth gating: this lane then adds no dev-only text at all to
a release module, and the only line it does add there —
[flan_bytes_dup] — is a function release builds really call, since
(bytes s) allocates in every build. The neighbouring
[flan_dev_reg_enable] stays in the preamble ungated; it predates this
and moving it is not this lane's to make. *)
Buffer.add_string m.out "declare void @flan_dev_crash_enable()\n";
Buffer.add_char m.out '\n'
end;
List.iter (emit_global m ~hidden) p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
emit_fn m ~hidden
~pnames:(match List.assoc_opt fn.Tast.name pnames with
| Some ns -> ns | None -> [])
fn)
p.Tast.fns;
let startup = emit_startup m ~hidden p.Tast.globals in
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
| Some fn ->
emit_main m ~startup ~gc:(uses_dyn p)
~dyn_globals:
(List.filter_map
(fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn || dyn_offsets m g.Tast.gty <> []
then Some (g.Tast.gname, g.Tast.gty) else None)
p.Tast.globals)
fn
(* A program with no [main] is linked into a C host that brings its own
entry point, and then nothing calls the startup function — which is why
the constant image is a constant image on both backends and not a
third thing this has to run. *)
| None -> ());
List.iter
(fun n ->
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = n) p.Tast.fns with
| Some fn -> macro_thunk m fn
| None -> failwith ("no such macro: " ^ n))
macros;
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) ?(debug = false)
?(known = fun _ -> true) ?(retains = true)
?call ?(consts = []) (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
(* A clause lifted out of one of these comes with it: its body may have
changed too, and it is reached by address from inside the module rather
than through a cell. Every other lifted clause is invisible here — it
needs no declaration, since nothing in this module names it. *)
let lifted =
List.filter
(fun (f : Tast.fn) ->
match f.Tast.fparent with
| Some p -> List.mem p fns
| None -> false)
p.Tast.fns
in
(* The rest of the program, as the cell and registry machinery below sees it.
A lifted clause has neither, so it must not appear in either. *)
let siblings =
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
in
let m = new_module ~checks ~dev ~known ~debug p in
(* A thunk the module runs itself is excluded from all of this: it is called
directly by [flan_reload_call], so it needs no cell, must not be published
into one, and must not take a registry slot — there are 4096 of those and
an expression evaluated in a loop would exhaust them. Nothing pointing
into the module is also what lets the agent unload it afterwards. *)
let transient f = call = Some f in
let new_fns =
List.filter
(fun (f : Tast.fn) ->
(not (known f.Tast.name)) && not (transient f.Tast.name))
siblings
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 && not dev 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 host's ABI marker, and a pointer-sized datum holding its address.
That datum is a relocation the loader has to resolve while it maps the
object, so a host built by the other backend — which defines
[flan.abi.x86] and not this — fails the [dlopen] outright, rather than
loading and then dying at the first call into a redefined function that
takes or returns a struct. Hidden, so this module's own copy can never
be interposed by another loaded module's; the relocation against the
host's marker is the only part that matters. *)
Buffer.add_string m.out
(Printf.sprintf "%s = external global i64\n%s = hidden global ptr %s\n\n"
abi_marker_sym ("@" ^ quoted Mangle.abi_require) abi_marker_sym);
(* 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) ->
if not (transient f.Tast.name) then
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)))
siblings;
if new_fns <> [] || new_globals <> [] then
Buffer.add_string m.out
"\ndeclare ptr @flan_dev_cell(ptr)\n\
declare ptr @flan_dev_global(ptr, i64, ptr)\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)))
siblings;
(* Hidden for the same reason a redefined body is: default visibility in a
shared object is interposable, and that applies to taking the address too,
so a plain reference would resolve to the host's copy of the clause and
this module would install the very handler it is replacing. *)
List.iter (fun f -> emit_fn m ~hidden:true f) lifted;
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 (Mangle.sym 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. *)
(* Its declared initial value travels with it, as a constant the
runtime copies on the allocation and ignores afterwards. Without
this a new (defvar n i64 42) or a new defconst would silently be
zero — calloc is only the right answer for ZII.
A *computed* initialiser sends a null instead, and the allocation
keeps calloc's zeroes. That is the reload rule and not a gap in
this one: a global's initialiser runs at startup, once, and a
reload does not run initialisers — sand's grid is a global and
"edit the code, keep the sand" is the whole demo. A name the
program is meeting for the first time has no startup to have
missed, so it starts as ZII and the function that loads it loads
it. Both backends answer the same way, which is the only answer
that makes it a rule. *)
let init =
if not (Tast.const_init g.Tast.ginit) then "null"
else begin
let init = Printf.sprintf "@\".init.%d\"" m.nstr in
m.nstr <- m.nstr + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private constant %s %s\n" init
(ll g.Tast.gty) (const m g.Tast.ginit));
init
end
in
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), ptr %s)\n \
store ptr %s, ptr %s\n"
t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
(globalptr g.Tast.gname)))
new_globals;
(* A constant whose value the checker never consumed is just bytes in the
program's memory, so a new value is published the same way a new body
is: one store, at the frame boundary. One the checker *did* consume is
in the shape of the program and never gets here — the session refuses
it. *)
List.iter
(fun (g : Tast.global) ->
if List.exists (String.equal g.Tast.gname) consts then
Buffer.add_string b
(Printf.sprintf " store %s %s, ptr %s\n" (ll g.Tast.gty)
(const m g.Tast.ginit) (gname g.Tast.gname)))
p.Tast.globals;
List.iter
(fun (f : Tast.fn) ->
if transient f.Tast.name then ()
else 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));
(* An expression evaluation compiles to a function with nowhere to be
called from, so the module says so and the agent runs it once — after
the install, on the game thread, so it sees both the bodies this module
just published and a program state the program agrees is consistent. *)
match call with
| Some fn ->
Buffer.add_string m.out
(Printf.sprintf
"\ndefine void @flan_reload_call() {\nentry:\n \
%s = alloca ptr\n store ptr null, ptr %s\n \
call %s %s(ptr %s)\n ret void\n}\n"
xfer_param xfer_param (ll Types.Unit) (fname fn) xfer_param);
(* Nothing outside this module refers to anything in it once the call has
returned — no cell holds an address in its text, the registry has no
slot for it, and the value it produced was copied out. So it says so,
and the agent unloads it. A module that publishes a body can never say
this: its whole purpose is to leave a pointer behind.
[m.nstr = 0] is the third condition and it is about *data*, not text.
A string literal is emitted into this module's own image, and an
expression may store one anywhere it likes — [(set msg "tuned")] on a
string global leaves that global pointing into the mapping the agent
is about to drop. The next thunk can be mapped at the same address, so
the result is silent garbage rather than a fault. A module with no
string constants has nothing in its image anyone could still be
pointing at; one with any keeps its mapping, which costs a page and is
the same bargain every redefinition already makes. *)
(* [retains = false] is a caller saying it knows where every literal in
this module goes. The [m.nstr] test below is a conservative stand-in
for that — an expression may store a string literal anywhere it likes,
and a global left pointing into an unmapped image is silent garbage
rather than a fault. A locals thunk is the case where the answer is
known: every literal it emits goes to [flan_dev_emit], which memcpys
into the result buffer, so nothing outside the module holds an address
inside it once the call has returned. Without this, clicking through
the frames of a break loop costs a permanent mapping per click. *)
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
| None -> ()
end;
finish m
Reference in New Issue View Git Blame Copy Permalink