JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/lib/emit.ml

6205 lines
290 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. *)
(* The assertions below this line are not diagnostics. Every one of them says
the checker admitted something it refuses — a type with no layout, a case
that is not a case of its data type, arithmetic on a struct — so no program
text reaches one and there is no fix to name. They are still worded for a
reader, because the one way to see one is a compiler bug and the person who
sees it should be told that rather than left reading "no layout for t" as a
statement about their own code. [internal] is the whole of the treatment
they get: the prefix check.ml already uses, and the sentence that says who
the message is for. *)
let internal fmt =
Printf.ksprintf
(fun m -> failwith ("internal: " ^ m ^ " — this is a compiler bug")) fmt
(* [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)
(* ── The signature a cell carries ──────────────────────────────────────
A dev cell is three words, not one: the body, the signature word of that
body, and the signature spelled out as a C string.
{ ptr body, i64 word, ptr text }
The body is first, so everything that only ever wanted the body — a load
of the cell, [test/cells.sh]'s store through [dlsym] — reads the
same address it always did.
The word is what makes a signature change installable. A redefinition that
changes a function's parameters or return type publishes its new word with
its new body, and every call site through the cell compares the word it
was compiled against with the one the cell holds. A caller compiled before
the change finds them different and signals [StaleCall] instead of passing
arguments the body does not take. A caller recompiled after it finds them
equal and pays a load and a compare. A release build has no cells, so it
has neither.
The word is a hash of the text and not a counter the session keeps, and
that is a decision: a signature changed and then changed back is the
signature the old callers were compiled against, and they are right to
call it again. A counter would trap them. FNV-1a over the text — any
stable 64-bit hash would do, and this one needs no table.
The text is [defn]'s spelling, the parameters in brackets and then the
return — the same one the stale-caller report and the condition print. *)
let sig_text (params : Types.t list) (ret : Types.t) =
Printf.sprintf "[%s] %s"
(String.concat " " (List.map Types.to_string params))
(Types.to_string ret)
let sig_word params ret =
let s = sig_text params ret in
let h = ref 0xcbf29ce484222325L in
String.iter
(fun c ->
h := Int64.logxor !h (Int64.of_int (Char.code c));
h := Int64.mul !h 0x100000001b3L)
s;
!h
(* The cell's LLVM type, spelled once for the host's definition and every
module's declaration of it. *)
let cell_ty = "{ ptr, i64, ptr }"
(* A name the host was never built with — a defn or a defonce 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 environment parameter, the other name that is not a Flan name: the
address of the captured copies a function value was made with.
**It is declared by exactly the bodies that can be reached through a
[(Fn ...)] value**, and it is the *last* parameter, after the transfer
channel. That set is: a lifted [fn] literal written into an [Fn] position,
capturing or not; every handler clause, because [flan_signal] passes one
to whichever clause matched and cannot know which of them captured; and
the widening thunks ([Tast.Thicken]), which exist to read it.
Nothing else declares it. An ordinary [defn] therefore emits exactly the
signature it always did — its parameters and then the channel, and not a
byte more — and a call to it by name is unchanged. That is the whole of
what keeps capture free for everyone who does not use it, and it is the
author's ruling: the static side does not pay for the dynamic side.
So **every indirect call is exactly typed**. The two conventions meet in
one place, the thunk, and nowhere does a caller pass an argument the callee
did not declare. An earlier design did rely on that — the environment last,
ignored by a body that never asked for it, which SysV allows and Swift's
thin-vs-thick convention is built on — and wasm32 killed it: [call_indirect]
compares the signature at the call site, so a spare argument is a trap and
not a register nobody reads. Being exactly typed is checkable by a verifier
rather than argued from a calling convention, which is the better property
to have had all along. *)
let env_param = "%env"
(* 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, the
lifted function that runs, and the environment that function is handed —
the establishing function's captured copies, or null when the clause
captured nothing. *)
let handler =
{ sname = "handler";
fields = [ "prev", Ptr; "type", I32; "fn", Ptr; "env", Ptr ] }
(* A restart frame, field for field the runtime's [flan_restart]. The first
four are the lookup; [args] to [siglen] are §3's parameter passing,
described where the type is written into the header; the last five are
for a break loop and nothing reads them on the way to a transfer: where
the clause is written, its [:report] sentence, and [flags], whose bit 0
says the checker made the clause up (a [handler-case]'s landing). *)
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;
"loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
"flags", I32 ] }
(* What a signal site says about its condition — the runtime's
[flan_condesc]. The first four fields are the prelude's [Error] laid out,
because a handler that matched through a parent link is handed this
rather than the condition. [chain] is the type ids from the condition's
own to its root; [loc] is the signal site. *)
let condesc =
{ sname = "condesc";
fields =
[ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
"chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64;
"render", Ptr; "flags", I32 ] }
(* 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 ] }
(* [at] is the call this frame is in: the site of the last Flan call it
made, as a NUL-terminated file:line:col, stored after the arguments and
before the call. Null until the first. *)
let flanframe =
{ sname = "flanframe";
fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr; "at", Ptr;
"serial", I64; "fp", 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 -> internal "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
| [] -> internal "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 the runtime's [flan_allocator] record and the
incarnation of it the value was made for — flan_rt.c's [flan_alloc_value].
The runtime is handed its address; see [Check.use_alloc]. *)
| Types.Alloc -> "%alloc"
(* A code address and the environment it is called with: two words, always,
whether or not this particular value captured anything. See [%fnv]. *)
| Types.Fn _ -> "%fnv"
(* The bare address, and nothing beside it: one pointer, the width of any
other. A [CFn] cannot capture, so there is nothing an environment
would hold. *)
| Types.CFn _ -> "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 + epoch. Five words, as many 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 _ | Types.Len _ | Types.LArray _ ->
(* The checker rejects it by name — nothing reaches here. *)
internal "no layout for %s" (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
(* One word inside an instance that the collector follows, located twice.
[goff] is the byte offset under [lay]'s numbers, which are x86-64's and are
what the hand-written backend writes. [gpath] is the same place as a walk
an LLVM [getelementptr] can take — each step a type and its indices — so
the LLVM backend can write the offset as a constant expression and let the
target's own layout answer it. That is the difference on wasm32, where a
pointer is four bytes and [goff] would name the wrong word. *)
type gcword = { goff : int; gpath : (string * string list) list }
(* Every word of an instance the collector follows, by kind — the four
tables of runtime/flan_dyn.h's [flan_desc]. [gvec] carries each Vec's
element type and [gmap] each Map's value type, whose own descriptor the
entry points at. *)
type gclayout = {
gdyn : gcword list;
genv : gcword list;
gvec : (gcword * Types.t) list;
gmap : (gcword * Types.t) list;
}
(* A descriptor this module has to write out: its symbol, the words, the
instance size, and the symbol of each Vec entry's element descriptor in
[gvec]'s order and of each Map entry's value descriptor in [gmap]'s. *)
type desc = {
dsym : string;
dlay : gclayout;
dsize : int;
dvecs : string list;
dmaps : string list;
}
(* ── 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) *)
(* Whether an [(Fn ...)] value may carry an environment the collector owns,
which is what makes its second word something to root and to mark. True
when the program has a capturing [fn] that outlives its frame (see
[Check.place_closures]), and always in a dev
build — a redefinition can add the first one, and the frames of the
running program would then hold function values nobody had rooted. When
it is false every [Fn] word is a code address or null, and nothing roots
one or starts the collector for it: the static side does not pay for the
dynamic one. See [gc_layout]. *)
gcfn : bool;
(* 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. 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;
(* True when the module is written to be read: every Flan form that emits an
instruction is preceded by a comment quoting it and naming its position.
A comment is nothing to [llc], so the object is the same either way; see
[annot]. *)
ann : bool;
mutable nstr : int;
(* Set while an expression thunk's module is emitted: a string literal's
value is then a copy [flan_dev_literal] keeps for the life of the
process, so storing it anywhere leaves nothing pointing into the module,
and the literal is not counted in [nstr]. Without it every C-x C-e that
wrote a string or a keyword kept its mapping. *)
mutable pool : bool;
(* 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. A closure's
environment is the exception: it points at its descriptor for as long as
it lives, which is why making one counts in [nstr]. *)
descs : (string, desc) Hashtbl.t;
(* Every Flan function in the program, by name, with its parameters and its
return: what a dev call site compares the cell's signature word against.
Filled from the program the module is built from, which in a
redefinition module is the whole checked program — so a call site is
compiled against the signature its callee has in the same check. *)
fsigs : (string, Types.t list * Types.t) 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 -> 16, 8
| Types.Fn _ -> 16, 8
| Types.CFn _ -> 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 -> internal "no layout for struct %s" n)
| Types.Dyn -> 8, 8
| Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no layout for %s" (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 -> internal "no integer type of %d bits" n
(* ── 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] and [Types.Vec] 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. A [Types.Map]'s dyn values are not words of the
instance at all; [gc_layout] names the header in its [gmap] table. *)
| _ -> 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 rec desc_of m (t : Types.t) : string option =
let l = gc_layout m t in
if l.gdyn = [] && l.genv = [] && l.gvec = [] && l.gmap = [] then None
else
let key = Types.to_string t in
match Hashtbl.find_opt m.descs key with
| Some d -> Some d.dsym
| None ->
let sym =
Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs)
in
(* Claimed before the elements are asked for, so the counter a nested
element's symbol takes cannot be this one's. *)
Hashtbl.replace m.descs key
{ dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = []; dmaps = [] };
let elems what l =
List.map
(fun (_, e) ->
match desc_of m e with
| Some s -> s
| None -> internal "a %s entry whose element has no words" what)
l
in
let dvecs = elems "Vec" l.gvec in
let dmaps = elems "Map" l.gmap in
Hashtbl.replace m.descs key
{ dsym = sym; dlay = l; dsize = fst (lay m t); dvecs; dmaps };
Some sym
(* ── The words the collector follows ─────────────────────────────────
What [dyn_offsets] answers, widened by the two words closures added: the
environment half of an [(Fn ...)] value, and a [(Vec T)] whose elements hold
one. Both only when [m.gcfn] — a program that never makes a capturing [fn]
has no environment anywhere for the collector to find, so its [Fn] values
are code addresses and null and are rooted by nothing, exactly as before.
The dyn words are gathered where [dyn_offsets] gathers them and nowhere
else: a dyn inside an [Option], a data type's payload, a union or a Vec is
refused by [Check.hidden_dyn], so there is nothing more to find.
The environment words are gathered through all of those as well. An
[(Option (Fn ...))] is how a struct field or a global holds a function
value — a bare one would be zeroed — and a data type or a union overlays
its cases, so which bytes are a function value depends on a tag this table
cannot read. Naming every case's word is sound here, and would not be for
a dyn, because the collector never reads *through* an environment word it
did not allocate: it asks its own set first (runtime/flan_dyn.c's
[mark_env]). The word of a case that is not the live one is an integer or
half of something else, it is not in the set, and it is passed over.
Duplicates are kept apart by path, not by offset. Two cases can put a word
at the same x86-64 offset and at different wasm32 ones, and marking a word
twice costs nothing. *)
and gc_layout m (t : Types.t) : gclayout =
let dyn = ref [] and env = ref [] and vec = ref [] and map = ref [] in
let step ty idx path = path @ [ (ty, idx) ] in
let rec go ~full seen off path (t : Types.t) =
match t with
| Types.Dyn -> if full then dyn := { goff = off; gpath = path } :: !dyn
| Types.Fn _ when m.gcfn ->
env := { goff = off + 8; gpath = step "%fnv" [ "i32 0"; "i32 1" ] path }
:: !env
(* Asked with [reaches_fn] and not by laying the element out: a data type
may hold a Vec of itself, and the element's own descriptor, which
[desc_of] claims before it recurses, is what closes that loop. *)
| Types.Vec e when m.gcfn ->
if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec
(* A Map's values, when they hold a function value's environment or a
dyn. The key never does: neither is a key type. The value type's own
descriptor is what the entry points at, so a Map of Maps is walked
through the inner one's. *)
| Types.Map (_, v) ->
if (m.gcfn && reaches_fn m [] v) || reaches_dyn m [] v then
map := ({ goff = off; gpath = path }, v) :: !map
| Types.Array (n, e) ->
let s, _ = lay m e in
for i = 0 to Int64.to_int n - 1 do
go ~full seen (off + (i * s))
(step (ll t) [ "i32 0"; Printf.sprintf "i64 %d" i ] path) e
done
| Types.Option e when m.gcfn ->
let _, _, offs = lay_fields m [ Types.Int Types.I8; e ] in
go ~full:false seen (off + List.nth offs 1)
(step (ll t) [ "i32 0"; "i32 1" ] path) e
| Types.Named nm when not (List.mem nm seen) ->
let seen = nm :: seen in
(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.iteri
(fun i (ty, o) ->
go ~full seen (off + o)
(step (sname nm) [ "i32 0"; Printf.sprintf "i32 %d" i ] path) ty)
(List.combine tys offs)
| None when not m.gcfn -> ()
| None ->
match Hashtbl.find_opt m.datas nm with
| Some u ->
let size, align = payload_lay m u in
if size > 0 then begin
let _, _, poffs =
lay_fields m
[ Types.Int Types.I32;
Types.Array (Int64.of_int (size / align),
Types.Int (int_kind (align * 8))) ]
in
let poff = off + List.nth poffs 1 in
let ppath = step (sname nm) [ "i32 0"; "i32 1" ] path in
List.iter
(fun (c : Tast.variant) ->
let tys =
List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields
in
let _, _, offs = lay_fields m tys in
List.iteri
(fun i (ty, o) ->
go ~full:false seen (poff + o)
(step (sname (nm ^ "." ^ c.Tast.vname))
[ "i32 0"; Printf.sprintf "i32 %d" i ] ppath) ty)
(List.combine tys offs))
u.Tast.cases
end
| None ->
match Hashtbl.find_opt m.unions nm with
| Some u ->
(* Every member starts where the union does, so the walk goes on
from the same place with the member's own type. *)
List.iter
(fun (fl : Tast.field) -> go ~full:false seen off path fl.Tast.fty)
u.Tast.fields
| None -> ())
| _ -> ()
in
go ~full:true [] 0 [] t;
let order (a : gcword) (b : gcword) =
match compare a.goff b.goff with 0 -> compare a.gpath b.gpath | c -> c
in
let uniq l = List.sort_uniq order l in
{ gdyn = uniq !dyn; genv = uniq !env;
gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec;
gmap = List.sort_uniq (fun (a, _) (b, _) -> order a b) !map }
(* Whether an [(Fn ...)] is anywhere in a value's storage, a Vec's elements
included. A type met again on the way contributes nothing more, which
terminates a data type holding a Vec of itself without losing a function
value found along another path. *)
and reaches_fn m seen (t : Types.t) =
match t with
| Types.Fn _ -> true
| Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Map (_, e) ->
reaches_fn m seen e
| Types.Named nm when not (List.mem nm seen) ->
let seen = nm :: seen in
let fields =
match Hashtbl.find_opt m.structs nm with
| Some st -> st.Tast.fields
| None ->
match Hashtbl.find_opt m.datas nm with
| Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases
| None ->
match Hashtbl.find_opt m.unions nm with
| Some u -> u.Tast.fields
| None -> []
in
List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields
| _ -> false
(* Whether a dyn word is anywhere [gc_layout] records one: directly, in a
fixed array, in a struct field, or in a Map's values. The other places a
dyn could sit are refused by [Check.hidden_dyn]. *)
and reaches_dyn m seen (t : Types.t) =
match t with
| Types.Dyn -> true
| Types.Array (_, e) | Types.Map (_, e) -> reaches_dyn m seen e
| Types.Named nm when not (List.mem nm seen) ->
(match Hashtbl.find_opt m.structs nm with
| Some st ->
List.exists
(fun (fl : Tast.field) -> reaches_dyn m (nm :: seen) fl.Tast.fty)
st.Tast.fields
| None -> false)
| _ -> false
(* Whether the collector has anything to follow in a value of this type —
the question every rooting decision asks. [dyn_offsets <> []] was that
question until an [Fn] could hold an environment. *)
let traced m (t : Types.t) =
t = Types.Dyn
|| (let l = gc_layout m t in
l.gdyn <> [] || l.genv <> [] || l.gvec <> [] || l.gmap <> [])
(* The words to clear before an instance at a pushed root can be marked, as
x86-64 byte offsets of eight-byte words: each dyn word, each environment
word, each Vec header's pointer and length, and each Map header's block
pointer and capacity. The LLVM backend walks [gpath] instead; see
[zero_words]. *)
let gc_zero_offsets m (t : Types.t) : int list =
if t = Types.Dyn then [ 0 ]
else
let l = gc_layout m t in
List.map (fun w -> w.goff) l.gdyn
@ List.map (fun w -> w.goff) l.genv
@ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 8 ]) l.gvec
@ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 16 ]) l.gmap
(* A [gpath] as an LLVM constant expression over [base]: nested constant
[getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it
is the word's byte offset on whatever target the module is compiled for. *)
let path_const base path =
List.fold_left
(fun acc (ty, idx) ->
Printf.sprintf "getelementptr (%s, ptr %s, %s)" ty acc
(String.concat ", " idx))
base path
let offset_const (w : gcword) =
match w.gpath with
| [] -> "0"
| p -> Printf.sprintf "ptrtoint (ptr %s to i64)" (path_const "null" p)
(* 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 "str"
[ ("ptr", Types.Ptr (Types.Mut, (Types.Int Types.U8))); ("len", Types.Int Types.I64) ]
| Types.Slice (_, e) ->
composite (Types.to_string t)
[ ("ptr", Types.Ptr (Types.Mut, 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 -> internal "no debug type for struct %s" sn)
(* The record as an opaque pointer — its fields are the runtime's C and
lldb already has that type from flan_rt.c's own debug info — and the
incarnation beside it. *)
| Types.Alloc ->
composite "Allocator"
[ ("record", Types.Ptr (Types.Mut, Types.Unit));
("incarnation", Types.Int Types.U64) ]
(* 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 (Types.Mut, e)); ("len", Types.Int Types.I64);
("cap", Types.Int Types.I64); ("allocator", Types.Ptr (Types.Mut, Types.Unit));
("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.Mut, (Types.Int Types.U8)));
("len", Types.Int Types.I64); ("log2cap", Types.Int Types.I64);
("allocator", Types.Ptr (Types.Mut, Types.Unit)); ("epoch", Types.Int Types.I64) ]
|> fun n -> ignore k; ignore v; n
(* Two words, and shown as two, the same rule the Vec and the Map above
follow: a debugger told a function value were one pointer would put
every offset after it out by eight. [code] is the address that
resolves to a symbol, which is what [p f] was ever worth; [env] is
the captured copies, and there is nothing here that could say what is
in them — the environment is a struct the checker synthesised for one
literal, and DWARF for it would describe a type the program cannot
name. A reader who wants the copies asks the break loop for the
locals, where they are under the names the source gave them. *)
| Types.Fn _ ->
composite (Types.to_string t)
[ ("code", Types.Ptr (Types.Mut, Types.Unit)); ("env", Types.Ptr (Types.Mut, Types.Unit)) ]
(* And the bare one is what it always was: 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 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.CFn _ ->
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 _ | Types.Len _ | Types.LArray _ ->
internal "no debug type for %s" (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 [root_plan] 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;
(* The operands [root_plan] found held beside a sibling that may allocate,
by physical identity. [value] spills each of them into a root slot the
moment it is computed. See [held_operands]. *)
mutable pins : Tast.expr 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;
(* The source headings waiting for the instruction they are about, oldest
first, each with the serial [annot] handed out for it; and the last one
written, so that a macro's forty forms at one call site are headed once.
See [annot]. *)
mutable aq : (int * string) list;
mutable alast : string;
mutable adepth : int;
}
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. *)
(* An instruction is about to be written, so every heading queued is about it. *)
let ann_due f =
if f.aq <> [] then begin
List.iter (fun (_, l) -> Buffer.add_string f.b l) f.aq;
f.aq <- []
end
let ins f fmt =
Printf.ksprintf
(fun s ->
if f.live then begin
ann_due f;
Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")
end)
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 begin
ann_due f;
Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")
end;
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. *)
(* Whether lowering this expression into a destination is bound to reach the
end of it.
Asked first by the x86 backend. Nothing there holds a value in a register
across a statement, so an aggregate is built *in the destination*: field by field, element by
element, each one stored as it is computed. That is the cheapest thing that
works, and it works right up until the middle of the construction leaves.
A condition signalled while the third of four elements is being computed
transfers out of the assignment with two elements written and two not, and
what is left behind is a variable that is half its old value and half its
new one. The LLVM backend cannot have that shape — it builds the whole
aggregate as one value and stores it once — and where the two disagree,
the x86 one is the one that is wrong.
So an x86 assignment whose right-hand side might leave part-way builds into a
frame temporary and copies the finished value over in a single block move.
The copy is not free, which is what this question is for: it buys nothing
for [(set grid [1 2 3 4])], where nothing between the first store and the
last can go anywhere at all.
The answer is yes only for shapes spelled out below, none of which can
reach a call, a signal, a bounds or arithmetic check, or a return. Anything
else answers no and pays for the copy — a node added to the IR later
included, since being wrong this way costs a block copy and being wrong the
other way costs a corrupted variable.
[root_plan] asks the same question for a different reason: a sibling
operand that settles can neither allocate nor overwrite a place, so a dyn
value held beside it needs no root of its own. See [held_operands]. *)
let settled_prim (p : Tast.prim) =
match p with
(* Arithmetic that cannot fail. Division and remainder are absent on
purpose: both are checked, and a check signals. *)
| Tast.Add | Tast.Sub | Tast.Mul
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge | Tast.Not
| Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr
| Tast.BitNot | Tast.Popcount | Tast.Clz | Tast.Ctz | Tast.Rotl | Tast.Rotr
(* Questions about a value's shape, answered from the layout tables. *)
| Tast.Len | Tast.SizeOf _ | Tast.AlignOf _ | Tast.AddrOf -> true
(* Everything else reaches C, signals, or both: an index and a slice are
bounds-checked and [Rt] is a call by definition. [Cast] is not here
because it is only sometimes checked; see [cast_checks]. *)
| _ -> false
(* Which conversions can signal, and it is one of them. [cvttsd2si] answers a
fixed "integer indefinite" for a value out of range, which is a number
rather than an answer, so a float narrowed to an integer is tested against
the destination's range first and the failure signals ArithError — see
[cast], which is where the test is emitted. Every other conversion is a
move, a widen or one SSE instruction, and cannot go anywhere. That matters
here because an array of the language's own literals is usually written
[(u32 1)] and not [1], and refusing every cast would have made the most
ordinary aggregate literal there is pay for a copy. *)
let cast_checks (src : Types.t) (target : Types.t) =
let concrete (t : Types.t) =
match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
in
match concrete src, concrete target with
| Types.Float _, Types.Int _ -> true
| _ -> false
let rec settles (e : Tast.expr) =
match e.Tast.e with
(* Values with no code in them to leave from. *)
| Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit
| Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ | Tast.None_
| Tast.FnAddr _ -> true
(* Building an aggregate, and running a sequence: as settled as the parts. *)
| Tast.Make (_, es) | Tast.MakeCase (_, _, es) | Tast.Arr es | Tast.Do es ->
List.for_all settles es
| Tast.Some_ x | Tast.Field (x, _) | Tast.CaseField (x, _, _)
| Tast.Deref x -> settles x
| Tast.If (c, a, b) -> settles c && settles a && settles b
| Tast.Addr p -> settles_place p
| Tast.Prim (Tast.Cast target, [ a ]) ->
(not (cast_checks a.Tast.ty target)) && settles a
| Tast.Prim (p, es) -> settled_prim p && List.for_all settles es
(* A call, a signal, an invoke, an unwrap that returns early, a loop, a
[return], a [break] — and anything this list has not heard of. *)
| _ -> false
and settles_place (p : Tast.place) =
match p with
| Tast.Plocal _ | Tast.Pglobal _ -> true
| Tast.Pfield (x, _) | Tast.Pderef x -> settles x
(* An index is bounds-checked, and the check signals. *)
| Tast.Pindex _ -> false
(* 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 *)
rpins : Tast.expr list; (* see [held_operands] *)
}
(* The operands whose value is held while one of their siblings runs, and which
therefore need a root of their own from the moment they are computed.
A dyn read out of a place — a local, a global, a field — is rooted only by
the place, and only for as long as the place still holds it. In
[(pick (.d other) (do (set other ...) (churn)))] the first argument is
loaded, the second overwrites [other] and allocates, and between the two
the only copy of the first is a register or a temporary no root points at,
so a collection there frees it. Nothing about the place was wrong; what was
missing is a root for the value between being produced and being consumed.
The positions that hold a value while more code runs are the ordered
operand lists: a call's arguments, a runtime call's, a primitive's, a
struct or array literal's fields. An operand taken by address — the array
[at] and [slice] index, an array handed to the runtime — holds whatever its
address was taken of, which is a temporary when that is not a place. The
positions outside a list each have one operand and nothing beside it to
run: a [let] stores it into a rooted slot, a [set] into its place (both
backends compute the place first), a branch tests it, a [return] hands it
back.
An operand is pinned when its type holds a dyn word, when nothing already
roots it — a call's result and a dyn-producing runtime call's are spilled
into their own slot where they are made — and when some *other* operand in
the same list does not settle. A sibling that settles cannot allocate and
cannot write a place, so a value beside it is safe where it is. Any other
sibling, before or after, counts: which order the operands run in is then
not a question this plan has to agree with a backend about.
The node itself is the key, by physical identity, and the backends spill
its value after computing it — [value] in this file, [lower] in the other —
exactly as they spill a call's result. For an operand taken by address the
node pinned is the temporary under it, found by [addr_base]; a place under
it needs nothing, and neither backend evaluates one through either hook. *)
let held_operands m ?(fn_params = fun _ -> false) (e : Tast.expr) :
Tast.expr list =
let holds (x : Tast.expr) =
traced m x.Tast.ty
&& (match x.Tast.e with
| Tast.Call _ | Tast.CallPtr _ -> false
(* A parameter of function type cannot be assigned, so no sibling can
take the value away from under it; its caller holds it. *)
| Tast.Local s when fn_params s -> false
| Tast.Prim (Tast.Rt _, _) -> x.Tast.ty <> Types.Dyn
| Tast.Zero _ | Tast.Uninit _ | Tast.None_ | Tast.Unit -> false
| _ -> true)
in
(* An operand taken by address holds the value its address is taken of.
A place holds nothing new: its storage is rooted where it was declared.
A field or an element of something else is an address into that
something, and a value that is not a place is copied into a temporary —
which is the value held, and the node both backends evaluate. *)
let rec addr_base (x : Tast.expr) =
match x.Tast.e with
| Tast.Local _ | Tast.Global _ | Tast.Deref _ | Tast.CaseField _ -> None
| Tast.Field (t, _) -> addr_base t
| Tast.Prim (Tast.At, t :: _ :: _) -> addr_base t
| _ -> Some x
in
(* [ops] is the list with, for each operand, whether it crosses by address. *)
let pick ops =
List.filter_map
(fun ((x : Tast.expr), by_addr) ->
let held = if by_addr then addr_base x else Some x in
match held with
| Some h when holds h
&& List.exists
(fun ((s : Tast.expr), _) -> s != x && not (settles s))
ops -> Some h
| _ -> None)
ops
in
let by_value es = List.map (fun x -> (x, false)) es in
let is_array (x : Tast.expr) =
match x.Tast.ty with Types.Array _ -> true | _ -> false
in
(* A function value handed to a call is held by the caller for the whole of
the call, because the callee does not root a parameter of function type
(see [root_plan]). A read of a rooted local is held already; anything
else — a field, an element, a global the callee could overwrite, a fresh
closure — is pinned whatever its siblings are. *)
let fn_args es =
if not m.gcfn then []
else
List.filter
(fun (x : Tast.expr) ->
(match x.Tast.ty with Types.Fn _ -> true | _ -> false)
&& (match x.Tast.e with
| Tast.Local _ | Tast.Call _ | Tast.CallPtr _ | Tast.FnAddr _
| Tast.Thicken _ -> false
| Tast.Closure (_, env) ->
(match env.Tast.ty with Types.Ptr _ -> false | _ -> true)
| _ -> true))
es
in
let with_fn_args es picked =
picked @ List.filter (fun x -> not (List.memq x picked)) (fn_args es)
in
match e.Tast.e with
| Tast.Call (_, es) -> with_fn_args es (pick (by_value es))
| Tast.CallPtr (c, es) -> with_fn_args es (pick (by_value (c :: es)))
| Tast.Prim (Tast.Rt _, es) -> pick (List.map (fun x -> (x, is_array x)) es)
| Tast.Prim ((Tast.At | Tast.Slice), t :: rest) ->
pick ((t, true) :: by_value rest)
| Tast.Prim (_, es) | Tast.Make (_, es)
| Tast.MakeCase (_, _, es) | Tast.Arr es -> pick (by_value es)
| _ -> []
let root_plan m (fn : Tast.fn) : rootplan =
let rslots = ref [] in
let nparams = List.length fn.Tast.params in
Array.iteri
(fun i t ->
(* A parameter of function type is not rooted here: a parameter
cannot be assigned, so it holds what the caller passed for the whole
call, and the caller holds that — in a rooted slot, or pinned by
[held_operands]. This is what keeps a higher-order function such as
the prelude's [map] free of root pushes in a program that makes an
escaping closure somewhere else. *)
let fn_param =
i < nparams && (match t with Types.Fn _ -> true | _ -> false)
in
if traced m t && not fn_param then
rslots := (i, t) :: !rslots)
fn.Tast.slots;
let dyn = ref 0 and agg = ref [] in
let want (t : Types.t) = t <> Types.Dyn && traced m t in
(* The pinned operands first, as a set of nodes. The checker shares a node
between two positions now and then — the same [Local] read in two places
— and the backends spill by identity, so a node pinned in one position is
spilled in every position it is emitted from. The count below is
therefore taken per visit of a pinned node, which is per emission, and
not per position that asked for the pin. *)
let pins = ref [] in
let collect (e : Tast.expr) =
List.iter
(fun x -> if not (List.memq x !pins) then pins := x :: !pins)
(held_operands m ~fn_params:(fun s ->
s < List.length fn.Tast.params
&& (match fn.Tast.slots.(s) with Types.Fn _ -> true | _ -> false))
e)
in
List.iter (Tast.walk collect) fn.Tast.body;
List.iter (Tast.walk collect) fn.Tast.fdefers;
let count (e : Tast.expr) =
if !pins <> [] && List.memq e !pins then begin
if e.Tast.ty = Types.Dyn then incr dyn else agg := e.Tast.ty :: !agg
end;
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;
rpins = !pins }
(* 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.
[root_plan] 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 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.
One byte more than the length, a NUL, which nothing reads through the
length. The x86 backend has always written it; this one writes it too, so
that a declare-c wrapper handed a literal can give C the constant itself
rather than a copy (see [Shim.cstr_helpers]) on either backend. A string
is still a pointer and a length, and no slice of one is promised a NUL. *)
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\\00\"\n"
id (String.length s + 1) (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
(* A call site for a frame's [at], NUL-terminated because it is one pointer
stored per call and the reader takes its length. Counted on [m.nfi] for
[fi_bytes]' reason: the frame naming it is popped before the module could
go, and the break loop copies the text. *)
let fi_cstring 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\\00\"\n"
id (String.length s + 1) (escape s));
id
(* 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
(* How many slots a frame's record says it has: all of them when any is named,
and none otherwise, since only a function with a named slot gets a slot
table (see the shadow stack's push in [emit_fn]). Both backends write it and
[Dev] compares a frame against it, so a body whose slots are all the
compiler's own — a [print]'s temporaries — reads as the same body at both
ends. *)
let recorded_slots (fn : Tast.fn) =
if Array.exists (fun n -> n <> None) fn.Tast.snames then
Array.length fn.Tast.slots
else 0
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
(* A signal site's [%condesc], as a constant: the name and the sentence through
[string_bytes], because a handler may carry their addresses away (a
handler-case copies them out) and that is what keeps a module holding them
loaded; the chain and the site through [fi_bytes]'s counter, because
nothing reads them after the signal returns — the break loop copies the
site. *)
let condesc m (d : Tast.condesc) loc =
let nid, nlen = string_bytes m d.Tast.cname in
(* A compiled condition carries no sentence: the runtime asks [render]. *)
let mid, mlen = string_bytes m "" in
let lid, llen = fi_bytes m (Loc.to_string loc) in
let cid = Printf.sprintf "@\".cd.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant [%d x i32] [%s]\n" cid
(List.length d.Tast.cchain)
(String.concat ", "
(List.map (fun i -> Printf.sprintf "i32 %d" i) d.Tast.cchain)));
let id = Printf.sprintf "@\".cd.%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.condesc
[ nid; string_of_int nlen; mid; string_of_int mlen; cid;
string_of_int (List.length d.Tast.cchain); lid;
string_of_int llen;
(match d.Tast.crender with Some r -> fname r | None -> "null");
(if d.Tast.cself then "1" else "0") ]));
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, 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.** *)
(* A dev build's frame records where it is when it hands control to something
that can come back into Flan: a call, a signal, a C function, a runtime
check that signals. So a backtrace names the call each frame is in, and a
frame re-entered through a handler names the signal and not whatever it
called last. Stored before and cleared after, so a frame that has come back
names nothing rather than a call that has already returned. One store each
side; nothing in a release build. *)
let mark_call f at =
match f.frame with
| None -> ()
| Some _ ->
let id = fi_cstring f.md (Loc.to_string at) in
ins f "store ptr %s, ptr %%frame.a" id
let clear_call f =
match f.frame with
| None -> ()
| Some _ -> if f.live then ins f "store ptr null, ptr %%frame.a"
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;
mark_call f loc;
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
let arith_cast_nan = 5
let arith_cast_inf = 6
(* 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;
(* NaN and the infinities are named rather than reported as out of range:
they are not values that overshot the type, they have no integer at
all. Worked out on the cold path, so the guard is still two compares. *)
signal_block f loc ~guard ok (fun id nn ->
let nan = fresh f in
ins f "%s = fcmp uno double %s, %s" nan v v;
let pinf = fresh f in
ins f "%s = fcmp oeq double %s, %s" pinf v (dbl infinity);
let ninf = fresh f in
ins f "%s = fcmp oeq double %s, %s" ninf v (dbl neg_infinity);
let inf = fresh f in
ins f "%s = or i1 %s, %s" inf pinf ninf;
let c1 = fresh f in
ins f "%s = select i1 %s, i32 %d, i32 %d" c1 inf arith_cast_inf
arith_cast_range;
let code = fresh f in
ins f "%s = select i1 %s, i32 %d, i32 %s" code nan arith_cast_nan c1;
ins f
"call void @flan_arith_error(ptr %s, i64 %d, i32 %s, i64 %Ld, i64 %Ld, \
ptr %s)"
id nn code 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
(* [!=] is unordered and the rest are ordered, so a NaN is unequal to
everything, itself included, and neither less, greater nor equal: IEEE 754's
answers, and C's and Odin's. *)
let fcmp_op = function
| Tast.Eq -> "oeq" | Tast.Ne -> "une" | Tast.Lt -> "olt"
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
| _ -> assert false
(* ── Source headings ──
In an annotated module every Flan form is headed by a comment quoting it and
naming where it was written, placed above the first instruction it emits, so
the IR reads as the source it came from. Queued rather than written, because
a form that emits nothing must not leave its heading on the next form's
code; the first instruction written flushes the queue, and a form that
finished without one withdraws what it queued.
An atom — a literal, a local, a global — is not headed: it would steal the
heading of the form that uses it. A form the checker invented has line 0 and
no text to quote, and inherits its parent's heading. A form at the position
the last heading named is skipped, which keeps a macro's expansion from
repeating its call site once per form. [X86] heads its listing by the same
rules. *)
let atomic (e : Tast.expr) =
match e.Tast.e with
| Tast.Int _ | Tast.Bool _ | Tast.Float _ | Tast.Str _ | Tast.Unit
| Tast.Zero _ | Tast.None_ | Tast.Uninit _ | Tast.Local _ | Tast.Global _
| Tast.FnAddr _ -> true
| _ -> false
(* The heading's two halves: the form's text, with the macro it came out of if
it did, and its position. *)
(* Text made safe to put in a one-line comment of either language. A comment
ends at a newline, and a file name or a source line can hold one, or a
carriage return, or any other control character; each is written as an
escape instead. Tab is escaped too, because the headings use it as the one
separator that can appear in neither half. *)
let comment_text s =
let unsafe c = Char.code c < 0x20 || Char.code c = 0x7f in
if not (String.exists unsafe s) then s
else begin
let b = Buffer.create (String.length s + 8) in
String.iter
(fun c ->
match c with
| '\n' -> Buffer.add_string b "\\n"
| '\r' -> Buffer.add_string b "\\r"
| '\t' -> Buffer.add_string b "\\t"
| c when unsafe c -> Buffer.add_string b (Printf.sprintf "\\x%02x" (Char.code c))
| c -> Buffer.add_char b c)
s;
Buffer.contents b
end
(* The heading's two halves, each safe for a comment: the form's text, with the
macro it came out of if it did, and its position. The position names the
file as the location does rather than by its base name, because two
packages can each have a file of the same name. *)
let heading (loc : Loc.t) =
match Loc.snippet loc with
| None -> None
| Some src ->
let where = Printf.sprintf "%s:%d:%d" loc.Loc.file loc.Loc.line loc.Loc.col in
let src =
match loc.Loc.macro with
| Some m -> Printf.sprintf "%s [from the macro %s]" src m
| None -> src
in
Some (comment_text where, comment_text src)
(* A heading's position read back: the file, the line and the column. The file
is everything before the last two colons, so a name with a colon or a space
in it survives. *)
let split_where where =
match String.rindex_opt where ':' with
| None -> None
| Some j ->
(match String.rindex_from_opt where (j - 1) ':' with
| None -> None
| Some i ->
(match
int_of_string_opt (String.sub where (i + 1) (j - i - 1)),
int_of_string_opt (String.sub where (j + 1) (String.length where - j - 1))
with
| Some line, Some col -> Some (String.sub where 0 i, line, col)
| _ -> None))
let aserial = ref 0
let annot f (e : Tast.expr) =
if atomic e || e.Tast.loc.Loc.line = 0 then None
else
match heading e.Tast.loc with
| None -> None
| Some (where, src) ->
let key = where ^ " " ^ src in
if key = f.alast then None
else begin
let prev = f.alast in
f.alast <- key;
incr aserial;
let head =
Printf.sprintf " ; %s%s" (String.make (2 * min 12 f.adepth) ' ') src
in
(* A tab before the position, which is what [Dev.ll_headings] splits
on: neither half can hold one. *)
let pad = max 1 (64 - String.length head) in
f.aq <-
f.aq @ [ (!aserial, head ^ String.make pad ' ' ^ "\t" ^ where ^ "\n") ];
Some (!aserial, prev)
end
(* 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 =
(* Code after a terminator — past a [return], a [break] or a trap — is never
reached and is not emitted: a form in it that opens blocks of its own, a
bounds check say, would reopen the dead block and branch on operands
[ins] never wrote. Nothing reads the answer. *)
if not f.live then "poison" else
let v =
if not f.md.ann then value_located f e
else begin
let d = f.adepth in
let h = annot f e in
f.adepth <- d + 1;
let v = value_located f e in
f.adepth <- d;
(match h with
| Some (s, prev) ->
(* Withdrawn if the form wrote no instruction, a [Unit] in statement
position or a local read: a heading left standing would be read as
belonging to whatever came next. *)
if List.exists (fun (k, _) -> k = s) f.aq then begin
f.aq <- List.filter (fun (k, _) -> k < s) f.aq;
f.alast <- prev
end
| None -> ());
v
end
in
(* An operand held while a sibling may allocate: spilled into a root slot the
instant it exists, the same move a call's result gets in [call_through].
The value carries on being used as a register; the store is what the
collector reads. *)
if f.pins <> [] && List.memq e f.pins then begin
if e.Tast.ty = Types.Dyn then ins f "store i64 %s, ptr %s" v (dyn_tmp f)
else ins f "store %s %s, ptr %s" (ll e.Tast.ty) v (agg_tmp f e.Tast.ty)
end;
v
and value_located 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 when f.md.pool ->
(* See [pool]: the bytes are still this module's, but only the copy
leaves it, so they are [fi_bytes]' kind of constant and not
[string_bytes']. The copy carries the NUL. *)
let id, n = fi_bytes f.md s in
let p = fresh f in
ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n;
let v = fresh f in
ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p;
v
| 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
(* A [(Fn ...)] value, which is two words: a code address and the
environment it is called with. A value made out of a name captures
nothing, so the second word is null and [zeroinitializer] has already put
it there. See [%fnv].
Only a [Fn]-typed one. The same three [fnref] constructors are also asked
for as bare addresses — carrying [CFn], and carrying [(Ptr ())] for the
map's hash and equality pair and a handler frame's clause, which are
fields of structs the runtime declares — and those stay one word. The
node's type is what says which is being asked for. *)
| (Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _)
when (match e.Tast.ty with Types.Fn _ -> true | _ -> false) ->
let code, env =
match e.Tast.e with
| Tast.FnAddr r -> fnaddr f ~loc:e.Tast.loc r, "null"
(* The copies, made here as a struct value and stored into an
environment the collector allocates. Built before the allocation:
every field is a read of a slot, and those slots are still rooted
while the allocation collects. The fresh object is in the
runtime's allocation ring until this value reaches a root. *)
(* A closure that does not outlive this frame: its copies are in a
slot of it, and the value carries that slot's address. *)
| Tast.Closure (r, env)
when (match env.Tast.ty with Types.Ptr _ -> true | _ -> false) ->
fnaddr f ~loc:e.Tast.loc r, value f env
| Tast.Closure (r, copies) ->
(* The environment will point at this module's descriptor, and the
value at this module's code, for as long as the collector keeps it.
Counted with the string literals so an expression thunk that makes
one keeps its mapping rather than being unloaded under it. *)
f.md.nstr <- f.md.nstr + 1;
let v = value f copies in
let ety = copies.Tast.ty in
let desc =
match desc_of f.md ety with
| Some s -> Printf.sprintf "@\"%s\"" s
| None -> "null"
in
let p = fresh f in
ins f
"%s = call ptr @flan_dyn_env_new(i64 ptrtoint (ptr getelementptr (%s, \
ptr null, i32 1) to i64), ptr %s)"
p (ll ety) desc;
ins f "store %s %s, ptr %s" (ll ety) v p;
fnaddr f ~loc:e.Tast.loc r, p
(* The widening: the thunk's code, with the bare address stored where
an environment would be. The thunk reads it back out and calls it,
which is what keeps every indirect call exactly typed. *)
| Tast.Thicken (n, p) -> fname n, value f p
| _ -> assert false
in
let a = fresh f in
ins f "%s = insertvalue %%fnv zeroinitializer, ptr %s, 0" a code;
if String.equal env "null" then a
else begin
let b = fresh f in
ins f "%s = insertvalue %%fnv %s, ptr %s, 1" b a env;
b
end
| Tast.FnAddr r -> fnaddr f ~loc:e.Tast.loc r
| Tast.Closure _ | Tast.Thicken _ ->
(* Unreachable: both are [Fn] values and the arm above has already taken
every [Fn]-typed node. Here because nothing else could be meant. *)
failwith "a closure is a function value"
| 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 ->
(* A C function may call back into Flan. *)
let r = extern_call ~at:e.Tast.loc f e.Tast.ty ("@" ^ sym) args in
clear_call f;
r
| None -> call f ~loc:e.Tast.loc e.Tast.ty name args)
| Tast.CallPtr (callee, args) -> call_ptr ~at:e.Tast.loc 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
(* A (watch ...) outside a dev build: its else branch, which is unit. See
[Tast.is_watch_guard]. *)
| Tast.If (c, _, e') when (not f.md.dev) && Tast.is_watch_guard c -> value f e'
| 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, d, c) ->
let p = addr_rooted f c in
let dp = condesc f.md d e.Tast.loc in
mark_call f e.Tast.loc;
ins f "call void @flan_signal(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
guard f;
clear_call 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, d, c) ->
let p = addr_rooted f c in
let dp = condesc f.md d e.Tast.loc in
mark_call f e.Tast.loc;
ins f "call void @flan_error(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
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
|| not (traced 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 -> internal "field of %s" (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
(* A string is the same two words as a slice of u8 and indexes the
same way, bounds check included. *)
| Types.Slice _ | Types.String ->
let elem =
match ty with Types.Slice (_, e) -> e | _ -> Types.Int Types.U8 in
(* 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 -> internal "index into %s" (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 -> internal "field of %s" (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 -> internal "deref of %s" (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 -> internal "no case %s of %s" case 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 -> internal "case field of %s" (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 ?loc flan =
if not f.md.dev then fname flan
else begin
let cell =
if f.md.known flan then cellname flan
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);
c
end
in
let p = fresh f in
ins f "%s = load ptr, ptr %s" p cell;
(match loc, Hashtbl.find_opt f.md.fsigs flan with
| Some loc, Some (ps, r) -> stale_check f loc flan cell ps r
| _ -> ());
p
end
(* The signature word, at a call site through a cell: the one the cell holds
against the one this site was compiled with. Equal is the whole of the fast
path — a load, a compare, a branch not taken.
Different means the body in the cell was installed with other parameters
or another return since this site was compiled, and calling it would pass
arguments it does not take. So the call is not made. [flan_stale_call]
signals [StaleCall] naming the site and both signatures, and returns only
when something transferred — the same shape as a bounds failure, and a
guard after it for the same reason.
Its strings go through [fi_bytes] and not [string_bytes]: [m.nstr] is the
test that keeps an expression thunk's module mapped, and a thunk that
calls a function would otherwise never be unloaded. Nothing holds these
once the call returns — the runtime copies what it keeps. *)
and stale_check f loc flan cell ps r =
let wp = fresh f in
ins f "%s = getelementptr inbounds i8, ptr %s, i64 8" wp cell;
let w = fresh f in
ins f "%s = load i64, ptr %s" w wp;
let ok = fresh f in
ins f "%s = icmp eq i64 %s, %Ld" ok w (sig_word ps r);
let good = fresh_label f "sig" and bad = fresh_label f "stale" in
term f "br i1 %s, label %%%s, label %%%s" ok good bad;
label f bad;
let cstr s = fst (fi_bytes f.md (s ^ "\000")) in
ins f "call void @flan_stale_call(ptr %s, ptr %s, ptr %s, ptr %s, ptr %s)"
(cstr (Loc.to_string loc)) (cstr flan) (cstr (sig_text ps r)) cell
xfer_param;
guard f;
term f "unreachable";
label f good
and call f ?loc 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
Option.iter (mark_call f) loc;
(* The cell is loaded *after* the arguments, so a redefinition that lands
between two calls still cannot land in the middle of one. The signature
word is read beside it, for the same reason: an argument that polls can
install a new body, and the word checked has to be the body's own. *)
let callee = body_of f ?loc flan in
let r = call_through f ret callee vs in
if loc <> None then clear_call f;
r
(* 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 ?at f ret callee args =
let c = value f callee in
(* A [(Fn ...)] is two words and both are taken before the arguments are
evaluated: an argument may itself make a function value, and the two
halves of *this* one have to come out of the same value. A
[(CFn ...)] is the address alone, and the call that follows is the
call a name would have produced. *)
let code, env =
match callee.Tast.ty with
| Types.Fn _ ->
let code = fresh f in
ins f "%s = extractvalue %%fnv %s, 0" code c;
let env = fresh f in
ins f "%s = extractvalue %%fnv %s, 1" env c;
code, Some ("ptr " ^ env)
| _ -> c, None
in
(match callee.Tast.ty, at with
| Types.CFn _, Some loc -> null_check f loc callee.Tast.ty code
| _ -> ());
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
Option.iter (mark_call f) at;
let r = call_through f ?env ret code vs in
if at <> None then clear_call f;
r
(* A (CFn ...) may be a zeroed field, array element or global, and a zeroed
one is a null address. Tested before the arguments are evaluated, so a
call that is not going to be made runs none of them — the x86 backend
tests at the same point. [flan_null_call] signals [NullCall] and returns
only when something transferred, the shape of a bounds failure. *)
and null_check f loc ty code =
let ok = fresh f in
ins f "%s = icmp ne ptr %s, null" ok code;
signal_block f loc ~guard:(fun () -> guard f) ok (fun id n ->
let tys = fst (fi_bytes f.md (Types.to_string ty ^ "\000")) in
ins f "call void @flan_null_call(ptr %s, i64 %d, ptr %s, ptr %s)"
id n tys xfer_param)
(* The code address behind one of the three [fnref]s, which is the same string
whether it is wanted as a bare [(Ptr ())] or as the first word of a
function value.
[Flanfn] and [Rtfn] are the symbol itself, not a load from it: a function's
address is a link-time constant. [Fnval] is the one that is not — 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. *)
and fnaddr f ?loc (r : Tast.fnref) =
match r with
| Tast.Flanfn n -> fname n
| Tast.Rtfn n -> "@" ^ n
(* Checked where the address is taken, not where the value is called: the
value's type is this site's idea of the signature, and a body installed
with another one must not become a value of it. A value taken *before*
the change holds the old body and goes on computing the old thing, which
is consistent and is left alone. *)
| Tast.Fnval n -> body_of f ?loc n
(* [env] is present on exactly one kind of call: one through a [(Fn ...)]
value, which cannot know whether the body it reaches declared one. Every
other call — by name, through a [(CFn ...)] — passes what it always
passed. See [env_param] for why appending it is safe when the callee did
not ask for it. *)
and call_through f ?env ret callee vs =
let t = fresh f in
let tail =
match env with
| None -> [ "ptr " ^ xfer_param ]
| Some e -> [ "ptr " ^ xfer_param; e ]
in
ins f "%s = call %s %s(%s)" t (ll ret) callee (String.concat ", " (vs @ tail));
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 traced 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 ?at 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
Option.iter (mark_call f) at;
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. *)
ins f "store ptr %s, ptr %s" (fname h.Tast.hfn) fp;
(* And the environment the clause is called with, which is a pointer
into this very frame. Written unconditionally — null when the
clause captured nothing — because a frame the runtime reads a
field of must have every field written, not only the ones this
clause happens to use. *)
let ep = fresh f in
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 3"
ep slot;
ins f "store ptr %s, ptr %s"
(match h.Tast.henv with Some e -> value f e | None -> "null") ep;
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 lid, llen = string_bytes f.md (Loc.to_string c.Tast.rloc) in
ins f "store ptr %s, ptr %s" lid (restart_field f slot "loc");
ins f "store i64 %d, ptr %s" llen (restart_field f slot "loclen");
let rid, rlen = string_bytes f.md c.Tast.rreport in
ins f "store ptr %s, ptr %s" rid (restart_field f slot "report");
ins f "store i64 %d, ptr %s" rlen (restart_field f slot "reportlen");
ins f "store i32 %d, ptr %s" (if c.Tast.rhidden then 1 else 0)
(restart_field f slot "flags");
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 -> internal "match on %s" (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 -> internal "match on %s" (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 -> internal "no case %s of %s" c 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 -> internal "no case %s of %s" case 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, _ -> internal "arithmetic on %s" (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] 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 bool is an i1 here, and only [=]/[!=] reach it: [<] on a bool is
refused in check.ml. *)
| Types.Bool ->
ins f "%s = icmp %s i1 %s, %s" t (icmp_op false p) 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 [internal] 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"
| _ -> internal "comparison on %s" (Types.to_string x.Tast.ty)
in
ins f "%s = icmp %s i8 %s, 0" t cc r
| t' -> internal "comparison on %s" (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, _ -> internal "bitwise on %s" (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.BitNot, [ x ] ->
let a = value f x in
let t = fresh f in
ins f "%s = xor %s %s, -1" t (ll x.Tast.ty) a;
t
(* [i1 false] says a zero operand is defined — the width — rather than
poison, which is the language's answer for 0. *)
| (Tast.Popcount | Tast.Clz | Tast.Ctz), [ x ] ->
let a = value f x in
let ty = ll x.Tast.ty in
let t = fresh f in
(match p with
| Tast.Popcount -> ins f "%s = call %s @llvm.ctpop.%s(%s %s)" t ty ty ty a
| Tast.Clz ->
ins f "%s = call %s @llvm.ctlz.%s(%s %s, i1 false)" t ty ty ty a
| _ -> ins f "%s = call %s @llvm.cttz.%s(%s %s, i1 false)" t ty ty ty a);
t
(* A funnel shift of a value with itself is a rotation, and the funnel
shifts take their count modulo the width, which is the rotation's rule. *)
| (Tast.Rotl | Tast.Rotr), [ x; y ] ->
let a = value f x in
let b = value f y in
let ty = ll x.Tast.ty in
let t = fresh f in
ins f "%s = call %s @llvm.%s.%s(%s %s, %s %s, %s %s)" t ty
(if p = Tast.Rotl then "fshl" else "fshr") ty ty a ty a ty b;
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 -> internal "slice of %s" (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 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.SliceFrom, [ p; n ] ->
let pv = value f p in
(* check.ml has already widened n to i64, by its own signedness. *)
let n64 = value f n in
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 "str" 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.Mut, Types.String)) in
ins f "call void @flan_argv(ptr %s)" tmp;
load f tmp (Types.Slice (Types.Mut, 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 crosses by address, as a Vec or a Map does: a
runtime entry point that takes one reads it in place. (A dyn
view is handed an explicit [addr_of] by check.ml's [box].) *)
| 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. [root_plan] 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
| _ -> internal "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.Mut, (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.Mut, (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.Mut, (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.Mut, (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"
(* ((Ptr U) p), and the locals thunk, which is handed a slot's address
as a raw pointer and has to read it as the type the slot holds.
Under opaque pointers there is no instruction to emit, 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"
| _ -> internal "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
(* And the environment, last, and only on a body that can be reached
through an [Fn] value: see [env_param]. Everything else emits the
signature it always did. *)
let params =
match fn.Tast.fenv with
| None -> params
| Some _ -> params @ [ (if named then "ptr " ^ env_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 = []; pins = [];
dsub;
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
dloc = "";
aq = []; alast = ""; adepth = 0;
} 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;
(* And the environment, on the one kind of function that has one. Every
other function is handed it too and never reads it; there is no slot for
it there and nothing to store. *)
(match fn.Tast.fenv with
| Some slot ->
Buffer.add_string f.allocas
(Printf.sprintf " store ptr %s, ptr %s\n" env_param f.slots.(slot))
| None -> ());
(* 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 — [root_plan] is empty 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 words the collector reads at [base], which is the whole of
the contract runtime/flan_dyn.h states for a pushed root: each dyn
word, each environment word, and each Vec header's pointer and length.
Reached through the word's [gpath], so the store lands where the
target lays the word out and not where x86-64 would. *)
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 begin
let at path =
List.fold_left
(fun acc (sty, idx) ->
let p = Printf.sprintf "%%z%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas
(Printf.sprintf " %s = getelementptr inbounds %s, ptr %s, %s\n"
p sty acc (String.concat ", " idx));
p)
base path
in
let store what path =
Buffer.add_string f.allocas
(Printf.sprintf " store %s, ptr %s\n" what (at path))
in
let l = gc_layout m ty in
List.iter (fun w -> store "i64 0" w.gpath) l.gdyn;
List.iter (fun w -> store "ptr null" w.gpath) l.genv;
List.iter
(fun ((w : gcword), _) ->
store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]);
store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ]))
l.gvec;
List.iter
(fun ((w : gcword), _) ->
store "ptr null" (w.gpath @ [ ("%map", [ "i32 0"; "i32 0" ]) ]);
store "i64 0" (w.gpath @ [ ("%map", [ "i32 0"; "i32 2" ]) ]))
l.gmap
end
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.pins <- plan.rpins;
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");
Printf.sprintf
"%%frame.a = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "at");
"store ptr null, ptr %frame.a";
(* Zeroed at every push: a dyn view of a local claims a number here
(runtime/flan_dev.c, [flan_dev_frame_claim]), and the next call
to land at this address must not inherit it. *)
Printf.sprintf
"%%frame.n = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "serial");
"store i64 0, ptr %frame.n";
(* The frame address: every local lies below it, so the dev runtime
can tell which frame a stack address belongs to
([flan_dev_frame_owner]). Asking for it keeps this function's
frame pointer, which only a dev build pays. *)
"%frame.fpv = call ptr @llvm.frameaddress.p0(i32 0)";
Printf.sprintf
"%%frame.f = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "fp");
"store ptr %frame.fpv, ptr %frame.f";
"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 [defonce] 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 [defonce] 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. *)
| _ ->
internal "no constant image for %s at %s"
(Types.to_string e.Tast.ty) (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
[defonce] 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 —
def, defonce and defconst decide what a re-run does. A [defonce] is Common
Lisp's [defvar] under Clojure's name: 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 [defonce] 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 [def] is Common Lisp's
[defparameter]: its initialiser runs on every re-run — no flag — so an
edited initialiser repaints the same storage on the next re-run, which is
the reason the form exists. 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 [defonce]. One refusal in the checker is
what ended it.
So each [defonce]'s computed initialiser guards itself with a flag of its
own, and a [def]'s takes none. Per global and not per startup function,
because the rule belongs to the form: a [def] beside a [defonce] 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 [defonce] 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 [(defonce .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) =
(* Which globals the startup function stores at all: every initialiser
that is not a constant the image already holds. A [def]'s is *never*
such a constant — [Check.check_global] lifts every one of them,
zero and literal included, into a [global/<n>] call — so every [def]
except an [uninit] one is in here, which is what makes its store run
on each re-run and its initialiser reachable through the function
cell a re-evaluation swaps. *)
let computed =
List.filter
(fun (g : Tast.global) -> not (Tast.const_init g.Tast.ginit))
globals
in
(* One guard flag per [defonce] with something to run, and none for a
[def]: the flag is exactly what makes an initialiser run once, and a
[def]'s runs every time — that unguarded store is the whole difference
between the two forms. *)
let flag_for (g : Tast.global) =
if m.dev && not g.Tast.grerun then
Some
{ 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; grerun = false }
else None
in
let flagged = List.map (fun g -> (g, flag_for g)) computed in
let flags = List.filter_map snd flagged 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.map
(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 })
flagged
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 = []; fenv = None; fparent = None;
floc = (List.hd computed).Tast.ginit.Tast.loc };
true
(* ── What a name the process has never had starts with ─────────────────
A global a redefinition module introduces is allocated by
[flan_dev_global], which copies an image on the allocation and ignores it
for ever after. That image is the only chance the value gets: the host's
[.init-globals] was fixed when the process was built, so nothing in it
calls the new global's initialiser, now or at any re-run.
For most globals the image is the initialiser itself, when the linker
could have written it. A *computed* one has none and the allocation keeps
calloc's zeroes — the reload rule, not a gap in it: an initialiser runs at
startup, once, a reload does not run initialisers, and "edit the code,
keep the sand" is the whole demo.
A [def] needs the second arm, and it is the whole reason this is a
function rather than a call to [Tast.const_init]. Every def's initialiser
is lifted into [global/<n>] so that a re-evaluation can swap it through
the function cell, which means a def's own [ginit] is a [Call] and never a
constant — and a brand-new [(def n i64 42)] typed into a live session
would come up zero and stay zero for the life of the process, where the
[defonce] beside it correctly comes up 42. So the constant is read back
out of the lifted body, which is where it went.
Both backends ask this, because a rule only one of them follows is not a
rule. *)
let initial_image (p : Tast.program) (g : Tast.global) : Tast.expr option =
if Tast.const_init g.Tast.ginit then Some g.Tast.ginit
else
(* Only a lifted body that is exactly one expression, which is what a
constant initialiser lifts to. Anything else — a [let], a defer
counter ahead of the value — is computed by definition and has no
image, so the conservative shape is also the correct one. *)
match
List.find_opt
(fun (f : Tast.fn) -> String.equal f.Tast.name ("global/" ^ g.Tast.gname))
p.Tast.fns
with
| Some { Tast.body = [ v ]; _ } when Tast.const_init v -> Some v
| _ -> None
(* ── 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 }
; A function value: the code address, and the environment the captured copies
; live in. Two words rather than one because the environment has to travel
; *with* the value — a callee that takes a (Fn [T] R) and calls it knows
; nothing about where the value came from, so there is nowhere else to put it.
; A value that captures nothing carries a null there and every call passes it
; on regardless; see [env_param].
%fnv = type { ptr, ptr }
; An Allocator value: the runtime's record, and the incarnation of it the value
; was made for, so a value kept past its arena's destroy is caught on use.
%alloc = 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 — an open-addressed Swiss table. 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, the
; lifted function that runs, and the environment that function is handed.
; Allocated on the establishing frame's stack.
|} ^ Rt.ll_type Rt.handler ^ {|
; What a signal site says about its condition: its name, the sentence a
; handler for a parent reads, the type ids from its own to its root, and the
; site. A constant per site; see [condesc].
|} ^ Rt.ll_type Rt.condesc ^ {|
; 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. Then, for a break loop only, where the clause is written, its
; :report sentence, and flags (bit 0: a handler-case's own landing). The C
; [flan_restart] declares every one of these, in this order.
|} ^ 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 i8 @llvm.ctpop.i8(i8)
declare i8 @llvm.ctlz.i8(i8, i1 immarg)
declare i8 @llvm.cttz.i8(i8, i1 immarg)
declare i8 @llvm.fshl.i8(i8, i8, i8)
declare i8 @llvm.fshr.i8(i8, i8, i8)
declare i16 @llvm.ctpop.i16(i16)
declare i16 @llvm.ctlz.i16(i16, i1 immarg)
declare i16 @llvm.cttz.i16(i16, i1 immarg)
declare i16 @llvm.fshl.i16(i16, i16, i16)
declare i16 @llvm.fshr.i16(i16, i16, i16)
declare i32 @llvm.ctpop.i32(i32)
declare i32 @llvm.ctlz.i32(i32, i1 immarg)
declare i32 @llvm.cttz.i32(i32, i1 immarg)
declare i32 @llvm.fshl.i32(i32, i32, i32)
declare i32 @llvm.fshr.i32(i32, i32, i32)
declare i64 @llvm.ctpop.i64(i64)
declare i64 @llvm.ctlz.i64(i64, i1 immarg)
declare i64 @llvm.cttz.i64(i64, i1 immarg)
declare i64 @llvm.fshl.i64(i64, i64, i64)
declare i64 @llvm.fshr.i64(i64, i64, i64)
declare ptr @llvm.frameaddress.p0(i32 immarg)
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_c_literal(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(ptr, ptr, ptr)
declare void @flan_error(ptr, ptr, ptr)
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
; A dev call site whose callee was installed with another signature since it
; was compiled: the site, the callee's name and the signature the site expects
; as C strings, then the cell and the channel. Signals StaleCall; returns when
; something answered.
declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold
; A call through a (CFn ...) holding null: the site, the value's type as a C
; string and the channel. Signals NullCall; returns when something answered.
declare void @flan_null_call(ptr, i64, ptr, ptr) cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_use(ptr, i64)
declare void @flan_context_value(ptr)
declare void @flan_free_temp()
declare void @flan_slice_free(ptr, i64, i64, i64, ptr, ptr, i64)
declare i8 @flan_i64_temp(i64, ptr)
declare i8 @flan_f64_temp(double, ptr)
declare void @flan_alloc_seal(ptr, ptr)
declare ptr @flan_alloc_use(ptr, ptr, i64)
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, ptr, i64)
declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64)
declare void @flan_dyn_slot_init(i64, i64, i64, ptr, i64)
declare void @flan_dyn_ctor_site(ptr, i64)
declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64)
declare i64 @flan_dyn_class_of(i64)
declare i64 @flan_dyn_type_of(i64)
declare void @flan_dyn_class_def(i64, ptr, i64)
declare void @flan_dyn_class_hook(ptr)
declare i64 @flan_dyn_kw(ptr, i64)
declare i64 @flan_dyn_map_get(i64, i64)
declare i64 @flan_dyn_get(i64, i64, ptr, i64)
declare i64 @flan_dyn_get_at(i64, i64, ptr, i64)
declare void @flan_dyn_map_set(i64, i64, i64)
declare i64 @flan_dyn_map_contains(i64, i64)
declare i64 @flan_dyn_map_contains_at(i64, i64, ptr, i64)
; The ones that trap carry the site as ptr+len, the way the bounds and
; arithmetic traps 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_neg(i64, ptr, i64)
declare i64 @flan_dyn_bitand(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitor(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitxor(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitnot(i64, ptr, i64)
declare i64 @flan_dyn_shl(i64, i64, ptr, i64)
declare i64 @flan_dyn_shr(i64, i64, ptr, i64)
declare i64 @flan_dyn_rotl(i64, i64, ptr, i64)
declare i64 @flan_dyn_rotr(i64, i64, ptr, i64)
declare i64 @flan_dyn_popcount(i64, ptr, i64)
declare i64 @flan_dyn_clz(i64, ptr, i64)
declare i64 @flan_dyn_ctz(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_eq_at(i64, i64, ptr, i64)
declare i64 @flan_dyn_len_at(i64, ptr, i64)
declare i64 @flan_dyn_at(i64, i64, ptr, i64)
declare i64 @flan_dyn_slice(i64, i64, i64, ptr, i64)
declare void @flan_dyn_set_at(i64, i64, i64, ptr, i64)
declare void @flan_dyn_push(i64, i64, ptr, i64)
declare void @flan_dyn_print(i64)
declare void @flan_dyn_print_at(i64, ptr, i64)
declare void @flan_dyn_emit_dev(i64)
declare void @flan_dyn_emit_watch(i64)
; The watch table, which (watch "name" v) renders into. flan_dev.c is linked
; into every build, so these resolve in a release build too.
declare i32 @flan_dev_watch_begin_n(ptr, i64)
declare void @flan_dev_watch_emit(ptr, i64)
declare void @flan_msg_emit(ptr, i64)
declare void @flan_dyn_emit_msg(i64)
declare void @flan_dev_watch_emit_str(ptr, i64)
declare void @flan_dev_watch_emit_i64(i64)
declare void @flan_dev_watch_emit_u64(i64)
declare void @flan_dev_watch_emit_f64(double)
declare void @flan_dev_watch_end()
; An expression thunk's string literals, copied to storage the process keeps.
declare ptr @flan_dev_literal(ptr, 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_slice(ptr, i64, ptr, i64, i32)
declare i64 @flan_dyn_view_at(ptr, i64, ptr, i64, i32, i32)
declare void @flan_dyn_root_push(ptr)
declare void @flan_dyn_root_push_desc(ptr, ptr)
declare ptr @flan_dyn_env_new(i64, ptr)
declare void @flan_dyn_track_vecs()
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_slice(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64)
declare void @flan_dev_reg_note_res_acquire(i64, ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_release(i64, ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_rekey_from(i64)
declare void @flan_dev_reg_note_res_rekey_to(i64, ptr, i64)
declare void @flan_dev_reg_note_res_site(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_done(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, i64, 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. *)
(* Whether any closure in the program has its environment allocated by the
collector. *)
let makes_closures (p : Tast.program) =
let found = ref false in
let see (e : Tast.expr) =
match e.Tast.e with
| Tast.Closure (_, env)
when (match env.Tast.ty with Types.Ptr _ -> false | _ -> true) ->
found := true
| _ -> ()
in
List.iter
(fun (fn : Tast.fn) ->
List.iter (Tast.walk see) fn.Tast.body;
List.iter (Tast.walk see) fn.Tast.fdefers)
p.Tast.fns;
List.iter (fun (g : Tast.global) -> Tast.walk see g.Tast.ginit) p.Tast.globals;
!found
(* A program that makes a capturing [fn] allocates its environments from the
collector, so it has a heap to set up even if no dyn is ever written. *)
let uses_dyn (p : Tast.program) =
makes_closures p ||
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) | Types.Map (_, 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";
(* Before anything can allocate a Vec or Map block: a program that can make
a collector-owned closure environment, or that holds a dyn, has
flan_rt.c report every such block to the collector, which reads a
container's elements only through a block it knows to be live
(runtime/flan_dyn.c, "The Vec blocks a marker may read"). *)
if m.gcfn || gc then
Buffer.add_string b " call void @flan_dyn_track_vecs()\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
(* [main] is called the way [body_of] calls every other Flan function: a
release build names the symbol, a dev build loads the indirection cell.
Without the cell this one call site kept the body [main] had at the
initial build, so a redefined [main] took effect at every call in the
program except the entry point's — and the dev daemon's re-run, which
re-enters this function as [flan_program_main], re-ran the old body.
[main] is one of [p.Tast.fns], so a dev build defines its cell above
initialised to the body compiled here; the first run therefore calls
exactly what it called before this existed. The load is after the
arguments, for the reason [call] gives at its own. *)
let callee =
if not m.dev then fname "main"
else begin
Buffer.add_string b
(Printf.sprintf " %%mainfn = load ptr, ptr %s\n" (cellname "main"));
"%mainfn"
end
in
Buffer.add_string b
(Printf.sprintf " %%r = call %s %s(%s)\n" (ll fn.Tast.ret) callee
(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 fsigs_of (p : Tast.program) =
let t = Hashtbl.create 64 in
List.iter
(fun (f : Tast.fn) -> Hashtbl.replace t f.Tast.name (f.Tast.params, f.Tast.ret))
p.Tast.fns;
t
let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
?(annotate = 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; gcfn = dev || makes_closures p;
known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate;
descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None);
fsigs = fsigs_of p;
} 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 descriptors, as runtime/flan_dyn.h's [flan_desc] laid out by
hand: the size, then a count and a table for each of the three kinds of
word. An empty table is a null pointer rather than a zero-length array.
[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.
Every offset is a constant expression over the word's [gpath] rather than
a number, so the offset is the one the target lays the type out with — on
wasm32 a pointer is four bytes, and [goff]'s x86-64 number would name the
wrong word. [size] stays [lay]'s number: it is only read as a Vec's
element stride, and a Vec's elements are placed at that stride by the
[SizeOf] every push is handed. *)
let descriptors m =
let b = Buffer.create 256 in
let table sym suffix ty rows =
if rows = [] then "null"
else begin
Buffer.add_string b
(Printf.sprintf "@\"%s.%s\" = private unnamed_addr constant [%d x %s] [%s]\n"
sym suffix (List.length rows) ty (String.concat ", " rows));
Printf.sprintf "@\"%s.%s\"" sym suffix
end
in
let word (w : gcword) = "i64 " ^ offset_const w in
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c)
|> List.iter
(fun (_, d) ->
let l = d.dlay in
let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) in
let envs = table d.dsym "envs" "i64" (List.map word l.genv) in
let pairs suffix words syms =
table d.dsym suffix "{ i64, ptr }"
(List.map2
(fun ((w : gcword), _) e ->
Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }"
(offset_const w) e)
words syms)
in
let vecs = pairs "vecs" l.gvec d.dvecs in
let maps = pairs "maps" l.gmap d.dmaps in
Buffer.add_string b
(Printf.sprintf
"@\"%s\" = private unnamed_addr constant \
{ i64, i64, ptr, i64, ptr, i64, ptr, i64, ptr } \
{ i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s, \
i64 %d, ptr %s }\n"
d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv)
envs (List.length l.gvec) vecs (List.length l.gmap) maps));
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. The offsets are [goff]'s numbers, which
are this backend's own layout. *)
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 descriptors — runtime/flan_dyn.h's flan_desc: the size\n\
# of one instance, then the dyn words, the environment words of its\n\
# function values, and the Vec headers whose elements hold either, each\n\
# as a count and a table. Read by the collector through\n\
# flan_dyn_root_push_desc and flan_dyn_env_new and by nothing else.\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 (_, d) ->
let l = d.dlay in
let table suffix lines =
if lines = [] then "0"
else begin
Buffer.add_string b
(Printf.sprintf "\t.align\t8\n.L%s.%s:\n" d.dsym suffix);
List.iter (fun s -> Buffer.add_string b ("\t.quad\t" ^ s ^ "\n")) lines;
Printf.sprintf ".L%s.%s" d.dsym suffix
end
in
let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) in
let envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in
let pairs suffix words syms =
table suffix
(List.concat
(List.map2
(fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ])
words syms))
in
let vecs = pairs "vecs" l.gvec d.dvecs in
let maps = pairs "maps" l.gmap d.dmaps in
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%s\n\
\t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\
\t.quad\t%d\n\t.quad\t%s\n"
d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) envs
(List.length l.gvec) vecs (List.length l.gmap) maps))
rows;
Buffer.contents b
(* The descriptors go after the body, because their offsets are constant
expressions over the module's named types and LLVM wants a type defined
before a [getelementptr] can size it. A global may be named before it is
defined, so the functions that push them are unaffected. *)
let finish m =
header ^ Buffer.contents m.strs ^ Buffer.contents m.out ^ "\n" ^ descriptors m
^ (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) ?(annotate = false)
(p : Tast.program) : string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
(* [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
internal
"Emit.program was given ~hidden and ~dev together, and a dev build has \
to export its cells";
let m =
new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize ~annotate 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 %s { ptr %s, i64 %Ld, ptr %s }\n"
(cellname fn.Tast.name) cell_ty (fname fn.Tast.name)
(sig_word fn.Tast.params fn.Tast.ret)
(cstring m (sig_text fn.Tast.params fn.Tast.ret))))
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 [defonce] 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. *)
(* Both of them behind one constructor defined here, rather than named
directly in the table, and that shape is load-bearing rather than
tidiness. [llvm.global_ctors] naming a *declaration* — which both of
these are, they are C in the runtime — crashes clang 20's
AddressSanitizer module pass outright, so `--dev --sanitize` could not
compile any program at all; the whole combination was unreachable, and
that includes the [__asan_init] yield in [flan_dev_crash_enable] that
is the one thing keeping the crash handler out of ASan's way. Reduced
to five lines of IR here; it is an upstream crash and nobody has filed
it. A local definition in the table is what clang itself emits for its
own constructors, and it costs a call before main.
The ordering the wrapper now fixes was unspecified before — two entries
at one priority — and arming the registry before the handler is the
order that was wanted anyway. Its name is [Mangle.dev_ctor] and the
leading dot there is load-bearing too; that comment says why. *)
(* Declared here rather than in the preamble, which is the one place a
declare is worth gating: the crash-handler 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 that
lane and moving it was not its to make. *)
Buffer.add_string m.out "declare void @flan_dev_crash_enable()\n";
let ctor = "@" ^ quoted Mangle.dev_ctor in
Buffer.add_string m.out
(Printf.sprintf
"define internal void %s() {\n\
\ call void @flan_dev_reg_enable()\n\
\ call void @flan_dev_crash_enable()\n\
\ ret void\n\
}\n"
ctor);
Buffer.add_string m.out
(Printf.sprintf
"@llvm.global_ctors = appending global [1 x { i32, ptr, ptr }] \
[{ i32, ptr, ptr } { i32 65535, ptr %s, ptr null }]\n" ctor);
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 traced 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 -> internal "no such macro %s" 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 (TODO.org, "The dev loop,
step 1: the reload primitive").
[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. *)
(* Whether an expression thunk makes a function value anywhere in its body or
in the clauses lifted out of it. Such a value's code address is in this
module — a lambda's body, or the thick wrapper a named function is handed
out through — and it may be stored anywhere, so the module must stay
mapped. Both backends ask this before marking a thunk's module
unloadable. *)
let thunk_makes_fn_values (p : Tast.program) name =
let mine = Hashtbl.create 8 in
Hashtbl.replace mine name ();
(* Lifted clauses nest: a lambda inside a lambda is lifted out of the
outer one's body, so the set grows until nothing new joins it. *)
let rec close () =
let grew = ref false in
List.iter
(fun (f : Tast.fn) ->
match f.Tast.fparent with
| Some q when Hashtbl.mem mine q && not (Hashtbl.mem mine f.Tast.name) ->
Hashtbl.replace mine f.Tast.name (); grew := true
| _ -> ())
p.Tast.fns;
if !grew then close ()
in
close ();
let found = ref false in
List.iter
(fun (f : Tast.fn) ->
if Hashtbl.mem mine f.Tast.name then
List.iter
(Tast.walk (fun (e : Tast.expr) ->
match e.Tast.e with
| Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _ -> found := true
| _ -> ()))
f.Tast.body)
p.Tast.fns;
!found
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
?(known = fun _ -> true) ?(retains = true)
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
: string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f
| None -> internal "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.
And the widening thunks, every one of them, whichever body they belong
to: a module that hands a name to an [Fn]-typed parameter names one, and
the host has no cell for it to be reached through. They are hidden and
tiny, so a copy per module is the whole cost — and the alternative is an
undefined symbol at dlopen, which is the shape of bug [Fnval] was. *)
let lifted =
List.filter
(fun (f : Tast.fn) ->
match f.Tast.fparent with
| Some "<thick>" -> true
| 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 ~annotate p in
m.pool <- call <> None && retains;
(* 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
(* A lifted initialiser asked for by name — [global/<n>] when a [def] is
evaluated. It is not a sibling, because its [fparent] is the global it
initialises, so the cell machinery below would pass it over; and it is
not one of [lifted] either, because the thing it was lifted out of is a
global and not a function in [fns]. It still needs a cell like any other
published body: the thunk that stores the new value calls it, and a call
in a dev module goes through a cell. *)
let lifted_targets =
List.filter (fun (f : Tast.fn) -> f.Tast.fparent <> None) targets
in
let new_fns =
List.filter
(fun (f : Tast.fn) ->
(not (known f.Tast.name)) && not (transient f.Tast.name))
(siblings @ lifted_targets)
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 %s\n" (cellname f.Tast.name)
cell_ty
else
Printf.sprintf "%s = internal global ptr null\n"
(cellptr f.Tast.name)))
siblings;
(* A lifted initialiser handed in as a target — [global/<n>] when a [def]
is evaluated — is not a sibling: its [fparent] is the global it
initialises, not a function in [fns]. So the publish store below needs
the declaration the sibling loop above could not write, and it is the
same two: the host's cell for a name the host has, and a slot of this
module's own for one it does not, filled from the registry by the
installer. A brand-new [def] is the second case — nothing in the host
ever named its initialiser. *)
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 %s\n" (cellname f.Tast.name)
cell_ty
else
Printf.sprintf "%s = internal global ptr null\n"
(cellptr f.Tast.name)))
lifted_targets;
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 (fi_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 (defonce n i64 42), a new (def n i64 42) or a new
defconst would silently be zero — calloc is only the right answer
for ZII. [initial_image] is what decides, and it is shared with
the x86 backend: see the note above it for the def's case and for
why a computed initialiser sends a null instead. *)
let init =
match initial_image p g with
| None -> "null"
| Some v ->
(* Copied by the runtime and not kept, so not counted in
[nstr]; a string inside it is, through [const]. *)
let init = Printf.sprintf "@\".init.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private constant %s %s\n" init
(ll g.Tast.gty) (const m v));
init
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 (fi_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;
(* The body and its signature together, the word before the body. Both
stores happen here, on the game thread, at a frame boundary — so no
call site can see one without the other, and the order is for a
reader rather than for a race. *)
let publish cell (f : Tast.fn) =
let wp = fresh () and tp = fresh () in
Buffer.add_string b
(Printf.sprintf
" %s = getelementptr inbounds i8, ptr %s, i64 8\n \
store i64 %Ld, ptr %s\n \
%s = getelementptr inbounds i8, ptr %s, i64 16\n \
store ptr %s, ptr %s\n \
store ptr %s, ptr %s\n"
wp cell (sig_word f.Tast.params f.Tast.ret) wp
tp cell (cstring m (sig_text f.Tast.params f.Tast.ret)) tp
(fname f.Tast.name) cell)
in
List.iter
(fun (f : Tast.fn) ->
if transient f.Tast.name then ()
else if known f.Tast.name then publish (cellname f.Tast.name) f
else begin
let t = fresh () in
Buffer.add_string b
(Printf.sprintf " %s = load ptr, ptr %s\n" t (cellptr f.Tast.name));
publish t f
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. So a thunk's
literal is a copy the process keeps (see [pool]) and is not counted;
what [nstr] still counts is a constant something may go on pointing
at, such as a condition's name, and a module with one keeps its
mapping. The registry names above are not counted: flan_dev.c copies
a name it keeps, and an initial image is copied on allocation. *)
(* [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)
&& not (thunk_makes_fn_values p fn) 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