Unions and a two-index (at), which the corpus asked for by name
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.
This commit is contained in:
parent
786656dfee
commit
fcdaa105af
161
lib/x86.ml
161
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 =
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user