From fcdaa105af060bf1a69877da7952f62d63a56262 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 15:06:31 +0700 Subject: [PATCH] Unions and a two-index (at), which the corpus asked for by name MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The sweep over test/programs named its own next two nodes. (at grid r c) is one node with two indices and not two nodes — an array of arrays is contiguous, so the second index walks into the element the first landed on — and machine.flan is the program that says so. Then unions: MakeCase, CaseField and Match. The payload offset comes from lay_fields over the same two fields Emit.lay measures a union as, and a case's field offsets from lay_fields over that case's own fields, so there is still one layout calculator and this file is still a caller of it. match reads the tag and compares, an Option reads an i8 at offset 0 and a declared union an i32, and everything past the tag and the binds is shared — the arrangement emit.ml settled on, for the same reason. An exhausted match falls through to ud2 rather than to whatever follows. The checker proved it cannot happen; a defined SIGILL at the instruction that fell through costs two bytes and is the cheap half of item 15's question 4. machine.flan, bytes2.flan, array-ctor.flan and destructure.flan all agree with the LLVM build now. --- lib/x86.ml | 161 ++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 154 insertions(+), 7 deletions(-) diff --git a/lib/x86.ml b/lib/x86.ml index 4a84ba5..acad01b 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -599,6 +599,37 @@ let field_offsets f (sn : string) = 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 + else + let _, _, offs = + Emit.lay_fields f.md + [ Types.Int Types.I32; + Types.Array (Int64.of_int (size / align), + Types.Int (Emit.int_kind (align * 8))) ] + in + List.nth offs 1 + +let union_of f n = + match Hashtbl.find_opt f.md.Emit.unions n with + | Some u -> u + | None -> unsupported "no union %s" n + +(* The offsets of one case's fields inside the payload blob. The single place + in this backend that knows how a payload is read, so [match]'s binds, + [CaseField] and [MakeCase] cannot come to different conclusions about it. *) +let case_offsets f (c : Tast.variant) = + let _, _, offs = + Emit.lay_fields f.md + (List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields) + in + offs + (* An Option is { i8 tag, T }, the same two fields [Emit.lay] measures it as. *) let option_lay f (t : Types.t) = let _, _, offs = Emit.lay_fields f.md [ Types.Int Types.I8; t ] in @@ -861,8 +892,28 @@ let rec lower f (e : Tast.expr) (dst : loc) : unit = jmp_lbl f.b f.retlbl; lbl f.b lsome; move f ~dst ~src:(shift src ov) payload - | Tast.Match _ | Tast.MakeCase _ | Tast.CaseField _ -> - unsupported "union values, in %s" f.fnname + | Tast.MakeCase (uname, case, fields) -> + let u = union_of f uname in + let i, c = + match Tast.case_index u case with + | Some (i, c) -> i, c + | None -> unsupported "no case %s of %s" case uname + in + (* Zeroed first: an omitted field is ZII and the payload blob is wider + than this case, so the bytes past its last field have to be something + rather than whatever the frame held. *) + zero_loc f dst (sizeof f.md t); + imm_into f ~reg:rax (Int64.of_int i); + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:4; + let poff = union_payload_off f u in + let offs = case_offsets f c in + List.iteri + (fun k (x : Tast.expr) -> + scoped f (fun () -> lower f x (shift dst (poff + List.nth offs k)))) + fields + | 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 @@ -903,9 +954,91 @@ and lvalue f (e : Tast.expr) : loc = of its elements. [emit.ml] gets this from [addr]'s own [At] case; without it here the store lands in a temporary and the program is quietly wrong. *) - | Tast.Prim (Tast.At, [ a; i ]) -> element f (lvalue f a) a.Tast.ty i + | Tast.Prim (Tast.At, a :: is) when is <> [] -> + elements f (lvalue f a) a.Tast.ty is + | Tast.CaseField (target, case, i) -> case_field f target case i | _ -> eval f e +(* The address of one field of one case of a union value. Only ever reached + under an arm that proved the tag — [match] is the only thing that proves + it — or from the structural printer, which compares the same tag first. *) +and case_field f (target : Tast.expr) case i = + let uname = + match target.Tast.ty with + | Types.Named n -> n + | ty -> unsupported "case field of %s" (Types.to_string ty) + in + let u = union_of f uname in + let c = + match Tast.case_index u case with + | Some (_, c) -> c + | None -> unsupported "no case %s of %s" case uname + in + shift (lvalue f target) (union_payload_off f u + List.nth (case_offsets f c) i) + +(* [match]. The two subjects are the same shape and are read differently: an + [Option] is an i8 tag and a payload at a known offset, a declared union is + an i32 tag and a blob the arm's case reinterprets. Everything past the tag + and the binds is shared, which is the arrangement [emit.ml] settled on for + the same reason. *) +and emit_match f (scrut : Tast.expr) (arms : Tast.arm list) dst t = + let base = lvalue f scrut in + let tag_size, tag_of, bind_at = + match scrut.Tast.ty with + | Types.Named n when Hashtbl.mem f.md.Emit.unions n -> + let u = union_of f n in + let poff = union_payload_off f u in + ( 4, + (fun case -> + match Tast.case_index u case with + | Some (i, _) -> i + | None -> unsupported "no case %s of %s" case n), + fun case k -> + match Tast.case_index u case with + | Some (_, c) -> + shift base (poff + List.nth (case_offsets f c) k), + (List.nth c.Tast.vfields k).Tast.fty + | None -> unsupported "no case %s of %s" case n ) + | Types.Option el -> + (* [lay_fields] puts the i8 tag at 0, so [base] is the tag's address the + way it is for a union. *) + let _, ov = option_lay f el in + ( 1, + (fun case -> if String.equal case "Some" then 1 else 0), + fun _case _k -> shift base ov, el ) + | ty -> unsupported "match on %s" (Types.to_string ty) + in + let lend = new_label f "endmatch" in + let rec go = function + | [] -> + (* The checker proved exhaustiveness, so nothing reaches here. A trap + rather than a fallthrough: [ud2] is a defined SIGILL at the + instruction that fell through, which is the cheap half of item 15's + question 4. *) + ud2 f.b + | (a : Tast.arm) :: rest -> + let lnext = new_label f "arm" in + (match a.Tast.acase with + | None -> () + | Some case -> + load_int f.b ~dst:rax ~mm:(lmem f base ~scratch:r11) ~size:tag_size + ~signed:false; + cmp_imm f.b ~dst:rax (tag_of case); + jcc_lbl f.b ~cc:cc_ne lnext); + List.iteri + (fun k slot -> + let src, fty = + bind_at (match a.Tast.acase with Some c -> c | None -> "") k + in + move f ~dst:(Lf f.slots.(slot)) ~src fty) + a.Tast.binds; + block f a.Tast.abody dst t; + jmp_lbl f.b lend; + if a.Tast.acase <> None then (lbl f.b lnext; go rest) + in + go arms; + lbl f.b lend + and field_loc f (base : loc) (ty : Types.t) i = match ty with | Types.Named sn -> shift base (List.nth (field_offsets f sn) i) @@ -927,13 +1060,27 @@ and place f (p : Tast.place) : loc = | Tast.Pglobal n -> Lg (gsym n, 0) | Tast.Pderef x -> let q = eval f x in Lp (off_of q, 0) | Tast.Pfield (x, i) -> field_loc f (lvalue f x) x.Tast.ty i - | Tast.Pindex (x, [ i ]) -> element f (lvalue f x) x.Tast.ty i - | Tast.Pindex _ -> unsupported "multi-dimensional index" + (* [(at grid r c)] is one node with two indices, not two nodes: an array of + arrays is contiguous, so the second index walks into the element the + first one landed on. *) + | Tast.Pindex (x, is) -> elements f (lvalue f x) x.Tast.ty is (* One element of an array, a slice or a pointer. No bounds check: the check [emit.ml] emits signals, and signalling is the row of item 15's table with no plan here yet — so this backend is the [--no-bounds-checks] shape of the program and says so. *) +and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc = + match is with + | [] -> base + | i :: rest -> + let elem = + match ty with + | Types.Array (_, el) | Types.Slice el | Types.Ptr el -> el + | Types.String -> Types.Int Types.U8 + | t -> unsupported "index into %s" (Types.to_string t) + in + elements f (element f base ty i) elem rest + and element f (base : loc) (ty : Types.t) (i : Tast.expr) : loc = let elem = match ty with @@ -1107,8 +1254,8 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = ~signed:true | ty -> unsupported "len of %s" (Types.to_string ty)); store_loc f ~reg:rax dst t - | Tast.At, [ a; i ] -> - let l = element f (lvalue f a) a.Tast.ty i in + | Tast.At, a :: is when is <> [] -> + let l = elements f (lvalue f a) a.Tast.ty is in move f ~dst ~src:l t | Tast.Slice, [ a; lo; hi ] -> let elem =