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

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-13 19:44:13 +07:00
commit 3775aaf6c3
6 changed files with 1089 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
DISCUSS.md
View File

@ -1100,3 +1100,162 @@ Two things are worth doing before that, and both are cheap. Decide what a bounds
handler — because "no check" is what it means today and nothing says so. And take item 15's question 4 seriously now
that there are two backends to disagree: `(uninit)` and `unreachable` already differ, deliberately, and the difference
is currently documented only in a comment in `x86.ml`.
## 17. Conditions on the x86 backend, and with them bounds checks: the corpus, not 41 programs
Item 16's verdict was that conditions were the only obstacle left and that a bounds check was made of the same parts.
Both halves held. The transfer channel's guard, the landing pads, the per-function transfer exit, `fdefers` on it,
`emit_restart_case`, `emit_with_alloc`, `signal`, `error`, `handler-bind`, `invoke-restart`, `check_at` and
`check_slice` are all in `lib/x86.ml` now, written from `spec-conditions.md` and `emit.ml`'s semantics rather than
ported. **LLVM is untouched and still the default and the release backend, and `--x86` is still off by default and
still refused with `--dev`, `--debug`, `--sanitize` and every wasm target.**
`dune test --root .` was green twice on this work, and is green now apart from four raylib fixtures — `images` and
`audio`, each at `-O2` and `-O0` — which export to a *hardcoded* `/tmp` path and fail with
`Failed to export wave data` because `/tmp` is full. It is full because of a runaway `llc` in another lane writing a
5.8 GB `m4.o` out of a 13 KB `m4.ll`; the same four fail on two consecutive runs and nothing else does. Nothing in
this lane writes to `/tmp` by a fixed name, and `TMPDIR` does not reach those fixtures.
### Question 1 — the counts, and what was compared
`spike/x86/survey.sh`. Item 16 describes a script that builds every program both ways and diffs the output; it was
never committed, so this one is. It builds each program in `test/programs` and each probe in `spike/x86` twice — once
default, once `--x86`, **with the same bounds-check setting on both sides**, because a checked build compared against
an unchecked one says nothing about `bounds.flan` — runs both, and compares **stdout, stderr and the exit status**.
stderr is not a detail. Every message the new machinery produces goes there — the bounds and slice errors, the three
restart refusals, the transfer failure — and each carries a `Loc.to_string` string this backend emits by hand as a
`.rodata` label and a length in a register. An exit status of 134 with the wrong text beside it is exactly the failure
that reads as a match.
| | before | after |
|---|---|---|
| **MATCH** — same stdout, same stderr, same exit status | **41** | **89** |
| **DIFFER** | 1 (`bounds.flan`) | **0** |
| **refused by name** — a node this backend does not lower | 41 | **0** |
| skipped: does not compile (checker-error fixtures) | 25 | 25 |
| skipped: no `main` (package and library fixtures) | 6 | 6 |
| skipped: never terminates (`dev-loop`, `dev-watch`) | 2 | 2 |
The "before" row is measured, not quoted from item 16 — it is the same corpus seven files larger, and the 41 refusals
split as 26 `restart-case`, 7 `signal`, 4 `handler-bind`, 1 `with-allocator`, 1 `fdefers`, and one each for
`flan_vec_at` and `flan_vec_as_slice`.
**Every program in `test/programs` that compiles, has a `main` and terminates now goes through the hand-written backend
and agrees with the LLVM build.** That is the whole corpus: `restarts.flan`, `conditions.flan`, `bounds.flan`,
`bounds-condition.flan`, `allocators.flan`, `defers.flan`, the `Vec` and `Map` programs, `edn.flan`, `format.flan`.
The programs that only trap when given an argument — `restarts.flan`'s four signature-mismatch cases, `bounds.flan`'s
three — were run by hand with their arguments and agree on stderr and on exit 134 as well.
### Question 2 — what a bounds violation means in a build with no handler
**The same thing it means on the LLVM path, and that is the answer rather than a decision.** `check_at` and
`check_slice` here are `emit.ml`'s: a compare, a branch, a call to `flan_bounds_error` or `flan_slice_error` with the
transfer channel, and then **the guard** — which is why they could not exist before. The call is an ordinary one that
returns only when a handler or the break loop transferred, so the guard is the way out and the fall-through past it is
`ud2` where `emit.ml` writes `unreachable`.
So: a bounds violation signals `BoundsError`; a `handler-bind` can answer it; a `restart-case` catches the transfer
and its clause's value stands; an unanswered one dies inside the runtime and the program exits 134 with the location
and the index. `--no-bounds-checks` omits the check on both backends and both then exit 139. **`bounds.flan` has
stopped being a DIFFER**, and the row of item 16's question-4 table that said "no check at all" is gone rather than
documented.
The transitional refusal item 16 asked for — a build that says out loud that its behaviour differs — was not written,
because `check_at` landed in the same pass and the refusal would have been created and retired inside one commit.
There is nothing left to be loud about.
Item 16's other two divergences are unchanged and still deliberate: `(uninit)` reads whatever the slot held rather
than LLVM's `poison`, and an exhausted `match` is `ud2` rather than `unreachable`. Both are still documented only in
`x86.ml`.
### Question 3 — `check_no_transfer` narrowed, not removed
It was a whole-program argument: this backend emitted no guard, which is sound exactly when nothing reachable can
write the channel, so the build refused by name the moment it found something that could. Every call site is guarded
now and the argument has retired — **in every function.** It still stands in one place, so the walk is still there and
now walks only global initialisers:
A global's initialiser runs from `flan..init-globals`, before `main` and before anything has established a handler or
a restart. It owns its own channel cell because no caller hands it one, so a transfer out of it has nowhere to go —
its exit would return into the loader. `signal`, `error`, `restart-case` and `handler-bind` in a `defvar` initialiser
are refused by name. A bounds check there is *not* refused: it signals into a cell nothing is listening on, finds no
handler, and dies, which is the right answer.
### Question 4 — five bugs, and four are item 16's shape exactly
Found by what the programs printed, never by reading bytes. Two of them existed before this work and only became
reachable once the guard let the programs that expose them compile.
**The body fell through into the transfer exit.** Every `fdefer` ran twice on a normal return, so `restarts.flan`'s
`log` was one too high at every checkpoint and nothing else was wrong. `emit.ml` cannot have this bug: its `ret`
terminates the block, and there is no fall-through to forget. This is the same class as item 16's "a discarded value
was stored over the return address" — a construct this backend has that LLVM does not.
**A `Vec` crossed to the runtime as the address of a copy.** `eval` copies an aggregate into a temporary, so
`flan_vec_push` grew the temporary and the caller's header stayed at length zero — and an *in-bounds* `(at v 1)` then
signalled against a length of 0. `emit.ml` says so in a comment beside its own `addr`; this had no such case. Pre-
existing, and invisible until a program using a `Vec` could build.
**`ucomis` sets CF, ZF and PF together for a NaN**, so `sete` answered *true* for `(= x x)`. Flan's comparisons are
LLVM's *ordered* ones (`oeq`, `olt`, ...), which are false for a NaN; the unsigned table is not those. `<` and `<=`
now swap their operands and ask for a/ae, and `=` and `!=` take a `setnp` beside them. The symptom was
`(/ 0.0 0.0)` formatting as `-9223372036854775808`, because the prelude's NaN test is `(not (= x x))` and nothing
else. Pre-existing; `format.flan` could not build before.
**A union read field 0 through the struct table** and was refused by name. A union is a tag and a payload blob, which
is a two-field struct at that level, and the structural printer reads the tag without unwrapping the value.
**And one that could not have been found later:** `emit_globals_init` stored a null *into* the channel slot rather
than a cell's address into it, so every callee of a global initialiser was handed a null pointer to write a transfer
through. Harmless while nothing could transfer; a fault the first time a guard loaded through it. `emit_main` had it
right and was the model.
Against those: nothing went wrong with the frame, the stack alignment, or the pads' nesting. The one place worth
naming is the one item 16 could not have: **the channel is one indirection deeper here than in `emit.ml`.** There
`%xfer` is an alloca and the target is one `load` away; here `xfer_off` is a frame slot *holding the caller's
pointer*, so reading the target is two loads and clearing the channel is a store *through* the pointer and never a
store to the slot. `chan_into`, `xfer_load`, `xfer_store` and `xfer_clear` exist so that no call site has to remember
which.
### Question 5 — what the corpus does not walk, and the probe that does
Every pad has two halves: the one a body reaches by finishing, and the one a transfer reaches by passing through. The
corpus walks the first everywhere and the second in one place only — `allocators.flan`'s last case aims an
`invoke-restart` out of a `with-allocator` body at a `restart-case` outside it, which is the `wxfer` re-propagation.
The other two it never reaches. In `restarts.flan` every transfer stops at a `restart-case` *inside* the
`handler-bind`'s extent, so the handler frames never come off on the transfer path; and in `nested` and `shadowed` the
*inner* restart frame offers the name, so a restart-case that the transfer is not aimed at never has to put the target
back. `spike/x86/p6-transfer.flan` is those two, beside a defer and a clause parameter, and it agrees with the LLVM
build. It is in the survey, and it is why the count is 89 rather than 83.
The branch nothing exercises is `flan_transfer_fail` — a defer that starts a *second* transfer while the first is
unwinding. It is emitted and refused loudly, and it is untested.
### The honest no-plan bucket
- **`Rt` with an aggregate return.** Still refused by name. `flan_vec_as_slice` returns a slice by value, and
`bounds-condition.flan` exercises it both in and out of bounds through a `restart-case` and matches — so it does not
reach the refusal, and **nobody traced why.** That is a loose end, not a result.
- **`Fnval`'s indirection cell.** `FnAddr (Fnval n)` still emits the symbol. Correct for a whole-program build, wrong
the instant anything is redefined into it; there are no cells here and no `--dev`, deliberately.
- **`f64` → `i64` out of range**, and **`INT64_MIN / -1`**. Unchanged from items 15 and 16: `idiv` raises `SIGFPE`
where LLVM says undefined. A language decision, not a backend one.
- **`(uninit)` and `unreachable`** still differ from LLVM on purpose and are still written down only in a comment.
- **The `flan_transfer_fail` branch**, above.
- **`"defers on a transfer path nothing reaches"`** — the refusal that replaced the old `fdefers` one. No program in
the corpus hits it; it exists so that if the reasoning behind it is ever wrong, it says so.
- **Debug information.** None. `--x86` and `--debug` together are still refused.
- **Code size and speed.** Still not measured, and now there is more to measure: a guard after every call, two loads
and a branch each, and a bounds check that spends three frame temporaries. Nobody has put a number on any of it.
### The verdict
**The row with no plan is gone.** What item 15 called the last obstacle and item 16 called the only one is written,
and the measurement that made it the only one is the measurement that says it is finished: every program in the corpus
that can run, runs, and prints what LLVM's build prints — down to stderr.
What is left in `x86.ml` is not conditions. It is a container return convention, a redefinition cell, two arithmetic
edge cases the language has not decided, and no debug info. None of those is the shape conditions were: each is a
known thing in a known place, and the guard is not underneath any of them.

8
bin/main.ml
View File

@ -15,6 +15,14 @@ let with_errors path f =
prerr_endline (Flan.Loc.report_all ds);
ignore path;
exit 1
(* The dev backend's own refusal, which is not a program error: the program
is fine and this backend does not lower it. Its own exit status, so that
a sweep comparing the two backends can count "refused by name" apart from
"did not compile". *)
| Flan.X86.Unsupported m ->
prerr_endline ("x86: " ^ m);
ignore path;
exit 3
let summarise (d : Flan.Ast.decl) =
let open Flan.Ast in

2
lib/build.ml
View File

@ -748,7 +748,7 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) ?(pnames = [])
(Filename.basename out ^ if opts.x86 then ".s" else ".ll")
in
write ll
(if opts.x86 then X86.program p
(if opts.x86 then X86.program ~checks:opts.checks p
else
Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames
~sanitize:opts.sanitize p);

784
lib/x86.ml
View File

@ -319,14 +319,14 @@ let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modr
(* [Emit.m] carries the struct and union tables [Emit.lay] reads. Built here
rather than imported so that this module adds no line to [emit.ml]: the
record has no signature hiding it and every field it needs is inert. *)
let layout_ctx (p : Tast.program) : Emit.m =
let layout_ctx ~checks (p : Tast.program) : Emit.m =
let structs = Hashtbl.create 16 and unions = Hashtbl.create 16 in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
p.Tast.structs;
List.iter (fun (u : Tast.union) -> Hashtbl.replace unions u.Tast.uname u)
p.Tast.unions;
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; unions;
globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks = false;
globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks;
dev = false; known = (fun _ -> true); dbg = None; sanitize = false;
nstr = 0; nfi = 0 }
@ -386,9 +386,17 @@ type fnctx = {
jumps to and the label a [continue] jumps to, which is the latch and not
the head. *)
mutable loops : (string * string) list;
(* The innermost landing pad a transfer found after a call should jump to.
Empty means the function's own transfer exit. *)
mutable pads : string list;
(* The innermost landing pad a transfer found after a call should jump to,
with a flag saying whether anything ever aimed at it: a pad nobody jumps
to must not be emitted, because its code would then be reached by falling
into it. Empty means the function's own transfer exit, [xfer_lbl]. *)
mutable pads : (string * bool ref) list;
(* The function's own transfer exit — spec-conditions.md §5 and §6. A
transfer that reached the top of this function without a restart-case to
catch it leaves the way a [return] does, which is what reuses the epilogue
and the defers for free. [unwound] says whether anything can reach it. *)
mutable xfer_lbl : string;
mutable unwound : bool;
(* Collected while lowering: string literals and float constants both need a
labelled constant in .rodata, and both are discovered mid-expression. *)
rodata : Buffer.t;
@ -589,20 +597,6 @@ let imm_into f ~reg (n : int64) = movabs f.b ~dst:reg n
(* ── Struct layout, through [Emit] ───────────────────────────────────── *)
let field_offsets f (sn : string) =
match Hashtbl.find_opt f.md.Emit.structs sn with
| Some (s : Tast.structure) ->
let _, _, offs =
Emit.lay_fields f.md
(List.map (fun (fl : Tast.field) -> fl.Tast.fty) s.Tast.fields)
in
offs
| None -> unsupported "no struct %s" sn
(* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay]
measures it as — so the payload's offset is whatever [lay_fields] puts the
second one at, and not a rule spelled a second time here. A union whose
cases are all payload-less is a bare tag and has no second field. *)
let union_payload_off f (u : Tast.union) =
let size, align = Emit.payload_lay f.md u in
if size = 0 then 0
@ -615,6 +609,27 @@ let union_payload_off f (u : Tast.union) =
in
List.nth offs 1
let field_offsets f (sn : string) =
match Hashtbl.find_opt f.md.Emit.structs sn with
| Some (s : Tast.structure) ->
let _, _, offs =
Emit.lay_fields f.md
(List.map (fun (fl : Tast.field) -> fl.Tast.fty) s.Tast.fields)
in
offs
| None ->
(* A union is a struct too, at this level: [emit.ml] lays it out as a tag
and a payload blob, and the structural printer reads the tag as field 0
without unwrapping the value. *)
(match Hashtbl.find_opt f.md.Emit.unions sn with
| Some (u : Tast.union) -> [ 0; union_payload_off f u ]
| None -> unsupported "no struct %s" sn)
(* A union is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay]
measures it as — so the payload's offset is whatever [lay_fields] puts the
second one at, and not a rule spelled a second time here. A union whose
cases are all payload-less is a bare tag and has no second field. *)
let union_of f n =
match Hashtbl.find_opt f.md.Emit.unions n with
| Some u -> u
@ -651,20 +666,127 @@ let int_cc ~signed (p : Tast.prim) =
| Tast.Ge, true -> cc_ge | Tast.Ge, false -> cc_ae
| _ -> unsupported "not a comparison"
(* Parity, which on [ucomis] means "unordered": one of the operands was a NaN.
Nothing else in this file reads it. *)
let cc_np = 11
(* [ucomis] sets the flags the *unsigned* codes read, whichever way the
operands are signed, so a float comparison never uses l/g. *)
operands are signed, so a float comparison never uses l/g — and it sets
CF, ZF and PF all at once when either operand is a NaN.
That last part is why this is not simply the unsigned table. Every
comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq,
one, olt, ...), which answers false for a NaN, and [setb] after an
unordered compare answers true. So [<] and [<=] swap their operands and ask
for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be
spelled by one code at all and take a second [setnp] beside them.
[(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is
the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as
-9223372036854775808. *)
let float_swaps (p : Tast.prim) =
match p with Tast.Lt | Tast.Le -> true | _ -> false
let float_cc (p : Tast.prim) =
match p with
| Tast.Eq -> cc_e | Tast.Ne -> cc_ne
| Tast.Lt -> cc_b | Tast.Le -> cc_be
| Tast.Lt -> cc_a | Tast.Le -> cc_ae
| Tast.Gt -> cc_a | Tast.Ge -> cc_ae
| _ -> unsupported "not a comparison"
let float_ordered (p : Tast.prim) =
match p with Tast.Eq | Tast.Ne -> true | _ -> false
let is_cmp (p : Tast.prim) =
match p with
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge -> true
| _ -> false
(* ── The transfer channel, spec-conditions.md §6 ──────────────── *)
(* One indirection more than [emit.ml] has, and it is the whole trap in this
file. There [%xfer] is an alloca, so the target is one [load] away. Here
[xfer_off] is a frame slot *holding the caller's pointer*, so reading the
target is two loads — slot, then through it — and clearing the channel is a
store *through* the pointer and never a store to [xfer_off]. Getting that
wrong produces assembly that reads perfectly and a program that never sees
a transfer, which is exactly the failure item 15 warns about. *)
let chan_into f ~reg = load_int f.b ~dst:reg ~mm:(Frame f.xfer_off) ~size:8 ~signed:false
(* The transfer target, or null. *)
let xfer_load f ~reg =
chan_into f ~reg;
load_int f.b ~dst:reg ~mm:(Reg (reg, 0)) ~size:8 ~signed:false
(* [reg] into the channel. [scratch] must not be [reg]. *)
let xfer_store f ~reg ~scratch =
chan_into f ~reg:scratch;
store_int f.b ~src:reg ~mm:(Reg (scratch, 0)) ~size:8
let xfer_clear f =
chan_into f ~reg:r11;
xor_rr f.b ~dst:rax ~src:rax;
store_int f.b ~src:rax ~mm:(Reg (r11, 0)) ~size:8
(* Where a transfer found after a call goes: the innermost restart-case,
handler-bind or with-allocator pad we are inside, or the function's own
transfer exit. Naming one marks it reached — nothing emits a pad that is
only ever fallen into. *)
let current_pad f =
match f.pads with
| (p, used) :: _ -> used := true; p
| [] -> f.unwound <- true; f.xfer_lbl
(* The check after a call, which is the whole of §6's lowering at a call site:
two loads, a test and a branch. Only [r11] is touched, so it may be emitted
between the call and the store of the value in [rax] — which is where it
goes, because a transfer means the value is meaningless.
A foreign call gets none: a transfer cannot cross a C frame, so there is
nothing a guard there could find. The exceptions are the runtime entry
points that take the channel themselves and signal through it. *)
let guard f =
xfer_load f ~reg:r11;
test_rr f.b ~a:r11 ~c:r11;
jcc_lbl f.b ~cc:cc_ne (current_pad f)
(* Run [g] with a fresh pad on top of the stack, and answer the pad's label
beside whether anything aimed at it. *)
let with_pad f tag g =
let pad = new_label f tag and used = ref false in
f.pads <- (pad, used) :: f.pads;
let r = g () in
f.pads <- List.tl f.pads;
(pad, used, r)
(* ── The runtime's two dynamic stacks ────────────────────────────────── *)
(* [emit.ml]'s [%handler] and [%restart] types, laid out by the C rules — the
same rules the runtime's own structs get, and the same [Emit.lay] applies to
everything else. Both live as frame temporaries of the function that
establishes them, which is the point: the *address* of a frame is the
identity a transfer carries, so re-entering the same restart-case gets a
different one and a module loaded later cannot collide with it. *)
(* { ptr prev, i32 type_id, ptr fn } *)
let h_size = 24
let h_type = 8
let h_fn = 16
(* { ptr prev, i32 name_id, ptr name, i64 namelen, ptr args,
i32 arity, i32 sig_id, i32 armed, ptr sig, i64 siglen } *)
let r_size = 72
let r_name_id = 8
let r_name = 16
let r_namelen = 24
let r_args = 32
let r_arity = 40
let r_sig_id = 44
let r_armed = 48
let r_sig = 56
let r_siglen = 64
(* ── The calling convention, as the header states it ─────────────────── *)
(* One argument as it will actually be handed over. [Aptr] is an aggregate,
@ -931,9 +1053,349 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Tast.CaseField (target, case, i) ->
move f ~dst ~src:(case_field f target case i) t
| Tast.Match (scrut, arms) -> emit_match f scrut arms dst t
| Tast.Signal _ | Tast.Handled _ | Tast.RestartCase _
| Tast.InvokeRestart _ | Tast.WithAlloc _ ->
unsupported "conditions, in %s" f.fnname
(* 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) ->
scoped f (fun () ->
let l = lvalue f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
chan_into f ~reg:rdx;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_signal";
guard f)
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
[ud2] — where [emit.ml] writes [unreachable]. *)
| Tast.Signal (Tast.Serror, id, c) ->
scoped f (fun () ->
let l = lvalue f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
chan_into f ~reg:rdx;
let name =
match c.Tast.ty with Types.Named n -> n | _ -> "a condition" in
str_args f ~preg:rcx ~nreg:r8 name;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_error";
guard f;
ud2 f.b)
| Tast.Handled (frames, body) -> emit_handled f frames body dst t
| Tast.RestartCase (clauses, body) -> emit_restart_case f clauses body dst t
| Tast.WithAlloc (a, body) -> emit_with_alloc f a body dst t
| Tast.InvokeRestart (id, name, args, sg, sg_id, rloc) ->
emit_invoke_restart f id name args sg sg_id rloc
(* ── Conditions ──────────────────────────────────────────────────────── *)
(* A string constant handed to the runtime as ptr+len, in two registers. *)
and str_args f ~preg ~nreg s =
let l = string_const f s in
lea f.b ~dst:preg ~mm:(Sym (l, 0));
imm_into f ~reg:nreg (Int64.of_int (String.length s))
(* One of the runtime's [_Noreturn] refusals. Everything is already in its
register; this is the call and the [ud2] that says the fall-through is not
a path. *)
and die f sym =
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b sym;
ud2 f.b
(* (handler-bind ((C f) ...) BODY...) — §2. Two stores and a push per frame,
and the frames live on this function's own stack. Popping is by frame and
not by count, which is right even if something below got the stack out of
step.
The body may not [return] — the checker rejects that — so the pop below and
the pop in the pad are between them the only paths out. *)
and emit_handled f frames body dst t =
let slots =
List.map
(fun (h : Tast.hframe) ->
let slot = alloc f h_size 8 in
imm_into f ~reg:rax (Int64.of_int h.Tast.htype);
store_int f.b ~src:rax ~mm:(Frame (slot + h_type)) ~size:4;
(* The clause's body address, deliberately, and not a cell load: a
handler frame is not a redefinable top-level value — nothing can
name it and it lives only for this body. *)
lea f.b ~dst:rax ~mm:(Sym (fsym h.Tast.hfn, 0));
store_int f.b ~src:rax ~mm:(Frame (slot + h_fn)) ~size:8;
lea f.b ~dst:rdi ~mm:(Frame slot);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_handler_push";
slot)
frames
in
(* Innermost first, which is the order they were pushed in reverse. *)
let pop () =
List.iter
(fun slot ->
lea f.b ~dst:rdi ~mm:(Frame slot);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_handler_pop")
(List.rev slots)
in
let ld = new_label f "endhandled" in
let pad, used, () = with_pad f "hxfer" (fun () -> block f body dst t) in
pop ();
jmp_lbl f.b ld;
(* A transfer passing through: these frames are on this function's stack and
must come off before it goes any further. Nothing here calls Flan, so the
channel can stay as it is. *)
if !used then begin
lbl f.b pad;
pop ();
jmp_lbl f.b (current_pad f)
end;
lbl f.b ld
(* (with-allocator A BODY...) — spec-memory.md's "Allocators". Save, run,
restore, and restore *again at the pad*: a body that errors, or one a
handler transfers out of, leaves through [current_pad], and a context
allocator left pointing into a region nobody outside the body has heard of
would be wrong in the break loop — which is exactly where someone is about
to allocate to render a condition. *)
and emit_with_alloc f (a : Tast.expr) body dst t =
let prev = ptmp f in
scoped f (fun () ->
let av = eval f a in
load_loc f ~reg:rdi av a.Tast.ty);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_context_set";
store_int f.b ~src:rax ~mm:(Frame prev) ~size:8;
let restore () =
load_int f.b ~dst:rdi ~mm:(Frame prev) ~size:8 ~signed:false;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_context_restore"
in
let ld = new_label f "endwith" in
let pad, used, () = with_pad f "wxfer" (fun () -> block f body dst t) in
restore ();
jmp_lbl f.b ld;
if !used then begin
lbl f.b pad;
restore ();
jmp_lbl f.b (current_pad f)
end;
lbl f.b ld
(* A clause's parameters as one record: what the invoker stores into and what
the clause loads out of. The two ends never see each other, so the layout is
agreed by the signature hash they compare first — same types in the same
order is the same record, and both sides ask [Emit.lay_fields], which is the
one layout calculator in this compiler. *)
and args_layout f (tys : Types.t list) =
let size, align, offs = Emit.lay_fields f.md tys in
(max 1 size), (max 1 align), offs
(* (restart-case BODY (name [p T] BODY-1) ...) — §3, §4 and §6 together.
One frame per clause, so the frame a transfer names says which clause to
run. §4's "innermost offering the name" falls out of the runtime's stack
walk, and re-entering a restart-case works because each activation allocates
its own frames.
§5's defers between here and the invoke have already run: each function on
the way out ran its own at its transfer exit before returning. What is left
is to take these frames off, copy §3's parameters out of the buffer the
invoker filled, and start the clause. *)
and emit_restart_case f clauses body dst t =
(* Everything the pad reads is allocated here, before any [scoped] the body
or a clause runs. The frame allocator is a bump pointer that reclaims at
the end of each statement, so a slot allocated inside the body would be
handed out again to the clause that has to read it — and the read would
be of whatever the clause's own temporaries put there. *)
let tgt = ptmp f in
let bufp = ptmp f in
let frames =
List.map
(fun (c : Tast.rclause) ->
let slot = alloc f r_size 8 in
let args =
if c.Tast.rparams = [] then None
else begin
let size, align, offs =
args_layout f (List.map snd c.Tast.rparams) in
Some (alloc f size align, offs)
end
in
(c, slot, args))
clauses
in
List.iter
(fun ((c : Tast.rclause), slot, args) ->
imm_into f ~reg:rax (Int64.of_int c.Tast.rname_id);
store_int f.b ~src:rax ~mm:(Frame (slot + r_name_id)) ~size:4;
(* The name itself, beside the hash. A hash is all that matching needs,
but a break loop has to *show* someone their choices, and nothing at
run time can turn a hash back into a name. *)
str_args f ~preg:rax ~nreg:rcx c.Tast.rname;
store_int f.b ~src:rax ~mm:(Frame (slot + r_name)) ~size:8;
store_int f.b ~src:rcx ~mm:(Frame (slot + r_namelen)) ~size:8;
(* §3's signature, which every frame carries whether it takes
parameters or not: a clause taking none has to be able to refuse
arguments as loudly as one taking two of the wrong type. *)
imm_into f ~reg:rax (Int64.of_int (List.length c.Tast.rparams));
store_int f.b ~src:rax ~mm:(Frame (slot + r_arity)) ~size:4;
imm_into f ~reg:rax (Int64.of_int c.Tast.rsig_id);
store_int f.b ~src:rax ~mm:(Frame (slot + r_sig_id)) ~size:4;
str_args f ~preg:rax ~nreg:rcx c.Tast.rsig;
store_int f.b ~src:rax ~mm:(Frame (slot + r_sig)) ~size:8;
store_int f.b ~src:rcx ~mm:(Frame (slot + r_siglen)) ~size:8;
(match args with
| None -> ()
| Some (buf, _) ->
lea f.b ~dst:rax ~mm:(Frame buf);
store_int f.b ~src:rax ~mm:(Frame (slot + r_args)) ~size:8;
(* Nothing has filled it in yet. Whoever aims a transfer at this
frame without going through an [invoke-restart] — the break loop,
today — leaves this zero, and the clause refuses rather than
running on values no one supplied. *)
xor_rr f.b ~dst:rax ~src:rax;
store_int f.b ~src:rax ~mm:(Frame (slot + r_armed)) ~size:4);
lea f.b ~dst:rdi ~mm:(Frame slot);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_restart_push")
frames;
let pop () =
List.iter
(fun (_, slot, _) ->
lea f.b ~dst:rdi ~mm:(Frame slot);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_restart_pop")
(List.rev frames)
in
let ld = new_label f "endrestart" in
let pad, used, () = with_pad f "rxfer" (fun () -> lower f body dst) in
pop ();
jmp_lbl f.b ld;
if !used then begin
lbl f.b pad;
xfer_load f ~reg:rax;
store_int f.b ~src:rax ~mm:(Frame tgt) ~size:8;
(* Cleared before a clause runs, and put back if this transfer turns out to
be aimed further out. A clause body is ordinary code and its calls are
guarded like any other; it must not start with the channel still set. *)
xfer_clear f;
pop ();
List.iter
(fun ((c : Tast.rclause), slot, args) ->
let next = new_label f "outer" in
load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false;
lea f.b ~dst:rcx ~mm:(Frame slot);
cmp_rr f.b ~a:rax ~c:rcx;
jcc_lbl f.b ~cc:cc_ne next;
(match args with
| None -> ()
| Some (buf, offs) ->
(* Aimed here by something that supplied no arguments. There is no
such path from an [invoke-restart], so this is a break loop
taking a restart it cannot yet fill in — refused with the
reason. *)
load_int f.b ~dst:rax ~mm:(Frame (slot + r_armed)) ~size:4
~signed:true;
let armed = new_label f "armed" in
test_rr f.b ~a:rax ~c:rax;
jcc_lbl f.b ~cc:cc_ne armed;
let l0 = List.hd c.Tast.rbody in
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string l0.Tast.loc);
str_args f ~preg:rdx ~nreg:rcx c.Tast.rname;
str_args f ~preg:r8 ~nreg:r9 c.Tast.rsig;
die f "flan_restart_unarmed";
lbl f.b armed;
(* The frame is still addressable — it is a temporary of *this*
function — and the buffer is whatever the invoker left there. *)
lea f.b ~dst:rax ~mm:(Frame buf);
store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8;
List.iteri
(fun i (slot_i, ty) ->
move f ~dst:(Lf f.slots.(slot_i))
~src:(Lp (bufp, List.nth offs i)) ty)
c.Tast.rparams);
scoped f (fun () -> block f c.Tast.rbody dst t);
jmp_lbl f.b ld;
lbl f.b next)
frames;
(* Aimed further out than any of these. Back into the channel it goes. *)
load_int f.b ~dst:rax ~mm:(Frame tgt) ~size:8 ~signed:false;
xfer_store f ~reg:rax ~scratch:r11;
jmp_lbl f.b (current_pad f)
end;
lbl f.b ld
(* §4's lookup, then the transfer itself: the frame that was found goes into
the channel and this function leaves through its landing pad. Type [Never],
so nothing follows. *)
and emit_invoke_restart f id name (args : Tast.expr list) sg sg_id rloc =
(* The arguments first, each into a frame temporary of its own, because the
lookup and its two failure paths clobber every register. *)
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
let t = ptmp f in
let bufp = ptmp f in
imm_into f ~reg:rdi (Int64.of_int id);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_find_restart";
store_int f.b ~src:rax ~mm:(Frame t) ~size:8;
(* No frame offers the name. That is a runtime error at the invoke site —
not an unwind past everything — because there is nowhere to resume. *)
let found = new_label f "found" in
test_rr f.b ~a:rax ~c:rax;
jcc_lbl f.b ~cc:cc_ne found;
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc);
str_args f ~preg:rdx ~nreg:rcx name;
die f "flan_restart_fail";
lbl f.b found;
(* §3's run-time check. A restart is found by name on a dynamic stack, so
what it takes is not knowable here: the frame carries its parameter count
and the hash of how they are spelled, and both are compared. The count is
not redundant with the hash — it is what makes a 32-bit collision between
two different signatures harmless in practice — and it is the cheaper
half. *)
let ok = new_label f "sigok" and bad = new_label f "signo" in
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
load_int f.b ~dst:rax ~mm:(Reg (r11, r_arity)) ~size:4 ~signed:false;
cmp_imm f.b ~dst:rax (List.length args);
jcc_lbl f.b ~cc:cc_ne bad;
(* The hash is a full 32 bits and a [cmp] takes a signed imm32, so it goes
through a register rather than through the immediate. *)
load_int f.b ~dst:rax ~mm:(Reg (r11, r_sig_id)) ~size:4 ~signed:false;
imm_into f ~reg:rcx (Int64.of_int (sg_id land 0xffffffff));
cmp_rr f.b ~a:rax ~c:rcx;
jcc_lbl f.b ~cc:cc_e ok;
lbl f.b bad;
(* Eight arguments, so two go on the stack — which is what [outgoing] is
for. What the frame says it takes is read off the frame, because only the
frame knows; what was given is this call site's own spelling. *)
if f.outgoing < 16 then f.outgoing <- 16;
str_args f ~preg:rax ~nreg:r11 sg;
store_int f.b ~src:rax ~mm:(Reg (rsp, 0)) ~size:8;
store_int f.b ~src:r11 ~mm:(Reg (rsp, 8)) ~size:8;
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
load_int f.b ~dst:r8 ~mm:(Reg (r11, r_sig)) ~size:8 ~signed:false;
load_int f.b ~dst:r9 ~mm:(Reg (r11, r_siglen)) ~size:8 ~signed:true;
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string rloc);
str_args f ~preg:rdx ~nreg:rcx name;
die f "flan_restart_args_fail";
lbl f.b ok;
(* Into the buffer the target frame owns, field by field: this frame is about
to go, and the clause runs after it has. The layout is the one the
signature just agreed on. *)
if vals <> [] then begin
let _, _, offs = args_layout f (List.map snd vals) in
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
load_int f.b ~dst:rax ~mm:(Reg (r11, r_args)) ~size:8 ~signed:false;
store_int f.b ~src:rax ~mm:(Frame bufp) ~size:8;
List.iteri
(fun i (l, ty) -> move f ~dst:(Lp (bufp, List.nth offs i)) ~src:l ty)
vals;
load_int f.b ~dst:r11 ~mm:(Frame t) ~size:8 ~signed:false;
imm_into f ~reg:rax 1L;
store_int f.b ~src:rax ~mm:(Reg (r11, r_armed)) ~size:4
end;
load_int f.b ~dst:rax ~mm:(Frame t) ~size:8 ~signed:false;
xfer_store f ~reg:rax ~scratch:r11;
jmp_lbl f.b (current_pad f)
and zero_value f (dst : loc) (ty : Types.t) =
if is_agg ty then zero_loc f dst (sizeof f.md ty)
@ -1098,6 +1560,98 @@ and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc =
in
elements f (element f base ty i) elem rest
(* ── Bounds checks ───────────────────────────────────────────────────── *)
(* [emit.ml]'s [check_at] and [check_slice], which could not exist here until
the guard did: the runtime's bounds error *signals*, so the call is an
ordinary one that returns when a handler or the break loop transferred, and
what makes it a check rather than a call is the guard after it. The
fall-through past the guard is what is unreachable — nothing answered, so
the runtime already died inside the call — and [ud2] is where [emit.ml]
writes [unreachable].
That is also the answer to "does a bounds trap run defers": an answered one
does, because it leaves through the innermost pad; an unanswered one still
does not, because it is a die inside C. Identical on both backends. *)
and bounds_call f sym (loc : Loc.t) (extra : int list) =
let s = Loc.to_string loc in
str_args f ~preg:rdi ~nreg:rsi s;
let regs = [| rdx; rcx; r8; r9 |] in
List.iteri
(fun k off ->
load_int f.b ~dst:regs.(k) ~mm:(Frame off) ~size:8 ~signed:true)
extra;
chan_into f ~reg:regs.(List.length extra);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b sym;
guard f;
ud2 f.b
(* The length an index is checked against, or [None] for the forms [emit.ml]
does not check either: a raw pointer, which has no length, and a string,
which its [element_addr] does not index at all. *)
and index_len _f (base : loc) (ty : Types.t) =
match ty with
| Types.Array (n, _) -> Some (`Const n)
| Types.Slice _ -> Some (`At (shift base 8))
| _ -> None
and load_len f = function
| `Const n -> imm_into f ~reg:rcx n
| `At l -> load_int f.b ~dst:rcx ~mm:(lmem f l ~scratch:r11) ~size:8 ~signed:true
(* [at] is strict: the last valid index is len - 1, and one unsigned compare
catches a negative index as well as an oversized one. *)
and check_at f (base : loc) (ty : Types.t) (i : Tast.expr) (iv : loc) =
if f.md.Emit.checks then
match index_len f base ty with
| None -> ()
| Some len ->
scoped f (fun () ->
let a = ptmp f and b = ptmp f in
load_loc f ~reg:rax iv i.Tast.ty;
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
load_len f len;
store_int f.b ~src:rcx ~mm:(Frame b) ~size:8;
cmp_rr f.b ~a:rax ~c:rcx;
let ok = new_label f "inb" in
jcc_lbl f.b ~cc:cc_b ok;
bounds_call f "flan_bounds_error" i.Tast.loc [ a; b ];
lbl f.b ok)
(* [slice] is not strict: a slice ending at len — or an empty one at lo = len —
is legal. [lo <= hi] is not redundant with [hi <= len], because a reversed
range would otherwise yield hi - lo as a huge unsigned length, which is a
worse hole than the missing check. *)
and check_slice f (base : loc) (ty : Types.t) (loc : Loc.t) (lo : Tast.expr)
(llo : loc) (hi : Tast.expr) (lhi : loc) =
if f.md.Emit.checks then
let len =
match ty with
| Types.Array (n, _) -> Some (`Const n)
| Types.Slice _ | Types.String -> Some (`At (shift base 8))
| _ -> None
in
match len with
| None -> ()
| Some len ->
scoped f (fun () ->
let a = ptmp f and b = ptmp f and c = ptmp f in
load_loc f ~reg:rax llo lo.Tast.ty;
store_int f.b ~src:rax ~mm:(Frame a) ~size:8;
load_loc f ~reg:rdx lhi hi.Tast.ty;
store_int f.b ~src:rdx ~mm:(Frame b) ~size:8;
load_len f len;
store_int f.b ~src:rcx ~mm:(Frame c) ~size:8;
let ok = new_label f "inb" and bad = new_label f "oob" in
cmp_rr f.b ~a:rax ~c:rdx;
jcc_lbl f.b ~cc:cc_a bad;
cmp_rr f.b ~a:rdx ~c:rcx;
jcc_lbl f.b ~cc:cc_be ok;
lbl f.b bad;
bounds_call f "flan_slice_error" loc [ a; b; c ];
lbl f.b ok)
and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc =
let elem =
match ty with
@ -1106,6 +1660,7 @@ and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc =
| t -> unsupported "index into %s" (Types.to_string t)
in
let iv = eval f i in
check_at f base ty i iv;
(match ty with
| Types.Array _ -> addr_into f ~reg:rax base
| _ ->
@ -1168,6 +1723,13 @@ and call_flan f ~target ~args ~rty dst =
| `Loc o ->
load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false;
call_r f.b r11);
(* §6 at a call site, and it is every call site: a callee that transferred
wrote a frame address through the channel, and the value in [rax] means
nothing. The guard touches only [r11], so it goes between the call and
the store rather than after it. A call by pointer is guarded by the same
guard — a transfer is carried by the channel whether the callee was
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
@ -1177,16 +1739,42 @@ and call_flan f ~target ~args ~rty dst =
and call_c f ~sym ~args ~rty dst =
call_native f ~sym:(asm_sym sym) ~args ~rty dst
and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~args ~rty dst
(* The two runtime entry points whose bounds check signals. They are the only
[Rt] symbols that can transfer, so they are the only ones that take the
channel and the only ones guarded — everything else in this family is
arithmetic over a container header and cannot reach a handler. A Vec is
checked inside the runtime rather than in emitted code (BUILT.md), so this
is where [(at v i)] gets what [(at arr i)] gets from [check_at]. *)
and rt_signals sym =
String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice"
and call_native f ~sym ~(args : Tast.expr list) ~rty dst =
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
and call_rt f ~sym ~args ~rty dst =
call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst
and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
(* A Vec, a Map and a Pool are move-only and cross to the runtime as their
*address*, which is what lets an operation mutate the caller's container
in place. [eval] would hand over the address of a copy, and the runtime
would grow that and leave the caller's header at length zero — which is
how [bounds-condition.flan] failed, as an in-bounds (at v 1) signalling
against a length of 0. Every other aggregate is read-only across this
boundary, so a copy there is harmless. *)
let vals =
List.map
(fun (a : Tast.expr) ->
(match a.Tast.ty with
| Types.Vec _ | Types.Map _ | Types.Pool _ -> lvalue f a
| _ -> eval f a), a.Tast.ty)
args
in
let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in
let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] else flat in
let nsse = emit_args f flat in
(* [al] is how many SSE registers were used, which a variadic callee reads.
Harmless on a fixed one, and a [declare] does not say which it is. *)
imm_into f ~reg:rax (Int64.of_int nsse);
call_sym f.b sym;
if chan then guard f;
if not (is_void rty) then begin
if is_agg rty then unsupported "aggregate return from %s" sym;
store_loc f ~reg:(if is_float rty then xmm0 else rax) dst rty
@ -1240,10 +1828,17 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
let lb = eval f b in
if is_float a.Tast.ty then begin
let f64 = f64_of a.Tast.ty in
fload f.b ~dst:xmm0 ~mm:(lmem f la ~scratch:r11) ~f64;
fload f.b ~dst:1 ~mm:(lmem f lb ~scratch:r11) ~f64;
let x, y = if float_swaps p then lb, la else la, lb in
fload f.b ~dst:xmm0 ~mm:(lmem f x ~scratch:r11) ~f64;
fload f.b ~dst:1 ~mm:(lmem f y ~scratch:r11) ~f64;
ucomis f.b ~f64 ~a:xmm0 ~c:1;
setcc f.b ~cc:(float_cc p) ~dst:rax
setcc f.b ~cc:(float_cc p) ~dst:rax;
if float_ordered p then begin
movzx8 f.b ~dst:rax ~src:rax;
setcc f.b ~cc:cc_np ~dst:rcx;
movzx8 f.b ~dst:rcx ~src:rcx;
and_rr f.b ~dst:rax ~src:rcx
end
end else begin
load_loc f ~reg:rax la a.Tast.ty;
load_loc f ~reg:rcx lb b.Tast.ty;
@ -1284,6 +1879,10 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
let base = lvalue f a in
let llo = eval f lo in
let lhi = eval f hi in
(* The source is read once, and the check goes between reading it and the
arithmetic: the length it is checked against must be the one the
arithmetic uses. *)
check_slice f base a.Tast.ty e.Tast.loc lo llo hi lhi;
(match a.Tast.ty with
| Types.Array _ -> addr_into f ~reg:rax base
| _ ->
@ -1436,7 +2035,8 @@ let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
fret = fn.Tast.ret; slots = Array.make nslots 0;
xfer_off = 0; sret_off = 0; retval = 0;
frame = 0; maxframe = 0; outgoing = 0;
loops = []; pads = []; rodata = Buffer.create 64; externs; fns }
loops = []; pads = []; xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns }
in
(* The header's own frame model: every slot and every temporary is
bump-allocated below rbp, and the high-water mark is what the prologue
@ -1447,6 +2047,7 @@ let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
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;
f.retlbl <- new_label f "ret";
f.xfer_lbl <- new_label f "xfer";
let sret_at, param_at, xfer_at = incoming_of ~sret fn.Tast.params in
(* An aggregate parameter arrives as a pointer to the caller's copy and has
to be copied into its slot before anything else runs — and [rep movsb]
@ -1476,11 +2077,64 @@ let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
scoped f (fun () -> lower f e (ret_loc f))
| Some e -> scoped f (fun () -> lower f e sink)
| None -> ());
(* The transfer exit is not built, and nothing can reach it: no node in this
program signals or invokes a restart (checked before any of this runs), so
[fdefers] has no second path to run on. *)
if fn.Tast.fdefers <> [] then
unsupported "%s has defers on the transfer path" fn.Tast.name;
(* The transfer exit, spec-conditions.md §5 and §6. A transfer that reached
the top of this function without a restart-case to catch it leaves the
same way a [return] does — which is what reuses the existing return path,
and with it the defers, for free. The value returned is meaningless: the
caller's guard sees the channel set and never looks at it.
Emitted here, *before* the prologue buffer is made, because [frame_bytes]
is read when the prologue is built and everything below allocates
temporaries and makes calls that move the high-water mark. *)
let zero_return () =
if not (is_void fn.Tast.ret) then zero_value f (ret_loc f) fn.Tast.ret
in
if f.unwound then begin
(* The body falls through to the epilogue, so it has to be sent there
explicitly before this: otherwise the last statement runs straight into
the transfer exit and the defers run a second time. [emit.ml] cannot
have this bug — its [ret] terminates the block. *)
jmp_lbl f.b f.retlbl;
lbl f.b f.xfer_lbl;
(* [emit.ml] leaves here with [ret zeroinitializer]. The value is
meaningless to a caller — its guard sees the channel set and never looks
at it — but [main] is a caller with no guard, and what it finds in [rax]
is the process exit status. Zero rather than whatever the return
temporary held. *)
if fn.Tast.fdefers <> [] then begin
(* The channel is cleared while the defers run and put back after. A
defer makes ordinary calls and each one is guarded; with the channel
still set the first of them would branch straight back here. *)
let saved = ptmp f in
xfer_load f ~reg:rax;
store_int f.b ~src:rax ~mm:(Frame saved) ~size:8;
xfer_clear f;
let cleanup = new_label f "cleanup" and used = ref false in
f.pads <- [ (cleanup, used) ];
List.iter (fun e -> scoped f (fun () -> lower f e sink)) fn.Tast.fdefers;
f.pads <- [];
load_int f.b ~dst:rax ~mm:(Frame saved) ~size:8 ~signed:false;
xfer_store f ~reg:rax ~scratch:r11;
zero_return ();
jmp_lbl f.b f.retlbl;
(* A defer that starts a *second* transfer while the first is unwinding.
§6's per-frame slot nests, but nothing here does: the first
transfer's target is in hand and the defers are half run. Refused
loudly rather than resolved to one of them. *)
if !used then begin
lbl f.b cleanup;
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string fn.Tast.floc);
die f "flan_transfer_fail"
end
end
else begin zero_return (); jmp_lbl f.b f.retlbl end
end
else if fn.Tast.fdefers <> [] then
(* Nothing in this function can transfer, so the second exit has no path
to it and the defers on it are dead. Left as a refusal rather than
quietly dropped: if that reasoning is ever wrong, this says so. *)
unsupported "%s has defers on a transfer path nothing reaches"
fn.Tast.name;
(* The prologue, now that the frame size is known. *)
let pb = create () in
@ -1634,20 +2288,38 @@ let emit_globals_init (md : Emit.m) ~externs ~fns (globals : Tast.global list) =
{ b; md; fnname = "<globals>"; retlbl = new_label () "ginit";
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns }
in
(* Two slots, not one: [xfer_off] holds the *pointer* every call passes on,
and [cell] is what it points at. Storing a null into [xfer_off] itself —
which is what this did while nothing could transfer — hands every callee
a null channel to write through. No caller gives this function one, so it
owns the cell. *)
let cell = ptmp f in
f.xfer_off <- ptmp f;
f.xfer_lbl <- new_label f "gxfer";
List.iter
(fun (g : Tast.global) ->
scoped f (fun () -> lower f g.Tast.ginit (Lg (gsym g.Tast.gname, 0))))
globals;
(* Nothing establishes a handler or a restart before this runs, so a
transfer out of an initialiser has nowhere to go and cannot arise: a
bounds failure here finds no handler and dies inside the runtime. The
exit still exists because a guard names it. *)
if f.unwound then begin
jmp_lbl f.b f.retlbl; lbl f.b f.xfer_lbl; jmp_lbl f.b f.retlbl
end;
let pb = create () in
push_r pb rbp;
mov_rr pb ~dst:rbp ~src:rsp;
let n = frame_bytes f in
if n > 0 then sub_imm pb ~dst:rsp n;
(* No caller hands this one a channel, so it gets a null one of its own. *)
(* No caller hands this one a channel, so it gets a null cell of its own and
passes that cell's address on. *)
xor_rr pb ~dst:rax ~src:rax;
store_int pb ~src:rax ~mm:(Frame cell) ~size:8;
lea pb ~dst:rax ~mm:(Frame cell);
store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8;
lbl f.b f.retlbl;
leave f.b;
@ -1663,26 +2335,31 @@ let emit_globals_init (md : Emit.m) ~externs ~fns (globals : Tast.global list) =
(* ── The program ─────────────────────────────────────────────────────── *)
(* The guard that makes the missing transfer guard sound. [emit.ml] emits a
check of the channel after every call; this backend emits none, and the
reason it may is a whole-program one: if nothing in the reachable set can
ever *write* the channel, no call can ever come back with it set. That is a
property of the program and not of the backend, so it is checked here rather
than assumed — and when it fails the build stops with the node that broke
it rather than running with a guard that is not there. *)
(* What is left of the precondition that used to stand in for conditions.
It was a whole-program argument: this backend emitted no guard after a call,
which is sound exactly when nothing in the reachable set can ever *write*
the channel, so the build refused by name the moment it found something that
could. Every call site is guarded now and the argument has retired — except
in one place, which is why the walk is still here.
A global's initialiser runs from [flan..init-globals], before [main] and
before anything has established a handler or a restart. It owns its own
channel cell because no caller hands it one, so a transfer out of an
initialiser has nowhere to go: its exit would return to the loader. Refused
by name rather than compiled into a return into ld.so. *)
let check_no_transfer (p : Tast.program) =
let bad what = unsupported "%s needs the transfer channel, which this \
backend does not emit a guard for" what in
let bad what =
unsupported "%s in a global's initialiser: it runs before main, before \
anything can handle it, and a transfer out of it has nowhere \
to go" what
in
let rec ex (e : Tast.expr) =
(match e.Tast.e with
| Tast.Signal _ -> bad "signal"
| Tast.InvokeRestart _ -> bad "invoke-restart"
| Tast.RestartCase _ -> bad "restart-case"
| Tast.Handled _ -> bad "handler-bind"
| Tast.WithAlloc _ -> bad "with-allocator"
| Tast.Prim (Tast.Rt s, _)
when String.equal s "flan_vec_at" || String.equal s "flan_vec_as_slice" ->
bad ("(" ^ s ^ ")")
| _ -> ());
iter_sub ex e
and iter_sub g (e : Tast.expr) =
@ -1711,15 +2388,12 @@ let check_no_transfer (p : Tast.program) =
| Tast.Pindex (x, ys) -> g x; List.iter g ys
| _ -> ()
in
List.iter
(fun (fn : Tast.fn) -> List.iter ex fn.Tast.body; List.iter ex fn.Tast.fdefers)
p.Tast.fns;
List.iter (fun (g : Tast.global) -> ex g.Tast.ginit) p.Tast.globals
(* A whole program as one assembly file. *)
let program (p : Tast.program) : string =
let program ~checks (p : Tast.program) : string =
check_no_transfer p;
let md = layout_ctx p in
let md = layout_ctx ~checks p in
let externs = Hashtbl.create 16 in
List.iter
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)

72
spike/x86/p6-transfer.flan Normal file
View File

@ -0,0 +1,72 @@
;;;; The re-propagation branches, which the corpus walks past.
;;;;
;;;; Every landing pad this backend emits has two halves: the one a body
;;;; reaches by finishing, and the one a transfer reaches by passing through.
;;;; `test/programs` exercises the first everywhere and the second only for
;;;; with-allocator (allocators.flan's last case aims an invoke-restart out of
;;;; a with-allocator body at a restart-case outside it). The two below it does
;;;; not reach at all, so they are here:
;;;;
;;;; hxfer a transfer crossing a handler-bind, which has to take the handler
;;;; frames off before it goes any further -- in restarts.flan every
;;;; transfer stops at a restart-case *inside* the handler-bind's
;;;; extent, so that pop never runs on the transfer path
;;;;
;;;; rxfer's last branch
;;;; a restart-case the transfer is not aimed at: it puts the target
;;;; back in the channel and re-propagates. restarts.flan's `nested`
;;;; and `shadowed` both have the *inner* frame offering the name, so
;;;; the inner one always wins and this branch is never taken.
;;;;
;;;; Proved the way everything else here is: built both ways, and compared by
;;;; what it prints.
(defstruct Blip [n i32])
(defvar log i64)
;;; Two frames down, with a defer between, so the transfer crosses a function
;;; boundary and a transfer exit that has work to do.
(defn deep [n i32] i32
(signal (Blip {.n n}))
0)
(defn middle [n i32] i32
(defer (set log (+ log 1)))
(deep n))
;;; The handler frames come off on the transfer path. The restart-case is
;;; outside the handler-bind, so the pad pops and re-propagates rather than
;;; the body's own pop running.
(defn crosses-handler [n i32] i32
(restart-case
(handler-bind [(Blip [c] (invoke-restart 'outer-one))]
(middle n))
(outer-one [] 11)))
;;; An inner restart-case that does not offer the name. Its pad clears the
;;; channel, pops its frames, matches nothing, and puts the target back.
(defn crosses-restart [n i32] i32
(restart-case
(handler-bind [(Blip [c] (invoke-restart 'outer-two))]
(restart-case (middle n)
(inner-only [] 22)))
(outer-two [] 33)))
;;; Both at once, and a parameter as well, so the buffer the outer frame owns
;;; is written by an invoke two pads and one function away from it.
(defn crosses-both [n i32] i32
(restart-case
(handler-bind [(Blip [c] (invoke-restart 'outer-three 7))]
(restart-case (middle n)
(inner-only [] 44)))
(outer-three [v i32] (* v 100))))
(defn main [] i32
(print (crosses-handler 1)) (println "") ; 11
(print log) (println "") ; 1 — the defer ran
(print (crosses-restart 2)) (println "") ; 33
(print log) (println "") ; 2
(print (crosses-both 3)) (println "") ; 700
(print log) (println "") ; 3
0)

120
spike/x86/survey.sh Executable file
View File

@ -0,0 +1,120 @@
#!/usr/bin/env bash
# Does the hand-written backend agree with LLVM?
#
# The only honest test of a hand-encoded backend is what the program prints and
# what it exits with -- DISCUSS.md item 15 and item 16 both say so, and both
# say it after a disassembly that read perfectly beside a wrong answer. So this
# builds every program in test/programs twice, runs both, and diffs stdout,
# stderr and the exit status. objdump is for after a program already has the
# wrong answer.
#
# stderr is not an afterthought: every message the condition machinery produces
# goes there -- the bounds and slice errors, the three restart refusals, the
# transfer failure -- and each carries a location string this backend emits by
# hand as a .rodata label and a length in a register. An exit status of 134
# with the wrong text beside it is exactly the failure that looks like a
# match.
#
# Both sides get the same bounds-check setting (the default: on). A sweep that
# compared a checked build against an unchecked one would say nothing about
# bounds.flan, which is the one program the two backends disagreed about.
#
# Five outcomes, and the third is the progress meter:
#
# MATCH built both ways, same stdout, same stderr, same exit status
# DIFFER built both ways, and disagreed
# REFUSED X86.Unsupported -- a node this backend does not lower (exit 3)
# NOX86 failed to build through --x86 for some other reason
# SKIP no main, does not compile at all, or does not terminate
#
# Over test/programs, and over spike/x86's own probes, which are here for the
# paths the corpus does not walk.
#
# Usage: spike/x86/survey.sh [name-substring ...]
set -u
here=$(cd "$(dirname "$0")" && pwd)
root=$(cd "$here/../.." && pwd)
cd "$root" || exit 1
dune build --root . bin/main.exe 2>&1 | head -30
flan=$root/_build/default/bin/main.exe
test -x "$flan" || { echo "build failed"; exit 1; }
out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
# The two that run until something stops them. Not a failure and not a match;
# they are excluded by name because a timeout cannot tell them apart from a
# backend that hung.
forever="dev-loop dev-watch"
TIMEOUT=${TIMEOUT:-20}
declare -a match=() differ=() refused=() nox86=() skip=()
for src in "$root"/test/programs/*.flan "$root"/spike/x86/*.flan; do
name=$(basename "$src" .flan)
if [ $# -gt 0 ]; then
want=0
for pat in "$@"; do case "$name" in *"$pat"*) want=1;; esac; done
[ $want = 1 ] || continue
fi
case " $forever " in *" $name "*) skip+=("$name:runs-forever"); 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.
if ! "$flan" build "$src" -o "$out/$name.llvm" >"$out/$name.llvm.err" 2>&1; then
if grep -q "in function \`_start\|undefined reference to \`main\|crt1.o" "$out/$name.llvm.err"; then
skip+=("$name:no-main")
else
skip+=("$name:does-not-compile")
fi
continue
fi
"$flan" build "$src" --x86 -o "$out/$name.x86" >"$out/$name.x86.err" 2>&1
rc=$?
if [ $rc = 3 ]; then
why=$(head -1 "$out/$name.x86.err" | sed 's/^x86: //')
refused+=("$name:$why")
continue
fi
if [ $rc != 0 ]; then
nox86+=("$name:$(head -1 "$out/$name.x86.err")")
continue
fi
( cd "$out" && timeout "$TIMEOUT" "$out/$name.llvm" \
>"$out/$name.llvm.out" 2>"$out/$name.llvm.diag" )
a=$?
( cd "$out" && timeout "$TIMEOUT" "$out/$name.x86" \
>"$out/$name.x86.out" 2>"$out/$name.x86.diag" )
b=$?
if [ "$a" = "$b" ] && cmp -s "$out/$name.llvm.out" "$out/$name.x86.out" \
&& cmp -s "$out/$name.llvm.diag" "$out/$name.x86.diag"; then
match+=("$name")
else
differ+=("$name:llvm=$a/x86=$b")
if [ "${SURVEY_SHOW:-}" = 1 ]; then
echo "--- $name: llvm exit $a, x86 exit $b"
diff "$out/$name.llvm.out" "$out/$name.x86.out" | head -20
diff "$out/$name.llvm.diag" "$out/$name.x86.diag" | head -20
fi
fi
done
echo
echo "MATCH ${#match[@]}"
echo "DIFFER ${#differ[@]}"
[ "${#differ[@]}" = 0 ] || printf ' %s\n' "${differ[@]}"
echo "REFUSED ${#refused[@]}"
if [ "${#refused[@]}" != 0 ] && [ "${SURVEY_QUIET:-}" != 1 ]; then
printf '%s\n' "${refused[@]}" | sed 's/^[^:]*://' | sort | uniq -c | sort -rn \
| sed 's/^/ /'
fi
echo "NOX86 ${#nox86[@]}"
[ "${#nox86[@]}" = 0 ] || printf ' %s\n' "${nox86[@]}"
echo "SKIP ${#skip[@]}"
if [ "${#skip[@]}" != 0 ] && [ "${SURVEY_QUIET:-}" != 1 ]; then
printf '%s\n' "${skip[@]}" | sed 's/^[^:]*://' | sort | uniq -c \
| sed 's/^/ /'
fi