2863 lines
128 KiB
OCaml
2863 lines
128 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)
|
|
|
|
(* ── Types ─────────────────────────────────────────────────────────── *)
|
|
|
|
let rec ll (t : Types.t) =
|
|
match t with
|
|
| Types.Int k -> "i" ^ string_of_int (Types.bits k)
|
|
| Types.Float Types.F32 -> "float"
|
|
| Types.Float Types.F64 -> "double"
|
|
| Types.Bool -> "i1"
|
|
| Types.String | Types.Slice _ -> "%slice"
|
|
| Types.Unit | Types.Never -> "{}"
|
|
| Types.Named n -> sname n
|
|
(* A C enum is an i32 — its own type in the checker, nothing at all here. *)
|
|
| Types.Enum _ -> "i32"
|
|
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
|
|
| Types.Ptr _ -> "ptr"
|
|
(* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a
|
|
copy of one: see Types. Opaque here in the same sense [ptr] is. *)
|
|
| Types.Alloc -> "ptr"
|
|
(* A function value is a code address and nothing else. There is no
|
|
environment beside it — capture does not exist (check.ml refuses it by
|
|
name) — so it is one pointer, the same width as any other, and a backend
|
|
needs to know no more about it than that. *)
|
|
| Types.Fn _ -> "ptr"
|
|
(* ptr + len + cap + allocator, and two more words the runtime owns: see
|
|
flan_rt.c's (Vec T) header for why they are in every build. Nothing in
|
|
this file reads a field of one — every operation is a runtime call taking
|
|
the Vec's address — so the shape is here only so that a slot, a struct
|
|
field and a copy in the IR are the right number of bytes. *)
|
|
| Types.Vec _ -> "%vec"
|
|
(* data + len + log2cap + allocator + gen + epoch. Six words, exactly as the
|
|
Vec's, and read here for exactly the same reason: nothing in this file
|
|
touches a field of one — every operation is a runtime call taking the
|
|
map's address — so the shape exists only so that a slot, a struct field
|
|
and a copy in the IR are the right number of bytes. *)
|
|
| Types.Map _ -> "%map"
|
|
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
|
|
| 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 unions, by name. [Types.Named] covers both a struct and a
|
|
union, 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 union is a type like any other everywhere except at its layout, its
|
|
construction and its match. *)
|
|
unions : (string, Tast.union) 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 ""
|
|
|
|
let field_ty m sn i =
|
|
let s = Hashtbl.find m.structs 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
|
|
(* [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.unions 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 -> 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
|
|
|
|
(* The size and alignment of a union'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 union of payload-less
|
|
cases has a zero-size payload and is a bare tag. *)
|
|
and payload_lay m (u : Tast.union) : 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.unions 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 -> 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
|
|
(* 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
|
|
|
|
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 four 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
|
|
|
|
(* [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 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
|
|
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 (uname, case, fields) ->
|
|
emit_make_case f uname 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
|
|
(* 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 union 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 uname case fields =
|
|
let ty = Types.Named uname in
|
|
let u = Hashtbl.find f.md.unions uname in
|
|
let tag = match Tast.case_index u case with
|
|
| Some (i, _) -> i
|
|
| None -> failwith ("no case " ^ case ^ " of " ^ uname)
|
|
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 uname) tmp;
|
|
ins f "store i32 %d, ptr %s" tag tp;
|
|
if fields <> [] then begin
|
|
let pp = payload_addr f uname tmp in
|
|
let cty = sname (uname ^ "." ^ 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 union with no payload has no field 1, so this
|
|
is only ever reached for one that has fields to reach. *)
|
|
and payload_addr f uname base =
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 1" p (sname uname) base;
|
|
p
|
|
|
|
(* The address of one field of one case of a union 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 uname = 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 uname base in
|
|
let p = fresh f in
|
|
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d"
|
|
p (sname (uname ^ "." ^ 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
|
|
union 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 uname =
|
|
match scrut.Tast.ty with
|
|
| Types.Named n when Hashtbl.mem f.md.unions n -> Some n
|
|
| Types.Option _ -> None
|
|
| t -> failwith ("match on " ^ Types.to_string t)
|
|
in
|
|
let tag, read_tag, bind_of =
|
|
match uname 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.unions 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
|
|
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
|
|
| 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
|
|
(* 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
|
|
| Tast.F64ToBytes, [ x ] -> shim_out f "@flan_f64_to_bytes" x
|
|
| Tast.I64ToBytes, [ x ] -> shim_out f "@flan_i64_to_bytes" x
|
|
| Tast.U64ToBytes, [ x ] -> shim_out f "@flan_u64_to_bytes" x
|
|
| 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. *)
|
|
| Tast.Rt sym, args ->
|
|
let vs =
|
|
List.concat
|
|
(map_lr
|
|
(fun (a : Tast.expr) ->
|
|
match a.Tast.ty with
|
|
| Types.String | Types.Slice _ ->
|
|
let p, n = explode f a in
|
|
[ "ptr " ^ p; "i64 " ^ n ]
|
|
| Types.Unit | Types.Never -> []
|
|
(* A Vec and a Map are move-only and never copied, so each
|
|
crosses to the runtime as its address — which is also what
|
|
lets an operation mutate the caller's container in place.
|
|
Passing the header by value here would hand the runtime a
|
|
copy to grow and leave the caller's untouched. *)
|
|
| Types.Vec _ | Types.Map _ -> [ "ptr " ^ addr f a ]
|
|
| 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 (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 x target
|
|
| _ -> failwith "malformed primitive"
|
|
|
|
(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
|
|
and explode f (x : Tast.expr) =
|
|
let v = value f x in
|
|
let p = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 0" p v;
|
|
let n = fresh f in
|
|
ins f "%s = extractvalue %%slice %s, 1" n v;
|
|
p, n
|
|
|
|
and shim_in f name ret x =
|
|
let p, n = explode f x in
|
|
let t = fresh f in
|
|
ins f "%s = call %s %s(ptr %s, i64 %s)" t ret name p n;
|
|
t
|
|
|
|
and shim_out f name (x : Tast.expr) =
|
|
let v = value f x in
|
|
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
|
|
ins f "call void %s(%s %s, ptr %s)" name (ll x.Tast.ty) v tmp;
|
|
load f tmp (Types.Slice (Types.Int Types.U8))
|
|
|
|
(* 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 (x : Tast.expr) target =
|
|
let v = value f x in
|
|
(* An enum is an i32 at run time and its own type only in the checker, so a
|
|
cast involving one is a cast on that i32. Nothing in the surface language
|
|
produces this — a keyword resolves against the enum and never widens — but
|
|
the REPL's renderer needs an enum's number when it falls outside the
|
|
declared members. *)
|
|
let concrete (t : Types.t) =
|
|
match t with Types.Enum _ -> Types.Int Types.I32 | t -> t
|
|
in
|
|
let src = concrete x.Tast.ty and target = concrete target in
|
|
if Types.equal src target then v
|
|
else
|
|
let op =
|
|
match src, target with
|
|
| Types.Int a, Types.Int b ->
|
|
if Types.bits b < Types.bits a then "trunc"
|
|
else if Types.bits b = Types.bits a then "bitcast"
|
|
else if Types.signed a then "sext" else "zext"
|
|
| Types.Int a, Types.Float _ -> if Types.signed a then "sitofp" else "uitofp"
|
|
| Types.Float _, Types.Int b -> if Types.signed b then "fptosi" else "fptoui"
|
|
| Types.Float a, Types.Float b ->
|
|
if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc"
|
|
(* 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"
|
|
| _ -> 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 union'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 (uname, case, _) ->
|
|
fail e.Tast.loc
|
|
"a global cannot be initialised with %s.%s — a union'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"
|
|
uname case uname
|
|
(match Hashtbl.find_opt m.unions uname 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 (g : Tast.global) =
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = %s %s %s\n" (gname g.Tast.gname)
|
|
(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 }
|
|
; 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 @flan_rt_init(i32, ptr)
|
|
declare void @flan_argv(ptr)
|
|
declare void @flan_write_stdout(ptr, i64)
|
|
declare void @flan_exit(i32)
|
|
declare double @flan_bytes_to_f64(ptr, i64)
|
|
declare i64 @flan_bytes_to_i64(ptr, i64)
|
|
declare void @flan_f64_to_bytes(double, ptr)
|
|
declare void @flan_i64_to_bytes(i64, ptr)
|
|
declare void @flan_u64_to_bytes(i64, 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 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 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 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)
|
|
; (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_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)
|
|
|}
|
|
|
|
(* 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; 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.union) -> Hashtbl.replace m.unions u.Tast.uname 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 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.union) ->
|
|
List.iter
|
|
(fun (c : Tast.variant) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { %s }\n"
|
|
(sname (u.Tast.uname ^ "." ^ c.Tast.vname))
|
|
(String.concat ", "
|
|
(List.map (fun (f : Tast.field) -> ll f.Tast.fty)
|
|
c.Tast.vfields))))
|
|
u.Tast.cases)
|
|
p.Tast.unions;
|
|
List.iter
|
|
(fun (u : Tast.union) ->
|
|
let size, align = payload_lay m u in
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = type { i32%s }\n" (sname u.Tast.uname)
|
|
(if size = 0 then ""
|
|
else Printf.sprintf ", [%d x i%d]" (size / align) (align * 8))))
|
|
p.Tast.unions;
|
|
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. *)
|
|
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
|
|
?(sanitize = false) ?(macros = []) (p : Tast.program) : string =
|
|
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
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
Buffer.add_string m.out
|
|
(Printf.sprintf "%s = global ptr %s\n" (cellname fn.Tast.name)
|
|
(fname fn.Tast.name)))
|
|
p.Tast.fns;
|
|
Buffer.add_char m.out '\n'
|
|
end;
|
|
List.iter (emit_global m) p.Tast.globals;
|
|
List.iter
|
|
(fun (fn : Tast.fn) ->
|
|
emit_fn m
|
|
~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 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
|