JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A struct's dyn fields become markable, so the refusal comes off

Browse Source 
The crux was never where to put a descriptor; it was how an instance finds
one.  A bare struct on the stack has no header to hang a pointer off, and
giving it one would change the layout C interop agrees on, change the stride
of an array and change what embedding a struct in another costs.  So it has
none.  The instance never carries a pointer to its type and the collector
never derives one from the bytes: the pairing of an address with a descriptor
is made at the *push*, by the code that put the value there and therefore
knows its static type.  That is the same trick the shadow stack has always
used, and it makes the stack case the easy one rather than the impossible one.

A descriptor is the size of an instance, a count, and a table of byte offsets,
emitted once per type as private static data.  Flattened, not a graph — a
struct held by value contributes its offsets shifted by where it sits, and a
fixed array contributes its element's once per element — so nesting costs
nothing at run time and there is no recursion in the marker.  The offsets of a
big array would be a big table, and that is capped with a sentence rather than
half of the repeat form item 3 will bring.

Four places a value of such a type can live, and all four are rooted: a frame
slot, a global, the temporary a call's by-value return is spilled into, and
the slot a condition that is not a place is evaluated into.  The last two are
new and are the ones that were not obvious.  A callee roots its dyn words and
pops them in its epilogue, so between the return and the caller's store the
only copy is a register, which a collector that finds its roots by address
cannot see; the same hole was open for a Flan call answering a bare dyn and is
closed here too.  And a condition crosses as a pointer into the signalling
frame while a handler allocates, which is exactly what the original refusal
said could not be made safe.

dyn_roots grows into root_plan and both backends read it, which is what the
older note about one counter deciding both ends was always for.  The aggregate
temporaries are pooled by type rather than handed out in mint order: a
positional supply that drifted would pair an address with another type's
descriptor, and marking arbitrary offsets off a base is corruption where a
missed root is only a bug.  Pooled, the worst a drift can do is run out.

What is still refused is a dyn no static offset can reach — inside a typed
container, in a data type's payload or a union's members where the cases
overlay, or under an Option where the payload exists only beneath the tag.
A (Ptr S) and a [S] are deliberately not on that list: neither owns storage,
and the only storage this compiler hands out for such a type is a frame slot,
a global or a fixed array in one, all of them already rooted.  That is what
lets a handler clause take its (Ptr Cond) and read a dyn payload.

test/programs/dyn-struct.flan is the evidence.  It runs forty thousand rows
past flan_dyn.c's one-megabyte floor, so marks and sweeps really happen, and
it holds live values through them in all four places at once.  It has teeth:
with the descriptor walk stubbed out of the marker, the kept vector's length
comes back 24 instead of 628 and its first element is a stale word.  Clean
under ASan and UBSan, same output at -O2, -O0 and --x86.  dyn_ops.c grows an
aggregate-root mode so the runtime half can be wrong on its own, with a
header word holding a bit pattern that looks boxed and is not a dyn slot.

--no-gc still refuses, and had to be told how: a struct with a dyn field is a
collected value even when no expression in the program ever has the type dyn,
because a zeroed one still has a word the collector is asked to mark.

dune test --force: green, 0 failures across every suite.
This commit is contained in:
Joseph Ferano 2026-09-19 21:28:17 +07:00
parent 7c1a818001
commit f6ab3b62fc
11 changed files with 1252 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

307
lib/check.ml
View File

@ -2045,31 +2045,23 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
that transfer — which is the collector's question, not this one's, and
it is milestone 2's. *)
| Types.Dyn ->
no_dyn_yet c.Tast.loc ~into:false Types.Dyn
" — a condition crosses a handler boundary and a dyn payload has to \
stay rooted across the transfer, which is milestone 2"
fail c.Tast.loc
"a condition is matched by its type and dyn is not one — write the \
condition's struct type, whose dyn fields are fine"
| t ->
fail c.Tast.loc
"a condition is a struct, not %s — matching is by type and there is \
no condition hierarchy"
(Types.to_string t)
in
(* And the same refusal for a condition that merely *holds* one. The
payload is what crosses, so a dyn field is the dyn payload the note
above is about, whatever the struct around it is called. *)
(match Hashtbl.find_opt ctx.env.structs name with
| Some (s : Tast.structure) ->
List.iter
(fun (f : Tast.field) ->
if f.Tast.fty = Types.Dyn then
no_dyn_yet c.Tast.loc ~into:false Types.Dyn
(Printf.sprintf
" — the field %s of the condition %s is one, and a payload \
has to stay rooted across a handler transfer, which is \
milestone 2"
f.Tast.fname name))
s.Tast.fields
| None -> ());
(* A condition that *holds* a dyn used to be refused here for the same
reason. It is not any more: the condition crosses as a pointer to a
value in the signalling frame, and that value is on the collector's
root stack with its type's descriptor beside it — which is exactly the
shape the transfer needed and could not have. Where the condition is
not a place, the backends evaluate it into a rooted slot rather than a
scratch temporary, so a handler that allocates cannot collect the
payload it was handed. See [Emit.addr_rooted]. *)
(* §1 and §2. [signal] is Unit whatever it finds; [error] is Never,
because the only way past it is a handler that transfers — one that
returns normally has not answered it, and the program stops. *)
@ -6489,23 +6481,23 @@ let collect env (decls : Ast.decl list) =
means reading [Value]'s own cases back out of the table. A [fail]
aborts the whole compilation, so an entry left behind by a
declaration that is about to be refused is never read. *)
(* A dyn field is refused for the reason a condition's already is
(see the [signal] arm): the collector's roots are the frames, and
a struct outlives the frame that built it — its dyn field would be
a live value reachable only through memory the marker never walks,
which is a use-after-free on a timer. The audit that found the
hole is docs/SPIKE-DUPLICITY.md, question 1; the per-type
descriptor that lifts this is milestone 2's, alongside the
condition payload's. *)
List.iter
(fun (f : Tast.field) ->
if f.Tast.fty = Types.Dyn then
no_dyn_yet loc ~into:false Types.Dyn
(Printf.sprintf
" — the field %s of %s is one, and a struct outlives the \
frame that roots its values, which is milestone 2"
f.Tast.fname n))
fields;
(* A dyn field used to be refused here, for the reason a condition's
was: the collector's roots are the frames, and a struct outlives
the frame that built it, so its dyn field was a live value
reachable only through memory the marker never walked. The
per-type descriptors lifted that. A struct that holds a dyn now
gets a descriptor saying at which byte offsets its dyn words sit,
and every slot, global and temporary that holds one goes on the
collector's root stack with that descriptor beside it — see
runtime/flan_dyn.h's [flan_dyn_root_push_desc], which is also where
the reason no instance carries a header word is written down.
What is still refused is a dyn the descriptor cannot reach: one
inside a typed container, behind a pointer, or in a data type's
payload, where the offset is not a static property of the type.
That refusal is [hidden_dyn] below, and it is made over the whole
program rather than here, because the type that hides it may be
declared after the one that names it. *)
Hashtbl.replace env.structs n { Tast.sname = n; fields };
(* A struct field may own storage. Since the repeal a struct
holding a [(Vec i32)] is an ordinary value: assignment copies the
@ -7385,6 +7377,207 @@ let init_order (globals : Tast.global list) (fns : Tast.fn list) =
globals
end
(* ── What a per-type descriptor can reach ───────────────────────────────
*
* The struct dyn field is no longer refused: a type that holds dyn words at
* static offsets gets a descriptor naming those offsets, and every place a
* value of it can live — a frame slot, a global, a temporary a call answered
* with — goes on the collector's root stack with that descriptor beside it.
* runtime/flan_dyn.h's [flan_dyn_root_push_desc] is where the whole of that
* argument is written, including why no instance carries a header word.
*
* What a static offset cannot express is what is left, and it is refused here
* rather than emitted as a descriptor that quietly omits a field:
*
* - a dyn inside a typed container. A [(Vec S)] holds its elements in
* allocator memory of a length nothing static knows, so the dyn words of
* one are not a list of offsets. The M2 queue's item 3 is the
* descriptor that can say it — pointer, length and element type — and it is
* a different shape from this one, deliberately. A [(Map K V)] is the same
* fact twice over.
* - a dyn in a data type's payload. The cases overlay one another, so which
* words are dyn depends on the tag, which is a run-time question. The same
* goes for a C union's members.
* - a dyn inside an [(Option T)], whose payload exists only under the tag: the
* words of a [None] are zero and marking them is harmless, but that is a
* fact about how this compiler happens to build one and not something the
* type says, and a descriptor that relied on it would be relying on it
* silently.
*
* A [(Ptr S)] and a [[S]] are deliberately *not* on that list, and the reason
* is worth stating because it looks like an omission. Neither owns storage.
* The only storage this compiler hands out for a type that holds dyn is a
* frame slot, a global, or a fixed array inside one of those — and all three
* are rooted with their descriptor already, so a pointer or a slice into one
* addresses bytes the collector is marking. That is what makes a condition's
* payload work at all: a handler clause is lifted to a function taking a
* [(Ptr Cond)], and the value it points at is in the signalling frame with a
* descriptor beside it. Storage that came from C is the program's business the
* way every other pointer from C is.
*
* And one cap, which is not a representation question but an arithmetic one:
* the offsets of a fixed array are flattened one element at a time, so an
* array of a million structs would be a million-word table in .rodata. The
* repeat form that avoids it is item 3's machinery, so this says so instead of
* building half of it. *)
let desc_offsets_max = 4096
(* Is there a dyn anywhere under this type at all, by value or otherwise. *)
let rec dyn_anywhere p seen (t : Types.t) =
let go = dyn_anywhere p seen in
match t with
| Types.Dyn -> true
| Types.Array (_, e) | Types.Vec e | Types.Ptr e | Types.Option e
| Types.Slice e -> go e
| Types.Map (k, v) -> go k || go v
| Types.Fn _ -> false
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
(match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n)
p.Tast.structs with
| Some s ->
List.exists (fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty)
s.Tast.fields
| None ->
match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n)
p.Tast.datas with
| Some u ->
List.exists
(fun (c : Tast.variant) ->
List.exists
(fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty)
c.Tast.vfields)
u.Tast.cases
| None ->
match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n)
p.Tast.unions with
| Some u ->
List.exists
(fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty)
u.Tast.fields
| None -> false)
| _ -> false
(* How many dyn words a descriptor for this type would name, which is what the
cap above is about. Only the by-value shapes contribute; the rest are
refused by [hidden_dyn] before this number matters. *)
let rec dyn_words p seen (t : Types.t) =
match t with
| Types.Dyn -> 1
| Types.Array (n, e) -> Int64.to_int n * dyn_words p seen e
| Types.Named nm when not (List.mem nm seen) ->
(match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = nm)
p.Tast.structs with
| Some s ->
List.fold_left
(fun acc (fl : Tast.field) ->
acc + dyn_words p (nm :: seen) fl.Tast.fty)
0 s.Tast.fields
| None -> 0)
| _ -> 0
(* The first place under this type where a dyn sits that no descriptor reaches,
as the type to name in the refusal. *)
let rec hidden_dyn p seen (t : Types.t) : Types.t option =
let under e = if dyn_anywhere p seen e then Some t else None in
match t with
| Types.Dyn -> None
| Types.Array (_, e) -> hidden_dyn p seen e
| Types.Vec e | Types.Option e -> under e
| Types.Map (k, v) ->
if dyn_anywhere p seen k || dyn_anywhere p seen v then Some t else None
(* A pointer and a slice are views of storage something else roots; see the
note above. What they point at is checked where it is declared. *)
| Types.Ptr e | Types.Slice e -> hidden_dyn p seen e
| Types.Fn _ -> None
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
(match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n)
p.Tast.structs with
| Some s ->
List.fold_left
(fun acc (fl : Tast.field) ->
match acc with
| Some _ -> acc
| None -> hidden_dyn p seen fl.Tast.fty)
None s.Tast.fields
| None ->
(* A data type's payload and a union's members both overlay, so any dyn
in one is hidden by the type itself and not by a member of it. *)
match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n)
p.Tast.datas with
| Some u ->
if List.exists
(fun (c : Tast.variant) ->
List.exists
(fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty)
c.Tast.vfields)
u.Tast.cases
then Some t else None
| None ->
match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n)
p.Tast.unions with
| Some u ->
if List.exists
(fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty)
u.Tast.fields
then Some t else None
| None -> None)
| _ -> None
(* Over the whole program rather than at each declaration, because the type
that hides a dyn may be declared after the one that names it — and because
a struct nobody ever holds a value of costs nothing either way. Every place
a value can live is here: a global, a parameter, a return, a frame slot. *)
let dyn_descriptors (p : Tast.program) =
let check loc what (t : Types.t) =
(match hidden_dyn p [] t with
| Some at ->
Loc.failk "check/dyn-descriptor" loc
"%s is %s, and the dyn inside %s is one no descriptor can find. The \
collector marks a struct's dyn fields by their byte offsets, which \
%s does not have — its storage is not part of the value. Hold the \
dyn in a struct field, or wait for the typed container view"
what (Types.to_string t) (Types.to_string at) (Types.to_string at)
| None -> ());
let n = dyn_words p [] t in
if n > desc_offsets_max then
Loc.failk "check/dyn-descriptor" loc
"%s is %s, whose descriptor would name %d dyn words. The offsets of an \
array are flattened one element at a time, and %d is the most this \
compiler will write out — the repeat form that would avoid it arrives \
with the typed container view"
what (Types.to_string t) n desc_offsets_max
in
List.iter
(fun (g : Tast.global) ->
check g.Tast.ginit.Tast.loc
(Printf.sprintf "the global %s" g.Tast.gname) g.Tast.gty)
p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iteri
(fun i t ->
check fn.Tast.floc
(Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name) t)
fn.Tast.params;
check fn.Tast.floc
(Printf.sprintf "the return type of %s" fn.Tast.name) fn.Tast.ret;
Array.iteri
(fun i t ->
let what =
match
(if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None)
with
| Some n -> Printf.sprintf "%s in %s" n fn.Tast.name
| None -> Printf.sprintf "a local of %s" fn.Tast.name
in
check fn.Tast.floc what t)
fn.Tast.slots)
p.Tast.fns
let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
let env = new_env () in
let decls = Parse.program (Prelude.forms ()) @ decls in
@ -7467,11 +7660,17 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
env.externs []
|> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym)
in
({ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas;
unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions;
globals; externs; fns; cshim },
env)
let p =
{ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas;
unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions;
globals; externs; fns; cshim }
in
(* Last, over the finished program: which dyn words a per-type descriptor can
reach and which it cannot. It needs every declaration in hand, which is
what makes it a pass here rather than a check at each one. *)
dyn_descriptors p;
(p, env)
(** The program and the environment, stopping at the first refusal. What a
session needs, and it raises [Loc.Error] and never [Loc.Errors]. *)
@ -7610,21 +7809,38 @@ let expression env ?want (e : Ast.expr) :
let dyn_sites (p : Tast.program) : Loc.diag list =
let found = ref [] in
let add loc what = found := (loc, what) :: !found in
(* A type that *holds* a dyn and not only the type [dyn] itself. A struct
with a dyn field is a collected value as much as a bare one is, and since
the per-type descriptors it is a value a program can have without any
expression in it ever having the type [dyn] — a zeroed one, never filled,
whose dyn word the collector is still asked to mark. *)
let holds t = dyn_anywhere p [] t in
List.iter
(fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn then
if holds g.Tast.gty then
add g.Tast.ginit.Tast.loc (Printf.sprintf "the global %s" g.Tast.gname))
p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iteri
(fun i t ->
if t = Types.Dyn then
if holds t then
add fn.Tast.floc
(Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name))
fn.Tast.params;
if fn.Tast.ret = Types.Dyn then
if holds fn.Tast.ret then
add fn.Tast.floc (Printf.sprintf "the return type of %s" fn.Tast.name);
Array.iteri
(fun i t ->
if holds t && not (t = Types.Dyn) then
add fn.Tast.floc
(Printf.sprintf "%s in %s"
(match
(if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None)
with Some n -> n | None -> "a local")
fn.Tast.name))
fn.Tast.slots;
(* The body's own dyn values, which are the ones a signature does not
show: a let bound to a boxed literal, a (vec-new dyn) deep inside an
expression. Reported at the node, because that is the character to
@ -7645,7 +7861,8 @@ let dyn_sites (p : Tast.program) : Loc.diag list =
(fun (loc, what) ->
Loc.diag ~kind:"check/no-gc" loc
(Printf.sprintf
"%s is dyn, and --no-gc says this program carries no collector. A \
"%s holds a dyn, and --no-gc says this program carries no \
collector. A \
dyn value is one the runtime allocates and the collector owns, so \
there is nothing smaller to compile it to — write the type"
what))

456
lib/emit.ml
View File

@ -264,6 +264,25 @@ type m = {
rather than keeping the pointer. Counting these in [nstr] would silently
stop every C-x C-e module from ever being unloaded. *)
mutable nfi : int;
(* The per-type dyn descriptors this module has had to name, by symbol. The
value is the byte offsets of the dyn words inside one instance and the
instance's size — runtime/flan_dyn.h's [flan_desc], in the two numbers a
backend needs to write it out.
A table and not a buffer, because the two backends write the same data in
two syntaxes: this is what they agree about, and each renders it at the
end of its own module. Keyed by symbol so a type asked for twice is
emitted once.
Not counted in [nstr], and for [nfi]'s reason rather than by oversight. A
string literal in a module image is something the program may still be
pointing at after a thunk returns, which is why [nstr] gates unloading. A
descriptor is not: nothing but the collector's root stack ever holds one,
the entries that named it came off when the frames that pushed them did,
and no value of any type points at one. A redefinition module naming a
type the base program already named therefore gets its own copy, which is
harmless — a descriptor is read-only and has no identity. *)
descs : (string, int list * int) Hashtbl.t;
}
(* The attribute group every emitted function names, empty unless sanitizing.
@ -381,6 +400,86 @@ and int_kind = function
| 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64
| n -> failwith ("no integer type of " ^ string_of_int n ^ " bits")
(* ── Per-type dyn descriptors ────────────────────────────────────────
*
* Where the dyn words are inside one instance of a type, in bytes from its
* first, ascending. This is the whole of what runtime/flan_dyn.h's [flan_desc]
* holds, and the whole of what the collector needs in order to mark a struct
* that has dyn fields in it.
*
* Flattened, not a graph: a struct held by value inside another contributes
* its own offsets shifted by where it sits, and a fixed array contributes its
* element's offsets once per element. So nesting costs nothing at run time —
* there is no second descriptor to follow and no recursion in the marker — at
* the price of a descriptor whose length grows with an array's length, which
* [Check] caps so that the price is one a program can be told about.
*
* Everything that is not a struct, an array or a dyn answers with no offsets,
* and for the container cases that is a refusal upstream rather than a guess
* here: a [(Vec S)] whose element has a dyn field is storage this descriptor
* cannot describe — the length is not static — and [Check] says so by name.
* The typed-container view of the M2 queue's item 3 is what grows a descriptor
* that can, and it will read [size] below as its stride.
*
* [seen] is belt and braces. A struct cannot contain itself by value and be
* laid out at all, so [lay] would already have recursed forever; this makes
* the walk terminate on its own terms rather than on that assumption. *)
and dyn_offsets m (t : Types.t) : int list =
let rec go seen base (t : Types.t) acc =
match t with
| Types.Dyn -> base :: acc
| Types.Array (n, e) ->
let s, _ = lay m e in
let acc = ref acc in
for i = Int64.to_int n - 1 downto 0 do
acc := go seen (base + i * s) e !acc
done;
!acc
| Types.Named nm when not (List.mem nm seen) ->
(match Hashtbl.find_opt m.structs nm with
| Some st ->
let tys = List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields in
let _, _, offs = lay_fields m tys in
List.fold_left2
(fun acc ty off -> go (nm :: seen) (base + off) ty acc)
acc tys offs
(* A data type's payload is a union of its cases and a union's members
all start at the same byte, so which words are dyn depends on the tag
— which is a run-time question a static descriptor cannot answer.
Refused in [Check] rather than described wrongly here. *)
| None -> acc)
| _ -> acc
in
List.sort_uniq compare (go [] 0 t [])
(* The symbol a type's descriptor is written under. Mangled from the type's
printed form, so two spellings of one type share an entry and no two types
share a symbol; private or local in both backends, so a redefinition module
naming the same type as the program it patches is not a duplicate symbol. *)
let desc_sym (t : Types.t) =
let b = Buffer.create 32 in
String.iter
(fun c ->
if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
|| (c >= '0' && c <= '9') || c = '_'
then Buffer.add_char b c
else Buffer.add_char b '.')
(Types.to_string t);
"flan.desc." ^ Buffer.contents b
(* The descriptor for a type, recorded on the module and named. [None] when the
type holds no dyn, which is the answer for almost every type in almost every
program and is what keeps a dyn-free program's output byte for byte what it
was. *)
let desc_of m (t : Types.t) : string option =
match dyn_offsets m t with
| [] -> None
| offs ->
let sym = desc_sym t in
if not (Hashtbl.mem m.descs sym) then
Hashtbl.replace m.descs sym (offs, fst (lay m t));
Some sym
(* A DWARF type node for a Flan type, memoised by the type's printed form so
the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int =
@ -624,6 +723,11 @@ type f = {
collector keeps one cycle longer than it must, and that is the safe
direction to be wrong in. *)
mutable droot_ns : string list;
(* The aggregate root slots, pooled by type: every entry under one type is
interchangeable, so [agg_tmp] takes the head of the right pool and order
within a pool never matters. See [root_plan] for why this is by type and
not a single positional list. *)
mutable aroot_ns : (string * string list) list;
(* Where a dev build records each slot's address, so that a stopped frame's
locals can be read. [None] in a release build and in a function with no
named slot at all. Only *named* slots are recorded: a slot the compiler
@ -706,16 +810,87 @@ let label f name =
becomes a stack slot with a store at every optimisation level.
A count rather than a running tally for the reason [droots] gives: [ret] is
reached while the body is still being emitted. *)
let dyn_roots (fn : Tast.fn) =
let slots =
Array.fold_left
(fun acc t -> if t = Types.Dyn then acc + 1 else acc) 0 fn.Tast.slots
in
let temps = ref 0 in
reached while the body is still being emitted.
Since the per-type descriptors there is a second kind of root beside the
bare dyn word: an aggregate — a struct with a dyn field, a struct holding
one of those, a fixed array of either — whose descriptor says where its dyn
words are. It goes on the same stack and comes off in the same pop, so the
count below is still the number the epilogue takes off; what changed is that
the plan has to say, per entry, which kind it is. *)
(* Which expressions [addr] can answer without copying. Shared with [addr]
itself rather than repeated, because the counter below has to make exactly
the same call: a place has an address already and needs no root, and
everything else is copied into a temporary that does. *)
let addr_is_place (e : Tast.expr) =
match e.Tast.e with
| Tast.Local _ | Tast.Global _ | Tast.Deref _ | Tast.Field _
| Tast.Prim (Tast.At, _ :: _) -> true
| _ -> false
(* A function's roots, worked out before a line of it is emitted, and the one
thing both backends read rather than each deriving it. [rslots] is the frame
slots, in slot order; [rdyn] is how many bare dyn temporaries the body
mints; [ragg] is the aggregate temporaries, as their types.
The aggregate temporaries are *pooled by type* rather than handed out in
mint order, which is the one design decision here worth the sentence. A
positional supply that drifted from the emission would pair an address with
the wrong type's descriptor, and reading arbitrary offsets off a base and
marking whatever is there is memory corruption rather than a missed root —
a worse failure than the one [dyn_tmp]'s fallback already admits. Pooled by
type, every temporary in a pool is interchangeable, so the only thing that
can go wrong is running out, and running out falls back to an unrooted
slot.
Why pooling cannot alias two live values: the count is per *node* and each
node draws exactly once, and two values that are live at the same time are
always two nodes. A node inside a loop draws one slot and reuses it across
iterations, which is right — the previous iteration's value is dead, and
where it is not, it is dead here and live in the named slot that kept it,
which is rooted on its own. *)
type rootplan = {
rslots : (int * Types.t) list; (* slot index and its type, in slot order *)
rdyn : int;
ragg : Types.t list; (* sorted, with multiplicity *)
}
let root_plan m (fn : Tast.fn) : rootplan =
let rslots = ref [] in
Array.iteri
(fun i t ->
if t = Types.Dyn || dyn_offsets m t <> [] then
rslots := (i, t) :: !rslots)
fn.Tast.slots;
let dyn = ref 0 and agg = ref [] in
let want (t : Types.t) = t <> Types.Dyn && dyn_offsets m t <> [] in
let count (e : Tast.expr) =
match e.Tast.e with
| Tast.Prim (Tast.Rt _, _) when e.Tast.ty = Types.Dyn -> incr temps
| Tast.Prim (Tast.Rt _, _) when e.Tast.ty = Types.Dyn -> incr dyn
(* A Flan call answering a dyn, which wants the same slot a dyn-producing
runtime call gets and did not have one until the descriptors went in.
The hazard is the aggregate's exactly: the callee rooted the word and
popped it in its epilogue, so between the return and the caller's store
the only copy is a register. *)
| Tast.Call (_, _) | Tast.CallPtr (_, _) when e.Tast.ty = Types.Dyn ->
incr dyn
(* A call answering an aggregate with a dyn in it. The value comes back in
a register or through an sret buffer the frame is about to hand out
again, and either way the dyn word inside it was last rooted by the
frame that has just popped its roots and returned. *)
| Tast.Call (_, _) | Tast.CallPtr (_, _) when want e.Tast.ty ->
agg := e.Tast.ty :: !agg
(* The two places a non-place expression's *address* is taken and then
given to something that can allocate: the condition a signal crosses on
(the handler runs, and a handler allocates) and an explicit address-of.
Every other [addr] on a non-place is a copy a load or a store consumes
on the next instruction, with no allocation in between. *)
| Tast.Signal (_, _, c) when (not (addr_is_place c)) && want c.Tast.ty ->
agg := c.Tast.ty :: !agg
| Tast.Prim (Tast.AddrOf, [ x ])
when (not (addr_is_place x)) && want x.Tast.ty ->
agg := x.Tast.ty :: !agg
| _ -> ()
in
List.iter (Tast.walk count) fn.Tast.body;
@ -728,7 +903,17 @@ let dyn_roots (fn : Tast.fn) =
one and counting [%dx] in the IR, which is the only thing that can see it
while the runtime is a stub that never collects. *)
List.iter (Tast.walk count) fn.Tast.fdefers;
slots + !temps
{ rslots = List.rev !rslots;
rdyn = !dyn;
(* Sorted so the pools are built in an order both backends agree on: an
asm listing and an IR listing put the same value at the same depth. *)
ragg =
List.sort (fun a b -> String.compare (Types.to_string a) (Types.to_string b))
!agg }
let dyn_roots m (fn : Tast.fn) =
let p = root_plan m fn in
List.length p.rslots + p.rdyn + List.length p.ragg
(* The next pre-made root slot for a dyn temporary. They are all minted, zeroed
and pushed in the entry block before a line of the body is emitted, and this
@ -739,6 +924,23 @@ let dyn_roots (fn : Tast.fn) =
out only if those two disagree. If it ever does, the fallback is an ordinary
unrooted slot: one temporary the collector cannot see is a bug to find,
where a root stack that pops more than it pushed is memory corruption. *)
(* The same for an aggregate temporary, out of the pool for its type. A pool
that runs dry falls back to an ordinary unrooted alloca, exactly as
[dyn_tmp] does and for the same reason — the safe direction to be wrong in
is a temporary the collector cannot see, never a root stack out of step. *)
let agg_tmp f (ty : Types.t) =
let key = Types.to_string ty in
match List.assoc_opt key f.aroot_ns with
| Some (n :: rest) ->
f.aroot_ns <- (key, rest) :: List.remove_assoc key f.aroot_ns;
n
| _ ->
let name = Printf.sprintf "%%ax%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas
(Printf.sprintf " %s = alloca %s\n" name (ll ty));
name
let dyn_tmp f =
match f.droot_ns with
| n :: rest -> f.droot_ns <- rest; n
@ -1296,7 +1498,7 @@ and value_at f (e : Tast.expr) : string =
(* 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
let p = addr_rooted f c in
ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
guard f;
"zeroinitializer"
@ -1305,7 +1507,7 @@ and value_at f (e : Tast.expr) : string =
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 p = addr_rooted f c in
let name = struct_name_of c.Tast.ty in
let nid, nn = string_bytes f.md name in
ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
@ -1414,6 +1616,25 @@ and addr f (e : Tast.expr) : string =
ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
tmp
(* [addr], for the two callers whose address outlives the next instruction:
the condition a [signal] crosses on, which a handler reads while allocating,
and an explicit address-of, which is handed to a runtime that may. A place
already has an address and it is one something else rooted; everything else
is copied, and the copy goes into a slot the collector was told about.
Every other caller of [addr] hands the address to the load or the store on
the next line, with no allocation in between, and wants the cheaper
unrooted copy. [root_plan] counts exactly these two callers. *)
and addr_rooted f (e : Tast.expr) : string =
if addr_is_place e || e.Tast.ty = Types.Dyn
|| dyn_offsets f.md e.Tast.ty = [] then addr f e
else begin
let tmp = agg_tmp f e.Tast.ty in
let v = value f e in
ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
tmp
end
and field_addr f (target : Tast.expr) i =
let base = addr f target in
(* A union's members all start where the union starts, so the address of one
@ -1611,6 +1832,24 @@ and call_through f ret callee vs =
ins f "%s = call %s %s(%s)" t (ll ret) callee
(String.concat ", " (vs @ [ "ptr " ^ xfer_param ]));
guard f;
(* An aggregate with a dyn in it is spilled into a rooted slot the instant it
arrives, the same move a dyn word gets in [prim] and for a sharper reason:
the callee rooted that dyn word in its own frame and popped it on the way
out, so between this instruction and the next allocation the only copy of
it anywhere is an SSA value, which a collector that finds its roots by
address cannot see. The spill is a shadow the collector reads and the
program never does — the value carries on being used as a register — and
marking through it keeps the object alive, which is all that is wanted.
[root_plan] counted this node, so the slot is one the entry block has
already zeroed and pushed. *)
if ret = Types.Dyn then begin
let slot = dyn_tmp f in
ins f "store i64 %s, ptr %s" t slot
end
else if dyn_offsets f.md ret <> [] then begin
let slot = agg_tmp f ret in
ins f "store %s %s, ptr %s" (ll ret) t slot
end;
t
(* The check after a call, which is the whole of §6's lowering at a call site:
@ -2403,7 +2642,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
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.AddrOf, [ x ] -> addr_rooted f x
| Tast.Cast target, [ x ] -> cast f ~guard:(fun () -> guard f) x target
| _ -> failwith "malformed primitive"
@ -2568,7 +2807,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
pads = []; loops = []; unwind = "unwind"; unwound = false;
defers = fn.Tast.fdefers;
frame = None; slotv = None; snames = fn.Tast.snames;
droots = 0; droot_ns = [];
droots = 0; droot_ns = []; aroot_ns = [];
dsub;
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
dloc = "";
@ -2600,40 +2839,85 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
are minted here, in order, so that [dyn_tmp] only has to hand them out.
Zeroed because the push happens at entry and the call that fills one may
be inside a branch that never runs — runtime/flan_dyn.h says a rooted slot
holding 0 is not a value. *)
let nroots = dyn_roots fn in
holding 0 is not a value.
An aggregate root is the same idea with a descriptor beside the address:
only the dyn words the descriptor names are zeroed, which is all the
collector ever reads through that entry and is a great deal cheaper than
clearing a whole struct. *)
let plan = root_plan m fn in
let nroots =
List.length plan.rslots + plan.rdyn + List.length plan.ragg
in
if nroots > 0 then begin
let nparams = List.length fn.Tast.params in
let pushed = ref [] in
Array.iteri
(fun i t ->
if t = Types.Dyn then begin
(* A parameter's slot was filled from [%pN] a few lines above and
must not be zeroed over the top of it. Every other slot holds
whatever the stack held until its binding runs, and the binding
may be inside a branch that does not. *)
if i >= nparams then
(* Zeroing the dyn words at [base], which is the whole of the contract
runtime/flan_dyn.h states for a pushed root. *)
let zero_dyn base (ty : Types.t) =
if ty = Types.Dyn then
Buffer.add_string f.allocas (Printf.sprintf " store i64 0, ptr %s\n" base)
else
List.iter
(fun off ->
let p = Printf.sprintf "%%z%d" f.n in
f.n <- f.n + 1;
Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" f.slots.(i));
pushed := f.slots.(i) :: !pushed
end)
fn.Tast.slots;
let ntemps = nroots - List.length !pushed in
let temps =
List.init ntemps (fun i ->
(Printf.sprintf " %s = getelementptr inbounds i8, ptr %s, i64 %d\n"
p base off);
Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" p))
(dyn_offsets m ty)
in
let push base (ty : Types.t) =
match (if ty = Types.Dyn then None else desc_of m ty) with
| None ->
Buffer.add_string f.allocas
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" base)
| Some sym ->
Buffer.add_string f.allocas
(Printf.sprintf
" call void @flan_dyn_root_push_desc(ptr %s, ptr @\"%s\")\n"
base sym)
in
(* The slots first, in slot order. A parameter's slot was filled from [%pN]
a few lines above and must not be zeroed over the top of it — which
matters more for an aggregate than it ever did for a dyn word, because
zeroing an aggregate parameter's dyn fields destroys the argument in
silence. Every other slot holds whatever the stack held until its
binding runs, and the binding may be inside a branch that does not. *)
List.iter
(fun (i, ty) -> if i >= nparams then zero_dyn f.slots.(i) ty)
plan.rslots;
let dtemps =
List.init plan.rdyn (fun i ->
let name = Printf.sprintf "%%dr%d" i in
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca i64\n" name);
Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" name);
name)
in
List.iter
(fun n ->
Buffer.add_string f.allocas
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" n))
(List.rev !pushed @ temps);
let atemps =
List.mapi
(fun i ty ->
let name = Printf.sprintf "%%ar%d" i in
Buffer.add_string f.allocas
(Printf.sprintf " %s = alloca %s\n" name (ll ty));
zero_dyn name ty;
(ty, name))
plan.ragg
in
List.iter (fun (i, ty) -> push f.slots.(i) ty) plan.rslots;
List.iter (fun n -> push n Types.Dyn) dtemps;
List.iter (fun (ty, n) -> push n ty) atemps;
f.droots <- nroots;
f.droot_ns <- temps
f.droot_ns <- dtemps;
f.aroot_ns <-
List.fold_left
(fun acc (ty, n) ->
let key = Types.to_string ty in
(key, n :: (try List.assoc key acc with Not_found -> []))
:: List.remove_assoc key acc)
[] (List.rev atemps)
end;
(* The shadow stack's push, in the entry block, and the pop is at every
[ret] (see [ret]). plan.org has had *Frames: shadow stack* in the dev
@ -3063,6 +3347,7 @@ declare i64 @flan_dyn_need_i64(i64)
declare double @flan_dyn_need_f64(i64)
declare i32 @flan_dyn_need_bool(i64)
declare void @flan_dyn_root_push(ptr)
declare void @flan_dyn_root_push_desc(ptr, ptr)
declare void @flan_dyn_root_pop(i64)
declare void @flan_gc_init()
declare void @flan_dev_reg_enable()
@ -3139,8 +3424,29 @@ declare i8 @flan_slurp_into(ptr, ptr, i64, i64, ptr, i64)
signature that mentions it, a slot that holds one, or an expression that
produces one. *)
let uses_dyn (p : Tast.program) =
let structs = Hashtbl.create 16 in
List.iter
(fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
p.Tast.structs;
(* A struct with a dyn field counts, and counts even if no expression in the
program ever has the type [dyn] on it — a zero-initialised one has a dyn
word in it that the collector will be asked to mark, and asking it before
[flan_gc_init] has run is the one thing [main] is ordering here. *)
let rec carries seen (t : Types.t) =
match t with
| Types.Dyn -> true
| Types.Array (_, e) -> carries seen e
| Types.Named n when not (List.mem n seen) ->
(match Hashtbl.find_opt structs n with
| Some st ->
List.exists
(fun (fl : Tast.field) -> carries (n :: seen) fl.Tast.fty)
st.Tast.fields
| None -> false)
| _ -> false
in
let found = ref false in
let note t = if t = Types.Dyn then found := true in
let note t = if carries [] t then found := true in
List.iter (fun (g : Tast.global) -> note g.Tast.gty) p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
@ -3174,8 +3480,18 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.
for free, and runtime/flan_dyn.h says a rooted slot holding 0 is not a
value. *)
List.iter
(fun g -> Buffer.add_string b
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" (gname g)))
(fun (g, ty) ->
match (if ty = Types.Dyn then None else desc_of m ty) with
| None ->
Buffer.add_string b
(Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" (gname g))
(* A global struct with a dyn field goes on the same stack with its
descriptor beside it, and [.bss] gives the zero the push wants. *)
| Some sym ->
Buffer.add_string b
(Printf.sprintf
" call void @flan_dyn_root_push_desc(ptr %s, ptr @\"%s\")\n"
(gname g) sym))
dyn_globals;
(* 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
@ -3250,6 +3566,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; dev; known; nstr = 0; nfi = 0; sanitize;
descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None);
} in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
@ -3350,8 +3667,62 @@ let dmodule d =
Buffer.add_buffer b d.dout;
Buffer.contents b
(* The per-type dyn descriptors, as runtime/flan_dyn.h's [flan_desc] laid out
by hand: two i64s and a pointer to the offset table. [private] because a
redefinition module may name a type the program it patches already named,
and a private constant has no symbol for the two to collide over. Sorted, so
the .ll is reproducible build to build. *)
let descriptors m =
let b = Buffer.create 256 in
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c)
|> List.iter
(fun (sym, (offs, size)) ->
Buffer.add_string b
(Printf.sprintf
"@\"%s.offs\" = private unnamed_addr constant [%d x i64] [%s]\n"
sym (List.length offs)
(String.concat ", "
(List.map (Printf.sprintf "i64 %d") offs)));
Buffer.add_string b
(Printf.sprintf
"@\"%s\" = private unnamed_addr constant { i64, i64, ptr } \
{ i64 %d, i64 %d, ptr @\"%s.offs\" }\n"
sym size (List.length offs) sym));
Buffer.contents b
(* The same table in the other backend's syntax. It lives here rather than in
x86.ml so that the two renderings sit beside each other and the layout the
runtime reads is agreed in one place. [.L] so the labels never reach the
symbol table, which is what lets a redefinition module name a type the
program it patches already named. *)
let descriptors_asm m =
let b = Buffer.create 256 in
let rows =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c)
in
if rows <> [] then
Buffer.add_string b
"\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\
# size of one instance, how many dyn words it holds, and where they are.\n\
# Read by the collector through flan_dyn_root_push_desc and by nothing\n\
# else; no value points at one.\n\t.section\t.rodata\n";
List.iter
(fun (sym, (offs, size)) ->
Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym);
List.iter
(fun o -> Buffer.add_string b (Printf.sprintf "\t.quad\t%d\n" o))
offs;
Buffer.add_string b
(Printf.sprintf
"\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t.L%s.offs\n"
sym size (List.length offs) sym))
rows;
Buffer.contents b
let finish m =
header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
header ^ Buffer.contents m.strs ^ descriptors m ^ "\n" ^ Buffer.contents m.out
^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "")
^ (match m.dbg with None -> "" | Some d -> dmodule d)
@ -3486,7 +3857,8 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
~dyn_globals:
(List.filter_map
(fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn then Some g.Tast.gname else None)
if g.Tast.gty = Types.Dyn || dyn_offsets m g.Tast.gty <> []
then Some (g.Tast.gname, g.Tast.gty) else None)
p.Tast.globals)
fn
(* A program with no [main] is linked into a C host that brings its own

183
lib/x86.ml
View File

@ -461,9 +461,17 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions;
globals; externs = Hashtbl.create 1; checks;
dev; known = (fun _ -> true); dbg = None; sanitize = false;
nstr = 0; nfi = 0 }
nstr = 0; nfi = 0; descs = Hashtbl.create 8 }
let sizeof md t = fst (Emit.lay md t)
(* The assembler label a type's dyn descriptor is written under, recorded on
the module the first time it is asked for and written out with the rest of
.rodata. [None] when the type holds no dyn, which is nearly every type in
nearly every program. [.L] so the symbol never reaches the table and a
redefinition module naming the same type cannot collide with the program
it patches. *)
let desc_label md t = Option.map (fun s -> ".L" ^ s) (Emit.desc_of md t)
let alignof md t = snd (Emit.lay md t)
(* The one classification this backend makes, and it has two answers rather
@ -666,6 +674,12 @@ type fnctx = {
counter and not two. *)
mutable droots : int;
mutable droot_ns : int list;
(* The aggregate root slots — a struct with a dyn field, or an array of one —
pooled by the type's printed form. [emit.ml]'s [aroot_ns] in frame offsets
rather than alloca names, and pooled for its reason: every slot under one
type is interchangeable, so a supply that drifted from the emission can
only run out and never pair an address with another type's descriptor. *)
mutable aroot_ns : (string * int list) list;
(* [fn.snames], carried so [bind_slot] can ask whether a slot has a name to
show without the whole [Tast.fn] being threaded to every binding site. *)
snames : string option array;
@ -1389,6 +1403,16 @@ let dyn_tmp f =
| n :: rest -> f.droot_ns <- rest; n
| [] -> alloc f 8 8
(* The same for an aggregate temporary, out of the pool for its type, with the
same fallback and the same trade. *)
let agg_tmp f (ty : Types.t) =
let key = Types.to_string ty in
match List.assoc_opt key f.aroot_ns with
| Some (n :: rest) ->
f.aroot_ns <- (key, rest) :: List.remove_assoc key f.aroot_ns;
n
| _ -> alloc f (max 1 (sizeof f.md ty)) (alignof f.md ty)
(* ── The runtime's two dynamic stacks ────────────────────────────────── *)
(* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the
@ -1730,7 +1754,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
scoped f (fun () ->
let l = lvalue f c in
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
chan_into f ~reg:rdx;
@ -1742,7 +1766,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
[ud2] — where [emit.ml] writes [unreachable]. *)
| Tast.Signal (Tast.Serror, id, c) ->
scoped f (fun () ->
let l = lvalue f c in
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
chan_into f ~reg:rdx;
@ -2112,6 +2136,24 @@ and lvalue f (e : Tast.expr) : loc =
| Tast.CaseField (target, case, i) -> case_field f target case i
| _ -> eval f e
(* [lvalue], for the two callers whose address outlives the next instruction:
the condition a [signal] crosses on, which a handler reads while allocating,
and an explicit address-of, which is handed to a runtime that may. A place
already has an address and it is one something else rooted; everything else
is evaluated into a slot the collector was told about, rather than into a
[scoped] temporary the next statement reuses.
[Emit.addr_is_place] and not this file's own list, because the counter that
decided how many of these slots to mint asked that same function. *)
and lvalue_rooted f (e : Tast.expr) : loc =
if Emit.addr_is_place e || e.Tast.ty = Types.Dyn
|| Emit.dyn_offsets f.md e.Tast.ty = [] then lvalue f e
else begin
let o = agg_tmp f e.Tast.ty in
lower f e (Lf o);
Lf o
end
(* The address of one field of one case of a data type value. Only ever reached
under an arm that proved the tag — [match] is the only thing that proves
it — or from the structural printer, which compares the same tag first. *)
@ -2599,7 +2641,26 @@ and call_flan f ~target ~args ~rty dst =
reached by name or by address. *)
guard f;
if (not (is_void rty)) && not sret then
store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty
store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty;
(* An aggregate with a dyn in it is copied into a rooted slot the instant it
arrives, the same move a dyn word gets in [call_rt] and for a sharper
reason: the callee rooted that dyn word in its own frame and popped it in
its epilogue, and [dst] is not enough — it is usually a temporary inside a
[scoped] that the bump allocator is about to hand out again, and it is
never a slot anything was pushed for. The copy is a shadow the collector
reads and the program never does; marking through it keeps the object
alive, which is all that is wanted. [Emit.root_plan] counted this node, so
the slot is one the prologue has already zeroed and pushed. *)
if rty = Types.Dyn then begin
(* rax still holds the answer — [store_loc] above takes r11 for its scratch
and nothing else, which is the note [call_rt] makes for the same line. *)
let o = dyn_tmp f in
store_int f.b ~src:rax ~mm:(Frame o) ~size:8
end
else if (not (is_void rty)) && Emit.dyn_offsets f.md rty <> [] then begin
let o = agg_tmp f rty in
copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty)
end
(* Flan calling C. SysV exactly, because this is the boundary where it has to
be — and the only aggregates that get here are the ones the shim rules
@ -2931,7 +2992,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
imm_into f ~reg:rax (Int64.of_int (alignof f.md ty));
store_loc f ~reg:rax dst t
| Tast.AddrOf, [ a ] ->
let l = lvalue f a in
let l = lvalue_rooted f a in
addr_into f ~reg:rax l;
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
(* The allocation registry's notes are the one runtime family a release
@ -3260,7 +3321,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
{ b; md; fnname = fn.Tast.name; retlbl = "";
fret = fn.Tast.ret; slots = Array.make nslots 0;
xfer_off = 0; sret_off = 0; retval = 0;
dframe = None; dslotv = None; droots = 0; droot_ns = [];
dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = [];
snames = fn.Tast.snames;
frame = 0; maxframe = 0; outgoing = 0;
loops = []; pads = []; xfer_lbl = ""; unwound = false;
@ -3322,7 +3383,11 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
The pushes themselves go into the *body* buffer below, not this one: this
runs before the prologue is built, and it is the prologue that still has
the incoming arguments in registers. *)
let nroots = Emit.dyn_roots fn in
let plan = Emit.root_plan md fn in
let nroots =
List.length plan.Emit.rslots + plan.Emit.rdyn
+ List.length plan.Emit.ragg
in
(* The slots to zero and the offsets to push, worked out here and emitted
into the body buffer further down. In push order, which is [emit.ml]'s:
every dyn slot in slot order, and then the temporaries. The order has to
@ -3343,23 +3408,41 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
marker, and crucially never a pointer the collector will follow. Zero is
safe, and it is safe for a reason rather than by the two sides having
guessed the same thing. *)
(* An aggregate root is the same idea with a descriptor beside the address,
and only the dyn words the descriptor names are zeroed — that is the whole
of what the collector reads through the entry, and it is a great deal
cheaper than clearing a struct. Zeroing an aggregate *parameter's* dyn
fields would destroy the argument in silence, which is why the [nparams]
gate matters more here than it ever did for a dyn word. *)
let droot_zero = ref [] and droot_push = ref [] in
if nroots > 0 then begin
let nparams = List.length fn.Tast.params in
let slots = ref [] and zeros = ref [] in
Array.iteri
(fun i t ->
if t = Types.Dyn then begin
slots := f.slots.(i) :: !slots;
if i >= nparams then zeros := f.slots.(i) :: !zeros
end)
fn.Tast.slots;
let slots = List.rev !slots and zeros = List.rev !zeros in
let temps = List.init (nroots - List.length slots) (fun _ -> ptmp f) in
droot_push := slots @ temps;
droot_zero := zeros @ temps;
(* [off] is the frame offset, [ty] the type at it; [None] descriptor means
a bare dyn word. Zeroing is a list of (offset, byte offsets within). *)
let slots =
List.map (fun (i, ty) -> (f.slots.(i), ty)) plan.Emit.rslots
in
let zeros =
List.filteri (fun i _ -> fst (List.nth plan.Emit.rslots i) >= nparams)
slots
in
let dtemps = List.init plan.Emit.rdyn (fun _ -> ptmp f) in
let atemps =
List.map
(fun ty -> (alloc f (max 1 (sizeof f.md ty)) (alignof f.md ty), ty))
plan.Emit.ragg
in
droot_push := slots @ List.map (fun o -> (o, Types.Dyn)) dtemps @ atemps;
droot_zero := zeros @ List.map (fun o -> (o, Types.Dyn)) dtemps @ atemps;
f.droots <- nroots;
f.droot_ns <- temps
f.droot_ns <- dtemps;
f.aroot_ns <-
List.fold_left
(fun acc (o, ty) ->
let key = Types.to_string ty in
(key, o :: (try List.assoc key acc with Not_found -> []))
:: List.remove_assoc key acc)
[] (List.rev atemps)
end;
(* The shadow stack's storage, in a dev build and nowhere else: three words
for the record and one per slot for the table. Allocated here, beside the
@ -3413,20 +3496,35 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
if f.droots > 0 then begin
if ann then set_ind f.b "";
note f
"The collector's roots — runtime/flan_dyn.h. Every dyn slot and every dyn-producing \
runtime call gets a frame slot the collector is told the address of, zeroed first \
because the push happens here and the code that fills one may be in a branch that \
never runs. The single pop is in the epilogue, which every return and every \
transfer out of this frame goes through.";
"The collector's roots — runtime/flan_dyn.h. Every dyn slot, every dyn-producing \
runtime call and every aggregate with a dyn field in it gets a frame slot the \
collector is told the address of, zeroed first because the push happens here and \
the code that fills one may be in a branch that never runs. An aggregate goes on \
with its type's descriptor beside it, which is how the collector knows which of \
its words are dyn. The single pop is in the epilogue, which every return and \
every transfer out of this frame goes through.";
xor_rr f.b ~dst:rax ~src:rax;
List.iter
(fun off -> store_int f.b ~src:rax ~mm:(Frame off) ~size:8)
(fun (off, ty) ->
if ty = Types.Dyn then store_int f.b ~src:rax ~mm:(Frame off) ~size:8
else
List.iter
(fun d -> store_int f.b ~src:rax ~mm:(Frame (off + d)) ~size:8)
(Emit.dyn_offsets f.md ty))
!droot_zero;
List.iter
(fun off ->
(fun (off, ty) ->
lea f.b ~dst:rdi ~mm:(Frame off);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_root_push")
match (if ty = Types.Dyn then None else desc_label f.md ty) with
| None ->
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_root_push"
| Some l ->
(* Pc-relative and not through the GOT: the descriptor is this
object's own private constant. *)
lea f.b ~dst:rsi ~mm:(Sym (l, 0));
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_root_push_desc")
!droot_push
end;
(* The shadow stack's push, and the pop is in the epilogue. plan.org has had
@ -3790,12 +3888,20 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
follow — see the entry-block roots in [emit_fn] for why that is a fact
about runtime/flan_dyn.c and not a convention. *)
List.iter
(fun g ->
(fun (g, ty) ->
(* Pc-relative and not through the GOT: [emit_main] is only ever a
whole program's, and a whole program defines every global it names. *)
lea b ~dst:rdi ~mm:(Sym (gsym g, 0));
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_dyn_root_push")
(* A global struct with a dyn field goes on the same stack with its
descriptor beside it, and [.bss] gives the zero the push wants. *)
match (if ty = Types.Dyn then None else desc_label md ty) with
| None ->
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_dyn_root_push"
| Some l ->
lea b ~dst:rsi ~mm:(Sym (l, 0));
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_dyn_root_push_desc")
dyn_globals;
(* The computed globals, after the runtime is up and before a line of the
program's own code — [emit.ml]'s [emit_startup] says why this is a call
@ -3864,7 +3970,7 @@ let emit_globals_init ?(cfi = false) ?(ann = false) ~sym (md : Emit.m) ~externs
let f =
{ b; md; fnname = "<globals>"; retlbl = new_label () "ginit";
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
dframe = None; dslotv = None; droots = 0; droot_ns = [];
dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = [];
snames = [||];
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;
@ -4293,7 +4399,8 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
~dyn_globals:
(List.filter_map
(fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn then Some g.Tast.gname else None)
if g.Tast.gty = Types.Dyn || Emit.dyn_offsets md g.Tast.gty <> []
then Some (g.Tast.gname, g.Tast.gty) else None)
p.Tast.globals)
md fn)
(* No [main] is not an error, and [emit.ml] treats it the same way: a
@ -4342,6 +4449,12 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
Buffer.add_string out (emit_globals_data md p.Tast.globals);
Buffer.add_string out "\n\t.section\t.rodata\n";
Buffer.add_buffer out rodata;
(* The per-type dyn descriptors, as runtime/flan_dyn.h's [flan_desc] laid out
by hand: two words and a pointer to the offset table. Written here, after
every function and [main] have been emitted, because that is when the
module knows which types were asked for. Sorted, so the listing is
reproducible build to build. *)
Buffer.add_string out (Emit.descriptors_asm md);
(match dw with
| Some d ->
Buffer.add_string out
@ -4515,7 +4628,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
let f =
{ b = ib; md; fnname = "<install>"; retlbl = new_label () "install";
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
dframe = None; dslotv = None; droots = 0; droot_ns = [];
dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = [];
snames = [||];
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;

63
runtime/flan_dyn.c
View File

@ -93,6 +93,17 @@ _Noreturn void flan_trap(const uint8_t *name, int64_t namelen);
typedef uint64_t flan_dyn;
/* A type's dyn map: where the dyn words are inside one instance of it. The
* compiler emits one of these per type that has any, as static data, and hands
* a pointer to it to [flan_dyn_root_push_desc]. Nothing here ever writes one.
* [size] is not read by the collector; it is the stride an array of the type
* has, which is what the typed-container view will need. */
typedef struct flan_desc {
int64_t size;
int64_t n;
const int64_t *offs;
} flan_desc;
#define DYN_QNAN 0xFFF8000000000000ULL
#define DYN_TAGMASK 0x0007000000000000ULL
#define DYN_PAYMASK 0x0000FFFFFFFFFFFFULL
@ -198,10 +209,24 @@ static int gc_ready;
* would look for. Precision here is cheaper than the arguments about it.
*
* Growable, because a deep recursion over dyn locals is an ordinary program
* and a fixed table would be a limit nobody could predict. The array holds
* [flan_dyn *], so growing it moves the array and not the slots. */
* and a fixed table would be a limit nobody could predict. The array holds the
* addresses, so growing it moves the array and not the slots.
*
* A root is an address and a shape. The shape is NULL for the common case —
* the address is a dyn word and marking it is one call — and a [flan_desc] for
* an aggregate, which is a struct or an array of them with dyn fields
* somewhere inside. The descriptor is static data the compiler emitted for
* that type, and the pairing of address with descriptor is made at the *push*,
* by the code that knows what is at that address, which is why nothing in the
* heap or on the stack needs a header word for the collector to read. See
* flan_dyn.h's [flan_dyn_root_push_desc] for the whole of that argument. */
static flan_dyn **roots;
typedef struct {
void *base;
const flan_desc *desc; /* NULL: [base] is one flan_dyn */
} flan_root;
static flan_root *roots;
static int64_t roots_n, roots_cap;
/* ── The temporaries ring ──────────────────────────────────────────────
@ -728,7 +753,15 @@ static void mark_value(flan_dyn v) {
static void gc_mark_all(void) {
int64_t i;
unsigned k;
for (i = 0; i < roots_n; i++) mark_value(*roots[i]);
for (i = 0; i < roots_n; i++) {
const flan_desc *d = roots[i].desc;
if (d == NULL) mark_value(*(flan_dyn *)roots[i].base);
else {
int64_t j;
for (j = 0; j < d->n; j++)
mark_value(*(flan_dyn *)((char *)roots[i].base + d->offs[j]));
}
}
for (k = 0; k < RING; k++) mark_push(ring[k]);
while (mstack_n > 0) {
flan_obj *o = mstack[--mstack_n];
@ -762,15 +795,31 @@ static void gc_sweep(void) {
}
}
void flan_dyn_root_push(flan_dyn *slot) {
static void root_add(void *base, const flan_desc *d) {
if (roots_n == roots_cap) {
int64_t cap = roots_cap ? roots_cap * 2 : 64;
flan_dyn **r = (flan_dyn **)realloc(roots, (size_t)cap * sizeof *r);
flan_root *r = (flan_root *)realloc(roots, (size_t)cap * sizeof *r);
if (r == NULL) trap_oom(cap * (int64_t)sizeof *r);
roots = r;
roots_cap = cap;
}
roots[roots_n++] = slot;
roots[roots_n].base = base;
roots[roots_n].desc = d;
roots_n++;
}
void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); }
/* The aggregate form. One entry on the same stack, so one [flan_dyn_root_pop]
* takes off a mixture of the two and a function's pop count stays the number
* of pushes it made. A NULL descriptor is not an error — it is a type the
* compiler found no dyn in — but it still occupies an entry, because the count
* is what the epilogue knows, and it is turned into an empty descriptor rather
* than stored as NULL, which on this stack means something else. */
static const flan_desc desc_empty = { 0, 0, NULL };
void flan_dyn_root_push_desc(void *base, const flan_desc *d) {
root_add(base, d == NULL ? &desc_empty : d);
}
/* Clamped at empty rather than refused. A pop that outruns its pushes means

47
runtime/flan_dyn.h
View File

@ -30,6 +30,27 @@ extern "C" {
* has to agree about. NaN-boxed; see the design doc. */
typedef uint64_t flan_dyn;
/* A type's dyn map — where the dyn words are inside one instance of it.
*
* The compiler emits one of these as static data for every type that holds a
* dyn anywhere: a struct with a dyn field, a struct holding such a struct by
* value, a fixed array of either. The offsets are flattened at compile time,
* so nesting costs nothing here — an inner struct's dyn word appears at the
* outer offset plus the inner one, and there is no walking of a type graph at
* run time and no second descriptor to follow.
*
* [size] is the stride of one instance. The collector does not read it; the
* typed-container view will, which is the reason it is here now rather than
* being added later to data both lanes already emit.
*
* Nothing in this ABI ever writes a descriptor, and no value ever points at
* one. See [flan_dyn_root_push_desc]. */
typedef struct flan_desc {
int64_t size;
int64_t n;
const int64_t *offs;
} flan_desc;
/* ── Constructors ──────────────────────────────────────────────────── */
flan_dyn flan_dyn_nil(void);
@ -158,6 +179,32 @@ int64_t flan_gc_live_bytes(void);
void flan_dyn_root_push(flan_dyn *slot);
void flan_dyn_root_pop(int64_t n);
/* The same stack, for a slot that holds an aggregate rather than a dyn word:
* a struct with a dyn field, a struct holding one of those by value, an array
* of either. [base] is the first byte of the instance and [d] says where the
* dyn words are inside it.
*
* The question this answers, and it is the only interesting one about the
* whole mechanism: how does the collector get from a run of bytes to the
* descriptor for the type at those bytes? It does not. **The instance never
* carries a pointer to its descriptor, and the collector never derives one.**
* The pairing is made here, at the push, by the code that put the value there
* and therefore knows its static type. That is what makes a bare struct on the
* stack the easy case rather than the impossible one, and it is why no Flan
* struct grows a header word: a header would change the layout C interop
* agrees on, change the stride of an array, and change what embedding a struct
* in another one costs.
*
* The same contract as the dyn form: **the dyn words named by [d] must hold
* valid flan_dyn values before the push**, which zero satisfies. The compiler
* zeroes those words and not the whole instance — the rest of the bytes are
* never read through this stack.
*
* One entry, so one pop takes it off like any other, and a function's pop
* count is still the number of pushes it made. [d] is static data with the
* lifetime of the program; nothing copies it. */
void flan_dyn_root_push_desc(void *base, const flan_desc *d);
/* ── Extensions ────────────────────────────────────────────────────────
*
* Additions to the agreed ABI, none of which the compiler lane has to emit.

80
test/dyn_ops.c
View File

@ -17,6 +17,7 @@
* gets its own.
*/
#include <stddef.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
@ -550,6 +551,84 @@ static void unrooted(void) {
after <= before + 64 ? "yes" : "no");
}
/* An aggregate root: a struct with dyn fields somewhere inside it, rooted by
* its address and a descriptor rather than word by word. This is the runtime's
* half of the per-type descriptors, exercised with the descriptor written out
* here by hand — the compiler emits the same three words as static data, and a
* runtime that read them wrongly would be wrong in both lanes at once.
*
* The shape deliberately has a gap and a nesting in it: a header word that is
* not a dyn, an inner struct that carries one, and a trailing one. If the
* marker walked the struct as a run of words rather than by the offsets it was
* given, it would decode [n] as a value and miss nothing — which is why [n]
* holds a bit pattern that is a plausible boxed pointer. */
typedef struct {
int64_t n;
flan_dyn label;
struct { int32_t k; flan_dyn note; } inner;
flan_dyn tail;
} desc_row;
static void desc(void) {
static const int64_t offs[] = {
(int64_t)offsetof(desc_row, label),
(int64_t)offsetof(desc_row, inner.note),
(int64_t)offsetof(desc_row, tail)
};
static const flan_desc row_desc = {
(int64_t)sizeof(desc_row), 3, offs
};
desc_row row;
flan_dyn was_label, was_note;
int i, ok = 1;
flan_gc_init();
flan_gc_set_floor(16 * 1024);
/* The contract the header states: the dyn words must hold valid values
before the push. Zero satisfies it; the header word need not. */
row.label = flan_dyn_nil();
row.inner.note = flan_dyn_nil();
row.tail = flan_dyn_nil();
row.n = (int64_t)0xFFFB000000001234LL; /* looks boxed, is not a dyn slot */
row.inner.k = 7;
flan_dyn_root_push_desc(&row, &row_desc);
row.label = flan_dyn_vec_new();
flan_dyn_push(row.label, text("held"));
row.inner.note = text("nested");
row.tail = flan_dyn_vec_new();
flan_dyn_push(row.tail, flan_dyn_from_i64(99));
was_label = row.label;
was_note = row.inner.note;
for (i = 0; i < 20000; i++) (void)text("noise");
flan_gc_collect();
if (row.label != was_label || row.inner.note != was_note) ok = 0;
if (!flan_dyn_need_bool(
flan_dyn_eq(flan_dyn_at(row.label, flan_dyn_from_i64(0)),
text("held")))) ok = 0;
if (!flan_dyn_need_bool(flan_dyn_eq(row.inner.note, text("nested")))) ok = 0;
if (flan_dyn_need_i64(flan_dyn_at(row.tail, flan_dyn_from_i64(0))) != 99)
ok = 0;
printf("aggregate root survives collection: %s\n", ok ? "yes" : "no");
printf("the word at a non-dyn offset is untouched: %s\n",
row.n == (int64_t)0xFFFB000000001234LL ? "yes" : "no");
/* And the positive control, which is the same one [unrooted] makes: drop the
fields and the objects go. One pop takes the aggregate entry off exactly
as it takes a dyn one off, which is what keeps a function's pop a count. */
row.label = flan_dyn_nil();
row.inner.note = flan_dyn_nil();
row.tail = flan_dyn_nil();
flan_dyn_root_pop(1);
for (i = 0; i < 5000; i++) (void)text("noise");
flan_gc_collect();
printf("and is reclaimed once dropped: %s\n",
flan_gc_count() <= 128 ? "yes" : "no");
}
/* ── The refusals ──────────────────────────────────────────────────────
*
* One per mode, because each ends the process. The driver asserts on the
@ -625,6 +704,7 @@ int main(int argc, char **argv) {
if (strcmp(argv[1], "nested") == 0) { nested(); return 0; }
if (strcmp(argv[1], "sharing") == 0) { sharing(); return 0; }
if (strcmp(argv[1], "unrooted") == 0) { unrooted(); return 0; }
if (strcmp(argv[1], "desc") == 0) { desc(); return 0; }
if (strncmp(argv[1], "refuse:", 7) == 0) { refuse(argv[1] + 7); return 0; }
printf("no such mode: %s\n", argv[1]);
return 2;

114
test/programs/dyn-struct.flan Normal file
View File

@ -0,0 +1,114 @@
;;;; A struct with a dyn field, under an actual collection.
;;;;
;;;; Until the per-type descriptors this program did not compile: the checker
;;;; refused a dyn field outright, because the collector's roots were frames
;;;; and a struct outlives the frame that built it, so the field's vector was
;;;; reachable only through memory the marker never walked.
;;;;
;;;; What lifted it: every type that holds dyn words at static offsets gets a
;;;; descriptor — a table of byte offsets, emitted once as static data — and
;;;; every place a value of that type can live goes on the collector's root
;;;; stack with the descriptor beside it. The instance never points at its
;;;; descriptor and the collector never derives one from the bytes; the pairing
;;;; is made at the push, by the code that knows the static type of what it put
;;;; there. runtime/flan_dyn.h's flan_dyn_root_push_desc argues that at length.
;;;;
;;;; So this file exercises the four places such a value lives, and does it
;;;; past flan_dyn.c's one-megabyte floor, which is the only way a mark and a
;;;; sweep actually run:
;;;;
;;;; - a frame slot, which is [keep] in [churn];
;;;; - a global, which is [registry], rooted before the startup function;
;;;; - the temporary a call's by-value return lands in, which is what
;;;; [make-row] hands back — the callee rooted that vector and popped it in
;;;; its epilogue, so between the return and the caller's store the only
;;;; copy is a register the collector cannot see;
;;;; - a condition's payload, which crosses a handler boundary as a pointer
;;;; into a live frame while the handler allocates.
;;;;
;;;; Nesting is in here twice over: Row holds a Tag by value, and Tag holds the
;;;; dyn. A descriptor is flattened, so Row's table names Tag's dyn word at
;;;; Row's offset plus Tag's, and there is no second descriptor to follow.
;;;;
;;;; What a lost root looks like here is not a wrong number. It is a use of
;;;; freed memory — a crash, or a word that decodes as another tag and traps
;;;; with a sentence about the wrong type.
(defstruct Tag [name dyn])
(defstruct Row [id i32 tag Tag rows dyn])
(defstruct Stalled [why dyn id i32])
;;; A global holding dyn words, which main roots before a line of the program
;;; runs and never pops. Zero until its field is set, and a zero word is not a
;;; value the collector follows.
(defvar registry Row)
;;; What the handler saw, read back after the handler had allocated.
(defvar echoed dyn)
(defvar stalls i64)
;;; The collector's own counters, so that "nothing leaks" is a fact this
;;; program states rather than one the absence of a crash implies.
(declare gc-collect [] () "flan_gc_collect")
(declare gc-count [] i64 "flan_gc_count")
;;; Returned by value. The vector is rooted in this frame and unrooted the
;;; instant the epilogue pops, so the caller's own root is the only thing
;;; between it and the next allocation.
(defn make-row [i i32] Row
(let [rows (vec-new dyn)]
(push rows i)
(push rows "row")
(push rows 2.5)
(Row {.id i .tag (Tag {.name "tag"}) .rows rows})))
;;; An aggregate parameter, which arrives in its slot before the roots are
;;; pushed. Zeroing its dyn words over the top of the argument would be a
;;; silent miscompile, so the count this returns is the check for it.
(defn row-len [r Row] i64 (i64 (len (.rows r))))
;;; The payload crosses as a pointer to a value in this frame, and the handler
;;; below allocates before it reads it.
(defn stall [i i32] ()
(let [why (vec-new dyn)]
(push why "stalled")
(push why i)
(signal (Stalled {.why why .id i}))))
;;; The garbage is a whole Row per iteration, kept by nothing. The live one
;;; grows *through* the collections rather than only between them.
(defn churn [n i32] i64
(let [keep (make-row 0)
total (i64 0)
i 0]
(while (< i n)
(let [junk (make-row i)]
(set total (+ total (row-len junk))))
(if (= 0 (% i 64)) (push (.rows keep) i))
(if (= 0 (% i 4096)) (stall i))
(set i (+ i 1)))
(set (.rows registry) (.rows keep))
total))
(defn main [] ()
(set (.name (.tag registry)) "registry")
(set (.rows registry) (vec-new dyn))
(handler-bind [(Stalled [c]
;; Allocate first, then read the payload: if the payload's
;; vector were unrooted across the transfer, this is the
;; allocation that would free it.
(let [noise (vec-new dyn)]
(push noise "noise"))
(set stalls (+ stalls 1))
(set echoed (at (.why c) 0)))]
(print (churn 40000)) (print "\n"))
(print stalls) (print "\n")
(print echoed) (print "\n")
(print (.name (.tag registry))) (print "\n")
(print (len (.rows registry))) (print "\n")
(print (at (.rows registry) 0)) (print "\n")
;; And the heap after a final collection, which is the leak question asked
;; rather than assumed. Everything the run built is unreachable by now except
;; the registry's vector and the handful of words it holds.
(gc-collect)
(if (< (gc-count) 2000) (print "bounded\n") (print "LEAKED\n")))

54
test/test_acceptance.ml
View File

@ -3311,6 +3311,35 @@ level "1"
"programs/dyn-map.flan" dyn_map_out;
outputs ~x86:true "dyn: maps and keywords, --x86"
"programs/dyn-map.flan" dyn_map_out;
(* ── Per-type descriptors, M2 item 2 ─────────────────────────────
The first program anywhere with a dyn field in a struct, which was a
refusal until the descriptors landed. It matters at all three rows
because what it checks is a *root*, and a root is emitted by the
backend: the LLVM rows check one emitter and the --x86 row the other,
and a lost root on either is a live object swept.
The expectation was captured from the running program. Reading it: the
120000 is 40000 rows of three elements each, counted through an
aggregate parameter whose dyn fields must not be zeroed over the top of
the incoming argument; the 10 is how many times the loop signalled a
condition carrying a dyn payload, and [stalled] is that payload read
back *after* the handler had itself allocated; [registry] and the 628
and the 0 are a global struct's dyn fields, set once and read after
forty thousand rows of churn had collected many times over; and
[bounded] is the collector's own object count after a final sweep,
which is the leak question asked rather than assumed. With the
descriptor walk disabled in the marker, the 628 comes out 24 and the 0
comes out a stale word — which is how this row was checked to have
teeth. *)
let dyn_struct_out =
"120000\n10\nstalled\nregistry\n628\n0\nbounded\n"
in
outputs "dyn: a struct with dyn fields, under collection"
"programs/dyn-struct.flan" dyn_struct_out;
outputs ~opt:"-O0" "dyn: a struct with dyn fields, under collection, -O0"
"programs/dyn-struct.flan" dyn_struct_out;
outputs ~x86:true "dyn: a struct with dyn fields, under collection, --x86"
"programs/dyn-struct.flan" dyn_struct_out;
let dyn_global_out = "0 start\n2 done\n" in
outputs "dyn: a global" "programs/dyn-global.flan" dyn_global_out;
outputs ~opt:"-O0" "dyn: a global, -O0"
@ -3378,20 +3407,29 @@ level "1"
[%dr] is a rooted slot and [%dx] is the fallback, so the claim is that
the emitted IR contains none of the latter. It is worth stating as a
property of the whole corpus and not only of this file: any dyn program
that mints one has a temporary the collector cannot see. *)
that mints one has a temporary the collector cannot see.
[%ar] and [%ax] are the same pair for the aggregate roots the per-type
descriptors added — the temporary a call's by-value return is spilled
into, and the slot a condition that is not a place is evaluated into. A
fallback there is the same bug with a struct in front of it. *)
let no_fallback_slots path =
let l = Load.program ~file:path (Reader.read_file path) in
let ir = Emit.program (Check.program_all l.Load.decls) in
if contains ir "%dx" then begin
incr failures;
Printf.printf
"FAIL %s emits an unrooted dyn temporary (%%dx) — dyn_roots counted \
fewer than the emission minted\n"
path
end
List.iter
(fun (mark, what) ->
if contains ir mark then begin
incr failures;
Printf.printf
"FAIL %s emits an unrooted %s temporary (%s) — root_plan \
counted fewer than the emission minted\n"
path what mark
end)
[ ("%dx", "dyn"); ("%ax", "aggregate") ]
in
List.iter no_fallback_slots
[ "programs/dyn-basic.flan"; "programs/dyn-vec.flan";
"programs/dyn-struct.flan";
"programs/dyn-global.flan"; "programs/dyn-boundary.flan";
"programs/dyn-defer.flan" ];
(* And that the defer program still runs and still runs its defer: the

19
test/test_dyn.ml
View File

@ -14,6 +14,8 @@
gc a million allocations against a hundred live, and the heap's
high-water mark bounded
unrooted the positive control: an object nothing points at is reclaimed.
desc an aggregate root: a struct whose dyn fields are named by a
descriptor rather than pushed one at a time.
Without it a collector that never freed would pass everything
nested a chain of vecs sixty-four deep, traced through one root
sharing one object held three times — written through one path and read
@ -96,6 +98,21 @@ let () =
fail "an unrooted object\n got: %S (exit %d)\n wanted: %S"
out code want_un;
(* The aggregate roots the per-type descriptors added: a struct with dyn
fields at three offsets, one of them inside a nested struct, rooted by
address and descriptor rather than word by word. The second line is the
one that would catch a marker walking the struct as a run of words: the
header holds a bit pattern that looks boxed and is not a dyn slot. *)
let code, out, _ = run "desc" in
let want_desc =
"aggregate root survives collection: yes\n\
the word at a non-dyn offset is untouched: yes\n\
and is reclaimed once dropped: yes\n"
in
if code <> 0 || out <> want_desc then
fail "an aggregate root\n got: %S (exit %d)\n wanted: %S"
out code want_desc;
let code, out, _ = run "nested" in
if code <> 0 || out <> "chain of 64 intact: yes\n" then
fail "a chain of nested vecs\n got: %S (exit %d)" out code;
@ -159,7 +176,7 @@ let () =
(* A line on the way out, because a test that says nothing when it passes
is a test nobody can tell from a test that did not run. *)
if !failures = 0 then
Printf.printf " ok the dyn runtime: %d refusals and five runs\n"
Printf.printf " ok the dyn runtime: %d refusals and six runs\n"
(List.length refusals)
else exit 1
| _ -> print_endline "SKIP test_dyn: no clang"

71
test/test_flan.ml
View File

@ -890,21 +890,64 @@ let () =
accepts "a bracket literal where a dyn is wanted is a dyn vec"
"(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take [1 2 3]))";
(* A condition crosses a handler boundary as a pointer to a live frame, and
a dyn payload has to stay rooted across that transfer — the collector's
question, and milestone 2's. *)
rejects_check "a dyn in a condition's payload"
(* ── Per-type descriptors — M2 item 2 ──────────────────────────
Both of these were refusals until the descriptors landed, and for one
reason: the collector's roots were frames, so a struct's dyn field was a
live value reachable only through memory the marker never walked. A type
that holds dyn words at static offsets now has a descriptor naming them,
and every slot, global and temporary holding one goes on the root stack
with that descriptor beside it — so the instance never has to carry a
pointer to its own type, which is what would have cost a header word. *)
accepts "a dyn field in a struct"
"(defstruct S [x dyn])\n(defn main [] i32 0)";
accepts "a dyn in a condition's payload"
"(defstruct Boom [what dyn])\n\
(defn main [] () (signal (Boom {.what 1})))"
~needle:"milestone 2";
(* A plain struct too, not only a condition's: the struct outlives the
frame that roots its values, so a dyn field is reachable only through
memory the marker never walks. Found as SPIKE-DUPLICITY.md's question 1
— the emitted program rooted the temporary, popped it at ret, and left
the field's vec live and untraced. *)
rejects_check "a dyn field in a struct"
"(defstruct S [x dyn])\n(defn main [] i32 0)"
~needle:"a struct outlives the frame";
(defn main [] () (signal (Boom {.what 1})))";
(* Nested by value, which is the case the flattening is for: the inner
struct's dyn word appears in the outer's table at the sum of the two
offsets, and there is no second descriptor to follow at run time. *)
accepts "a dyn inside a struct inside a struct"
"(defstruct Inner [x dyn])\n\
(defstruct Outer [n i32 in Inner])\n\
(defn main [] i32 (let [o (Outer {.n 1 .in (Inner {.x 2})})] (.n o)))";
(* And a fixed array of them, which is the same flattening once per
element — an array is a value and its storage is the slot's. *)
accepts "a fixed array of structs with dyn fields"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [a (array 4 S)] (set (.x (at a 0)) 7) 0))";
(* A global, rooted before the startup function runs and never popped. *)
accepts "a global struct with a dyn field"
"(defstruct S [x dyn])\n(defvar s S)\n(defn main [] i32 0)";
(* What the descriptor still cannot reach, each by name. A typed container
owns storage of a length nothing static knows, so the dyn words of one
are not a list of offsets — that is the M2 queue's item 3, and it is a
different shape of descriptor on purpose. *)
rejects_check "a dyn field under a typed container"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [v (vec-new S)] 0))"
~needle:"no descriptor can find";
(* A data type's cases overlay one another, so which words are dyn depends
on the tag, which is a run-time question a static table cannot answer. *)
rejects_check "a dyn field in a data type's payload"
"(defdata D [(A [x dyn]) (B [n i32])])\n\
(defn main [] i32 (let [d (D.B {.n 1})] 0))"
~needle:"no descriptor can find";
(* An Option's payload exists only under the tag. A None's words are zero
and marking them would be harmless, but that is how this compiler happens
to build one and not something the type says. *)
(* And the one cap, which is arithmetic rather than representation: an
array's offsets are flattened one element at a time, so a big enough
array would be a megabyte of static table. The repeat form that avoids
it is the typed container view's machinery, so this says so. *)
rejects_check "an array too big for a flattened descriptor"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [a (array 5000 S)] 0))"
~needle:"the most this compiler will write out";
rejects_check "a dyn field under an Option"
"(defstruct S [x dyn])\n\
(defn f [] (Option S) None)\n\
(defn main [] i32 0)"
~needle:"no descriptor can find";
(* And the C boundary, which is the one that would otherwise pass silently:
a dyn is one word and would cross as an integer, and nothing on the other
side can ask what the word means. *)

11
test/test_sanitize.ml
View File

@ -192,6 +192,15 @@ let corpus =
and the interned keywords are what the sweep has to leave alone. *)
"programs/dyn-vec.flan", [];
"programs/dyn-defer.flan", [];
(* The per-type descriptors' own program, and the one in this list whose
roots are aggregates rather than dyn words: a struct with a dyn field
in a frame slot, in a global, in the temporary a by-value return lands
in, and as a condition's payload across a handler transfer. It runs
past the one-megabyte floor like [p13], so a mark and a sweep really
happen, and what a wrong descriptor offset looks like is a read of a
freed object — which is exactly what ASan is here to see and what no
amount of reading the offsets can. *)
"programs/dyn-struct.flan", [];
"programs/dyn-map.flan", [];
"../spike/x86/p13-dyn-collect.flan", [];
"programs/sand-headless.flan", [];
@ -276,7 +285,7 @@ let dyn_sweep () =
if reported text then fail "dyn %s: sanitizer report\n%s" mode text
else if code <> 0 then
fail "dyn %s: exit %d under the sanitizers\n%s" mode code text)
[ "ops"; "gc"; "unrooted"; "nested"; "sharing" ];
[ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing" ];
(try Sys.remove exe with Sys_error _ -> ())
(* The positive controls, which are the only evidence that a clean sweep means