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

Conditions on the x86 backend, and bounds checks with them

Browse Source 
The transfer channel was the only thing between 41 programs and the
corpus. It is there now: a guard after every Flan call, a landing pad
per restart-case, handler-bind and with-allocator, a transfer exit per
function that runs its fdefers, and check_at and check_slice, which
could not exist until the guard did.

Measured by what the programs print and what they exit with, never by
reading bytes. spike/x86/survey.sh builds every program in
test/programs both ways and diffs stdout and the exit status; it did
not exist, so it is here too, and it is the progress meter.

  before  41 MATCH   1 DIFFER  41 refused by name
  after   83 MATCH   0 DIFFER   0 refused by name

The one DIFFER was bounds.flan, and it was the honest answer to
"--x86 is silently a --no-bounds-checks build". It is not one any
more: check_at and check_slice signal through the channel exactly as
emit.ml's do, so a bounds violation signals, a restart-case catches
it, and an unhandled one exits 134 on both backends. The transitional
refusal that would have said so retired before it was written.

check_no_transfer is not removed, it is narrowed to the one place the
argument still holds: a global's initialiser runs from
flan..init-globals, before main and before anything can handle
anything, so a transfer out of it has nowhere to go.

Four bugs, and three of them are the shape item 16 predicted -- code
that reads correctly and answers wrong, found by output and not by
objdump:

- The body fell through into the transfer exit, so every fdefer ran
  twice on a normal return. emit.ml cannot have this bug: its ret
  terminates the block.
- A Vec crossed to the runtime as the address of a *copy*, so pushes
  grew the copy and an in-bounds (at v 1) signalled against a length
  of zero.
- ucomis sets CF, ZF and PF together for a NaN, so sete answered true
  for (= x x) and the prelude's NaN test never fired: (/ 0.0 0.0)
  formatted as -9223372036854775808. Flan's comparisons are LLVM's
  ordered ones, so < and <= swap and =, != take a setnp beside them.
- A union read field 0 through the struct table and was refused by
  name rather than laid out as a tag and a payload.

And one that could not have been found later: emit_globals_init stored
a null *into* the channel slot rather than a cell address into it,
which is a null pointer for every callee to write through. Harmless
while nothing could transfer; a fault the first time a guard loaded
through it.
This commit is contained in:
Joseph Ferano 2026-09-13 18:05:08 +07:00
parent 888915402e
commit 63d9b87b7a
4 changed files with 834 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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);

775
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,55 @@ 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. *)
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;
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;
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 jmp_lbl f.b f.retlbl
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 +2279,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 +2326,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 +2379,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)

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

@ -0,0 +1,105 @@
#!/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 and
# the exit status. objdump is for after a program already has the wrong answer.
#
# 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 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
#
# 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; 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>/dev/null )
a=$?
( cd "$out" && timeout "$TIMEOUT" "$out/$name.x86" >"$out/$name.x86.out" 2>/dev/null )
b=$?
if [ "$a" = "$b" ] && cmp -s "$out/$name.llvm.out" "$out/$name.x86.out"; 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
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