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

Merge branch 'worktree-agent-af0dbd9d75a1c8bee' into dev-loop

Browse Source 
# Conflicts:
#	test/dune
#	test/test_acceptance.ml
This commit is contained in:
Joseph Ferano 2026-09-19 16:02:39 +07:00
commit 73ab213134
13 changed files with 585 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
docs/handoffs/HANDOFF-dyn-m1.md
View File

@ -84,6 +84,17 @@ encoding.
If the real runtime NaN-boxes and integer zero is the zero word, this is wrong
and the two sides need a different sentinel. Do not fix it on one side.
**Settled, by reading the other side.** The real runtime does NaN-box, and the
zero word is *not* the zero integer: an integer is boxed, and boxed means the
quiet-NaN prefix is set. `mark_value` in `runtime/flan_dyn.c` follows a value
only when `dyn_boxed` holds, which tests `(v & 0xFFF8000000000000) ==
0xFFF8000000000000`, and the zero word fails it. So a rooted slot holding 0
decodes as the double `0.0` — an ordinary value rather than a marker, and
crucially never an address the collector dereferences. Zero is safe, and the
header's sentence is true for a reason both sides can check rather than by the
two of them having guessed alike. No sentinel is needed and neither side
changes.
## Not in milestone 1, each refused by name with a location
- a typed container boxing into dyn (`(Vec i64)` → dyn): "not yet"; the
@ -99,7 +110,15 @@ and the two sides need a different sentinel. Do not fix it on one side.
the ABI carries one of each, and a `need_i64` plus a truncation would put an
implicit narrowing at the one boundary where the value's type was already
uncertain
- the x86 dev backend, and the JS dialect, refuse dyn entirely
- ~~the x86 dev backend, and~~ the JS dialect, refuse dyn entirely. The x86
backend does not any more: a dyn is one machine word in both calling
conventions and every operation on one is an ordinary `Tast.Rt` call, so what
the lane cost was the root discipline and not the arithmetic — a zeroed frame
slot per dyn local and per dyn-producing call, pushed in the body buffer at
entry, and one `flan_dyn_root_pop` in the epilogue that every return and
every transfer out of the frame already went through. `Emit.dyn_roots` is
called by both backends, which is what makes the counts agree rather than
merely both being written down
## Roots: what is and is not verified

32
lib/check.ml
View File

@ -2354,7 +2354,6 @@ and check_fn ctx ~want loc (params : string list) body =
it, and an early exit would leave them on the stack pointing into a function
that has gone. *)
and check_handler_bind ctx ?want loc clauses body =
ignore want;
let frames =
List.map
(fun (c : Ast.hclause) ->
@ -2422,11 +2421,36 @@ and check_handler_bind ctx ?want loc clauses body =
collide. *)
let saved = ctx.in_frames in
ctx.in_frames <- Some "handler-bind";
let body =
barrier ctx "a handler-bind" (fun () -> map_lr (fun e -> check ctx e) body)
(* The body's last form is the form's value, which is [with-allocator]'s
shape and for the same reason: both wrap a body in something established
around it and taken off after, and neither is a reason for the body to
stop being an expression. §3 needs it — a [restart-case] whose body is a
[handler-bind] has to agree in type with its clauses, which is how all
four of this repository's crossing probes are written — and it is what
[handler-case] will *not* be: that one's value is the handler's, which is
the whole difference between the two and is why it is still refused by
name in [parse.ml].
This used to be [ignore want] and a flat [Types.Unit], and nothing
complained, because a unit in value position is only caught where the
expectation is checked. So the two backends each answered a caller that
asked anyway, and answered differently: [emit.ml] a literal zero, this
machine whatever the body's last form had left in the slot. Neither was a
value; one of them merely looked like one. *)
let body, ty =
barrier ctx "a handler-bind" (fun () ->
let rec go = function
| [] -> [ unit_at loc ], Types.Unit
| [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty
| e :: rest ->
let e = check ctx e in
let rest, ty = go rest in
e :: rest, ty
in
go body)
in
ctx.in_frames <- saved;
mk loc Types.Unit (Tast.Handled (frames, body))
expect loc ~want (mk loc ty (Tast.Handled (frames, body)))
(* (restart-case BODY (name [] BODY-1) ...) — spec-conditions.md §3 and §6.

9
lib/dev.ml
View File

@ -3695,6 +3695,14 @@ extern void (*flan_exit_hook)(int32_t status);
extern void flan_condition_stacks_reset(void);
extern void flan_dev_frames_reset(void) __attribute__((weak));
/* And the collector's roots, which are the third stack threaded through stack
* the finished run no longer owns. main is re-entered by longjmp, which pops
* no frame, so every root the last run pushed still names an address the next
* run is about to write over — and the next mark would follow whatever it put
* there. Weak for the reason the frames reset is weak; runtime/flan_dyn.h
* exports this for this one caller. */
extern void flan_dyn_root_reset(void) __attribute__((weak));
/* The agent's ring, drained on whatever thread calls this. Weak for the reason
* the reset above is weak, and it is the same class of fact: a merged binary
* links the agent by construction, which is exactly the kind of guarantee that
@ -3843,6 +3851,7 @@ static void flan_merged_exit(int32_t status) {
static void flan_merged_park(void) {
flan_condition_stacks_reset();
if (flan_dev_frames_reset) flan_dev_frames_reset();
if (flan_dyn_root_reset) flan_dyn_root_reset();
pthread_mutex_lock(&program_lock);
program_state = PROGRAM_PARKED;
pthread_mutex_unlock(&program_lock);

15
lib/emit.ml
View File

@ -1700,7 +1700,6 @@ and emit_handled f frames body =
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
@ -1713,7 +1712,19 @@ and emit_handled f frames body =
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
else begin
label f ld;
(* The body's own value, and no [phi] or slot to carry it, unlike
[emit_with_alloc] next door: [ld] has exactly one predecessor. The pad
terminates at [current_pad] and never at [ld], so the only edge into it
is the [br] above, and [last] is computed in the block that ends with
that [br] — it dominates every use here.
This used to answer "zeroinitializer" and drop [last] on the floor, from
when the checker typed this form [unit] and no caller was supposed to be
able to ask. One could, and the constant zero is what it got. *)
last
end
(* A clause's parameters, as one LLVM struct: what the invoker stores into and
what the clause loads out of. The two ends never see each other, so the

236
lib/x86.ml
View File

@ -475,23 +475,16 @@ let is_agg (t : Types.t) =
| Types.Unit | Types.Never -> false
| Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _
| Types.Option _ | Types.Named _ -> true
(* Refused by name rather than classified. A dyn word is one machine word and
would classify trivially — it is not the representation that is missing,
it is every operation on it, which is a call into runtime/flan_dyn.h that
this backend does not emit. Saying "a dyn value" here rather than letting
it through to fail at the first [+] means the reader is told the one true
thing about their program instead of something about an opcode.
The sentence naming [--llvm] is not written here on purpose: both callers
add it, and each says it differently for a good reason — Session because
the daemon takes this backend by default and the reader chose a program
rather than a code generator, and main.ml only when [--x86] was not typed
out. Repeating it here would say it twice to the one reader and to the
wrong one. *)
| Types.Dyn ->
unsupported
"a dyn value. Every operation on one is a call into the dynamic runtime, \
and this backend emits none of them"
(* A scalar, and trivially one: runtime/flan_dyn.h says [typedef uint64_t
flan_dyn], so a dyn is a machine word in both calling conventions and
nothing about it is ever passed by address. This arm used to refuse — not
because the representation was missing but because every *operation* on
one is a call into the dynamic runtime, and for a while this backend
emitted none of them. It emits them now: they are [Tast.Rt] primitives
like every other runtime call, and [call_rt] has always known how to make
one. What the lane actually cost was the collector's root discipline, not
the arithmetic. *)
| Types.Dyn -> false
| Types.Var v -> unsupported "type variable %s" v
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
@ -656,6 +649,23 @@ type fnctx = {
anyway is what makes the two backends' frames answer identically, which is
the only thing the break loop can check. *)
mutable dslotv : int option;
(* The collector's shadow stack — runtime/flan_dyn.h's [flan_dyn_root_push]
and [flan_dyn_root_pop]. [droots] is how many this function pushed at
entry and so how many the one pop in the epilogue takes off; [droot_ns]
is the frame offsets of the *temporaries* among them, in push order,
handed out one at a time by [dyn_tmp] as the body is lowered. Both are
zero and empty for every function with no dyn in it, and then not an
instruction is emitted — which is what keeps every other program in the
survey byte for byte what it was.
A count rather than a running tally for [emit.ml]'s reason: the epilogue
is emitted after the body, but the pushes are decided before it, by
[Emit.dyn_roots], which is deliberately the *same* function both backends
call. The pushes and the pops balance because one counter decides both
ends, and the two backends root the same nodes because there is one
counter and not two. *)
mutable droots : int;
mutable droot_ns : int 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;
@ -1361,6 +1371,24 @@ let with_pad f tag g =
f.pads <- List.tl f.pads;
(pad, used, r)
(* The next pre-made root slot for a dyn temporary — [emit.ml]'s [dyn_tmp],
in frame offsets rather than alloca names. Every one of them was minted,
zeroed and pushed before a line of the body was emitted, and this only
hands them out, which is what makes the pushes and the pops balance by
construction rather than by the body being walked the same way twice.
[Emit.dyn_roots] counts the same nodes this emission visits, so the supply
runs out only if those two disagree — and since both backends call that one
function, disagreeing would be one of them visiting a node the other does
not. The fallback is an ordinary unrooted temporary, for [emit.ml]'s
reason and it is the same trade here: one dyn value the collector cannot
see is a bug to go and find, where a root stack that pops more than it
pushed is memory corruption. *)
let dyn_tmp f =
match f.droot_ns with
| n :: rest -> f.droot_ns <- rest; n
| [] -> alloc f 8 8
(* ── The runtime's two dynamic stacks ────────────────────────────────── *)
(* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the
@ -2589,7 +2617,23 @@ and rt_signals sym =
String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice"
and call_rt f ~sym ~args ~rty dst =
call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst
call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst;
(* A dyn word is spilled into a rooted slot the instant it exists, because
the next allocation may be the one that collects what it is holding and
the collector finds its roots by address. [dst] is not enough: it is
often 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.
[Emit.dyn_roots] counted this call, so the slot below is one the entry
block has already zeroed and pushed.
Here rather than in [call_native], which is [call_c]'s as well: a dyn
crossing to C is refused in the checker and there would be nothing to
root. rax still holds the answer — [store_loc] above takes r11 for its
scratch and nothing else. *)
if rty = Types.Dyn then begin
let slot = dyn_tmp f in
store_int f.b ~src:rax ~mm:(Frame slot) ~size:8
end
and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
(* A Vec and a Map cross to the runtime as their
@ -3193,7 +3237,8 @@ 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; snames = fn.Tast.snames;
dframe = None; dslotv = None; droots = 0; droot_ns = [];
snames = fn.Tast.snames;
frame = 0; maxframe = 0; outgoing = 0;
loops = []; pads = []; xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns; ext; slot; dw;
@ -3236,6 +3281,63 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
f.xfer_off <- ptmp f;
if sret then f.sret_off <- ptmp f;
if (not sret) && not (is_void fn.Tast.ret) then f.retval <- tmp f fn.Tast.ret;
(* The collector's roots — runtime/flan_dyn.h. Not gated on [md.dev], unlike
everything below it: the shadow stack is a debugging convenience a release
build does without, while a collector that cannot find its roots is a
collector that frees live values. Only a function with a dyn in it pays
anything, because [Emit.dyn_roots] is zero otherwise and not an
instruction is emitted — which is what keeps every dyn-free program in the
survey byte for byte what it was before this lane.
The *slots* are already frame temporaries from the loop above, so they are
pushed where they are; the temporaries need slots of their own, and they
are minted here, beside the channel and the return temporary and outside
every [scoped], because the bump allocator reclaims at the end of each
statement and a slot minted inside the body would be handed out again to
the next one while the collector still held its address.
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
(* 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
be *an* order and this is the one both backends use, so an asm listing
and an IR listing put the same value at the same depth.
A parameter's slot is filled from its incoming register in the prologue
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 in
a branch that does not.
Zero rather than a call to [flan_dyn_nil], and this is the ABI point the
dyn handoff left open for the integrator while the collector was a stub.
It is not a stub now, and the answer is in runtime/flan_dyn.c:
[mark_value] follows a value only when [dyn_boxed] holds, which tests
[(v & 0xFFF8...) == 0xFFF8...], and the zero word fails it. So a rooted
slot holding 0 decodes as the double 0.0 — an ordinary value, not a
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. *)
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;
f.droots <- nroots;
f.droot_ns <- temps
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
channel and the return temporary, so that they sit above [fixed] and the
@ -3275,6 +3377,35 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
| _ -> None)
fn.Tast.params param_at
in
(* The collector's roots, zeroed and pushed. Into the *body* buffer for the
same reason the shadow stack's push below is, and more sharply: this is a
run of calls, and a call clobbers every scratch register the prologue is
still using to hand the arguments to their slots. The body buffer's first
byte is the first point at which they are all safely in the frame.
Before the shadow stack's push and not after, so that a stopped frame's
record is the last thing established and the first thing taken down —
the two stacks are independent, but keeping them strictly nested is
one less thing to reason about at a break. *)
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.";
xor_rr f.b ~dst:rax ~src:rax;
List.iter
(fun off -> store_int f.b ~src:rax ~mm:(Frame off) ~size:8)
!droot_zero;
List.iter
(fun off ->
lea f.b ~dst:rdi ~mm:(Frame off);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_root_push")
!droot_push
end;
(* The shadow stack's push, and the pop is in the epilogue. plan.org has had
*Frames: shadow stack* in the dev column since the beginning; [emit.ml]
builds the same four words on the LLVM side and this is the x86 one, down
@ -3499,6 +3630,26 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
load_int f.b ~dst:rax ~mm:(Frame fr) ~size:8 ~signed:false;
store_int f.b ~src:rax
~mm:(lmem f (sym_loc f "flan_frame_head") ~scratch:r11) ~size:8);
(* The collector's pop, and it is one call because this backend has one
epilogue: a [return], the fall through the body's tail and the transfer
exit all arrive at this label, so the roots come off on the unwinding
path as well as on the normal one. [emit.ml] needs the same pop at five
separate [ret]s and routes them through its own [ret] for exactly that
reason — roots left on the stack after a handled condition point into a
frame that has gone, and the next mark reads whatever the next call put
there.
Here, between the shadow stack's restore and the return value's load,
because a call clobbers both rax and xmm0 and the return value is about
to go into one of them. Bare — one immediate into rdi and the call —
because [frame_bytes] was read to build the prologue's [sub] before this
line was reached: a frame temporary or a stack argument allocated here
would be a frame this function never subtracted for. *)
if f.droots > 0 then begin
imm_into f ~reg:rdi (Int64.of_int f.droots);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_root_pop"
end;
if sret then load_int f.b ~dst:rax ~mm:(Frame f.sret_off) ~size:8 ~signed:false
else if not (is_void fn.Tast.ret) then
load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax)
@ -3574,8 +3725,8 @@ let init_sym = "\"flan..init-globals\""
the loader put them in, the program's own end of the transfer channel is a
null cell on this frame, and the exit goes through [flan_exit] because
stdout is a FILE* and something has to flush it. *)
let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) (md : Emit.m)
(fn : Tast.fn) =
let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
?(dyn_globals = []) (md : Emit.m) (fn : Tast.fn) =
let b = create () in
bnote ann b
"C's main, which is the whole of the adapter between the loader and a Flan program. \
@ -3595,6 +3746,34 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) (md : Emit.m)
without an exception, which is worth more than the two bytes. *)
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_rt_init";
(* Immediately after the host runtime and before anything that could box: a
dyn global's initialiser runs in the startup function below, and the very
first thing it does is allocate. Asked of the whole program rather than
assumed, so a program with no dyn in it emits no call and its [main] is
byte for byte the [main] it was. *)
if gc then begin
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_gc_init"
end;
(* The dyn globals, rooted here and never popped, which is the whole of what
a global's extent means. They go on the root stack *before* the startup
function runs, because that function is what fills them and its first
allocation may be the one that collects — and before any function of the
program pushes a root of its own, because every pop takes the top of the
stack and these are the ones that must never be at the top.
Zero is what a global holds until its initialiser has run: [.bss] gives
that for free, and a zero word is not a pointer the collector will
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 ->
(* 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")
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
from here rather than a second constructor. It takes no channel: no caller
@ -3662,7 +3841,8 @@ 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; snames = [||];
dframe = None; dslotv = None; droots = 0; droot_ns = [];
snames = [||];
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns; ext = (fun _ -> false);
@ -4085,7 +4265,14 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
end;
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
| Some fn ->
Buffer.add_string text (emit_main ~cfi:debug ~ann:annotate ~startup md fn)
Buffer.add_string text
(emit_main ~cfi:debug ~ann:annotate ~startup ~gc:(Emit.uses_dyn p)
~dyn_globals:
(List.filter_map
(fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn then Some g.Tast.gname else None)
p.Tast.globals)
md fn)
(* No [main] is not an error, and [emit.ml] treats it the same way: a
program can be linked against a C host that brings its own entry point,
which is what [reload_host.c] is. Refusing here made a --x86 host for the
@ -4305,7 +4492,8 @@ 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; snames = [||];
dframe = None; dslotv = None; droots = 0; droot_ns = [];
snames = [||];
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;
rodata = Buffer.create 256; externs; fns = fnstbl; ext; slot; dw = None;

7
runtime/flan_dyn.h
View File

@ -124,6 +124,13 @@ int64_t flan_gc_live_bytes(void);
* is the whole of the contract; the compiler lane zeroes a slot at its
* declaration anyway.
*
* A zeroed slot satisfies it, and this used to be the one thing in this header
* decided by one side alone. It is checkable now that both sides exist:
* flan_dyn.c's mark walks a value only when it is boxed, and boxed means the
* quiet-NaN prefix is set, which the zero word does not have. So zero decodes
* as the double 0.0 — an ordinary value, and never an address anything
* follows. Both backends zero, and they are right to.
*
* Globals go through the same pair, pushed once at startup and never popped.
*
* [flan_dyn_root_pop] takes a count rather than an address because that is

95
spike/x86/p12-handler-value.flan Normal file
View File

@ -0,0 +1,95 @@
;;;; A handler-bind in value position, and the shapes around it.
;;;;
;;;; This is here because for a long time nothing in the corpus asked a
;;;; [handler-bind] what its value was. [check.ml] typed the form [unit] and
;;;; dropped the expectation without checking it, so a caller that asked got an
;;;; answer anyway -- and the two backends had picked different ones. [emit.ml]
;;;; answered a literal zero; the hand-written backend answered whatever the
;;;; body's last form had left in the destination slot. The program below
;;;; printed 0 through LLVM and 2 through --x86, and neither number was the
;;;; restart's.
;;;;
;;;; The four programs that did write a [handler-bind] in value position all
;;;; wrote it as a [restart-case] body -- restarts.flan, cleanup.flan,
;;;; p6-transfer.flan, p10-defer-transfer.flan -- where §3 makes the types
;;;; agree but a transfer always leaves before the fall-through is reached. So
;;;; the value was never read and the hole stayed open. Here it is read:
;;;; [answered] returns through the handler-bind, and its value has to be the
;;;; clause's.
;;;;
;;;; The rest are the neighbouring shapes, because a divergence is rarely
;;;; alone: a clause parameter, two nested restart-cases, a defer between the
;;;; signal and the restart-case, and three types wider than the i32 the
;;;; condition corpus is written in.
(defstruct Oops [id i32])
(defvar trace i64)
;;; The shape that had no answer. The handler-bind is this function's last
;;; form, so what it yields is what the function returns, two frames above the
;;; restart-case the transfer lands in.
(defn risky [] i64
(restart-case (do (signal (Oops {.id 1})) 7)
(use-zero [] 42)))
(defn answered [] i64
(handler-bind [(Oops [c] (invoke-restart 'use-zero))]
(risky)))
;;; The fall-through half of the same shape: nothing handles the signal, so the
;;; body's own value is the one that comes back out through both forms.
(defn unanswered [] i64
(handler-bind [(Oops [c] (set trace (+ trace 100)))]
(risky)))
;;; §3's parameter, crossing into an i64 clause.
(defn supplied [] i64
(restart-case (do (signal (Oops {.id 2})) 7)
(use-value [v i64] (* v 3))))
;;; §4: the inner frame wins, and the arithmetic written around it still runs.
(defn nested [] i64
(restart-case
(+ (restart-case (do (signal (Oops {.id 3})) 7)
(use-zero [] 10))
1000)
(use-zero [] 20)))
;;; §5: a defer between the signal and the restart-case runs on the way out,
;;; before the clause body starts.
(defn mid [] i64
(defer (set trace (+ trace 1)))
(signal (Oops {.id 4}))
7)
(defn deferred [] i64
(restart-case (mid) (use-zero [] 9)))
;;; Two widths the condition corpus does not otherwise carry across a transfer:
;;; a float, which travels in the other register file, and a string, which is a
;;; pointer and a length rather than one machine word.
(defn floating [] f64
(restart-case (do (signal (Oops {.id 5})) 1.5)
(use-value [v f64] (* v 2.0))))
(defn spelled [] string
(restart-case (do (signal (Oops {.id 6})) "fell-through")
(use-value [v string] v)))
(defn main [] i32
(handler-bind [(Oops [c] (invoke-restart 'use-zero))]
(println (answered))) ; 42
(println (unanswered)) ; 7
(println trace) ; 100
(handler-bind [(Oops [c] (invoke-restart 'use-value (i64 5)))]
(println (supplied))) ; 15
(handler-bind [(Oops [c] (invoke-restart 'use-zero))]
(println (nested))) ; 1010
(handler-bind [(Oops [c] (invoke-restart 'use-zero))]
(println (deferred))) ; 9
(println trace) ; 101 — the defer ran
(handler-bind [(Oops [c] (invoke-restart 'use-value 2.5))]
(println (floating))) ; 5
(handler-bind [(Oops [c] (invoke-restart 'use-value "supplied"))]
(println (spelled))) ; supplied
0)

55
spike/x86/p13-dyn-collect.flan Normal file
View File

@ -0,0 +1,55 @@
;;;; Enough allocation that the collector actually runs, with live dyn values
;;;; held across it.
;;;;
;;;; Every other dyn program in this repository allocates a handful of objects
;;;; and stops. runtime/flan_dyn.c's trigger has a one-megabyte floor, so none
;;;; of them ever crosses it and none of them collects even once — which means
;;;; that until this file existed, a program whose root discipline was entirely
;;;; wrong printed the right answer on both backends. The dyn handoff said that
;;;; about the stub that never collected; the stub is gone and the observation
;;;; outlived it, because a heap that never fills is a collector that never
;;;; runs.
;;;;
;;;; So this one allocates well past the floor while holding values the
;;;; collector must not free: a vector that grows for the whole run, a text
;;;; allocated before the loop and read after it, and a running total. The
;;;; garbage is the per-iteration vector that nothing keeps, and there is a lot
;;;; of it.
;;;;
;;;; 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 some other tag and traps
;;;; with a sentence about the wrong type. Either way the two backends stop
;;;; saying the same thing, which is what the sweep asks.
;;; Held in locals across every allocation the loop makes, which are the slots
;;; the entry block roots. Returned, so the vector is live to the last line.
(defn build [n dyn] dyn
(let [xs (vec-new dyn)
i 0]
(while (< i n)
;; Fresh and unreferenced: this is the garbage. Four pushes each, so the
;; items array is allocated too and the heap moves quickly.
(let [junk (vec-new dyn)]
(push junk i)
(push junk "row")
(push junk 2.5)
(push junk true))
;; Every sixteenth iteration keeps one, so the live vector grows *through*
;; the collections rather than only between them.
(if (= 0 (% i 16)) (push xs i))
(set i (+ i 1)))
xs))
(defn main [] ()
;; Allocated before the loop runs and read after it, which is the check that
;; main's own root outlived every collection build triggered.
(let [keep "kept"
xs (build 40000)]
(print (len xs))
(print "\n")
(print (at xs 0))
(print "\n")
(print (at xs (- (len xs) 1)))
(print "\n")
(print keep)
(print "\n")))

18
spike/x86/survey.sh
View File

@ -78,14 +78,15 @@ out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
# truncations are both empty.
forever="dev-loop dev-watch dev-chatty"
# The dyn programs, which this backend refuses by name and is meant to: every
# operation on a dyn value is a call into the dynamic runtime and x86.ml emits
# none of them. They are listed rather than left to be counted as refusals
# because a REFUSED here means "a node this backend has stopped lowering",
# which is a regression, and this is the opposite -- a lane that has not
# started. Take a name off this list when the backend grows the lowering, and
# the survey will say whether it works.
llvmonly="dyn-basic dyn-vec dyn-global dyn-boundary dyn-defer"
# There used to be a second exclusion list here, holding the five dyn
# programs, and its note said to take a name off it when the backend grew the
# lowering and the sweep would then say whether it works. The backend grew it,
# so the list is gone rather than empty: a dyn is one machine word in both
# calling conventions and every operation on one is an ordinary runtime call.
# What the lane cost was the collector's root discipline -- a zeroed frame
# slot per dyn local and per dyn-producing call, pushed at entry, and one pop
# in the epilogue that every exit already went through. The five are in the
# sweep now and they are five of the MATCHes.
TIMEOUT=${TIMEOUT:-20}
@ -110,7 +111,6 @@ for src in "$corpus"/test/programs/*.flan "$corpus"/spike/x86/*.flan \
[ $want = 1 ] || continue
fi
case " $forever " in *" $name "*) skip+=("$name:runs-forever"); continue;; esac
case " $llvmonly " in *" $name "*) skip+=("$name:dyn-is-llvm-only"); continue;; esac
# LLVM first. A program that does not compile at all, or has no main, is not
# this backend's business -- the frontend refused it either way.

9
test/dune
View File

@ -149,9 +149,16 @@
(glob_files programs/*.flan)
(glob_files programs/assets/*)
(glob_files programs/assets/edn/*)
; p13-dyn-collect.flan, which lives with the x86 probes because that is the
; lane that wrote it, and is in this sweep because of what it does rather
; than where it is: it is the only program anywhere that allocates past
; flan_dyn.c's one-megabyte floor, so it is the only one under which a mark
; and a sweep actually run. Every other Flan program here agrees with ASan
; by never collecting at all.
(glob_files %{workspace_root}/spike/x86/*.flan)
; The dyn runtime's C main, which is the one thing in this sweep that is not
; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one
; translation unit here that frees anything, which is what makes it worth a
; translation unit here that frees the most, which is what makes it worth a
; sanitized run at all. See [dyn_sweep].
(file dyn_ops.c)
(glob_files programs/assets/json/*))

87
test/test_acceptance.ml
View File

@ -27,10 +27,13 @@ let run exe arg =
Sys.remove out;
(code, text)
let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) path =
let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) ?(x86 = false) path =
let exe =
Filename.concat scratch
("flan-t-" ^ Filename.remove_extension (Filename.basename path))
("flan-t-" ^ Filename.remove_extension (Filename.basename path)
(* A name of its own, so an x86 row and an LLVM row over the same
program are two files and not one built twice over the other. *)
^ if x86 then "-x86" else "")
in
(* Through [Load], so a program with an (import ...) is buildable here: it
brings back the package's C shim and linker arguments as well. *)
@ -40,7 +43,7 @@ let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) path =
reachable calls into hands over no C and no linker argument, and its
functions are not emitted. *)
let p, csrcs, lflags = Reach.link ~dev l p in
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev; x86 }
~csrcs ~lflags p ~out:exe);
exe
@ -101,8 +104,8 @@ let () =
surface calc-me does not reach — globals, 2-D arrays, places through a
pointer, casts, match with either arm taken, and the value semantics of
spec-memory.md. *)
let outputs ?opt ?dev name path expected =
let exe = compile ?opt ?dev path in
let outputs ?opt ?dev ?x86 name path expected =
let exe = compile ?opt ?dev ?x86 path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
@ -3168,45 +3171,69 @@ level "1"
call whose result feeds a machine instruction and that is exactly the
shape the optimiser could launder away.
They are LLVM-only, and the [@x86] survey skips them by name — see
[llvmonly] in spike/x86/survey.sh. Not compiled by the dev backend, so
not run as dev builds either. *)
They used to be LLVM-only, and this paragraph used to say so. The x86
backend compiles them now, and each gets a row of its own here beside
its LLVM rows — which is not the same question the [@x86] sweep asks.
That one asks whether the two backends agree with *each other*, and
two backends can agree on the wrong answer; these rows are the
expected text, written out, and a backend that is wrong on its own is
wrong against them. The dev daemon takes x86 by default and dyn is the
iteration feature, so this is the pairing the whole lane was about. *)
let dyn_basic_out = "5\n3.75\n" in
outputs "dyn: an unannotated defn at two types"
"programs/dyn-basic.flan" dyn_basic_out;
outputs ~opt:"-O0" "dyn: an unannotated defn at two types, -O0"
"programs/dyn-basic.flan" dyn_basic_out;
(* The rendering is the typed printer's: a leading space after the open
bracket, and a string quoted inside a collection but bare alone —
println of a one-string array and of the string itself already
disagree exactly this way, so the dyn printer disagreeing would have
been the bug. The stub this expectation was first written against
printed neither. *)
outputs ~x86:true "dyn: an unannotated defn at two types, --x86"
"programs/dyn-basic.flan" dyn_basic_out;
(* Two things in the container line that the stub this row was first
written against did not do, and the real renderer does on purpose. The
space is a prefix per element rather than a separator between them, so
the open bracket is followed by one — runtime/flan_dyn.c's [render],
pinned by test/dyn_ops.c's own "[ 1 2 3]". And a text *nested* in a
container is escaped and quoted while the same text printed on its own
is not, which is the third line here: [three] bare, ["three"] inside
the vector. Both were red against the expectation below until this was
corrected — on LLVM as much as on x86, because neither is a backend's
business. *)
let dyn_vec_out = "4\n[ 1 2.5 \"three\" true]\n1 2.5 three true \n" in
outputs "dyn: a heterogeneous vector"
"programs/dyn-vec.flan" dyn_vec_out;
outputs ~opt:"-O0" "dyn: a heterogeneous vector, -O0"
"programs/dyn-vec.flan" dyn_vec_out;
outputs ~x86:true "dyn: a heterogeneous vector, --x86"
"programs/dyn-vec.flan" dyn_vec_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"
"programs/dyn-global.flan" dyn_global_out;
(* The one that needed [main] to push a root before the startup function
ran, on this backend as on the other: the initialiser is what fills the
global and its first allocation may be the one that collects. *)
outputs ~x86:true "dyn: a global, --x86"
"programs/dyn-global.flan" dyn_global_out;
(* The boundary, both directions, and then the claim that is wrong. The
first four lines are the conversions; the trap is the fifth, and the
runtime owns its wording — the compiler could only have said that two
dyns did not agree, which is what they are for. *)
let dyn_boundary ?opt () =
let exe = compile ?opt "programs/dyn-boundary.flan" in
let dyn_boundary ?opt ?x86 () =
let exe = compile ?opt ?x86 "programs/dyn-boundary.flan" in
let code, text = run exe None in
let want = "107\n42\n21\n5\n" in
let name =
"dyn: the boundary both ways, and the trap"
^ (match opt with Some o -> ", " ^ o | None -> "")
^ (match x86 with Some true -> ", --x86" | _ -> "")
in
if code <> 134
|| not (contains text want)
|| not (contains text "an int was wanted")
(* The runtime's wording, and the stub's was different: what it says
now is which tag it found and which was wanted, then the value.
Matched on the half that carries the meaning rather than on the
whole sentence, so the row is about the trap being reached with
the right two things in hand and not about punctuation. *)
|| not (contains text "float, and an int was wanted")
then begin
incr failures;
Printf.printf
@ -3218,10 +3245,21 @@ level "1"
in
dyn_boundary ();
dyn_boundary ~opt:"-O0" ();
(* The trap path, on the backend the dev daemon takes by default. The same
exit status and the same sentence: the runtime owns the wording, so a
backend can only get this wrong by not reaching the runtime with the
right two words in the right two registers — which is exactly what the
exit status alone would not have shown. *)
dyn_boundary ~x86:true ();
(* The root count, which is the one part of this feature no run can check:
the stub never collects, so a program whose roots are entirely wrong
passes every test above. What can be checked is the IR, and this is the
(* The root count, which is the part of this feature the runs above cannot
check — and the reason has outlived the stub it was first written
about. flan_dyn.c's trigger has a one-megabyte floor, and not one
program in this list allocates enough to cross it, so none of them
collects even once and a program whose roots are entirely wrong passes
every row above. spike/x86/p13-dyn-collect.flan is the one that does
cross it, on both backends, and it is the sweep's business rather than
this file's. What can be checked here is the IR, and this is the
assertion that found a real hole — a defer appears twice in the typed IR,
spliced into the body for the normal path and again in [fdefers] for the
path a transfer leaves through, so a dyn temporary inside one is emitted
@ -3255,6 +3293,15 @@ level "1"
"1005\n6\n";
outputs ~opt:"-O0" "dyn: a defer on the transfer path, -O0"
"programs/dyn-defer.flan" "1005\n6\n";
(* And through the other backend, where the defer and the roots meet in a
sharper place: this backend has *one* epilogue, so the single
[flan_dyn_root_pop] sits on the path a transfer leaves through as well
as on the path a return does, and there is no second copy to forget.
The [%dx] check above cannot be asked of it — that assertion reads LLVM
text and there is no asm spelling of it that means the same thing — so
what stands behind the roots here is this row and the sweep. *)
outputs ~x86:true "dyn: a defer on the transfer path, --x86"
"programs/dyn-defer.flan" "1005\n6\n";
(* ── --no-gc ─────────────────────────────────────────────────────
The flag is a pass between checking and emission that answers unit or

51
test/test_flan.ml
View File

@ -905,21 +905,42 @@ let () =
"(declare c-take [d dyn] () \"c_take\")"
~needle:"does not cross to C";
(* The x86 backend refuses dyn by name, and the sentence has to be good: the
dev daemon takes that backend by default, so this is the first thing a
user of dyn sees. Neither half of the message names [--llvm] — Session and
main.ml each add that, differently and for their own reasons — so what is
pinned here is the half this file owns. *)
(match
X86.program ~checks:true
(Check.program_all
(program "(defn add [x y] dyn (+ x y))\n\
(defn main [] () (print (add 1 2)))"))
with
| _ -> check "the x86 backend refuses dyn" false
| exception X86.Unsupported m ->
check "the x86 backend refuses dyn by name"
(contains m "a dyn value" && contains m "dynamic runtime"));
(* The x86 backend used to refuse dyn by name, and what was pinned here was
the sentence it refused with. It compiles it now, which is the thing this
row is for: that backend is the dev daemon's default and dyn is the
iteration feature, so a refusal there was the two of them never meeting.
The assertion is the same shape inverted — it lowers, and it emits the
root discipline while it does. The roots are asserted rather than only
the absence of an exception, because a build that emits the calls and
forgets the roots is exactly the failure that passes every output test:
the collector simply never hears about a value.
Which programs *agree* between the backends is the @x86 sweep's question
and all five dyn programs are in it; this one only has to know that the
lowering exists. *)
let dyn_asm =
X86.program ~checks:true
(Check.program_all
(program "(defn add [x y] dyn (+ x y))\n\
(defn main [] () (print (add 1 2)))"))
in
check "the x86 backend lowers dyn"
(contains dyn_asm "flan_dyn_add");
check "the x86 backend roots its dyn values"
(contains dyn_asm "flan_dyn_root_push"
&& contains dyn_asm "flan_dyn_root_pop");
(* And a program with no dyn in it emits not one byte of any of it, which is
what lets the sweep's other MATCHes stand as a regression check on this
lane rather than being re-measured by it. *)
check "a dyn-free program pays nothing for the collector"
(let plain =
X86.program ~checks:true
(Check.program_all
(program "(defn add [x i32 y i32] i32 (+ x y))\n\
(defn main [] () (print (add 1 2)))"))
in
(not (contains plain "flan_dyn_root_push"))
&& not (contains plain "flan_gc_init"));
(* ── Static bounds ─────────────────────────────────────────────── *)
(* A literal index into a fixed array is known now, so it is an error now

30
test/test_sanitize.ml
View File

@ -158,6 +158,23 @@ let corpus =
"programs/printers.flan", [];
"programs/println.flan", [];
"programs/restarts.flan", [];
(* The dyn programs, which reach flan_dyn.c from Flan rather than from the
hand-written C below — and the difference is the whole reason they are
here. [dyn_sweep] checks the collector against roots dyn_ops.c pushes
by hand; these check it against the roots the *compiler* emits, which
is the half no C test can reach. A root the emitter forgot is a live
object swept, and that is a use-after-free with the collector's own
hands on it.
[dyn-vec] is the one that builds objects of three kinds; [dyn-defer]
is the one whose roots come off on a transfer's path out rather than a
return's, which is where a pop written on one path only would show.
[p13] is the only program anywhere that allocates past flan_dyn.c's
one-megabyte floor, so it is the only one where a mark and a sweep
actually run — everything else in this list agrees with ASan by never
collecting at all. *)
"programs/dyn-vec.flan", [];
"programs/dyn-defer.flan", [];
"../spike/x86/p13-dyn-collect.flan", [];
"programs/sand-headless.flan", [];
"programs/signedness.flan", [];
"programs/slices.flan", [];
@ -194,10 +211,15 @@ let sweep ~checks label =
(try Sys.remove san with Sys_error _ -> ())))
corpus
(* The dyn runtime, under the same two sanitizers. It is not in [corpus] and
cannot be: there is no Flan program that reaches flan_dyn.c yet, so the
thing to build is test/dyn_ops.c against programs/dyn-host.flan — the same
pair test_dyn.ml builds, with [sanitize] on.
(* The dyn runtime, under the same two sanitizers, driven from C. There are
Flan programs that reach flan_dyn.c now and three of them are in [corpus]
above — this used to say there were none — but they are a different
question and not a replacement for this one. They exercise the roots the
*compiler* emits, over the handful of operations a program happens to
write; this exercises every entry point in the header, with the roots
pushed by hand so that the runtime can be wrong on its own. The thing to
build is test/dyn_ops.c against programs/dyn-host.flan — the same pair
test_dyn.ml builds, with [sanitize] on.
This is the case the sweep is most likely to have something to say about.
Every other program in the corpus allocates and never frees, which is a