From 63d9b87b7af1d864a80c4f7e76c2a2dd741709c4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 18:05:08 +0700 Subject: [PATCH] Conditions on the x86 backend, and bounds checks with them 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. --- bin/main.ml | 8 + lib/build.ml | 2 +- lib/x86.ml | 775 ++++++++++++++++++++++++++++++++++++++++---- spike/x86/survey.sh | 105 ++++++ 4 files changed, 834 insertions(+), 56 deletions(-) create mode 100755 spike/x86/survey.sh diff --git a/bin/main.ml b/bin/main.ml index 5958151..d045156 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 diff --git a/lib/build.ml b/lib/build.ml index bd462ce..24bf682 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -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); diff --git a/lib/x86.ml b/lib/x86.ml index fd5135d..f484184 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -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 = ""; 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) diff --git a/spike/x86/survey.sh b/spike/x86/survey.sh new file mode 100755 index 0000000..4e89ec5 --- /dev/null +++ b/spike/x86/survey.sh @@ -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