Joseph Ferano
81b807f544
Every number-to-text conversion wrote into one file-static in the runtime and answered a slice over it, and nothing copied. Two of them in one expression printed the second number twice — no crash, no diagnostic, and nothing a sanitizer could find, because every byte read was inside an object that was alive. The wrong object. The buffer is now the caller's, one frame slot per call site. The slot is allocated in the checker rather than in either backend: a slot is a function-lifetime location in both of them, where an x86 backend temporary is bump-allocated and reclaimed at the end of the expression that made it — which is the one lifetime a returned slice must outlive. Each backend gains one pointer argument and no reasoning of its own, which is what keeps them symmetric. The static is gone rather than left unused, since a buffer with nothing but a comment beside it is a loaded gun. What remains is the ordinary lifetime a pointer into a frame has: storing one of these slices in a container that outlives the frame, or returning it, is still a copy the caller has to make. NEXT.md's sharp edge now says that instead of what it used to say.
3365 lines
154 KiB
OCaml
3365 lines
154 KiB
OCaml
(** Typed IR → LLVM IR, as text.
|
|
|
|
Text rather than libLLVM bindings, for the reasons in plan.org: the build
|
|
dependency is a clang on PATH instead of a version-pinned libLLVM with C++
|
|
linkage, the output is readable when something is wrong, and an LLVM
|
|
upgrade does not break the compiler. The only thing text loses is the
|
|
in-process JIT, and that was measured at ~13ms — below perception.
|
|
|
|
Layout — this is the whole of it, and it is deliberately C's:
|
|
|
|
{v
|
|
i8..i64 / u8..u64 i8..i64 signedness lives in the ops
|
|
f32 f64 float double
|
|
bool i1
|
|
[T] and string { ptr, i64 } ptr+len, non-owning
|
|
[n T] [n x T] inline, a value
|
|
(Ptr T) ptr opaque pointers
|
|
(Option T) { i8, T } tag 0 None, 1 Some
|
|
a struct a literal struct in declaration order
|
|
Unit and Never {} zero-sized, one value
|
|
v}
|
|
|
|
No object headers anywhere, which is the consequence that drives everything
|
|
(plan.org, Memory) — a Flan struct is exactly its C struct.
|
|
|
|
Two things fall out of the layout and are load-bearing:
|
|
|
|
- Every slot is an [alloca], so reading a local is a [load] and assigning is
|
|
a [store]. Aggregates are SSA values in LLVM, so a [store] of a struct or
|
|
a fixed array *is* the copy that spec-memory.md requires on assignment,
|
|
and a slice copies its view for the same reason. [addr] of a local is then
|
|
just the alloca. [mem2reg] removes the ones nobody took the address of.
|
|
- A place lowers to a pointer and a value to a load from it, which is the
|
|
split the interpreter would have had to make by hand: [(set (.pos c) ...)]
|
|
through a [(Ptr Cursor)] becomes a [getelementptr] on the pointer, not on
|
|
a copy of the struct. *)
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
|
|
Emission is all side effect — instructions, calls, branches to a [ret] — so
|
|
left-to-right is required, not a preference. Same rule as in Check. *)
|
|
let rec map_lr f = function
|
|
| [] -> []
|
|
| x :: rest -> let y = f x in y :: map_lr f rest
|
|
|
|
(* ── Names ─────────────────────────────────────────────────────────── *)
|
|
|
|
(* Flan names contain -, ?, > and /, so every emitted name is quoted. The
|
|
[flan.] prefix keeps the Flan [main] from colliding with C's. *)
|
|
let quoted s = "\"" ^ s ^ "\""
|
|
let fname n = "@" ^ quoted ("flan." ^ n)
|
|
let gname n = "@" ^ quoted ("flan." ^ n)
|
|
let sname n = "%" ^ quoted n
|
|
|
|
(* A dev build's redefinable calls go through a cell: a mutable global holding
|
|
the address of the function that is current. Redefinition is then one store,
|
|
and every existing call site follows it — which is the whole point, since a
|
|
call bound at link time cannot be made to notice a new body. Release builds
|
|
have no cells and call the symbol directly. *)
|
|
let cellname n = "@" ^ quoted ("flan.cell." ^ n)
|
|
|
|
(* A name the host was never built with — a defn or a defvar typed in after the
|
|
process started — has no symbol to bind to, so it is keyed by string through
|
|
[flan_dev_cell] / [flan_dev_global] and the answer is cached in one of these
|
|
module-local slots. One indirection more than a name the host has, which is
|
|
why the compiler picks per name rather than routing everything this way. *)
|
|
(* The transfer channel's parameter, the one name that is not a Flan name. It
|
|
is not a slot: nothing in the language can address it, and it is read and
|
|
written only by the guards this file emits. *)
|
|
let xfer_param = "%xfer"
|
|
|
|
(* The condition's own name, for the message an unhandled [error] prints. The
|
|
checker has already refused anything that is not a struct. *)
|
|
let struct_name_of (t : Types.t) =
|
|
match t with Types.Named n -> n | _ -> "a condition"
|
|
|
|
let cellptr n = "@" ^ quoted ("flan.cellp." ^ n)
|
|
let globalptr n = "@" ^ quoted ("flan.gp." ^ 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
|
|
|
|
(* ── Types ─────────────────────────────────────────────────────────── *)
|
|
|
|
let rec ll (t : Types.t) =
|
|
match t with
|
|
| Types.Int k -> "i" ^ string_of_int (Types.bits k)
|
|
| Types.Float Types.F32 -> "float"
|
|
| Types.Float Types.F64 -> "double"
|
|
| Types.Bool -> "i1"
|
|
| Types.String | Types.Slice _ -> "%slice"
|
|
| Types.Unit | Types.Never -> "{}"
|
|
| Types.Named n -> sname n
|
|
(* A C enum is an i32 — its own type in the checker, nothing at all here. *)
|
|
| Types.Enum _ -> "i32"
|
|
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
|
|
| Types.Ptr _ -> "ptr"
|
|
(* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a
|
|
copy of one: see Types. Opaque here in the same sense [ptr] is. *)
|
|
| Types.Alloc -> "ptr"
|
|
(* A function value is a code address and nothing else. There is no
|
|
environment beside it — capture does not exist (check.ml refuses it by
|
|
name) — so it is one pointer, the same width as any other, and a backend
|
|
needs to know no more about it than that. *)
|
|
| Types.Fn _ -> "ptr"
|
|
(* ptr + len + cap + allocator, and two more words the runtime owns: see
|
|
flan_rt.c's (Vec T) header for why they are in every build. Nothing in
|
|
this file reads a field of one — every operation is a runtime call taking
|
|
the Vec's address — so the shape is here only so that a slot, a struct
|
|
field and a copy in the IR are the right number of bytes. *)
|
|
| Types.Vec _ -> "%vec"
|
|
(* data + len + log2cap + allocator + gen + epoch. Six words, exactly as the
|
|
Vec's, and read here for exactly the same reason: nothing in this file
|
|
touches a field of one — every operation is a runtime call taking the
|
|
map's address — so the shape exists only so that a slot, a struct field
|
|
and a copy in the IR are the right number of bytes. *)
|
|
| Types.Map _ -> "%map"
|
|
(* items + slots + len + cap + live + free + allocator + epoch. Nothing here
|
|
reads a field of one either — every operation is a runtime call taking
|
|
the pool's address. *)
|
|
| Types.Pool _ -> "%pool"
|
|
(* A handle is one 64-bit number: the slot index in the low half and that
|
|
slot's generation in the high half. Packed rather than a two-field struct
|
|
so that copying, zeroing and [=] are what they are for an integer, with no
|
|
backend arm anywhere except the one comparison below. *)
|
|
| Types.Handle _ -> "i64"
|
|
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
|
|
| Types.Var _ ->
|
|
(* The checker rejects it by name — nothing reaches here. *)
|
|
failwith ("no layout for " ^ Types.to_string t)
|
|
|
|
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
|
|
|
|
(* -- Debug info ----------------------------------------------------- *)
|
|
|
|
(* DWARF, as LLVM metadata. This is only worth the lines it takes because of
|
|
the layout above: a Flan struct *is* its C struct, every slot is an alloca
|
|
and there are no tag words, so the debug info describes machine types
|
|
directly and lldb has to learn nothing about Flan. The compile unit says
|
|
DW_LANG_C99 for that reason -- it is less a claim about the source language
|
|
than the truth about the data model, and it is what makes lldb's own
|
|
struct-printing correct here.
|
|
|
|
Metadata is a flat numbered pool with no ordering requirement, so a node can
|
|
be allocated an id, referred to, and written out later -- which is what
|
|
makes a recursive struct (a field of type [(Ptr Self)]) expressible. *)
|
|
|
|
type dbg = {
|
|
mutable dn : int; (* next metadata id *)
|
|
dout : Buffer.t; (* the [!N = ...] lines *)
|
|
dfiles : (string, int) Hashtbl.t; (* path -> !DIFile *)
|
|
dtys : (string, int) Hashtbl.t; (* Types.to_string -> a type node *)
|
|
dlocs : (string, int) Hashtbl.t; (* scope:line:col -> !DILocation *)
|
|
mutable dcu : int;
|
|
}
|
|
|
|
let dalloc d = let n = d.dn in d.dn <- n + 1; n
|
|
|
|
let dput d n body = Buffer.add_string d.dout (Printf.sprintf "!%d = %s\n" n body)
|
|
|
|
let dnode d body = let n = dalloc d in dput d n body; n
|
|
|
|
(* Metadata strings are C strings in the .ll grammar, so the two characters
|
|
that could end one have to be escaped. Flan names contain - ? > and /, none
|
|
of which do. *)
|
|
let dstr s =
|
|
let b = Buffer.create (String.length s + 2) in
|
|
String.iter
|
|
(fun c ->
|
|
if c = '"' || c = '\\' then (Buffer.add_char b '\\'; Buffer.add_char b c)
|
|
else Buffer.add_char b c)
|
|
s;
|
|
Buffer.contents b
|
|
|
|
let dfile d path =
|
|
match Hashtbl.find_opt d.dfiles path with
|
|
| Some n -> n
|
|
| None ->
|
|
let abs =
|
|
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path
|
|
in
|
|
let n =
|
|
dnode d
|
|
(Printf.sprintf "!DIFile(filename: \"%s\", directory: \"%s\")"
|
|
(dstr (Filename.basename abs)) (dstr (Filename.dirname abs)))
|
|
in
|
|
Hashtbl.replace d.dfiles path n;
|
|
n
|
|
|
|
(* -- Layout ----------------------------------------------------------
|
|
DWARF wants member offsets as integer literals: [!DIDerivedType(tag:
|
|
DW_TAG_member, offset: N)] takes a constant and nothing else, so the
|
|
[ptrtoint (ptr getelementptr ...)] form this file uses elsewhere for a size
|
|
is not accepted there and these have to be computed. That makes this the one
|
|
place in the backend where a layout number is worked out rather than handed
|
|
to LLVM, and it is exactly where a wrong answer shows up as a plausible
|
|
value printed for the wrong field. So the acceptance test checks every
|
|
offset against LLVM's own [getelementptr] answer for the same struct type,
|
|
not against a table written by the same hand as the code.
|
|
|
|
The rules are C's, which is what LLVM gives a non-packed literal struct:
|
|
natural alignment, each member at the next aligned offset, tail padding out
|
|
to the struct's own alignment. The numbers are the host's -- [ptr] is 8
|
|
bytes -- which is why [Build] refuses a debug build for wasm32. *)
|
|
|
|
let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a
|
|
|
|
(* ── Module-level state ────────────────────────────────────────────── *)
|
|
|
|
type m = {
|
|
out : Buffer.t;
|
|
strs : Buffer.t; (* string literal constants *)
|
|
structs : (string, Tast.structure) Hashtbl.t;
|
|
(* The declared data types, by name. [Types.Named] covers both a struct and a
|
|
data type, so which table the name is in is the only thing that says which
|
|
this is — the same arrangement the checker uses, and for the same reason:
|
|
a data type is a type like any other everywhere except at its layout, its
|
|
construction and its match. *)
|
|
datas : (string, Tast.data) Hashtbl.t;
|
|
(* The untagged unions, by name. A third table for the same [Types.Named],
|
|
on the same principle as the second: the name says which, and the members
|
|
are a field list whose offsets are all zero. *)
|
|
unions : (string, Tast.structure) Hashtbl.t;
|
|
globals : (string, Types.t) Hashtbl.t;
|
|
(* Flan name -> C symbol, for the foreign functions. A call to one names the
|
|
symbol directly; there is no thunk. *)
|
|
externs : (string, string) Hashtbl.t;
|
|
checks : bool; (* emit bounds checks *)
|
|
dev : bool; (* call through cells (below) *)
|
|
(* Was this name in the build the running process came from? False only in a
|
|
redefinition module, and only for a name introduced since. *)
|
|
known : string -> bool;
|
|
(* [Some] in a debug build. It lives on the module rather than being passed
|
|
down because every emitter that can produce an instruction has to be able
|
|
to hang a location on it. *)
|
|
dbg : dbg option;
|
|
(* True in a sanitized build, and the whole of what ASan needs from us.
|
|
AddressSanitizer is an LLVM *pass*, but it instruments only functions
|
|
carrying the [sanitize_address] attribute — which clang's C frontend adds
|
|
and nothing adds to IR written by hand. Passing -fsanitize=address to the
|
|
clang run over this .ll therefore instruments the runtime's C and not one
|
|
instruction of Flan; measured, not assumed (see NEXT.md). So every
|
|
[define] here names attribute group #0 and [finish] writes it out.
|
|
|
|
There is no equivalent for UndefinedBehaviorSanitizer: its checks are
|
|
emitted by the C frontend as branches to __ubsan_handle_*, and no
|
|
attribute asks a pass to produce them. UBSan over this .ll covers the C
|
|
and nothing else. *)
|
|
sanitize : bool;
|
|
mutable nstr : int;
|
|
(* The frame descriptors a dev build's shadow stack points at, counted apart
|
|
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
|
|
whether an expression thunk's module may be unloaded — a string literal in
|
|
the module image is something the program may still be pointing at after
|
|
the thunk returns. A frame descriptor is not: the frames that named it
|
|
were popped on the way out, and the break loop copies the bytes it shows
|
|
rather than keeping the pointer. Counting these in [nstr] would silently
|
|
stop every C-x C-e module from ever being unloaded. *)
|
|
mutable nfi : int;
|
|
}
|
|
|
|
(* The attribute group every emitted function names, empty unless sanitizing.
|
|
Spelled once so the [define] sites and [finish] cannot disagree. *)
|
|
let attrs m = if m.sanitize then " #0" else ""
|
|
|
|
(* The type of one member, of a struct or of a union alike — the index means
|
|
the same thing in both, and only the offset it lands at differs. *)
|
|
let field_ty m sn i =
|
|
let s =
|
|
match Hashtbl.find_opt m.structs sn with
|
|
| Some s -> s
|
|
| None -> Hashtbl.find m.unions sn
|
|
in
|
|
(List.nth s.Tast.fields i).Tast.fty
|
|
|
|
(* Size and alignment in bytes. *)
|
|
let rec lay m (t : Types.t) : int * int =
|
|
match t with
|
|
| Types.Int k -> let n = Types.bits k / 8 in n, n
|
|
| Types.Float Types.F32 -> 4, 4
|
|
| Types.Float Types.F64 -> 8, 8
|
|
(* [i1] occupies a byte in memory. *)
|
|
| Types.Bool -> 1, 1
|
|
| Types.String | Types.Slice _ -> 16, 8
|
|
| Types.Unit | Types.Never -> 0, 1
|
|
| Types.Enum _ -> 4, 4
|
|
| Types.Ptr _ -> 8, 8
|
|
| Types.Alloc -> 8, 8
|
|
| Types.Fn _ -> 8, 8
|
|
| Types.Vec _ | Types.Map _ -> 48, 8
|
|
| Types.Pool _ -> 64, 8
|
|
| Types.Handle _ -> 8, 8
|
|
(* [n x T] adds no padding of its own: T's size already carries its tail. *)
|
|
| Types.Array (n, e) -> let s, a = lay m e in Int64.to_int n * s, a
|
|
| Types.Option e -> let s, a, _ = lay_fields m [ Types.Int Types.I8; e ] in s, a
|
|
| Types.Named n ->
|
|
(match Hashtbl.find_opt m.structs n with
|
|
| Some st ->
|
|
let s, a, _ =
|
|
lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields)
|
|
in
|
|
s, a
|
|
| None ->
|
|
match Hashtbl.find_opt m.datas n with
|
|
| Some u ->
|
|
(* The tag then the payload, as one struct, so the answer is the same
|
|
arithmetic every other aggregate here gets rather than a second
|
|
rule that could drift from it. *)
|
|
let size, align = payload_lay m u in
|
|
if size = 0 then 4, 4
|
|
else
|
|
let s, a, _ =
|
|
lay_fields m
|
|
[ Types.Int Types.I32;
|
|
Types.Array (Int64.of_int (size / align),
|
|
Types.Int (int_kind (align * 8))) ]
|
|
in
|
|
s, a
|
|
| None ->
|
|
match Hashtbl.find_opt m.unions n with
|
|
| Some u -> union_lay m u
|
|
| None -> failwith ("no layout for struct " ^ n))
|
|
| Types.Var _ -> failwith ("no layout for " ^ Types.to_string t)
|
|
|
|
(* Size, alignment, and the offset of every member. *)
|
|
and lay_fields m tys =
|
|
let off = ref 0 and al = ref 1 and rev = ref [] in
|
|
List.iter
|
|
(fun t ->
|
|
let s, a = lay m t in
|
|
let a = if a < 1 then 1 else a in
|
|
off := align_up !off a;
|
|
rev := !off :: !rev;
|
|
off := !off + s;
|
|
if a > !al then al := a)
|
|
tys;
|
|
align_up !off !al, !al, List.rev !rev
|
|
|
|
(* C's union rule, and it is the only thing about this type that is not a
|
|
struct's: room for the largest member, the alignment the strictest member
|
|
needs, and the size rounded up to that alignment so an array of the union
|
|
keeps every element aligned. Written through [lay] and [align_up] rather
|
|
than with arithmetic of its own, so it cannot drift from the payload
|
|
measurement below — which is the same rule over a data type's cases, and
|
|
was here first. *)
|
|
and union_lay m (u : Tast.structure) : int * int =
|
|
let align = ref 1 and size = ref 0 in
|
|
List.iter
|
|
(fun (fl : Tast.field) ->
|
|
let s, a = lay m fl.Tast.fty in
|
|
let a = if a < 1 then 1 else a in
|
|
if a > !align then align := a;
|
|
if s > !size then size := s)
|
|
u.Tast.fields;
|
|
align_up !size !align, !align
|
|
|
|
(* The size and alignment of a data type's payload: room for the largest case, with
|
|
the alignment the widest member of any case needs, and the size rounded up
|
|
to it so the blob divides evenly into [k x iA]. A data type of payload-less
|
|
cases has a zero-size payload and is a bare tag. *)
|
|
and payload_lay m (u : Tast.data) : int * int =
|
|
let align = ref 1 and size = ref 0 in
|
|
List.iter
|
|
(fun (c : Tast.variant) ->
|
|
let s, a, _ =
|
|
lay_fields m (List.map (fun (f : Tast.field) -> f.Tast.fty) c.Tast.vfields)
|
|
in
|
|
if a > !align then align := a;
|
|
if s > !size then size := s)
|
|
u.Tast.cases;
|
|
align_up !size !align, !align
|
|
|
|
(* The integer kind of a given width, for the payload blob's element type. *)
|
|
and int_kind = function
|
|
| 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64
|
|
| n -> failwith ("no integer type of " ^ string_of_int n ^ " bits")
|
|
|
|
(* A DWARF type node for a Flan type, memoised by the type's printed form so
|
|
the pool holds one node per distinct type. *)
|
|
let rec dty m d (t : Types.t) : int =
|
|
let key = Types.to_string t in
|
|
match Hashtbl.find_opt d.dtys key with
|
|
| Some n -> n
|
|
| None ->
|
|
let basic name bits enc =
|
|
dnode d
|
|
(Printf.sprintf "!DIBasicType(name: \"%s\", size: %d, encoding: %s)"
|
|
(dstr name) bits enc)
|
|
in
|
|
(* A struct-shaped node, with its id claimed before the members are built:
|
|
a field of type [(Ptr Self)] comes back through here. *)
|
|
let composite name members =
|
|
let id = dalloc d in
|
|
Hashtbl.replace d.dtys key id;
|
|
let size, al, offs = lay_fields m (List.map snd members) in
|
|
let ms =
|
|
List.map2
|
|
(fun (mname, mty) off ->
|
|
let fs, fa = lay m mty in
|
|
let base = dty m d mty in
|
|
dnode d
|
|
(Printf.sprintf
|
|
"!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: %d)"
|
|
(dstr mname) base (fs * 8) (fa * 8) (off * 8)))
|
|
members offs
|
|
in
|
|
dput d id
|
|
(Printf.sprintf
|
|
"!DICompositeType(tag: DW_TAG_structure_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
|
|
(dstr name) (size * 8) (al * 8)
|
|
(String.concat ", " (List.map (fun i -> Printf.sprintf "!%d" i) ms)));
|
|
id
|
|
in
|
|
let n =
|
|
match t with
|
|
| Types.Int k ->
|
|
(* DW_ATE_signed / DW_ATE_unsigned, not the _char variants: an i8 is a
|
|
number in Flan, and lldb prints a character for a char. *)
|
|
basic (Types.to_string t) (Types.bits k)
|
|
(if Types.signed k then "DW_ATE_signed" else "DW_ATE_unsigned")
|
|
| Types.Float k -> basic (Types.to_string t) (Types.bits_f k) "DW_ATE_float"
|
|
| Types.Bool -> basic "bool" 8 "DW_ATE_boolean"
|
|
| Types.Enum e -> basic e 32 "DW_ATE_signed"
|
|
| Types.Unit | Types.Never -> composite (Types.to_string t) []
|
|
| Types.Ptr e ->
|
|
let id = dalloc d in
|
|
Hashtbl.replace d.dtys key id;
|
|
(* [(Ptr Unit)] and [(Ptr Never)] are the opaque pointer, and a DWARF
|
|
pointer with no base type is exactly C's void *. *)
|
|
let base =
|
|
match e with
|
|
| Types.Unit | Types.Never -> "null"
|
|
| e -> Printf.sprintf "!%d" (dty m d e)
|
|
in
|
|
dput d id
|
|
(Printf.sprintf
|
|
"!DIDerivedType(tag: DW_TAG_pointer_type, baseType: %s, size: 64)" base);
|
|
id
|
|
| Types.Array (n, e) ->
|
|
let base = dty m d e in
|
|
let size, al = lay m t in
|
|
let sub = dnode d (Printf.sprintf "!DISubrange(count: %Ld)" n) in
|
|
dnode d
|
|
(Printf.sprintf
|
|
"!DICompositeType(tag: DW_TAG_array_type, baseType: !%d, size: %d, align: %d, elements: !{!%d})"
|
|
base (size * 8) (al * 8) sub)
|
|
(* ptr+len, and shown as ptr+len. There is no hidden owner and no
|
|
capacity, so two members are the whole truth about a slice. *)
|
|
| Types.String ->
|
|
composite "string"
|
|
[ ("ptr", Types.Ptr (Types.Int Types.U8)); ("len", Types.Int Types.I64) ]
|
|
| Types.Slice e ->
|
|
composite (Types.to_string t)
|
|
[ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64) ]
|
|
| Types.Option e ->
|
|
composite (Types.to_string t)
|
|
[ ("tag", Types.Int Types.U8); ("value", e) ]
|
|
| Types.Named sn ->
|
|
(match Hashtbl.find_opt m.structs sn with
|
|
| Some st ->
|
|
composite sn
|
|
(List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty))
|
|
st.Tast.fields)
|
|
| None ->
|
|
match Hashtbl.find_opt m.datas sn with
|
|
(* The truth about the bytes, and nothing cleverer: a tag and a blob.
|
|
DWARF 5 has DW_TAG_variant_part for exactly this, and lldb's C
|
|
support does not use it — a debugger that was handed one would
|
|
show less, not more. The reader who wants the payload reads it
|
|
through the case's own type, which is emitted beside this. *)
|
|
| Some u ->
|
|
let size, align = payload_lay m u in
|
|
composite sn
|
|
([ ("tag", Types.Int Types.U32) ]
|
|
@ (if size = 0 then []
|
|
else
|
|
[ ("payload",
|
|
Types.Array (Int64.of_int (size / align),
|
|
Types.Int (int_kind (align * 8)))) ]))
|
|
| None ->
|
|
(* DW_TAG_union_type, which is the one place a DWARF tag says
|
|
exactly what the Flan type is — every member at offset zero,
|
|
each with its own type. lldb's C support reads this and prints
|
|
every member of a union side by side, which is the only honest
|
|
thing to show: the debugger cannot know which one is live
|
|
either. *)
|
|
match Hashtbl.find_opt m.unions sn with
|
|
| Some u ->
|
|
let id = dalloc d in
|
|
Hashtbl.replace d.dtys key id;
|
|
let size, al = union_lay m u in
|
|
let ms =
|
|
List.map
|
|
(fun (fl : Tast.field) ->
|
|
let fs, fa = lay m fl.Tast.fty in
|
|
let base = dty m d fl.Tast.fty in
|
|
dnode d
|
|
(Printf.sprintf
|
|
"!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: 0)"
|
|
(dstr fl.Tast.fname) base (fs * 8) (fa * 8)))
|
|
u.Tast.fields
|
|
in
|
|
dput d id
|
|
(Printf.sprintf
|
|
"!DICompositeType(tag: DW_TAG_union_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
|
|
(dstr sn) (size * 8) (al * 8)
|
|
(String.concat ", "
|
|
(List.map (fun i -> Printf.sprintf "!%d" i) ms)));
|
|
id
|
|
| None -> failwith ("no debug type for struct " ^ sn))
|
|
(* An opaque pointer under lldb, which is the truth: the allocator's
|
|
fields are the runtime's C and lldb already has that type from
|
|
flan_rt.c's own debug info. *)
|
|
| Types.Alloc ->
|
|
dnode d
|
|
"!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)"
|
|
(* Shown as what it is. The two dev words are in the layout and so they
|
|
are here too: a debugger that showed four fields of a six-field struct
|
|
would put the reader's offsets out by two. *)
|
|
| Types.Vec e ->
|
|
composite (Types.to_string t)
|
|
[ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64);
|
|
("cap", Types.Int Types.I64); ("allocator", Types.Alloc);
|
|
("gen", Types.Int Types.I64); ("epoch", Types.Int Types.I64) ]
|
|
(* Six fields again, and shown as six for the same reason: a debugger
|
|
that showed fewer would put the reader's offsets out. [log2cap] is
|
|
shown rather than a capacity because that is what is stored — the
|
|
capacity is 1 << it, and a debugger that invented the shift would be
|
|
describing a field that is not there. *)
|
|
| Types.Map (k, v) ->
|
|
composite (Types.to_string t)
|
|
[ ("data", Types.Ptr (Types.Int Types.U8));
|
|
("len", Types.Int Types.I64); ("log2cap", Types.Int Types.I64);
|
|
("allocator", Types.Alloc); ("gen", Types.Int Types.I64);
|
|
("epoch", Types.Int Types.I64) ]
|
|
|> fun n -> ignore k; ignore v; n
|
|
(* Eight fields, shown as eight, for the reason the two above are. *)
|
|
| Types.Pool e ->
|
|
composite (Types.to_string t)
|
|
[ ("items", Types.Ptr e);
|
|
("slots", Types.Ptr (Types.Int Types.U8));
|
|
("len", Types.Int Types.I64); ("cap", Types.Int Types.I64);
|
|
("live", Types.Int Types.I64); ("free", Types.Int Types.I64);
|
|
("allocator", Types.Alloc); ("epoch", Types.Int Types.I64) ]
|
|
(* An i64 under lldb, which is what it is. Splitting it into a two-field
|
|
composite would be describing a struct that is not there: the packing
|
|
is the runtime's, and [p h] answering with the number is honest. *)
|
|
| Types.Handle _ ->
|
|
basic (Types.to_string t) 64 "DW_ATE_unsigned"
|
|
(* A pointer to code, and lldb is told exactly that and no more. DWARF
|
|
has DW_TAG_subroutine_type for the signature behind it, and spelling
|
|
one out here would buy a reader nothing they cannot get from the
|
|
function it points at — [p f] answers with an address either way, and
|
|
the address is what resolves to a symbol. The name carries the
|
|
signature, which is where it is actually legible. *)
|
|
| Types.Fn _ ->
|
|
dnode d
|
|
(Printf.sprintf
|
|
"!DIDerivedType(tag: DW_TAG_pointer_type, name: \"%s\", \
|
|
baseType: null, size: 64)"
|
|
(Types.to_string t))
|
|
| Types.Var _ ->
|
|
failwith ("no debug type for " ^ Types.to_string t)
|
|
in
|
|
Hashtbl.replace d.dtys key n;
|
|
n
|
|
|
|
(* ── Per-function state ────────────────────────────────────────────── *)
|
|
|
|
type f = {
|
|
md : m;
|
|
allocas : Buffer.t; (* the entry block: mem2reg only promotes these *)
|
|
b : Buffer.t;
|
|
mutable n : int;
|
|
mutable live : bool; (* is the current block still open? *)
|
|
ret : Types.t;
|
|
slots : string array;
|
|
slot_tys : Types.t array;
|
|
(* The transfer channel's landing blocks, spec-conditions.md §6. A guard
|
|
after a call branches to the innermost one; each pops whatever frames it
|
|
established and either catches the transfer or forwards it outward. The
|
|
innermost is first, and with none open a transfer leaves the function
|
|
through [unwind], which runs its defers (§5) and returns early. The flag
|
|
says the block was branched to, so an unused one is not emitted. *)
|
|
mutable pads : (string * bool ref) list;
|
|
(* The loops being emitted, innermost first: for each, the label a [break]
|
|
branches to and the label a [continue] branches to. Exactly the shape
|
|
[pads] has, and for the same reason — a jump names its target by how far
|
|
out it is, so the stack is the lookup. [Tast.Break] carries that distance
|
|
already, so this is indexed and never searched. *)
|
|
mutable loops : (string * string) list;
|
|
unwind : string;
|
|
mutable unwound : bool;
|
|
defers : Tast.expr list;
|
|
(* The function's !DISubprogram, in a debug build, and the line it was
|
|
declared on -- the fallback for a node the checker made up. *)
|
|
dsub : int option;
|
|
dline : int;
|
|
(* The value the shadow-stack head held when this function was entered, in a
|
|
dev build: [Some %fprev]. Every [ret] restores it — see [ret] — which is
|
|
what makes the pop happen on the transfer path as well as the normal one.
|
|
[None] in a release build, where there is no frame at all. *)
|
|
mutable frame : string option;
|
|
(* Where a dev build records each slot's address, so that a stopped frame's
|
|
locals can be read. [None] in a release build and in a function with no
|
|
named slot at all. Only *named* slots are recorded: a slot the compiler
|
|
invented has no name to show, and leaving its alloca unrecorded leaves it
|
|
promotable, which is where most of the cost of this would otherwise be.
|
|
An entry is null until the binding that fills the slot has run — that is
|
|
how "not bound yet at this point" is told from "bound", with no liveness
|
|
analysis and no bitmap. *)
|
|
mutable slotv : string option;
|
|
snames : string option array;
|
|
(* The [, !dbg !N] suffix every instruction in this function carries, or "".
|
|
Uniform rather than only on the instructions that want a line: LLVM's
|
|
verifier rejects a call without a location inside a function that has
|
|
debug info, and this file emits calls from a dozen places -- the bounds
|
|
failure, the handler push and pop, the transfer guards -- none of which
|
|
would remember to ask. *)
|
|
mutable dloc : string;
|
|
}
|
|
|
|
let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
|
|
let fresh_label f name = f.n <- f.n + 1; Printf.sprintf "%s%d" name f.n
|
|
|
|
(* Nothing may follow a terminator, so emission after one is dropped: the code
|
|
is unreachable and LLVM would reject it. *)
|
|
let ins f fmt =
|
|
Printf.ksprintf
|
|
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")) fmt
|
|
|
|
(* A fixed array has no padding between elements, so its zero value is exactly
|
|
a run of zero bytes. Naming that operation lets LLVM choose its bulk-clear
|
|
implementation instead of expanding a large aggregate store into one store
|
|
per element. Keep small arrays as typed stores: their inline code is
|
|
cheaper than a call on targets which do not inline the intrinsic. *)
|
|
let bulk_zero_min_bytes = 64
|
|
|
|
let emit_bulk_zero f ptr ty =
|
|
match ty with
|
|
| Types.Array _ ->
|
|
let size, align = lay f.md ty in
|
|
if size >= bulk_zero_min_bytes then begin
|
|
ins f
|
|
"call void @llvm.memset.p0.i64(ptr align %d %s, i8 0, i64 %d, i1 false)"
|
|
align ptr size;
|
|
true
|
|
end else false
|
|
| _ -> false
|
|
|
|
let term f fmt =
|
|
Printf.ksprintf
|
|
(fun s ->
|
|
if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n");
|
|
f.live <- false)
|
|
fmt
|
|
|
|
let label f name =
|
|
Buffer.add_string f.b (Printf.sprintf "\n%s:\n" name);
|
|
f.live <- true
|
|
|
|
(* Every [ret] in a function body goes through here, which is the whole of how
|
|
the shadow stack's pop is got right. There are five of them — an explicit
|
|
[return] with a value and without, the [none] arm of [(some x)], the tail of
|
|
the body, and the landing block a transfer leaves through — and the last of
|
|
those is the one that matters: a condition handled further out unwinds past
|
|
this frame, so a pop written only on the normal path leaves a dead frame on
|
|
the stack after every handled error, and the next backtrace is a lie. Same
|
|
lesson [emit_with_alloc] learned about the context allocator. *)
|
|
let ret f v =
|
|
(match f.frame with
|
|
| Some prev -> ins f "store ptr %s, ptr @flan_frame_head" prev
|
|
| None -> ());
|
|
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
|
|
|
|
(* ── Constants ─────────────────────────────────────────────────────── *)
|
|
|
|
(* LLVM's hex form is exact, which decimal is not: a literal must mean the same
|
|
thing after a round trip through the .ll file. *)
|
|
let float_const (k : Types.fkind) x =
|
|
let x = match k with Types.F32 -> Int32.float_of_bits (Int32.bits_of_float x)
|
|
| Types.F64 -> x in
|
|
Printf.sprintf "0x%Lx" (Int64.bits_of_float x)
|
|
|
|
let escape s =
|
|
let b = Buffer.create (String.length s + 8) in
|
|
String.iter
|
|
(fun c ->
|
|
if c = '"' || c = '\\' || Char.code c < 0x20 || Char.code c > 0x7e then
|
|
Buffer.add_string b (Printf.sprintf "\\%02X" (Char.code c))
|
|
else Buffer.add_char b c)
|
|
s;
|
|
Buffer.contents b
|
|
|
|
(* The constant itself, as the pointer and length a caller needs separately —
|
|
a bounds message crosses to C as ptr+len like any other slice. *)
|
|
let string_bytes m s =
|
|
let id = Printf.sprintf "@\".str.%d\"" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
|
|
id (String.length s) (escape s));
|
|
id, String.length s
|
|
|
|
let string_const m s =
|
|
let id, n = string_bytes m s in
|
|
(* The value alone: LLVM takes the type from the operand's context. *)
|
|
Printf.sprintf "{ ptr %s, i64 %d }" id n
|
|
|
|
(* A NUL-terminated copy, for the two dev lookups that take a C string. Flan
|
|
strings are ptr+len and never NUL-terminated, so this is its own constant. *)
|
|
let cstring m s =
|
|
let id = Printf.sprintf "@\".name.%d\"" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\\00\"\n"
|
|
id (String.length s + 1) (escape s));
|
|
id
|
|
|
|
(* ── The shadow stack's descriptors ──────────────────────────────────── *)
|
|
|
|
(* One [flan_fninfo] per function in a dev build: the name and the location,
|
|
as bytes and lengths, plus how many slots the frame has. It is static data —
|
|
nothing about a function changes between two calls to it — so a frame stores
|
|
a pointer to this and not six fields of its own.
|
|
|
|
The strings go through [m.nfi] rather than [string_bytes], which is the
|
|
whole of why that counter exists; see [m.nfi]. *)
|
|
let fi_bytes m s =
|
|
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
|
|
m.nfi <- m.nfi + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
|
|
id (String.length s) (escape s));
|
|
id, String.length s
|
|
|
|
(* What the two ends compare about a frame's slots, since neither can see the
|
|
other. Same idea as a restart frame's [rsig_id], and for the same reason: a
|
|
frame on the stack was compiled from *some* body, the session holds
|
|
whatever body it last accepted, and installing while stopped is deliberately
|
|
allowed — so the two can be different bodies of the same function, and a
|
|
slot count alone does not notice a rename or a reordering. Pairing [q] with
|
|
[p]'s value and saying nothing is exactly the "visible rather than correct"
|
|
failure this project has already named once.
|
|
|
|
Over the names *and* the spellings of the types, because either can change
|
|
on its own. Computed here and read from here by [Dev], so there is one
|
|
definition of it and it cannot drift. *)
|
|
let slot_fingerprint (fn : Tast.fn) =
|
|
let b = Buffer.create 128 in
|
|
Array.iteri
|
|
(fun i ty ->
|
|
(match
|
|
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None
|
|
with
|
|
| Some n -> Buffer.add_string b n
|
|
| None -> ());
|
|
Buffer.add_char b ':';
|
|
Buffer.add_string b (Types.to_string ty);
|
|
Buffer.add_char b ';')
|
|
fn.Tast.slots;
|
|
Hashtbl.hash (Buffer.contents b) land 0x3fffffff
|
|
|
|
let fninfo m (fn : Tast.fn) ~nslots =
|
|
let nid, nlen = fi_bytes m fn.Tast.name in
|
|
let lid, llen = fi_bytes m (Loc.to_string fn.Tast.floc) in
|
|
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
|
|
m.nfi <- m.nfi + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf
|
|
"%s = private unnamed_addr constant %%fninfo { ptr %s, i64 %d, ptr %s, i64 %d, i32 %d, i32 %d, i32 %d }\n"
|
|
id nid nlen lid llen nslots (slot_fingerprint fn)
|
|
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn));
|
|
id
|
|
|
|
(* ── Bounds checks ───────────────────────────────────────────────────── *)
|
|
|
|
(* A failure is a branch to a [noreturn] call and then [unreachable] — the same
|
|
explicit shape as [return] and [some], so wasm32 needs no unwinding for it
|
|
either. Whether to check is its own flag, not the optimisation level: dev
|
|
builds trap, release builds do not (NEXT.md), and the acceptance table runs
|
|
at both -O0 and -O2 with the checks on either way.
|
|
|
|
Indices are i32 in Flan and sign-extended to i64 for the gep, so a negative
|
|
one arrives here as a huge unsigned value: an unsigned comparison catches
|
|
the negative and the too-large case in a single test.
|
|
|
|
This is the *trapping* shape and it still has three users: the restart
|
|
lookups and the unarmed-clause check, none of which is recoverable — there
|
|
is nowhere to resume a transfer whose target does not exist. The two bounds
|
|
checks moved off it; see [signal_block]. *)
|
|
let fail_block f (loc : Loc.t) ok emit_call =
|
|
let good = fresh_label f "inb" and bad = fresh_label f "oob" in
|
|
term f "br i1 %s, label %%%s, label %%%s" ok good bad;
|
|
label f bad;
|
|
let id, n = string_bytes f.md (Loc.to_string loc) in
|
|
emit_call id n;
|
|
term f "unreachable";
|
|
label f good
|
|
|
|
(* The same branch, for a failure that *signals* rather than dying. The call is
|
|
an ordinary one — it returns when a handler or the break loop transferred —
|
|
so it is followed by a guard, and the fall-through past the guard is what is
|
|
unreachable: nothing answered, so the runtime already died inside the call.
|
|
|
|
[guard] is passed in rather than called directly because [guard] is part of
|
|
the expression emitter's recursive group and this is defined above it. It is
|
|
the same [guard f] every call site emits, so a bounds failure that is
|
|
answered leaves the function through the innermost pad — a restart-case's,
|
|
or the function's own unwind block, which runs its defers and returns.
|
|
**That is the answer to "does a trap run defers": an answered one does, an
|
|
unanswered one still does not, because the unanswered one is still a die
|
|
inside C.** *)
|
|
let signal_block f (loc : Loc.t) ~guard ok emit_call =
|
|
let good = fresh_label f "inb" and bad = fresh_label f "oob" in
|
|
term f "br i1 %s, label %%%s, label %%%s" ok good bad;
|
|
label f bad;
|
|
let id, n = string_bytes f.md (Loc.to_string loc) in
|
|
emit_call id n;
|
|
guard ();
|
|
term f "unreachable";
|
|
label f good
|
|
|
|
(* ── Arithmetic with no answer ─────────────────────────────────────────
|
|
|
|
Three situations that had no defined behaviour until now, and they share a
|
|
helper for the same reason the two bounds checks share one: they are one
|
|
condition, ArithError, and a handler should write one clause and not five.
|
|
|
|
The shape is [signal_block]'s and not [fail_block]'s, so an answered
|
|
failure leaves through the innermost pad and runs the defers on its way
|
|
out, exactly as an answered bad index does.
|
|
|
|
The thing worth knowing about the divide guard is that it is a branch
|
|
*before* the instruction rather than anything after it. A SIGFPE cannot be
|
|
caught and resumed, so there is no version of this that tests afterwards;
|
|
the branch is the price of the operation having a defined behaviour at all,
|
|
not the price of that behaviour being a condition. Which is also why the
|
|
overflow test rides along for nearly nothing: the zero test has already
|
|
put a compare and a branch on the path, and (/ min -1) is two more compares
|
|
folded into the same one. *)
|
|
|
|
(* The codes flan_arith_fail switches on, and the ones the prelude's
|
|
ArithError documents. They are named here rather than written as bare
|
|
numbers at the call sites, because a bare number at a call site is exactly
|
|
the kind of agreement that drifts. *)
|
|
let arith_div_zero = 0
|
|
let arith_rem_zero = 1
|
|
let arith_div_overflow = 2
|
|
let arith_rem_overflow = 3
|
|
let arith_cast_range = 4
|
|
|
|
(* ArithError's fields are i64 and an operand may be narrower, so every
|
|
operand is widened on the way into the condition — signed or not according
|
|
to its own type, so that (-1 : i8) reads back as -1 and (255 : u8) reads
|
|
back as 255. A u64 above 2^63 still reinterprets as negative, which the
|
|
prelude says out loud and which a fourth field is not worth fixing. *)
|
|
let widen f (k : Types.ikind) v =
|
|
if Types.bits k = 64 then v
|
|
else begin
|
|
let t = fresh f in
|
|
ins f "%s = %s %s %s to i64" t
|
|
(if Types.signed k then "sext" else "zext") (ll (Types.Int k)) v;
|
|
t
|
|
end
|
|
|
|
(* The most negative value of a signed kind, as the decimal LLVM wants. *)
|
|
let int_min k = Int64.neg (Int64.shift_left 1L (Types.bits k - 1))
|
|
|
|
(* 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 = 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
|
|
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 n = Types.bits k in
|
|
let signed = Types.signed k in
|
|
(* The first value below the range and the first value above it, and then
|
|
the range the condition reports, which is the last value *in* it. *)
|
|
let lo_f = if signed then ldexp (-1.0) (n - 1) else 0.0 in
|
|
let hi_f = if signed then ldexp 1.0 (n - 1) else ldexp 1.0 n in
|
|
let lo_i = if signed then int_min k else 0L in
|
|
let hi_i =
|
|
if signed then Int64.sub (Int64.shift_left 1L (n - 1)) 1L
|
|
else if n = 64 then -1L
|
|
else Int64.sub (Int64.shift_left 1L n) 1L
|
|
in
|
|
(* LLVM takes a double constant as the hex of its bits, which is the only
|
|
spelling that cannot lose anything on the way through. *)
|
|
let dbl x = Printf.sprintf "0x%016Lx" (Int64.bits_of_float x) in
|
|
let a = fresh f in
|
|
ins f "%s = fcmp oge double %s, %s" a v (dbl lo_f);
|
|
let b = fresh f in
|
|
ins f "%s = fcmp olt double %s, %s" b v (dbl hi_f);
|
|
let ok = fresh f in
|
|
ins f "%s = and i1 %s, %s" ok a b;
|
|
signal_block f loc ~guard ok (fun id nn ->
|
|
ins f
|
|
"call void @flan_arith_error(ptr %s, i64 %d, i32 %d, i64 %Ld, i64 %Ld, \
|
|
ptr %s)"
|
|
id nn arith_cast_range lo_i hi_i xfer_param)
|
|
end
|
|
|
|
(* [at] is strict: the last valid index is len - 1. *)
|
|
let check_at f ~guard loc idx len =
|
|
if f.md.checks then begin
|
|
let ok = fresh f in
|
|
ins f "%s = icmp ult i64 %s, %s" ok idx len;
|
|
signal_block f loc ~guard ok (fun id n ->
|
|
ins f "call void @flan_bounds_error(ptr %s, i64 %d, i64 %s, i64 %s, ptr %s)"
|
|
id n idx len xfer_param)
|
|
end
|
|
|
|
(* [slice] is not: a slice ending at len — or an empty one at lo = len — is
|
|
legal, and its one-past-the-end gep is defined. [lo <= hi] is not redundant
|
|
with it, because a reversed range would otherwise yield hi - lo as a huge
|
|
unsigned length, which is a worse hole than the missing check. *)
|
|
let check_slice f ~guard loc lo hi len =
|
|
if f.md.checks then begin
|
|
let a = fresh f in
|
|
ins f "%s = icmp ule i64 %s, %s" a lo hi;
|
|
let b = fresh f in
|
|
ins f "%s = icmp ule i64 %s, %s" b hi len;
|
|
let ok = fresh f in
|
|
ins f "%s = and i1 %s, %s" ok a b;
|
|
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)
|
|
end
|
|
|
|
(* ── Expressions ───────────────────────────────────────────────────── *)
|
|
|
|
let icmp_op signed = function
|
|
| Tast.Eq -> "eq" | Tast.Ne -> "ne"
|
|
| Tast.Lt -> if signed then "slt" else "ult"
|
|
| Tast.Le -> if signed then "sle" else "ule"
|
|
| Tast.Gt -> if signed then "sgt" else "ugt"
|
|
| Tast.Ge -> if signed then "sge" else "uge"
|
|
| _ -> assert false
|
|
|
|
let fcmp_op = function
|
|
| Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt"
|
|
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
|
|
| _ -> assert false
|
|
|
|
(* Every [Tast] node already carries the position it was read from, and until
|
|
now nothing wrote them out. The location is set for the duration of a node's
|
|
own emission and restored afterwards, so instructions a parent emits *after*
|
|
a child -- the branch at the end of an [if], the store of a [set] -- are
|
|
attributed to the parent and not to whatever ran last inside it. *)
|
|
let rec value f (e : Tast.expr) : string =
|
|
match f.dsub with
|
|
| None -> value_at f e
|
|
| Some _ ->
|
|
let saved = f.dloc in
|
|
at_loc f e.Tast.loc;
|
|
let v = value_at f e in
|
|
f.dloc <- saved;
|
|
v
|
|
|
|
(* The [!DILocation] for a position, memoised: a loop body emits the same few
|
|
lines over and over and each would otherwise make its own node. *)
|
|
and at_loc f (loc : Loc.t) =
|
|
match f.md.dbg, f.dsub with
|
|
| Some d, Some sub ->
|
|
(* Line 0 is [Loc.unknown] -- a node the checker made up rather than one
|
|
anyone wrote. It is attributed to the function's own line instead, since
|
|
a zero line in DWARF means "no line" and would make lldb step over the
|
|
whole construct. *)
|
|
let line = if loc.Loc.line = 0 then f.dline else loc.Loc.line in
|
|
let key = Printf.sprintf "%d:%d:%d" sub line loc.Loc.col in
|
|
let id =
|
|
match Hashtbl.find_opt d.dlocs key with
|
|
| Some id -> id
|
|
| None ->
|
|
let id =
|
|
dnode d
|
|
(Printf.sprintf "!DILocation(line: %d, column: %d, scope: !%d)"
|
|
line loc.Loc.col sub)
|
|
in
|
|
Hashtbl.replace d.dlocs key id; id
|
|
in
|
|
f.dloc <- Printf.sprintf ", !dbg !%d" id
|
|
| _ -> ()
|
|
|
|
and value_at f (e : Tast.expr) : string =
|
|
match e.Tast.e with
|
|
| Tast.Int (n, _) -> Int64.to_string n
|
|
| Tast.Float (x, k) -> float_const k x
|
|
| Tast.Bool b -> if b then "true" else "false"
|
|
| Tast.Str s -> string_const f.md s
|
|
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
|
| Tast.Uninit _ -> "poison"
|
|
| Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
|
|
(* Everything that denotes a location is a load from its address. *)
|
|
load f (addr f e) e.Tast.ty
|
|
(* The symbol itself, not a load from it: a function's address is a link-time
|
|
constant. The same spelling the handler frames use for a lifted clause. *)
|
|
| Tast.FnAddr (Tast.Flanfn n) -> fname n
|
|
| Tast.FnAddr (Tast.Rtfn n) -> "@" ^ n
|
|
(* A function value someone wrote, which is the one [FnAddr] that is not the
|
|
symbol. In a dev build it is the cell's contents, so that a value taken
|
|
after a redefinition is the new body — the same load a direct call to the
|
|
same name would do, at the point the *address* is taken rather than at the
|
|
call. What that does not give is a value taken before a redefinition and
|
|
called after it: that one is still the old body, because there is nothing
|
|
left to re-resolve once the address is in a slot. Named in docs/BUILT.md rather
|
|
than papered over with a trampoline. *)
|
|
| Tast.FnAddr (Tast.Fnval n) -> body_of f n
|
|
| Tast.Addr p -> fst (place f p)
|
|
| Tast.Prim (p, args) -> prim f e p args
|
|
| Tast.Call (name, args) ->
|
|
(match Hashtbl.find_opt f.md.externs name with
|
|
| Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
|
|
| None -> call f e.Tast.ty name args)
|
|
| Tast.CallPtr (callee, args) -> call_ptr f e.Tast.ty callee args
|
|
| Tast.Do body -> block f body
|
|
| Tast.Let (bs, body) ->
|
|
List.iter
|
|
(fun (slot, v) ->
|
|
let v' = value f v in
|
|
ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot);
|
|
bind_slot f slot)
|
|
bs;
|
|
block f body
|
|
| Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
|
|
| Tast.While (c, body, latch) -> emit_while f c body latch; "zeroinitializer"
|
|
(* A plain branch, and then the block is dead — [term] closes it and [ins]
|
|
drops whatever the checker still had to walk past. The checker proved the
|
|
target exists and is one this jump may reach; here it is an index. *)
|
|
| Tast.Break n ->
|
|
term f "br label %%%s" (fst (List.nth f.loops n));
|
|
"zeroinitializer"
|
|
| Tast.Continue n ->
|
|
term f "br label %%%s" (snd (List.nth f.loops n));
|
|
"zeroinitializer"
|
|
| Tast.Return v ->
|
|
(match v with
|
|
| None -> ret f "zeroinitializer"
|
|
| Some v ->
|
|
let v' = value f v in
|
|
ret f v');
|
|
"zeroinitializer"
|
|
| Tast.Set (p, v) ->
|
|
let ptr, ty = place f p in
|
|
(match v.Tast.e with
|
|
| Tast.Zero _ when emit_bulk_zero f ptr ty -> ()
|
|
| _ ->
|
|
let v' = value f v in
|
|
ins f "store %s %s, ptr %s" (ll ty) v' ptr);
|
|
"zeroinitializer"
|
|
| Tast.Make (_, fields) -> aggregate f e.Tast.ty fields
|
|
| Tast.MakeCase (dname, case, fields) ->
|
|
emit_make_case f dname case fields
|
|
| Tast.CaseField (target, case, i) ->
|
|
load f (case_field_addr f target case i) e.Tast.ty
|
|
| Tast.Arr items -> aggregate f e.Tast.ty items
|
|
| Tast.Some_ v ->
|
|
let v' = value f v in
|
|
let t = ll e.Tast.ty in
|
|
let a = fresh f in
|
|
ins f "%s = insertvalue %s zeroinitializer, i8 1, 0" a t;
|
|
let b = fresh f in
|
|
ins f "%s = insertvalue %s %s, %s %s, 1" b t a (ll v.Tast.ty) v';
|
|
b
|
|
| Tast.Match (s, arms) -> emit_match f e.Tast.ty s arms
|
|
| Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v
|
|
(* The condition crosses as a pointer: a handler runs while the signalling
|
|
frame is still alive, so there is nothing to copy and nothing to own. *)
|
|
| Tast.Signal (Tast.Ssignal, id, c) ->
|
|
let p = addr f c in
|
|
ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
|
|
guard f;
|
|
"zeroinitializer"
|
|
(* §2's diverging variant. [flan_error] does not return unless a handler
|
|
transferred, so the guard is the only way out and the fall-through is
|
|
unreachable. It cannot be marked noreturn for that reason — it does
|
|
return, on exactly one path. *)
|
|
| Tast.Signal (Tast.Serror, id, c) ->
|
|
let p = addr f c in
|
|
let name = struct_name_of c.Tast.ty in
|
|
let nid, nn = string_bytes f.md name in
|
|
ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
|
|
id p xfer_param nid nn;
|
|
guard f;
|
|
term f "unreachable";
|
|
"zeroinitializer"
|
|
| Tast.Handled (frames, body) -> emit_handled f frames body
|
|
| Tast.RestartCase (clauses, body) -> emit_restart_case f e.Tast.ty clauses body
|
|
| Tast.WithAlloc (a, body) -> emit_with_alloc f e.Tast.ty a body
|
|
(* §4's lookup, then the transfer itself: the frame that was found goes into
|
|
the channel and this function leaves through its landing block. Type
|
|
Never, so nothing follows. *)
|
|
| Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) ->
|
|
(* The arguments are already in slots — the checker put them there, so an
|
|
argument that transferred on its own has been guarded before anything
|
|
here runs. *)
|
|
let vals = List.map (fun a -> (value f a, a.Tast.ty)) args in
|
|
let t = fresh f in
|
|
ins f "%s = call ptr @flan_find_restart(i32 %d)" t id;
|
|
let ok = fresh f in
|
|
ins f "%s = icmp ne ptr %s, null" ok t;
|
|
(* No frame offers the name. That is a runtime error at the invoke site —
|
|
not an unwind past everything — because there is nowhere to resume. *)
|
|
fail_block f rloc ok (fun id n ->
|
|
let nid, nn = string_bytes f.md name in
|
|
ins f "call void @flan_restart_fail(ptr %s, i64 %d, ptr %s, i64 %d)"
|
|
id n nid nn);
|
|
(* §3's run-time check. A restart is found by name on a dynamic stack, so
|
|
what it takes is not knowable here: the frame carries its parameter
|
|
count and the hash of how they are spelled, and both are compared.
|
|
The count is not redundant with the hash — it is what makes a 32-bit
|
|
collision between two different signatures harmless in practice — and
|
|
it is also the cheaper half. *)
|
|
let arity = fresh f in
|
|
ins f "%s = load i32, ptr %s" arity (restart_field f t 5);
|
|
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 6);
|
|
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 8);
|
|
let wl = fresh f in
|
|
ins f "%s = load i64, ptr %s" wl (restart_field f t 9);
|
|
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 4);
|
|
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 7)
|
|
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 address of an expression that denotes a location. Anything else is
|
|
spilled to a temporary first, so [(at (f) 0)] on a returned array works. *)
|
|
and addr f (e : Tast.expr) : string =
|
|
match e.Tast.e with
|
|
| Tast.Local i -> f.slots.(i)
|
|
| Tast.Global n -> global_addr f n
|
|
| Tast.Deref p -> value f p
|
|
| Tast.Field (target, i) -> field_addr f target i
|
|
| Tast.Prim (Tast.At, target :: idx) -> fst (element_addr f target idx)
|
|
| _ ->
|
|
let tmp = alloca f e.Tast.ty in
|
|
let v = value f e in
|
|
ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
|
|
tmp
|
|
|
|
and field_addr f (target : Tast.expr) i =
|
|
let base = addr f target in
|
|
(* A union's members all start where the union starts, so the address of one
|
|
is the address of the whole thing and there is no gep to do. The member's
|
|
own type is what the load or the store that follows uses, which is what
|
|
makes the read a reinterpretation of the bytes — with opaque pointers
|
|
that is the entire implementation of punning, and the [i32] and the [f32]
|
|
views of one storage differ in nothing but the instruction that reads
|
|
them. *)
|
|
match target.Tast.ty with
|
|
| Types.Named n when Hashtbl.mem f.md.unions n -> base
|
|
| _ ->
|
|
(* An Option is { i8, T } and has no declared name to gep through, so its
|
|
layout is spelled out instead. Nothing in the surface language reaches a
|
|
field of one -- [match] and [some] are how an Option is opened -- but the
|
|
structural printer does, to read the tag without unwrapping a None. *)
|
|
let sty = match target.Tast.ty with
|
|
| Types.Named n -> sname n
|
|
| Types.Option _ as t -> ll t
|
|
| t -> failwith ("field of " ^ Types.to_string t)
|
|
in
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p sty base i;
|
|
p
|
|
|
|
(* One index per dimension, so [(at grid row col)] is two geps. Indices are
|
|
i32 in Flan and i64 in a gep. *)
|
|
and element_addr f (target : Tast.expr) idx =
|
|
let rec go ptr ty = function
|
|
| [] -> ptr, ty
|
|
| (i : Tast.expr) :: rest ->
|
|
let iv = value f i in
|
|
let i64 = fresh f in
|
|
ins f "%s = sext %s %s to i64" i64 (ll i.Tast.ty) iv;
|
|
(match ty with
|
|
| Types.Array (n, elem) ->
|
|
(* The bound is static; LLVM folds the check away for a literal index. *)
|
|
check_at f ~guard:(fun () -> guard f) i.Tast.loc i64 (Int64.to_string n);
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
|
p (ll ty) ptr i64;
|
|
go p elem rest
|
|
| Types.Slice elem ->
|
|
(* A slice is ptr+len, so step through the pointer it holds. *)
|
|
let s = load f ptr ty in
|
|
let base = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" base s;
|
|
let len = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" len s;
|
|
check_at f ~guard:(fun () -> guard f) i.Tast.loc i64 len;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
|
|
go p elem rest
|
|
| t -> failwith ("index into " ^ Types.to_string t))
|
|
in
|
|
go (addr f target) target.Tast.ty idx
|
|
|
|
and place f (p : Tast.place) : string * Types.t =
|
|
match p with
|
|
| Tast.Plocal i -> f.slots.(i), f.slot_tys.(i)
|
|
| Tast.Pglobal n -> global_addr f n, Hashtbl.find f.md.globals n
|
|
| Tast.Pfield (target, i) ->
|
|
let sn = match target.Tast.ty with
|
|
| Types.Named n -> n | t -> failwith ("field of " ^ Types.to_string t)
|
|
in
|
|
field_addr f target i, field_ty f.md sn i
|
|
| Tast.Pindex (target, idx) -> element_addr f target idx
|
|
| Tast.Pderef target ->
|
|
let t = match target.Tast.ty with
|
|
| Types.Ptr t -> t | t -> failwith ("deref of " ^ Types.to_string t)
|
|
in
|
|
value f target, t
|
|
|
|
(* A struct or fixed-array value, built field by field from zeroinitializer.
|
|
The checker already filled the omitted fields in with Zero, so this is
|
|
simply every field in declaration order. *)
|
|
(* A data type value, built in memory rather than with [insertvalue], because the
|
|
payload's declared type is a blob of integers and the case's fields are not:
|
|
the two views of the same bytes are what a gep expresses and what a chain of
|
|
[insertvalue] cannot. The alloca is what [mem2reg] removes when nobody takes
|
|
an address of it. *)
|
|
and emit_make_case f dname case fields =
|
|
let ty = Types.Named dname in
|
|
let u = Hashtbl.find f.md.datas dname in
|
|
let tag = match Tast.case_index u case with
|
|
| Some (i, _) -> i
|
|
| None -> failwith ("no case " ^ case ^ " of " ^ dname)
|
|
in
|
|
let tmp = alloca f ty in
|
|
ins f "store %s zeroinitializer, ptr %s" (ll ty) tmp;
|
|
let tp = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname dname) tmp;
|
|
ins f "store i32 %d, ptr %s" tag tp;
|
|
if fields <> [] then begin
|
|
let pp = payload_addr f dname tmp in
|
|
let cty = sname (dname ^ "." ^ case) in
|
|
List.iteri
|
|
(fun i (p : Tast.expr) ->
|
|
let v = value f p in
|
|
let fp = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" fp cty pp i;
|
|
ins f "store %s %s, ptr %s" (ll p.Tast.ty) v fp)
|
|
fields
|
|
end;
|
|
load f tmp ty
|
|
|
|
(* The payload blob's address. A data type with no payload has no field 1, so this
|
|
is only ever reached for one that has fields to reach. *)
|
|
and payload_addr f dname base =
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 1" p (sname dname) base;
|
|
p
|
|
|
|
(* The address of one field of one case of a data type value. The single place in
|
|
this backend that knows how a payload is read, so [match]'s binds and the
|
|
structural printer cannot come to different conclusions about it. *)
|
|
and case_field_addr f (target : Tast.expr) case i =
|
|
let dname = match target.Tast.ty with
|
|
| Types.Named n -> n
|
|
| t -> failwith ("case field of " ^ Types.to_string t)
|
|
in
|
|
let base = addr f target in
|
|
let pp = payload_addr f dname base in
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
|
|
p (sname (dname ^ "." ^ case)) pp i;
|
|
p
|
|
|
|
and aggregate f ty parts =
|
|
let t = ll ty in
|
|
let acc = ref "zeroinitializer" in
|
|
List.iteri
|
|
(fun i (p : Tast.expr) ->
|
|
let v = value f p in
|
|
let next = fresh f in
|
|
ins f "%s = insertvalue %s %s, %s %s, %d" next t !acc (ll p.Tast.ty) v i;
|
|
acc := next)
|
|
parts;
|
|
!acc
|
|
|
|
and block f body =
|
|
match body with
|
|
| [] -> "zeroinitializer"
|
|
| _ ->
|
|
let last = ref "zeroinitializer" in
|
|
List.iter (fun e -> last := value f e) body;
|
|
!last
|
|
|
|
(* The current body of a named Flan function, as something callable. A release
|
|
build is the symbol; a dev build is whatever the indirection cell holds, and
|
|
there are two spellings of that because a function this module emitted has
|
|
its cell as a symbol and one it does not has only a cached address. *)
|
|
and body_of f flan =
|
|
if not f.md.dev then fname flan
|
|
else if f.md.known flan then begin
|
|
let p = fresh f in
|
|
ins f "%s = load ptr, ptr %s" p (cellname flan);
|
|
p
|
|
end else begin
|
|
(* The cell itself is not a symbol here; its address was looked up by
|
|
name at install time and cached. *)
|
|
let c = fresh f in
|
|
ins f "%s = load ptr, ptr %s" c (cellptr flan);
|
|
let p = fresh f in
|
|
ins f "%s = load ptr, ptr %s" p c;
|
|
p
|
|
end
|
|
|
|
and call f ret flan args =
|
|
let vs = map_lr (fun (a : Tast.expr) ->
|
|
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
|
|
(* The cell is loaded *after* the arguments, so a redefinition that lands
|
|
between two calls still cannot land in the middle of one. *)
|
|
let callee = body_of f flan in
|
|
call_through f ret callee vs
|
|
|
|
(* A call through a function value. Identical to the direct case once the
|
|
callee is in hand — a Flan function's signature is its parameters followed
|
|
by the transfer channel whether it was reached by name or by pointer — so
|
|
the guard after it is the same guard, and a [return] out of a callee taken
|
|
as a value transfers exactly as one out of a callee named does.
|
|
|
|
The callee is evaluated *before* the arguments, which is the order it is
|
|
written in and the order a reader expects; the direct case is the other way
|
|
round for a reason that does not apply here (there is no cell to keep out of
|
|
the middle of an argument list). *)
|
|
and call_ptr f ret callee args =
|
|
let c = value f callee in
|
|
let vs = map_lr (fun (a : Tast.expr) ->
|
|
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
|
|
call_through f ret c vs
|
|
|
|
and call_through f ret callee vs =
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(%s)" t (ll ret) callee
|
|
(String.concat ", " (vs @ [ "ptr " ^ xfer_param ]));
|
|
guard f;
|
|
t
|
|
|
|
(* The check after a call, which is the whole of §6's lowering at a call site:
|
|
a load, a compare and a branch that reads like ordinary code. A foreign call
|
|
gets none — a transfer cannot cross a C frame, so there is nothing a guard
|
|
there could find. *)
|
|
and guard f =
|
|
if f.live then begin
|
|
let t = fresh f in
|
|
ins f "%s = load ptr, ptr %s" t xfer_param;
|
|
let c = fresh f in
|
|
ins f "%s = icmp ne ptr %s, null" c t;
|
|
let cont = fresh_label f "on" in
|
|
let pad = current_pad f in
|
|
term f "br i1 %s, label %%%s, label %%%s" c pad cont;
|
|
label f cont
|
|
end
|
|
|
|
and current_pad f =
|
|
match f.pads with
|
|
| (p, used) :: _ -> used := true; p
|
|
| [] -> f.unwound <- true; f.unwind
|
|
|
|
(* A foreign call, where the same rule applies as to the runtime shims: a slice
|
|
or a string crosses as ptr+len and never as a struct by value. Every other
|
|
argument type is a scalar, because [check.ml] rejects an extern signature
|
|
that would need an aggregate — that is the shim's job, in C, where clang
|
|
knows the target's calling convention. *)
|
|
and extern_call f ret name args =
|
|
let vs =
|
|
List.concat_map
|
|
(fun (a : Tast.expr) ->
|
|
match a.Tast.ty with
|
|
| Types.String | Types.Slice _ ->
|
|
let p, n = explode f a in
|
|
[ Printf.sprintf "ptr %s" p; Printf.sprintf "i64 %s" n ]
|
|
| ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
|
|
args
|
|
in
|
|
if is_void ret then begin
|
|
ins f "call void %s(%s)" name (String.concat ", " vs);
|
|
"zeroinitializer"
|
|
end else begin
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
|
|
t
|
|
end
|
|
|
|
(* Establishing a handler is two stores and a push, per spec-conditions.md §2,
|
|
and the frame lives on this function's own stack. Popping is by frame rather
|
|
than by count: restoring what this one displaced is right even if something
|
|
below it left the stack out of step.
|
|
|
|
The body may not [return] — the checker rejects that — so the pops here are
|
|
on the only path out. *)
|
|
and emit_handled f frames body =
|
|
let allocated =
|
|
List.map
|
|
(fun (h : Tast.hframe) ->
|
|
let slot = alloca_raw f "%handler" in
|
|
let ty = fresh f in
|
|
ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 1"
|
|
ty slot;
|
|
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 2"
|
|
fp slot;
|
|
(* The clause's body address, deliberately, and not a cell load:
|
|
plan.org makes a top-level function value a stable trampoline over
|
|
its cell, but a handler frame is not one — nothing can name it, and
|
|
it lives only for this body. A reload landing while it is on the
|
|
stack finds what it pushed still valid, which is what "old code is
|
|
never unloaded" means. See NEXT.md, conditions step 1. *)
|
|
ins f "store ptr %s, ptr %s" (fname h.Tast.hfn) fp;
|
|
ins f "call void @flan_handler_push(ptr %s)" slot;
|
|
slot)
|
|
frames
|
|
in
|
|
let pop () =
|
|
(* Innermost first, which is the order they were pushed in reverse. *)
|
|
List.iter
|
|
(fun slot -> ins f "call void @flan_handler_pop(ptr %s)" slot)
|
|
(List.rev allocated)
|
|
in
|
|
let ld = fresh_label f "endhandled" in
|
|
let pad = fresh_label f "hxfer" and used = ref false in
|
|
f.pads <- (pad, used) :: f.pads;
|
|
let last = block f body in
|
|
f.pads <- List.tl f.pads;
|
|
ignore last;
|
|
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; "zeroinitializer" 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 i =
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %%restart, ptr %s, i32 0, i32 %d" p slot i;
|
|
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 1);
|
|
(* 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 2);
|
|
ins f "store i64 %d, ptr %s" slen (restart_field f slot 3);
|
|
(* §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 5);
|
|
ins f "store i32 %d, ptr %s" c.Tast.rsig_id (restart_field f slot 6);
|
|
let gid, glen = string_bytes f.md c.Tast.rsig in
|
|
ins f "store ptr %s, ptr %s" gid (restart_field f slot 8);
|
|
ins f "store i64 %d, ptr %s" glen (restart_field f slot 9);
|
|
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 4);
|
|
(* 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 7);
|
|
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 7);
|
|
let ok = fresh f in
|
|
ins f "%s = icmp ne i32 %s, 0" ok armed;
|
|
(* Aimed here by something that supplied no arguments — there is no such
|
|
path from an [invoke-restart], so this is the break loop taking a
|
|
restart it cannot yet fill in. Refused with the reason, rather than
|
|
running the clause on a buffer nobody wrote. *)
|
|
fail_block f (List.hd c.Tast.rbody).Tast.loc ok (fun id n ->
|
|
let nid, nn = string_bytes f.md c.Tast.rname in
|
|
let gid, gn = string_bytes f.md c.Tast.rsig in
|
|
ins f
|
|
"call void @flan_restart_unarmed(ptr %s, i64 %d, ptr %s, i64 %d, \
|
|
ptr %s, i64 %d)" id n nid nn gid gn);
|
|
List.iteri
|
|
(fun i (slot_i, ty) ->
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
|
|
p (args_type c) buf i;
|
|
let v = load f p ty in
|
|
ins f "store %s %s, ptr %s" (ll ty) v f.slots.(slot_i);
|
|
bind_slot f slot_i)
|
|
c.Tast.rparams
|
|
in
|
|
let rec dispatch = function
|
|
| [] ->
|
|
ins f "store ptr %s, ptr %s" tgt xfer_param;
|
|
term f "br label %%%s" (current_pad f)
|
|
| (slot, (c : Tast.rclause)) :: rest ->
|
|
let hit = fresh_label f "restart" and next = fresh_label f "outer" in
|
|
let t = fresh f in
|
|
ins f "%s = icmp eq ptr %s, %s" t tgt slot;
|
|
term f "br i1 %s, label %%%s, label %%%s" t hit next;
|
|
label f hit;
|
|
bind_params slot c;
|
|
yield (block f c.Tast.rbody);
|
|
label f next;
|
|
dispatch rest
|
|
in
|
|
dispatch (List.combine frames clauses);
|
|
if not !reached then begin f.live <- false; "zeroinitializer" end
|
|
else begin
|
|
label f ld;
|
|
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
|
end
|
|
|
|
and emit_if f ty c t e =
|
|
let cv = value f c in
|
|
let lt = fresh_label f "then" and le = fresh_label f "else"
|
|
and ld = fresh_label f "endif" in
|
|
let result = if is_void ty then None else Some (alloca f ty) in
|
|
term f "br i1 %s, label %%%s, label %%%s" cv lt le;
|
|
let arm lbl (branch : Tast.expr) =
|
|
label f lbl;
|
|
let v = value f branch in
|
|
(match result with
|
|
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
|
| _ -> ());
|
|
let reached = f.live in
|
|
term f "br label %%%s" ld;
|
|
reached
|
|
in
|
|
let a = arm lt t in
|
|
let b = arm le e in
|
|
if not (a || b) then begin
|
|
(* Both branches diverge, so there is no join: nothing follows. *)
|
|
f.live <- false;
|
|
"zeroinitializer"
|
|
end else begin
|
|
label f ld;
|
|
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
|
end
|
|
|
|
(* Four blocks, not three: the *latch* between the body and the test is what a
|
|
[continue] branches to, and it is where [dotimes] puts its increment. Folded
|
|
onto the end of the body instead, a continue would jump past it and the loop
|
|
would never advance. A [while] has an empty latch and the block is one
|
|
branch, which every optimiser folds away. *)
|
|
and emit_while f c body latch =
|
|
let lc = fresh_label f "loop" and lb = fresh_label f "body"
|
|
and ll = fresh_label f "latch" and le = fresh_label f "endloop" in
|
|
term f "br label %%%s" lc;
|
|
label f lc;
|
|
let cv = value f c in
|
|
term f "br i1 %s, label %%%s, label %%%s" cv lb le;
|
|
label f lb;
|
|
(* Pushed around the body only: the condition and the latch are not inside
|
|
the loop as far as a jump is concerned, and nothing in either is ever a
|
|
break in any case. *)
|
|
f.loops <- (le, ll) :: f.loops;
|
|
List.iter (fun e -> ignore (value f e)) body;
|
|
f.loops <- List.tl f.loops;
|
|
term f "br label %%%s" ll;
|
|
label f ll;
|
|
List.iter (fun e -> ignore (value f e)) latch;
|
|
term f "br label %%%s" lc;
|
|
label f le
|
|
|
|
and emit_match f ty scrut arms =
|
|
(* The two subjects are the same shape and are read differently: an [Option]
|
|
is an SSA aggregate with an i8 tag and its payload in field 1, a declared
|
|
data type is read through its address because its payload is a blob that has
|
|
to be reinterpreted. So the tag and the binds are each produced by one of
|
|
two small functions and everything else below is shared. *)
|
|
let dname =
|
|
match scrut.Tast.ty with
|
|
| Types.Named n when Hashtbl.mem f.md.datas n -> Some n
|
|
| Types.Option _ -> None
|
|
| t -> failwith ("match on " ^ Types.to_string t)
|
|
in
|
|
let tag, read_tag, bind_of =
|
|
match dname with
|
|
| None ->
|
|
let sv = value f scrut in
|
|
let sty = ll scrut.Tast.ty in
|
|
let payload_ty = match scrut.Tast.ty with
|
|
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
|
|
in
|
|
let tag = fresh f in
|
|
ins f "%s = extractvalue %s %s, 0" tag sty sv;
|
|
(tag, (fun c -> ("i8", if c = "Some" then 1 else 0)),
|
|
fun _case _i slot ->
|
|
let v = fresh f in
|
|
ins f "%s = extractvalue %s %s, 1" v sty sv;
|
|
ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot);
|
|
bind_slot f slot)
|
|
| Some n ->
|
|
let u = Hashtbl.find f.md.datas n in
|
|
(* Evaluated once, into a place, so that a scrutinee that is a call is
|
|
not re-run per arm. [addr] already spills a non-place for us. *)
|
|
let base = addr f scrut in
|
|
let tp = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname n) base;
|
|
let tag = fresh f in
|
|
ins f "%s = load i32, ptr %s" tag tp;
|
|
(tag,
|
|
(fun c ->
|
|
match Tast.case_index u c with
|
|
| Some (i, _) -> ("i32", i)
|
|
| None -> failwith ("no case " ^ c ^ " of " ^ n)),
|
|
fun case i slot ->
|
|
let pp = payload_addr f n base in
|
|
let fp = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
|
|
fp (sname (n ^ "." ^ case)) pp i;
|
|
let fty =
|
|
match Tast.case_index u case with
|
|
| Some (_, c) -> (List.nth c.Tast.vfields i).Tast.fty
|
|
| None -> failwith ("no case " ^ case ^ " of " ^ n)
|
|
in
|
|
let v = load f fp fty in
|
|
ins f "store %s %s, ptr %s" (ll fty) v f.slots.(slot);
|
|
bind_slot f slot)
|
|
in
|
|
let ld = fresh_label f "endmatch" in
|
|
let result = if is_void ty then None else Some (alloca f ty) in
|
|
let reached = ref false in
|
|
let rec go = function
|
|
| [] -> term f "unreachable" (* the checker proved exhaustiveness *)
|
|
| (a : Tast.arm) :: rest ->
|
|
let lb = fresh_label f "arm" and ln = fresh_label f "next" in
|
|
(match a.Tast.acase with
|
|
| None -> term f "br label %%%s" lb
|
|
| Some c ->
|
|
let ity, want = read_tag c in
|
|
let t = fresh f in
|
|
ins f "%s = icmp eq %s %s, %d" t ity tag want;
|
|
term f "br i1 %s, label %%%s, label %%%s" t lb ln);
|
|
label f lb;
|
|
List.iteri
|
|
(fun i slot ->
|
|
bind_of (match a.Tast.acase with Some c -> c | None -> "") i slot)
|
|
a.Tast.binds;
|
|
let v = block f a.Tast.abody in
|
|
(match result with
|
|
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
|
| _ -> ());
|
|
if f.live then reached := true;
|
|
term f "br label %%%s" ld;
|
|
if a.Tast.acase <> None then begin label f ln; go rest end
|
|
in
|
|
go arms;
|
|
if not !reached then begin f.live <- false; "zeroinitializer" end
|
|
else begin
|
|
label f ld;
|
|
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
|
end
|
|
|
|
(* (some x): unwrap Some, else return None from the enclosing function. The
|
|
early return is explicit — a branch to a ret, not platform unwinding, so
|
|
native and wasm32 do the same thing (plan.org, Compilation). *)
|
|
and emit_unwrap f ty v =
|
|
let ov = value f v in
|
|
let oty = ll v.Tast.ty in
|
|
let tag = fresh f in
|
|
ins f "%s = extractvalue %s %s, 0" tag oty ov;
|
|
let isnone = fresh f in
|
|
ins f "%s = icmp eq i8 %s, 0" isnone tag;
|
|
let ln = fresh_label f "none" and lc = fresh_label f "some" in
|
|
term f "br i1 %s, label %%%s, label %%%s" isnone ln lc;
|
|
label f ln;
|
|
ret f "zeroinitializer";
|
|
label f lc;
|
|
let out = fresh f in
|
|
ins f "%s = extractvalue %s %s, 1" out oty ov;
|
|
ignore ty;
|
|
out
|
|
|
|
(* ── Primitives ────────────────────────────────────────────────────── *)
|
|
|
|
and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
|
match p, args with
|
|
| (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let op = match x.Tast.ty, p with
|
|
| Types.Float _, Tast.Add -> "fadd" | Types.Float _, Tast.Sub -> "fsub"
|
|
| Types.Float _, Tast.Mul -> "fmul" | Types.Float _, Tast.Div -> "fdiv"
|
|
| Types.Float _, _ -> "frem"
|
|
| Types.Int _, Tast.Add -> "add" | Types.Int _, Tast.Sub -> "sub"
|
|
| Types.Int _, Tast.Mul -> "mul"
|
|
| Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
|
|
| Types.Int k, _ -> if Types.signed k then "srem" else "urem"
|
|
| t, _ -> failwith ("arithmetic on " ^ Types.to_string t)
|
|
in
|
|
(* A divide or a remainder by zero, and the one division that overflows,
|
|
signal ArithError. Integers only: IEEE says x / 0.0 is an infinity and
|
|
that is a defined answer somebody may want — the prelude's own
|
|
[rand-f32] divides by a float constant — so guarding a float division
|
|
would be refusing a result the language already promises.
|
|
|
|
A literal divisor is handed through so that the guard can be dropped
|
|
when it cannot fire, which is nearly every division anyone writes. *)
|
|
(match x.Tast.ty, p with
|
|
| Types.Int k, (Tast.Div | Tast.Rem) ->
|
|
let lit = match y.Tast.e with Tast.Int (n, _) -> Some n | _ -> None in
|
|
check_div f ~guard:(fun () -> guard f) e.Tast.loc
|
|
~is_rem:(p = Tast.Rem) k ~lit a b
|
|
| _ -> ());
|
|
let t = fresh f in
|
|
(* No nsw/nuw: arithmetic wraps (plan.org, Types). *)
|
|
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
|
|
t
|
|
| (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let t = fresh f in
|
|
(match x.Tast.ty with
|
|
| Types.Float _ ->
|
|
ins f "%s = fcmp %s %s %s, %s" t (fcmp_op p) (ll x.Tast.ty) a b
|
|
| Types.Int k ->
|
|
ins f "%s = icmp %s %s %s, %s" t (icmp_op (Types.signed k) p)
|
|
(ll x.Tast.ty) a b
|
|
(* An enum is an i32 at run time, and [Types.is_comparable] says so by
|
|
admitting one — the checker was stating an intent the backend never
|
|
honoured, so [(= k :a)] type checked and then died here with no source
|
|
location. Signed, because a member may be declared negative. *)
|
|
| Types.Enum _ ->
|
|
ins f "%s = icmp %s %s %s, %s" t (icmp_op true p) (ll x.Tast.ty) a b
|
|
(* [Types.is_equatable] admits a handle and [is_comparable] does not, so
|
|
only [Eq]/[Ne] arrive here — one unsigned integer compare over the
|
|
packed (index, generation) pair. *)
|
|
| Types.Handle _ ->
|
|
ins f "%s = icmp %s i64 %s, %s" t (icmp_op false p) a b
|
|
| t' -> failwith ("comparison on " ^ Types.to_string t'));
|
|
t
|
|
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
|
|
let a = value f x in
|
|
let b = value f y in
|
|
let op = match x.Tast.ty, p with
|
|
| _, Tast.BitAnd -> "and" | _, Tast.BitOr -> "or"
|
|
| _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
|
|
| Types.Int k, _ -> if Types.signed k then "ashr" else "lshr"
|
|
| t, _ -> failwith ("bitwise on " ^ Types.to_string t)
|
|
in
|
|
(* The count is masked to the operand's width. LLVM makes an over-wide
|
|
shift poison, and a poison return at -O2 is a function that returns
|
|
nothing at all; masking is what the hardware does anyway, and LLVM folds
|
|
the [and] away whenever the count is a constant. [check] has already
|
|
rejected a literal that is out of range, so this only ever fires on a
|
|
computed count. *)
|
|
let b =
|
|
match x.Tast.ty, p with
|
|
| Types.Int k, (Tast.Shl | Tast.Shr) ->
|
|
let m = fresh f in
|
|
ins f "%s = and %s %s, %d" m (ll x.Tast.ty) b (Types.bits k - 1);
|
|
m
|
|
| _ -> b
|
|
in
|
|
let t = fresh f in
|
|
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
|
|
t
|
|
| Tast.Not, [ x ] ->
|
|
let a = value f x in
|
|
let t = fresh f in
|
|
ins f "%s = xor i1 %s, true" t a;
|
|
t
|
|
| Tast.Len, [ x ] ->
|
|
(match x.Tast.ty with
|
|
| Types.Array (n, _) -> Int64.to_string n
|
|
| _ ->
|
|
let v = value f x in
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
let t = fresh f in
|
|
ins f "%s = trunc i64 %s to i32" t n;
|
|
t)
|
|
| Tast.At, target :: idx ->
|
|
let p, elem = element_addr f target idx in
|
|
load f p elem
|
|
| Tast.Slice, [ target; lo; hi ] ->
|
|
(* lo is evaluated once and used twice — as the offset and as part of the
|
|
length — so it must not be emitted twice. *)
|
|
let lov = value f lo in
|
|
let hiv = value f hi in
|
|
let lo64 = fresh f in
|
|
ins f "%s = sext i32 %s to i64" lo64 lov;
|
|
let hi64 = fresh f in
|
|
ins f "%s = sext i32 %s to i64" hi64 hiv;
|
|
(* The source is read once, and the check goes between reading it and the
|
|
gep: the length it is checked against must be the one the gep uses. *)
|
|
let base =
|
|
match target.Tast.ty with
|
|
| Types.Array (n, _) ->
|
|
let a = addr f target in
|
|
check_slice f ~guard:(fun () -> guard f) e.Tast.loc lo64 hi64 (Int64.to_string n);
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
|
p (ll target.Tast.ty) a lo64;
|
|
p
|
|
| Types.Slice elem ->
|
|
let v = value f target in
|
|
let q = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" q v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
check_slice f ~guard:(fun () -> guard f) e.Tast.loc lo64 hi64 n;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) q lo64;
|
|
p
|
|
| Types.String ->
|
|
let v = value f target in
|
|
let q = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" q v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
check_slice f ~guard:(fun () -> guard f) e.Tast.loc lo64 hi64 n;
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
|
|
p
|
|
| t -> failwith ("slice of " ^ Types.to_string t)
|
|
in
|
|
let d = fresh f in
|
|
ins f "%s = sub i64 %s, %s" d hi64 lo64;
|
|
let a = fresh f in
|
|
ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a base;
|
|
let b = fresh f in
|
|
ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a d;
|
|
b
|
|
(* (slice-from-ptr p n): the two words a %slice already is, with the pointer
|
|
the caller handed over and the length the caller promised. No new
|
|
representation — a Slice _ is {ptr, i64} here and in x86.ml, which is
|
|
exactly ptr+len, so this is an insertvalue pair and no more.
|
|
|
|
The check is the *length itself*, not a range: there is nothing to compare
|
|
it against, because the only thing that knows how many elements live
|
|
behind that pointer is the caller. So what is checked is the one half that
|
|
can be — that the promise is not absurd. It is signed, and it has to be:
|
|
[check_slice]'s comparisons are unsigned, and a negative i32 sign-extended
|
|
to i64 is a huge unsigned value that [ule] waves straight through.
|
|
|
|
It goes through [signal_block] for the reason the other two bounds checks
|
|
do — a bad length signals BoundsError and is answerable — and behind
|
|
[f.md.checks] for the reason they are: dropping bounds checks is a release
|
|
decision, not an optimisation one, so this is on at -O0 and -O2 alike and
|
|
off only when checks as a whole were asked off.
|
|
|
|
It has its own runtime function, @flan_slice_promise_error, and that is
|
|
the whole of what it needed. It used to borrow @flan_slice_error — the
|
|
violated condition is 0 <= n, which is a reversed range spelled the other
|
|
way — and the sentence that came out named a range and a length the
|
|
caller never wrote. Since this is the one form whose real condition the
|
|
compiler cannot check, its refusal is the place the caller's promise has
|
|
to be stated, and it was the one place it was not. The signalled
|
|
BoundsError is unchanged: same three fields, so a handler writes one
|
|
clause for every bad index in the language. *)
|
|
| Tast.SliceFromPtr, [ p; n ] ->
|
|
let pv = value f p in
|
|
let nv = value f n in
|
|
let n64 = fresh f in
|
|
ins f "%s = sext i32 %s to i64" n64 nv;
|
|
if f.md.checks then begin
|
|
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)
|
|
end;
|
|
let a = fresh f in
|
|
ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a pv;
|
|
let b = fresh f in
|
|
ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a n64;
|
|
b
|
|
(* string and [u8] have the same layout, so bytes is the identity — a view,
|
|
no copy (plan.org, Milestone-2 primitives). *)
|
|
| Tast.Bytes, [ x ] -> value f x
|
|
(* (string b), and the same non-instruction for the same reason: String and
|
|
Slice _ are both %slice. See check.ml's "string" case. *)
|
|
| Tast.StrOfBytes, [ x ] -> value f x
|
|
| Tast.BytesToF64, [ x ] -> shim_in f "@flan_bytes_to_f64" "double" x
|
|
| Tast.BytesToI64, [ x ] -> shim_in f "@flan_bytes_to_i64" "i64" x
|
|
(* The second argument is the caller's buffer — a frame slot the checker gave
|
|
this call site, so that two conversions in one expression are two buffers.
|
|
See check.ml's [to_bytes]. *)
|
|
| Tast.F64ToBytes, [ x; b ] -> shim_out f "@flan_f64_to_bytes" x b
|
|
| Tast.I64ToBytes, [ x; b ] -> shim_out f "@flan_i64_to_bytes" x b
|
|
| Tast.U64ToBytes, [ x; b ] -> shim_out f "@flan_u64_to_bytes" x b
|
|
| Tast.EscapeBytes, [ x ] -> shim_in_out f "@flan_escape_bytes" x
|
|
| Tast.WriteStdout, [ x ] ->
|
|
let p, n = explode f x in
|
|
ins f "call void @flan_write_stdout(ptr %s, i64 %s)" p n;
|
|
"zeroinitializer"
|
|
| Tast.Exit, [ x ] ->
|
|
let v = value f x in
|
|
ins f "call void @flan_exit(i32 %s)" v;
|
|
term f "unreachable";
|
|
"zeroinitializer"
|
|
| Tast.Argv, [] ->
|
|
let tmp = alloca f (Types.Slice Types.String) in
|
|
ins f "call void @flan_argv(ptr %s)" tmp;
|
|
load f tmp (Types.Slice Types.String)
|
|
(* One arm for every runtime entry point the allocator and container runtime
|
|
has. The result type is the node's own and the argument types are the
|
|
arguments' own, so nothing here has to know which symbol it is calling. *)
|
|
(* The allocation registry's notes are the one family in here a release
|
|
build drops on the floor, and the drop has to happen before the arguments
|
|
are walked rather than after: a note takes the address of the container it
|
|
is describing, and emitting that address only to discard the call would
|
|
leave an escaped alloca behind for mem2reg to refuse. So this is a
|
|
[Types.t] the checker built and the backend declines to use, which is the
|
|
same arrangement the indirection cells and the shadow stack have — the
|
|
checker does not know whether this is a dev build and does not have to. *)
|
|
| Tast.Rt sym, _
|
|
when (not f.md.dev)
|
|
&& String.length sym > 17
|
|
&& String.equal (String.sub sym 0 17) "flan_dev_reg_note" ->
|
|
"zeroinitializer"
|
|
| Tast.Rt sym, args ->
|
|
let vs =
|
|
List.concat
|
|
(map_lr
|
|
(fun (a : Tast.expr) ->
|
|
match a.Tast.ty with
|
|
| Types.String | Types.Slice _ ->
|
|
let p, n = explode f a in
|
|
[ "ptr " ^ p; "i64 " ^ n ]
|
|
| Types.Unit | Types.Never -> []
|
|
(* A Vec and a Map are move-only and never copied, so each
|
|
crosses to the runtime as its address — which is also what
|
|
lets an operation mutate the caller's container in place.
|
|
Passing the header by value here would hand the runtime a
|
|
copy to grow and leave the caller's untouched. *)
|
|
| Types.Vec _ | Types.Map _ | Types.Pool _ -> [ "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;
|
|
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 f x
|
|
| Tast.Cast target, [ x ] -> cast f ~guard:(fun () -> guard f) x target
|
|
| _ -> failwith "malformed primitive"
|
|
|
|
(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
|
|
and explode f (x : Tast.expr) =
|
|
let v = value f x in
|
|
let p = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" p v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
p, n
|
|
|
|
and shim_in f name ret x =
|
|
let p, n = explode f x in
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(ptr %s, i64 %s)" t ret name p n;
|
|
t
|
|
|
|
and shim_out f name (x : Tast.expr) (buf : Tast.expr) =
|
|
let v = value f x in
|
|
let b = value f buf in
|
|
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
|
|
ins f "call void %s(%s %s, ptr %s, ptr %s)" name (ll x.Tast.ty) v b tmp;
|
|
load f tmp (Types.Slice (Types.Int Types.U8))
|
|
|
|
(* Slice in, slice out: [shim_in] returns a scalar and [shim_out] takes one, so
|
|
a shim that transforms bytes into bytes is neither. *)
|
|
and shim_in_out f name (x : Tast.expr) =
|
|
let p, n = explode f x in
|
|
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
|
|
ins f "call void %s(ptr %s, i64 %s, ptr %s)" name p n tmp;
|
|
load f tmp (Types.Slice (Types.Int Types.U8))
|
|
|
|
and cast f ~guard (x : Tast.expr) target =
|
|
let v = value f x in
|
|
(* An enum is an i32 at run time and its own type only in the checker, so a
|
|
cast involving one is a cast on that i32. Nothing in the surface language
|
|
produces this — a keyword resolves against the enum and never widens — but
|
|
the REPL's renderer needs an enum's number when it falls outside the
|
|
declared members. *)
|
|
let concrete (t : Types.t) =
|
|
match t with
|
|
| Types.Enum _ -> Types.Int Types.I32
|
|
(* A handle already *is* an i64 — see [ll] — so a cast involving one
|
|
changes the reading and never the bits. [pool-handle] tests one against
|
|
the never-valid zero, and the renderer splits one into its index and
|
|
its generation. Unsigned, because both halves are. *)
|
|
| Types.Handle _ -> Types.Int Types.U64
|
|
| t -> t
|
|
in
|
|
let src = concrete x.Tast.ty and target = concrete target in
|
|
let src_loc = x.Tast.loc in
|
|
if Types.equal src target then v
|
|
else
|
|
let op =
|
|
match src, target with
|
|
| Types.Int a, Types.Int b ->
|
|
if Types.bits b < Types.bits a then "trunc"
|
|
else if Types.bits b = Types.bits a then "bitcast"
|
|
else if Types.signed a then "sext" else "zext"
|
|
| Types.Int a, Types.Float _ -> if Types.signed a then "sitofp" else "uitofp"
|
|
(* The one cast that can have no answer. LLVM calls an out-of-range
|
|
fptosi undefined and will fold it to anything; x86 produces a fixed
|
|
"integer indefinite". Neither is a result, so the value is tested
|
|
against the destination's range first and signals ArithError when it
|
|
misses. See [check_cast], which is also where NaN is dealt with. *)
|
|
| Types.Float a, Types.Int b ->
|
|
check_cast f ~guard src_loc a b v;
|
|
if Types.signed b then "fptosi" else "fptoui"
|
|
| Types.Float a, Types.Float b ->
|
|
if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc"
|
|
(* Nothing in the surface language writes this: [check.ml] has no cast
|
|
between pointer types. The locals thunk does — it is handed a slot's
|
|
address as a raw pointer and has to read it as the type the slot
|
|
holds — and under opaque pointers there is no instruction to emit for
|
|
it, both sides being [ptr]. *)
|
|
| Types.Ptr _, Types.Ptr _ -> "bitcast"
|
|
(* Also not written in the surface language. [resolve] needs it: the
|
|
pool 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"
|
|
| _ -> failwith "unsupported cast"
|
|
in
|
|
if op = "bitcast" then v
|
|
else begin
|
|
let t = fresh f in
|
|
ins f "%s = %s %s %s to %s" t op (ll src) v (ll target);
|
|
t
|
|
end
|
|
|
|
(* ── Functions ─────────────────────────────────────────────────────── *)
|
|
|
|
(* The one place a Flan function's LLVM signature is spelled. A [define] and
|
|
the [declare] a redefinition module needs for the same function have to
|
|
agree exactly, and the way they stop agreeing is one of them growing a case
|
|
for Unit or for a slice parameter that the other never gets. *)
|
|
let signature ~named (fn : Tast.fn) =
|
|
let params =
|
|
List.mapi
|
|
(fun i ty -> if named then Printf.sprintf "%s %%p%d" (ll ty) i else ll ty)
|
|
fn.Tast.params
|
|
in
|
|
(* The transfer channel, spec-conditions.md §6: one [ptr] appended to every
|
|
signature, written by an [invoke-restart] and checked after every call.
|
|
Uniform rather than only on the functions that need it — the spec's escape
|
|
analysis is an optimisation, and in a dev build a cell can hold anything,
|
|
so the honest answer to "what can this call?" is "anything". *)
|
|
let params = params @ [ (if named then "ptr " ^ xfer_param else "ptr") ] in
|
|
Printf.sprintf "%s %s(%s)" (ll fn.Tast.ret) (fname fn.Tast.name)
|
|
(String.concat ", " params)
|
|
|
|
(* [hidden] on a redefinition's own body, and this is load-bearing. Default
|
|
visibility in a shared object is interposable: [@"flan.bump"] inside the
|
|
module would resolve to the *host's* copy, so the installer would publish
|
|
the function it was replacing and the reload would appear to do nothing. *)
|
|
(* The name a slot goes into the debug info under. [Tast.fn.snames] carries the
|
|
source name of every slot the source named, parameters included, so that is
|
|
the answer wherever there is one.
|
|
|
|
A slot with no name is one the compiler invented -- [dotimes]'s hidden
|
|
bound, the pair (min) and (max) evaluate their operands into -- and it keeps
|
|
[s<index>], which is what it actually is. That is deliberate rather than a
|
|
fallback: a synthesized slot has no source name to print, and inventing a
|
|
plausible one would put a variable in the debugger that the programmer
|
|
cannot find in the file. [s4] is honest about being the frame's fourth slot.
|
|
|
|
[snames] is indexed defensively because a driver may build a frame by
|
|
appending arrays ([Session]'s evaluation thunk does), and a short [snames]
|
|
should cost a name, not raise. *)
|
|
let slot_name ~pnames ~snames ~nparams i =
|
|
let named = if i < Array.length snames then snames.(i) else None in
|
|
match named with
|
|
| Some n when n <> "" -> n
|
|
| _ ->
|
|
if i < nparams then
|
|
match List.nth_opt pnames i with
|
|
| Some n when n <> "" -> n
|
|
| _ -> Printf.sprintf "p%d" i
|
|
else Printf.sprintf "s%d" i
|
|
|
|
let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
|
|
let n = Array.length fn.Tast.slots in
|
|
(* The subprogram's id is claimed before the body is emitted, because every
|
|
instruction in the body refers to it, and the node itself is written at
|
|
the end once the retained variables are known. *)
|
|
let dsub = match m.dbg with None -> None | Some d -> Some (dalloc d) in
|
|
let f = {
|
|
md = m;
|
|
allocas = Buffer.create 256;
|
|
b = Buffer.create 1024;
|
|
n = 0;
|
|
live = true;
|
|
ret = fn.Tast.ret;
|
|
slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
|
|
slot_tys = fn.Tast.slots;
|
|
pads = []; loops = []; unwind = "unwind"; unwound = false;
|
|
defers = fn.Tast.fdefers;
|
|
frame = None; slotv = None; snames = fn.Tast.snames;
|
|
dsub;
|
|
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
|
|
dloc = "";
|
|
} in
|
|
(* Every slot is an alloca in the entry block, because [addr] may take the
|
|
address of any of them and mem2reg only promotes entry-block allocas. *)
|
|
Array.iteri
|
|
(fun i ty ->
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " %s = alloca %s\n" f.slots.(i) (ll ty)))
|
|
fn.Tast.slots;
|
|
(* Parameters arrive as SSA values and are stored into their slots at once,
|
|
which is also the copy a value struct gets on assignment. *)
|
|
List.iteri
|
|
(fun i ty ->
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
|
|
fn.Tast.params;
|
|
(* The 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"))
|
|
[ "%frame.i = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 1";
|
|
Printf.sprintf "store ptr %s, ptr %%frame.i" info;
|
|
"%frame.s = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 2";
|
|
Printf.sprintf "store ptr %s, ptr %%frame.s"
|
|
(match f.slotv with Some v -> v | None -> "null");
|
|
"store ptr %frame, ptr @flan_frame_head" ];
|
|
f.frame <- Some prev;
|
|
(* The parameters are bound before the body starts, so they are recorded
|
|
here rather than at a binding site there is none of. *)
|
|
List.iteri (fun i _ ->
|
|
match f.slotv with
|
|
| None -> ()
|
|
| Some v ->
|
|
if i < Array.length fn.Tast.snames && fn.Tast.snames.(i) <> None then begin
|
|
let p = fresh f in
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " %s = getelementptr inbounds ptr, ptr %s, i32 %d\n"
|
|
p v i);
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf " store ptr %s, ptr %s\n" f.slots.(i) p)
|
|
end)
|
|
fn.Tast.params
|
|
end;
|
|
(* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it
|
|
describes. This is the whole of what lldb needs to print a local: the slot
|
|
is ordinary stack storage of an ordinary machine type, so there is no
|
|
accessor to describe and no header to skip. *)
|
|
(match m.dbg, dsub with
|
|
| Some d, Some sub ->
|
|
let file = dfile d fn.Tast.floc.Loc.file in
|
|
let nparams = List.length fn.Tast.params in
|
|
let vars =
|
|
Array.to_list
|
|
(Array.mapi
|
|
(fun i ty ->
|
|
let arg =
|
|
(* [arg:] is 1-based over the LLVM formals, and the transfer
|
|
channel is appended after all of them, so a parameter's
|
|
index is its Flan index either way. The channel itself gets
|
|
no variable: nothing in the language can name it. *)
|
|
if i < nparams then Printf.sprintf ", arg: %d" (i + 1) else ""
|
|
in
|
|
dnode d
|
|
(Printf.sprintf
|
|
"!DILocalVariable(name: \"%s\"%s, scope: !%d, file: !%d, line: %d, type: !%d)"
|
|
(dstr (slot_name ~pnames ~snames:fn.Tast.snames ~nparams i))
|
|
arg sub file f.dline
|
|
(dty m d ty)))
|
|
fn.Tast.slots)
|
|
in
|
|
let dl =
|
|
dnode d
|
|
(Printf.sprintf "!DILocation(line: %d, column: 1, scope: !%d)" f.dline sub)
|
|
in
|
|
List.iteri
|
|
(fun i v ->
|
|
Buffer.add_string f.allocas
|
|
(Printf.sprintf
|
|
" call void @llvm.dbg.declare(metadata ptr %s, metadata !%d, metadata !DIExpression()), !dbg !%d\n"
|
|
f.slots.(i) v dl))
|
|
vars;
|
|
let sty =
|
|
dnode d
|
|
(Printf.sprintf "!DISubroutineType(types: !{%s})"
|
|
(String.concat ", "
|
|
((if is_void fn.Tast.ret then "null"
|
|
else Printf.sprintf "!%d" (dty m d fn.Tast.ret))
|
|
:: List.map (fun t -> Printf.sprintf "!%d" (dty m d t))
|
|
fn.Tast.params)))
|
|
in
|
|
dput d sub
|
|
(Printf.sprintf
|
|
"distinct !DISubprogram(name: \"%s\", linkageName: \"flan.%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})"
|
|
(dstr fn.Tast.name) (dstr fn.Tast.name) file file f.dline sty f.dline
|
|
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 ───────────────────────────────────────────────────────── *)
|
|
|
|
(* A global's initialiser is a compile-time constant: literals live in
|
|
read-only memory and zeroed globals live in BSS and cost nothing to start
|
|
(plan.org, Data model). There is no init-at-startup path, by design. *)
|
|
let rec const m (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Int (n, _) -> Int64.to_string n
|
|
| Tast.Float (x, k) -> float_const k x
|
|
| Tast.Bool b -> if b then "true" else "false"
|
|
| Tast.Str s -> string_const m s
|
|
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
|
| Tast.Uninit _ -> "poison"
|
|
| Tast.Make (_, parts) | Tast.Arr parts ->
|
|
let inner =
|
|
map_lr (fun (p : Tast.expr) ->
|
|
Printf.sprintf "%s %s" (ll p.Tast.ty) (const m p)) parts
|
|
in
|
|
(match e.Tast.ty with
|
|
| Types.Array _ -> "[" ^ String.concat ", " inner ^ "]"
|
|
| _ -> "{ " ^ String.concat ", " inner ^ " }")
|
|
| Tast.Some_ v ->
|
|
Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m v)
|
|
(* A data type's payload is declared as a blob of integers, so a constant of one
|
|
would have to be the case's fields *serialised into those integers* —
|
|
which is a byte-level encoder this compiler does not have, and which could
|
|
not express a string field at all, since that is a pointer the linker has
|
|
to relocate and a byte array has nowhere to put a relocation. Refused by
|
|
name, here, where the rest of the same rule is. A zeroed global is fine
|
|
and needs none of this: it is the first declared case, all-bytes-zero. *)
|
|
| Tast.MakeCase (dname, case, _) ->
|
|
fail e.Tast.loc
|
|
"a global cannot be initialised with %s.%s — a data type's payload is a \
|
|
blob, and writing a case into one at link time needs a byte-level \
|
|
encoder that does not exist (a string field could not be encoded at \
|
|
all). Declare the global zeroed, which is %s.%s, and assign the case \
|
|
you meant in a function"
|
|
dname case dname
|
|
(match Hashtbl.find_opt m.datas dname with
|
|
| Some { Tast.cases = c :: _; _ } -> c.Tast.vname
|
|
| _ -> "its first case")
|
|
| _ ->
|
|
fail e.Tast.loc
|
|
"a global's value must be a compile-time constant — this one is computed"
|
|
|
|
(* 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. *)
|
|
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) (const m g.Tast.ginit))
|
|
|
|
(* ── Program ───────────────────────────────────────────────────────── *)
|
|
|
|
let header = {|; Generated by flan. The layout is C's: no object headers anywhere,
|
|
; so a Flan struct is exactly its C struct and nothing marshals.
|
|
|
|
%slice = type { ptr, i64 }
|
|
; (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, i64 }
|
|
; (Map K V), spec-memory.md — Odin's open-addressed Robin Hood map. Neither key
|
|
; nor value type appears in it, for the same reason: one type-erased runtime,
|
|
; handed the two sizes and a hash/equality pair at each call site.
|
|
%map = type { ptr, i64, i64, ptr, i64, i64 }
|
|
; (Pool T) — slab storage handed out behind (Handle T). Type-erased in exactly
|
|
; the same way; the element type is nowhere in it. items and slots are grown
|
|
; together and share one cap, so a slot index is an index into both.
|
|
%pool = type { ptr, ptr, i64, i64, i64, i64, ptr, i64 }
|
|
; A handler frame: the one it displaced, the condition type it matches, and
|
|
; the lifted function that runs. Allocated on the establishing frame's stack.
|
|
%handler = type { ptr, i32, ptr }
|
|
; A restart frame: the one it displaced and the name it offers. There is no
|
|
; target field, because the frame's own address *is* the target — which makes
|
|
; a transfer's aim exact, and makes re-entering a restart-case work with
|
|
; nothing extra, since each activation allocates its own.
|
|
;
|
|
; Then §3's parameters: the buffer the clause reads them out of — owned by the
|
|
; restart-case, because the invoker's frame is gone by the time a clause runs —
|
|
; how many there are, the hash of how they are spelled, whether anything has
|
|
; filled the buffer in, and that spelling itself for the message when the two
|
|
; ends disagree. The first four fields are what the runtime's own
|
|
; [flan_restart] declares and their offsets do not move.
|
|
%restart = type { ptr, i32, ptr, i64, ptr, i32, i32, i32, ptr, i64 }
|
|
; 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.
|
|
%fninfo = type { ptr, i64, ptr, i64, i32, i32, i32 }
|
|
%flanframe = type { ptr, ptr, ptr }
|
|
@flan_frame_head = external global ptr
|
|
|
|
declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 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_handler_push(ptr)
|
|
declare void @flan_handler_pop(ptr)
|
|
declare void @flan_signal(i32, ptr, ptr)
|
|
declare void @flan_error(i32, ptr, ptr, ptr, i64)
|
|
declare void @flan_restart_push(ptr)
|
|
declare void @flan_restart_pop(ptr)
|
|
declare ptr @flan_find_restart(i32)
|
|
declare void @flan_restart_fail(ptr, i64, ptr, i64) noreturn cold
|
|
declare void @flan_restart_args_fail(ptr, i64, ptr, i64, ptr, i64, ptr, i64) noreturn cold
|
|
declare void @flan_restart_unarmed(ptr, i64, ptr, i64, ptr, i64) noreturn cold
|
|
declare void @flan_transfer_fail(ptr, i64) noreturn cold
|
|
; Not noreturn: each signals BoundsError and returns when something answered
|
|
; it, which is the one path out. The trailing ptr is the transfer channel.
|
|
declare void @flan_bounds_error(ptr, i64, i64, i64, ptr) cold
|
|
declare void @flan_slice_error(ptr, i64, i64, i64, i64, ptr) cold
|
|
declare void @flan_slice_promise_error(ptr, i64, i64, ptr) cold
|
|
; The same shape and the same reason: it signals ArithError and returns when
|
|
; something answered it. The i32 is the op code and the two i64s are the
|
|
; operands, or the destination's range for a cast.
|
|
declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold
|
|
declare ptr @flan_context_allocator()
|
|
declare ptr @flan_context_temp()
|
|
declare ptr @flan_heap_allocator()
|
|
declare ptr @flan_context_set(ptr)
|
|
declare void @flan_context_restore(ptr)
|
|
declare ptr @flan_arena_new(i64)
|
|
declare void @flan_arena_destroy(ptr)
|
|
declare void @flan_alloc_free_all(ptr, ptr, i64)
|
|
declare void @flan_vec_region_only(ptr, ptr, i64)
|
|
declare void @flan_map_region_only(ptr, ptr, i64)
|
|
declare void @flan_pool_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)
|
|
declare void @flan_dev_reg_enable()
|
|
declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64)
|
|
declare void @flan_dev_reg_note_pool(ptr, i64, ptr, i64)
|
|
declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64)
|
|
declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
|
|
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
|
|
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)
|
|
declare i8 @flan_vec_clone(ptr, ptr, ptr, i64, i64, ptr, i64)
|
|
declare 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)
|
|
; (Pool T) and (Handle T). A handle crosses as the i64 it is; the pool, like
|
|
; every other owning container, crosses as its address. [resolve] answers a
|
|
; pointer or null and [pool-handle] answers a packed handle or the never-valid
|
|
; zero, so neither needs a second return value.
|
|
declare i8 @flan_pool_init(ptr, ptr, i64, i64, ptr, i64)
|
|
declare i8 @flan_pool_insert(ptr, ptr, ptr, i64, i64, ptr, i64)
|
|
declare ptr @flan_pool_resolve(ptr, i64, i64, ptr, i64)
|
|
declare i8 @flan_pool_release(ptr, i64, ptr, i64)
|
|
declare i64 @flan_pool_len(ptr, ptr, i64)
|
|
declare i64 @flan_pool_live(ptr, ptr, i64)
|
|
declare i64 @flan_pool_handle(ptr, i32, ptr, i64)
|
|
declare void @flan_pool_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)
|
|
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)
|
|
declare i64 @flan_file_fail_reason()
|
|
declare i8 @flan_slurp_into(ptr, ptr, i64, i64, ptr, i64)
|
|
|}
|
|
|
|
(* C's main, adapting to whichever of the four shapes Flan's main has: argv and
|
|
the i32 status are each optional (plan.org, Milestone-2 primitives). *)
|
|
let emit_main m (fn : Tast.fn) =
|
|
let b = Buffer.create 256 in
|
|
Buffer.add_string b
|
|
(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";
|
|
(* 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);
|
|
let args =
|
|
if fn.Tast.params = [] then ""
|
|
else begin
|
|
Buffer.add_string b " %a = alloca %slice\n";
|
|
Buffer.add_string b " call void @flan_argv(ptr %a)\n";
|
|
Buffer.add_string b " %args = load %slice, ptr %a\n";
|
|
"%slice %args"
|
|
end
|
|
in
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %%r = call %s %s(%s)\n" (ll fn.Tast.ret)
|
|
(fname "main")
|
|
(if args = "" then "ptr " ^ xfer_param else args ^ ", ptr " ^ xfer_param));
|
|
(* Flushing matters: stdout is a FILE* and the acceptance test reads it. *)
|
|
Buffer.add_string b " call void @flan_exit(i32 ";
|
|
Buffer.add_string b
|
|
(if Types.equal fn.Tast.ret (Types.Int Types.I32) then "%r" else "0");
|
|
Buffer.add_string b ")\n unreachable\n}\n";
|
|
Buffer.add_string m.out (Buffer.contents b)
|
|
|
|
(* Everything a module needs before its own definitions: the tables the
|
|
emitters look names up in, the struct types, and the foreign [declare]s.
|
|
Both entry points below start here, so a redefinition module cannot drift
|
|
from the whole-program one in how it names or lays out a type. *)
|
|
(* Which file the compile unit is about. Every subprogram carries its own
|
|
[!DIFile], so this only decides what a debugger calls the unit as a whole;
|
|
the first function anyone actually wrote is the honest answer. *)
|
|
let cu_file (p : Tast.program) =
|
|
match
|
|
List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
|
|
with
|
|
| Some f -> f.Tast.floc.Loc.file
|
|
| None -> "<flan>"
|
|
|
|
let new_dbg (p : Tast.program) =
|
|
let d =
|
|
{ dn = 0; dout = Buffer.create 4096; dfiles = Hashtbl.create 8;
|
|
dtys = Hashtbl.create 32; dlocs = Hashtbl.create 256; dcu = 0 }
|
|
in
|
|
let file = dfile d (cu_file p) in
|
|
d.dcu <- dalloc d;
|
|
(* [isOptimized: false] is not decoration: it is what a debug build is, and
|
|
[Build] sets -O0 to make it true. DW_LANG_C99 because the layout is C's
|
|
and lldb's C support is then exactly right for it. *)
|
|
dput d d.dcu
|
|
(Printf.sprintf
|
|
"distinct !DICompileUnit(language: DW_LANG_C99, file: !%d, producer: \"flan\", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false)"
|
|
file);
|
|
d
|
|
|
|
let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
|
|
(p : Tast.program) =
|
|
let m = {
|
|
out = Buffer.create 8192; strs = Buffer.create 512;
|
|
structs = Hashtbl.create 16; datas = Hashtbl.create 16;
|
|
unions = Hashtbl.create 16;
|
|
globals = Hashtbl.create 16;
|
|
externs = Hashtbl.create 32;
|
|
checks; dev; known; nstr = 0; nfi = 0; sanitize;
|
|
dbg = (if debug then Some (new_dbg p) else None);
|
|
} in
|
|
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
|
|
p.Tast.structs;
|
|
List.iter (fun (u : Tast.data) -> Hashtbl.replace m.datas u.Tast.dname u)
|
|
p.Tast.datas;
|
|
List.iter (fun (u : Tast.structure) -> Hashtbl.replace m.unions u.Tast.sname u)
|
|
p.Tast.unions;
|
|
List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
|
|
p.Tast.globals;
|
|
List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym)
|
|
p.Tast.externs;
|
|
List.iter
|
|
(fun (s : Tast.structure) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { %s }\n" (sname s.Tast.sname)
|
|
(String.concat ", "
|
|
(List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
|
|
p.Tast.structs;
|
|
(* A union is its blob and nothing else: [k x iA], where A is the alignment
|
|
the strictest member needs and k*A is the size of the largest. LLVM has no
|
|
union type, and this is the shape clang gives one — the same shape the
|
|
data type payload below uses, for the same reason, which is that it makes
|
|
LLVM align the storage without an explicit [align] anywhere. Nothing geps
|
|
into it: a member is read through the union's own address. *)
|
|
List.iter
|
|
(fun (u : Tast.structure) ->
|
|
let size, align = union_lay m u in
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { [%d x i%d] }\n" (sname u.Tast.sname)
|
|
(if align = 0 then 0 else size / align) (align * 8)))
|
|
p.Tast.unions;
|
|
(* A data type is a tag and a blob, and each of its cases is a struct laid over
|
|
the blob. Both are emitted as named types so that every reader — a
|
|
construction, a match arm, the structural printer — geps rather than
|
|
computing byte offsets of its own.
|
|
|
|
The blob is [k x iA] where A is the alignment the widest member of any
|
|
case needs: that is what makes LLVM align the payload without an explicit
|
|
[align] on a type, and it is what makes the whole agree with C's
|
|
[struct { int tag; union { ... } u; }] byte for byte. That agreement is
|
|
the point — the macro expander's [Form] has to be the same bytes in the
|
|
compiler and in the dlopened macro. *)
|
|
List.iter
|
|
(fun (u : Tast.data) ->
|
|
List.iter
|
|
(fun (c : Tast.variant) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { %s }\n"
|
|
(sname (u.Tast.dname ^ "." ^ c.Tast.vname))
|
|
(String.concat ", "
|
|
(List.map (fun (f : Tast.field) -> ll f.Tast.fty)
|
|
c.Tast.vfields))))
|
|
u.Tast.cases)
|
|
p.Tast.datas;
|
|
List.iter
|
|
(fun (u : Tast.data) ->
|
|
let size, align = payload_lay m u in
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { i32%s }\n" (sname u.Tast.dname)
|
|
(if size = 0 then ""
|
|
else Printf.sprintf ", [%d x i%d]" (size / align) (align * 8))))
|
|
p.Tast.datas;
|
|
Buffer.add_char m.out '\n';
|
|
(* The foreign declarations. Every struct that crosses this boundary was
|
|
flattened by a C shim, so each of these is scalars only and no calling
|
|
convention has to be reproduced here. *)
|
|
List.iter
|
|
(fun (e : Tast.extern) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "declare %s @%s(%s)\n"
|
|
(ll e.Tast.eret) e.Tast.esym
|
|
(String.concat ", "
|
|
(List.concat_map
|
|
(fun (t : Types.t) ->
|
|
match t with
|
|
| Types.String | Types.Slice _ -> [ "ptr"; "i64" ]
|
|
| t -> [ ll t ])
|
|
e.Tast.eparams))))
|
|
p.Tast.externs;
|
|
if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
|
|
m
|
|
|
|
(* The two named metadata nodes without which none of the above survives:
|
|
LLVM drops every scrap of debug metadata, silently and with no diagnostic,
|
|
if "Debug Info Version" is absent. A build that "works" and shows nothing in
|
|
the debugger is that flag. *)
|
|
let dmodule d =
|
|
let b = Buffer.create 512 in
|
|
Buffer.add_string b
|
|
"\ndeclare void @llvm.dbg.declare(metadata, metadata, metadata)\n\n";
|
|
let dv = dalloc d and div = dalloc d in
|
|
dput d dv "!{i32 7, !\"Dwarf Version\", i32 5}";
|
|
dput d div "!{i32 2, !\"Debug Info Version\", i32 3}";
|
|
Buffer.add_string b (Printf.sprintf "!llvm.dbg.cu = !{!%d}\n" d.dcu);
|
|
Buffer.add_string b
|
|
(Printf.sprintf "!llvm.module.flags = !{!%d, !%d}\n\n" dv div);
|
|
Buffer.add_buffer b d.dout;
|
|
Buffer.contents b
|
|
|
|
let finish m =
|
|
header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
|
|
^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "")
|
|
^ (match m.dbg with None -> "" | Some d -> dmodule d)
|
|
|
|
(* ── The macro boundary ────────────────────────────────────────────── *)
|
|
|
|
(* One thunk per macro, and the only shape the compiler reaches a macro
|
|
through. A macro is [(defn name [args [Form]] Form)], so its own signature
|
|
takes a [%slice] by value and returns a [%"Form"] by value — and LLVM's
|
|
convention for an aggregate passed or returned by value in hand-written IR
|
|
is not promised to be clang's C ABI for the equivalent struct. The unions
|
|
lane verified the *memory* layout of a union against clang, which is a
|
|
different claim, so memory is the agreement that actually exists.
|
|
|
|
So nothing but pointers and scalars crosses:
|
|
|
|
void @"flan.macro.NAME"(ptr %args, i64 %n, ptr %out, ptr %xfer)
|
|
|
|
The thunk builds the slice from (args, n) on this side of the boundary,
|
|
calls the macro, and stores the result through %out. Every aggregate stays
|
|
LLVM-to-LLVM, and the compiler's side is a four-pointer C call. *)
|
|
let macro_thunk m (fn : Tast.fn) =
|
|
let name = fn.Tast.name in
|
|
let ret = ll fn.Tast.ret in
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf
|
|
"define void @%s(ptr %%args, i64 %%n, ptr %%out, ptr %%xfer) {\n\
|
|
entry:\n\
|
|
\ %%s0 = insertvalue %%slice zeroinitializer, ptr %%args, 0\n\
|
|
\ %%s1 = insertvalue %%slice %%s0, i64 %%n, 1\n\
|
|
\ %%r = call %s %s(%%slice %%s1, ptr %%xfer)\n\
|
|
\ store %s %%r, ptr %%out\n\
|
|
\ ret void\n\
|
|
}\n\n"
|
|
(quoted ("flan.macro." ^ name))
|
|
ret (fname name) ret)
|
|
|
|
(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
|
|
[slice], a release build is told to drop them.
|
|
|
|
[macros] names the functions that also get a thunk. It is a list of names
|
|
and not a flag because a macro module carries the whole prelude with it —
|
|
only the handful of functions that were written [defmacro] are reachable
|
|
from outside.
|
|
|
|
[hidden] takes every Flan definition in the module out of the dynamic symbol
|
|
table, and it exists for the one build that is dlopened into a process that
|
|
already has Flan in it: the macro module, loaded into [flan dev]'s merged
|
|
binary. That binary is the program *and* the compiler, linked [-rdynamic] so
|
|
a redefinition module can reach its cells, and [-rdynamic] exports every
|
|
[flan.*] body it has. ELF gives an executable precedence over a shared
|
|
object, so without this the macro module's own copy of a prelude function is
|
|
interposed by the host's — and the two copies are not interchangeable. Twice
|
|
measured, in two different ways:
|
|
|
|
- The host's [flan.rl/with-drawing] is the package's [defmacro] compiled as
|
|
an ordinary function, whose body was qualified at the [Ast] level after
|
|
the quasiquote had already become a string literal. Expanding through the
|
|
host's copy produced an unqualified [begin-drawing] the checker refused.
|
|
- Under [flan dev --x86] the host's bodies are the dev backend's and the
|
|
macro module's caller is LLVM's, which is the crossed pair: a SIGSEGV
|
|
inside [flan.\[clamp\]] during the first expansion, before the program had
|
|
started.
|
|
|
|
The thunks stay at default visibility, because [dlsym] is how the compiler
|
|
reaches them and a hidden symbol is not in the table it searches. Nothing
|
|
else in the module is anybody's to call. The C the module links — the
|
|
runtime, the shims — is untouched by this and goes on binding to the host's
|
|
copy where there is one, which is what keeps [flan_exit_hook] the merged
|
|
build installed in reach of a trap raised inside an expansion. *)
|
|
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
|
|
?(sanitize = false) ?(macros = []) ?(hidden = false)
|
|
(p : Tast.program) : string =
|
|
(* [hidden] and [dev] are opposites and the refusal is here so that they
|
|
cannot be written together by accident. A dev build's whole point is that
|
|
its cells, its globals and [flan.abi.*] are in the dynamic symbol table
|
|
for a redefinition module to bind against; hiding them would leave a host
|
|
that links, runs, and silently installs nothing. There is no such thing as
|
|
a reloadable macro module, so nothing is lost by saying so out loud. *)
|
|
if hidden && dev then
|
|
failwith
|
|
"Emit.program ~hidden ~dev: a dev build exports its cells so that a \
|
|
redefinition module can reach them, and hiding them would break every \
|
|
reload. [hidden] is the macro module's flag and a macro module is not a \
|
|
dev build.";
|
|
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in
|
|
(* One cell per function, initialised to the function this build compiled.
|
|
Nothing has been redefined yet, so a dev build starts out behaving exactly
|
|
like a release one — the indirection is the only difference. *)
|
|
if dev then begin
|
|
(* The ABI marker, defined here so a redefinition module can bind against
|
|
it, and only in a dev build: a release build has no cells and nothing to
|
|
load into one, so it keeps exactly the module text it had before this
|
|
existed. [-rdynamic] is what puts it in the executable's dynamic symbol
|
|
table, and a dev build is the only build that gets that either. *)
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = global i64 0\n" abi_marker_sym);
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = global ptr %s\n" (cellname fn.Tast.name)
|
|
(fname fn.Tast.name)))
|
|
p.Tast.fns;
|
|
(* And the allocation registry is armed, which is the whole of what makes
|
|
it a dev-build feature at run time. A constructor rather than a line in
|
|
[main]: the notes are emitted into every function, a global that a
|
|
[defvar] initialiser allocates runs before main does, and a note that
|
|
arrived before the flag was set would be a block the table never heard
|
|
of. Priority 65535 is the default slot; nothing here needs to beat
|
|
another constructor, only to beat the program. *)
|
|
Buffer.add_string m.out
|
|
"@llvm.global_ctors = appending global [1 x { i32, ptr, ptr }] \
|
|
[{ i32, ptr, ptr } { i32 65535, ptr @flan_dev_reg_enable, ptr null }]\n";
|
|
Buffer.add_char m.out '\n'
|
|
end;
|
|
List.iter (emit_global m ~hidden) p.Tast.globals;
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
emit_fn m ~hidden
|
|
~pnames:(match List.assoc_opt fn.Tast.name pnames with
|
|
| Some ns -> ns | None -> [])
|
|
fn)
|
|
p.Tast.fns;
|
|
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
|
| Some fn -> emit_main m fn
|
|
| None -> ());
|
|
List.iter
|
|
(fun n ->
|
|
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = n) p.Tast.fns with
|
|
| Some fn -> macro_thunk m fn
|
|
| None -> failwith ("no such macro: " ^ n))
|
|
macros;
|
|
finish m
|
|
|
|
(* A list of top-level forms, compiled into their own module against a host
|
|
that is already running — the redefinition unit (NEXT.md, the dev loop).
|
|
[C-c C-c] passes one name, [C-c C-k] passes a file's worth; there is one
|
|
code path either way.
|
|
|
|
The difference from [program] is almost entirely in what this module *does
|
|
not* define:
|
|
|
|
- a global the host has is [external]. Defining it would give the loaded
|
|
object a second copy, and the whole point of reloading into a live process
|
|
is that the state survives: sand's grid is a global, and "edit the code,
|
|
keep the sand" is the demo. So a redefinition can change a function's body
|
|
and can never re-initialise the program's data.
|
|
- a function the host has is reached through its cell, which is the host's
|
|
symbol, so a redefined [settle] calls whatever [move-grain] is current
|
|
rather than carrying a private copy of it.
|
|
- there is no [main]; this module is loaded, not started.
|
|
|
|
A name the host does *not* have is the case ELF cannot express, since there
|
|
is no symbol to bind to and no way to grow one. Those go through
|
|
[flan_dev_cell] / [flan_dev_global], keyed by string, resolved once at
|
|
install time into a module-local slot. See runtime/flan_dev.c.
|
|
|
|
String literals still have to come along: they are this module's own
|
|
constants, and omitting them is an undefined [@.str.N] at link time. *)
|
|
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
|
?(known = fun _ -> true) ?(retains = true)
|
|
?call ?(consts = []) (p : Tast.program) ~fns : string =
|
|
let target name =
|
|
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
|
|
| Some f -> f
|
|
| None -> failwith (Printf.sprintf "no such function: %s" name)
|
|
in
|
|
let targets = List.map target fns in
|
|
(* A clause lifted out of one of these comes with it: its body may have
|
|
changed too, and it is reached by address from inside the module rather
|
|
than through a cell. Every other lifted clause is invisible here — it
|
|
needs no declaration, since nothing in this module names it. *)
|
|
let lifted =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
match f.Tast.fparent with
|
|
| Some p -> List.mem p fns
|
|
| None -> false)
|
|
p.Tast.fns
|
|
in
|
|
(* The rest of the program, as the cell and registry machinery below sees it.
|
|
A lifted clause has neither, so it must not appear in either. *)
|
|
let siblings =
|
|
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
|
|
in
|
|
let m = new_module ~checks ~dev ~known ~debug p in
|
|
(* A thunk the module runs itself is excluded from all of this: it is called
|
|
directly by [flan_reload_call], so it needs no cell, must not be published
|
|
into one, and must not take a registry slot — there are 4096 of those and
|
|
an expression evaluated in a loop would exhaust them. Nothing pointing
|
|
into the module is also what lets the agent unload it afterwards. *)
|
|
let transient f = call = Some f in
|
|
let new_fns =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
(not (known f.Tast.name)) && not (transient f.Tast.name))
|
|
siblings
|
|
and new_globals =
|
|
List.filter (fun (g : Tast.global) -> not (known g.Tast.gname)) p.Tast.globals
|
|
in
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
Buffer.add_string m.out
|
|
(if known g.Tast.gname then
|
|
Printf.sprintf "%s = external %s %s\n" (gname g.Tast.gname)
|
|
(if g.Tast.gconst && not dev then "constant" else "global")
|
|
(ll g.Tast.gty)
|
|
else
|
|
Printf.sprintf "%s = internal global ptr null\n"
|
|
(globalptr g.Tast.gname)))
|
|
p.Tast.globals;
|
|
if dev then begin
|
|
(* The host's ABI marker, and a pointer-sized datum holding its address.
|
|
That datum is a relocation the loader has to resolve while it maps the
|
|
object, so a host built by the other backend — which defines
|
|
[flan.abi.x86] and not this — fails the [dlopen] outright, rather than
|
|
loading and then dying at the first call into a redefined function that
|
|
takes or returns a struct. Hidden, so this module's own copy can never
|
|
be interposed by another loaded module's; the relocation against the
|
|
host's marker is the only part that matters. *)
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = external global i64\n%s = hidden global ptr %s\n\n"
|
|
abi_marker_sym ("@" ^ quoted "flan.abi.require") abi_marker_sym);
|
|
(* The cells are the host's, like the globals. Referencing one is how a
|
|
redefined function reaches its siblings, and storing into one is how it
|
|
replaces itself. A name the host lacks gets a slot instead, filled by
|
|
the installer below. *)
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
if not (transient f.Tast.name) then
|
|
Buffer.add_string m.out
|
|
(if known f.Tast.name then
|
|
Printf.sprintf "%s = external global ptr\n" (cellname f.Tast.name)
|
|
else
|
|
Printf.sprintf "%s = internal global ptr null\n"
|
|
(cellptr f.Tast.name)))
|
|
siblings;
|
|
if new_fns <> [] || new_globals <> [] then
|
|
Buffer.add_string m.out
|
|
"\ndeclare ptr @flan_dev_cell(ptr)\n\
|
|
declare ptr @flan_dev_global(ptr, i64, ptr)\n";
|
|
Buffer.add_char m.out '\n'
|
|
end
|
|
else
|
|
(* Without cells there is nothing to route a call through, so the siblings
|
|
are named directly and every one of them needs a declaration. *)
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
if not (List.exists (String.equal f.Tast.name) fns) then
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "declare %s\n" (signature ~named:false f)))
|
|
siblings;
|
|
(* Hidden for the same reason a redefined body is: default visibility in a
|
|
shared object is interposable, and that applies to taking the address too,
|
|
so a plain reference would resolve to the host's copy of the clause and
|
|
this module would install the very handler it is replacing. *)
|
|
List.iter (fun f -> emit_fn m ~hidden:true f) lifted;
|
|
List.iter (fun f -> emit_fn m ~hidden:dev f) targets;
|
|
if dev then begin
|
|
(* Publishing is a separate, named function rather than a constructor: the
|
|
agent has to choose *when* the swap happens — at a frame boundary, on
|
|
the game thread — and a loader-run ctor would do it during dlopen, on
|
|
whatever thread called it, in the middle of a frame.
|
|
|
|
Order inside it is load-bearing. Every lookup is resolved before any
|
|
body is published, because publishing first exposes a function whose
|
|
slots are still null to anything that calls it. *)
|
|
let b = Buffer.create 512 in
|
|
let n = ref 0 in
|
|
let fresh () = incr n; Printf.sprintf "%%d%d" !n in
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
let t = fresh () in
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n"
|
|
t (cstring m ("flan." ^ f.Tast.name)) t (cellptr f.Tast.name)))
|
|
new_fns;
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
let t = fresh () in
|
|
(* sizeof, spelled the way LLVM spells it: the offset of element one
|
|
of a null pointer. Cheaper than a layout calculator in OCaml that
|
|
would have to agree with LLVM's on every target. *)
|
|
(* Its declared initial value travels with it, as a constant the
|
|
runtime copies on the allocation and ignores afterwards. Without
|
|
this a new (defvar n i64 42) or a new defconst would silently be
|
|
zero — calloc is only the right answer for ZII. *)
|
|
let init = Printf.sprintf "@\".init.%d\"" m.nstr in
|
|
m.nstr <- m.nstr + 1;
|
|
Buffer.add_string m.strs
|
|
(Printf.sprintf "%s = private constant %s %s\n" init
|
|
(ll g.Tast.gty) (const m g.Tast.ginit));
|
|
Buffer.add_string b
|
|
(Printf.sprintf
|
|
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \
|
|
store ptr %s, ptr %s\n"
|
|
t (cstring m ("flan." ^ g.Tast.gname)) (ll g.Tast.gty) init t
|
|
(globalptr g.Tast.gname)))
|
|
new_globals;
|
|
(* A constant whose value the checker never consumed is just bytes in the
|
|
program's memory, so a new value is published the same way a new body
|
|
is: one store, at the frame boundary. One the checker *did* consume is
|
|
in the shape of the program and never gets here — the session refuses
|
|
it. *)
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
if List.exists (String.equal g.Tast.gname) consts then
|
|
Buffer.add_string b
|
|
(Printf.sprintf " store %s %s, ptr %s\n" (ll g.Tast.gty)
|
|
(const m g.Tast.ginit) (gname g.Tast.gname)))
|
|
p.Tast.globals;
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
if transient f.Tast.name then ()
|
|
else if known f.Tast.name then
|
|
Buffer.add_string b
|
|
(Printf.sprintf " store ptr %s, ptr %s\n" (fname f.Tast.name)
|
|
(cellname f.Tast.name))
|
|
else begin
|
|
let t = fresh () in
|
|
Buffer.add_string b
|
|
(Printf.sprintf " %s = load ptr, ptr %s\n store ptr %s, ptr %s\n"
|
|
t (cellptr f.Tast.name) (fname f.Tast.name) t)
|
|
end)
|
|
targets;
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "\ndefine void @flan_reload_install() {\nentry:\n%s ret void\n}\n"
|
|
(Buffer.contents b));
|
|
(* An expression evaluation compiles to a function with nowhere to be
|
|
called from, so the module says so and the agent runs it once — after
|
|
the install, on the game thread, so it sees both the bodies this module
|
|
just published and a program state the program agrees is consistent. *)
|
|
match call with
|
|
| Some fn ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf
|
|
"\ndefine void @flan_reload_call() {\nentry:\n \
|
|
%s = alloca ptr\n store ptr null, ptr %s\n \
|
|
call %s %s(ptr %s)\n ret void\n}\n"
|
|
xfer_param xfer_param (ll Types.Unit) (fname fn) xfer_param);
|
|
(* Nothing outside this module refers to anything in it once the call has
|
|
returned — no cell holds an address in its text, the registry has no
|
|
slot for it, and the value it produced was copied out. So it says so,
|
|
and the agent unloads it. A module that publishes a body can never say
|
|
this: its whole purpose is to leave a pointer behind.
|
|
|
|
[m.nstr = 0] is the third condition and it is about *data*, not text.
|
|
A string literal is emitted into this module's own image, and an
|
|
expression may store one anywhere it likes — [(set msg "tuned")] on a
|
|
string global leaves that global pointing into the mapping the agent
|
|
is about to drop. The next thunk can be mapped at the same address, so
|
|
the result is silent garbage rather than a fault. A module with no
|
|
string constants has nothing in its image anyone could still be
|
|
pointing at; one with any keeps its mapping, which costs a page and is
|
|
the same bargain every redefinition already makes. *)
|
|
(* [retains = false] is a caller saying it knows where every literal in
|
|
this module goes. The [m.nstr] test below is a conservative stand-in
|
|
for that — an expression may store a string literal anywhere it likes,
|
|
and a global left pointing into an unmapped image is silent garbage
|
|
rather than a fault. A locals thunk is the case where the answer is
|
|
known: every literal it emits goes to [flan_dev_emit], which memcpys
|
|
into the result buffer, so nothing outside the module holds an address
|
|
inside it once the call has returned. Without this, clicking through
|
|
the frames of a break loop costs a permanent mapping per click. *)
|
|
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
|
|
Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
|
|
| None -> ()
|
|
end;
|
|
finish m
|