From 675241e226376458b4d88b8950fdd98092fac9e7 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 16:48:43 +0700 Subject: [PATCH] Union values: a tag, a blob, and a case laid over it defunion parsed and its shape checked; naming the type and constructing a value were both refused as milestone 6. They are not any more. A union is Types.Named, exactly as a struct is, so every path that carries a type -- a field, a parameter, a slot, a copy -- learns nothing about unions. Which table the name is in is the only thing that tells the two apart. The layout is a tag then room for the largest case, with the alignment the widest member of any case needs: %"U" = type { i32, [k x iA] }, and one named %"U.C" per case laid over the blob. That is C's struct { int tag; union { ... } u; } byte for byte, which is the requirement the macro expander's Form will arrive with. A value is (U.C {.field value ...}), or U.C on its own when the case has no fields. Construction goes through the struct-literal syntax already there, so parse.ml is untouched: the dot is a symbol constituent and U.C reads as one name. Tags are declaration order from zero, so an all-bytes-zero union is the first declared case with a zeroed payload -- the same rule that makes an Option's zero a None, and it makes case order part of a union's contract. A move-only field in a case is refused in the same words a struct's is, and a union is refused as a map key: the payload past the case in hand is indeterminate, so hashing the blob would make two equal values hash differently. --- lib/check.ml | 315 ++++++++++++++++++++++++++++++++++++++++++++------- lib/emit.ml | 246 +++++++++++++++++++++++++++++++++++++--- lib/reach.ml | 3 +- lib/tast.ml | 36 ++++++ 4 files changed, 541 insertions(+), 59 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 3260e5b..26dfd43 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -44,6 +44,20 @@ type binding = { type env = { structs : (string, Tast.structure) Hashtbl.t; unions : (string, Tast.union) Hashtbl.t; + (* Every union case, twice over: once under its full spelling ["U.C"], which + is how a value of it is written, and once under the bare ["C"], which is + how a [match] arm names it and how a mistake spells a constructor. The + full spelling is a key rather than something split out of a dotted name at + the use site, because a union's own name can contain a slash (an imported + [rl/U]) and may one day contain a dot; string surgery would own an edge + this does not have to. + + The bare entry is deliberately last-writer-wins and is *only* used to say + "C is a case of U, write (U.C ...)". Two unions may share a case name — + construction is qualified and a pattern resolves against the scrutinee, so + both are unambiguous — and refusing that would be a restriction with no + mechanism behind it. *) + cases : (string, string * Tast.variant) Hashtbl.t; aliases : (string, Ast.texpr) Hashtbl.t; consts : (string, int64) Hashtbl.t; (* compile-time array lengths *) locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *) @@ -64,6 +78,7 @@ type env = { let new_env () = { structs = Hashtbl.create 16; unions = Hashtbl.create 16; + cases = Hashtbl.create 32; aliases = Hashtbl.create 16; consts = Hashtbl.create 16; locs = Hashtbl.create 16; @@ -392,12 +407,12 @@ and resolve_name env ~seen loc n = fail loc "the type alias %s is defined in terms of itself" n else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) | _ when Hashtbl.mem env.structs n -> Types.Named n - (* A union has no layout in emit — nothing there mentions unions at all — - so a union-typed global reached clang as a reference to an undefined - %"U". Constructing one and reading a field of one are already refused, - so there is nothing to lower: only a declaration that got through. *) - | _ when Hashtbl.mem env.unions n -> - unimplemented loc (Printf.sprintf "the union type %s" n) 6 + (* A union is [Named] exactly as a struct is: one case in [Types.t] + covers both, and which table the name is in is what tells them apart. + Keeping them one case is what lets a union be a field, a parameter, a + return type and a slot without a single one of those paths learning + that unions exist. *) + | _ when Hashtbl.mem env.unions n -> Types.Named n | _ when Hashtbl.mem env.enums n -> Types.Enum n (* A typo in a primitive is lowercase too, and the type-variable rule below would otherwise report [f65] as unimplemented generics and send @@ -644,6 +659,18 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = | t when bytewise_key t -> Tast.Rtfn "flan_hash_flat", Tast.Rtfn "flan_eq_flat" | Types.Named n when Hashtbl.mem env.structs n -> struct_key_pair env loc n + (* A union key would have to hash the tag and then only the bytes the case in + hand actually uses — the rest of the payload is indeterminate, exactly as + a struct's padding is, so hashing the blob would make two equal values + hash differently. That is a per-case walk driven by a switch, which is a + different shape from the field list [struct_key_pair] emits and which + nothing has yet wanted. Refused by name rather than written untested. *) + | Types.Named n when Hashtbl.mem env.unions n -> + fail loc + "%s is a union, and a union is not a map key: the payload past the case \ + in hand is indeterminate, so hashing the bytes would make two equal \ + values hash differently. Hashing one needs a per-case walk, which is \ + not written — key on the tag, or on a struct holding what you meant" n | Types.Array (_, e) -> (* A fixed array of a struct or of strings would need the same per-element walk a struct key gets, driven by a loop rather than by a field list. @@ -1077,10 +1104,29 @@ and var ctx loc ~want name = match Hashtbl.find_opt ctx.env.globals name with | Some (ty, _) -> expect loc ~want (mk loc ty (Tast.Global name)) | None -> - if Hashtbl.mem ctx.env.fns name then - unimplemented loc - (Printf.sprintf "the function value %s (a name used as a value)" name) 5 - else begin captured ctx loc name; fail loc "unknown name %s" name end + match Hashtbl.find_opt ctx.env.cases name with + (* A case with no fields is a whole value on its own, so it is written + as a name and not as a call — the same shape [None] has, and for the + same reason: there is nothing to put in the braces. A case that does + have fields is refused here rather than silently zeroed, because ZII + on a constructor would quietly produce a value nobody wrote. *) + | Some (uname, c) when String.contains name '.' -> + if c.Tast.vfields <> [] then + fail loc + "%s has fields, so it needs them — write (%s {.%s ...})" + name name + (List.hd c.Tast.vfields).Tast.fname; + expect loc ~want + (mk loc (Types.Named uname) + (Tast.MakeCase (uname, c.Tast.vname, []))) + | Some (uname, c) -> + fail loc + "%s is a case of the union %s, and a union value names both — write %s.%s" name uname uname c.Tast.vname + | None -> + if Hashtbl.mem ctx.env.fns name then + unimplemented loc + (Printf.sprintf "the function value %s (a name used as a value)" name) 5 + else begin captured ctx loc name; fail loc "unknown name %s" name end (* Reading a move-only local. Every read is a move unless the site said it was a borrow, which is the conservative direction: passing one to a function, @@ -1414,12 +1460,33 @@ and check_if ctx ?want loc c t e = in mk loc ty (Tast.If (c, t, e)) +(* A record-shaped literal: one form for both, because [(Name {.f v})] is the + same syntax whether [Name] is a struct or a union case, and the two differ + only in what is built at the end. Deciding here rather than in the parser is + what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = match Hashtbl.find_opt ctx.env.structs name with | None -> - if Hashtbl.mem ctx.env.unions name then - unimplemented loc "constructing a union value" 6 - else fail loc "unknown struct %s" name + (match Hashtbl.find_opt ctx.env.cases name with + (* The full spelling [U.C], which is how a union value is written. Checked + before the diagnostics below, since the bare-name entry in the same + table is only ever a hint. *) + | Some (uname, c) when String.contains name '.' -> + check_case ctx ~want loc uname c kvs + (* A bare case name. This is the bug NEXT.md listed under "Bugs found and + not yet fixed": [(A {.x 1})] on a case of a union reported "unknown + struct A", because nothing in [env] could tell a case name from a + misspelling. It can now, so it says what was meant. *) + | Some (uname, c) -> + fail loc + "%s is a case of the union %s, not a struct — a union value names both, as (%s.%s {.field value ...})" + name uname uname c.Tast.vname + | None -> + if Hashtbl.mem ctx.env.unions name then + fail loc + "%s is a union, and a union value names the case as well as the type — write (%s.%s {.field value ...}) for one of %s" + name name (first_case_name ctx.env name) (case_list ctx.env name) + else fail loc "unknown struct %s" name) | Some s -> let seen = Hashtbl.create 8 in List.iter @@ -1443,6 +1510,44 @@ and check_struct ctx ~want loc name kvs = in expect loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) +(* The cases of a union, as written, for a message that has to name them. *) +and case_list env uname = + match Hashtbl.find_opt env.unions uname with + | None -> "its cases" + | Some u -> + String.concat ", " + (List.map (fun (c : Tast.variant) -> uname ^ "." ^ c.Tast.vname) + u.Tast.cases) + +and first_case_name env uname = + match Hashtbl.find_opt env.unions uname with + | Some { Tast.cases = c :: _; _ } -> c.Tast.vname + | _ -> "Case" + +(* [(U.C {.f v ...})]. The fields are checked and filled in exactly as a + struct's are — same ZII, same duplicate and unknown-field refusals — and the + only difference is the node at the end and the type it carries. *) +and check_case ctx ~want loc uname (c : Tast.variant) kvs = + let full = uname ^ "." ^ c.Tast.vname in + let seen = Hashtbl.create 8 in + List.iter + (fun (k, (v : Ast.expr)) -> + if Hashtbl.mem seen k then fail v.Ast.loc "field %s is given twice" k; + if Tast.vfield_index c k = None then + fail v.Ast.loc "%s has no field %s" full k; + Hashtbl.add seen k v) + kvs; + let fields = + map_lr + (fun (f : Tast.field) -> + match Hashtbl.find_opt seen f.Tast.fname with + | Some v -> check ctx ~want:f.Tast.fty v + | None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty)) + c.Tast.vfields + in + expect loc ~want + (mk loc (Types.Named uname) (Tast.MakeCase (uname, c.Tast.vname, fields))) + and check_arr ctx ~want loc items = let elem_want = match want with @@ -1475,9 +1580,17 @@ and check_arr ctx ~want loc items = and check_match ctx ?want loc scrutinee arms = let s = check ctx scrutinee in - let elem = + (* What the arms are alternatives over. An [Option] is a two-case union + wearing a special coat, so the two shapes below are the same shape: a set + of case names, an arity and a payload type per case, and a tag. Keeping + them apart here rather than desugaring [Option] into a declared union is + deliberate — [Option] is generic and no declared union is, so the coat is + the part that cannot yet be taken off. *) + let subject = match s.Tast.ty with - | Types.Option t -> t + | Types.Option t -> `Option t + | Types.Named n when Hashtbl.mem ctx.env.unions n -> + `Union (Hashtbl.find ctx.env.unions n) (* An enum is the one scrutinee that is not a milestone away: it is an i32 at run time and its members are all known, so the arms would be a chain of [=] with an exhaustiveness check over [env.enums] — a desugaring, not @@ -1491,12 +1604,63 @@ and check_match ctx ?want loc scrutinee arms = of (= k :member), but a keyword has no case in the pattern type yet. \ Use cond" n | other -> - (* Union matching arrives with unions themselves, at milestone 6. *) - fail loc "match works on an Option at milestone 2, not on %s" + fail loc "match works on an Option or a union, not on %s" (Types.to_string other) in + (* Which case each arm names, and the type of each name it binds. This is the + whole of what differs between the two subjects; everything below it is + shared. *) + let resolve_pat (a : Ast.arm) = + match subject, a.Ast.pat with + | _, Ast.Pwild -> None, [] + | `Option elem, Ast.Pctor ("Some", [ x ]) -> Some "Some", [ (x, elem) ] + | `Option _, Ast.Pctor ("Some", _) -> + fail a.Ast.aloc "the Some pattern binds exactly one name" + | `Option _, Ast.Pctor ("None", []) -> Some "None", [] + | `Option _, Ast.Pctor ("None", _) -> fail a.Ast.aloc "None binds no names" + | `Option _, Ast.Pctor (c, _) -> + fail a.Ast.aloc + "%s is not a case of Option — the cases are Some and None" c + | `Union u, Ast.Pctor (c, names) -> + (* A pattern names the case bare: the scrutinee's type already says which + union, so [(Node l r)] is unambiguous even where two unions share the + case name. The qualified spelling is accepted too, since that is how + the value was written and writing it again should not be an error. *) + let bare = + let full = u.Tast.uname ^ "." in + let n = String.length full in + if String.length c > n && String.sub c 0 n = full then + String.sub c n (String.length c - n) + else c + in + (match Tast.case_index u bare with + | None -> + fail a.Ast.aloc "%s is not a case of %s — the cases are %s" c + u.Tast.uname + (String.concat ", " + (List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases)) + | Some (_, v) -> + (* Positional, in declaration order, and all of them or none: a + pattern that bound some of a case's fields would be silently + reading the wrong one after a field is inserted. Refused with the + count, which is the thing that is wrong. *) + if List.length names <> List.length v.Tast.vfields then + fail a.Ast.aloc + "%s.%s has %d field%s, and this pattern binds %d — a case pattern \ + binds every field, in declaration order (%s)" + u.Tast.uname bare (List.length v.Tast.vfields) + (if List.length v.Tast.vfields = 1 then "" else "s") + (List.length names) + (String.concat " " + (List.map (fun (f : Tast.field) -> f.Tast.fname) + v.Tast.vfields)); + Some bare, + List.map2 (fun n (f : Tast.field) -> (n, f.Tast.fty)) + names v.Tast.vfields) + in let want = ref want in - let saw_some = ref false and saw_none = ref false and saw_wild = ref false in + let seen = Hashtbl.create 8 in + let saw_wild = ref false in (* The same rule as [if], and for the same reason: the arms are alternatives, so each is checked from the state before the match and the union of what they moved survives the join. Checked in sequence against one mutating set @@ -1507,23 +1671,19 @@ and check_match ctx ?want loc scrutinee arms = let arms = map_lr (fun (a : Ast.arm) -> - let ctor, binds = - match a.Ast.pat with - | Ast.Pwild -> saw_wild := true; None, [] - | Ast.Pctor ("Some", [ x ]) -> saw_some := true; Some "Some", [ x ] - | Ast.Pctor ("Some", _) -> - fail a.Ast.aloc "the Some pattern binds exactly one name" - | Ast.Pctor ("None", []) -> saw_none := true; Some "None", [] - | Ast.Pctor ("None", _) -> fail a.Ast.aloc "None binds no names" - | Ast.Pctor (c, _) -> - fail a.Ast.aloc - "%s is not a case of Option — the cases are Some and None" c - in + let ctor, binds = resolve_pat a in + (match ctor with + | None -> saw_wild := true + | Some c -> + if Hashtbl.mem seen c then + fail a.Ast.aloc "this match has two %s arms" c; + Hashtbl.add seen c ()); ctx.dead <- before; let arm = branch ctx (fun () -> let binds = - List.map (fun n -> bind ctx n elem ~assignable:false) binds + List.map + (fun (n, ty) -> bind ctx n ty ~assignable:false) binds in let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in if !want = None && body.Tast.ty <> Types.Never then @@ -1537,10 +1697,28 @@ and check_match ctx ?want loc scrutinee arms = arms in ctx.dead <- !joined; - if not (!saw_wild || (!saw_some && !saw_none)) then + (* Exhaustiveness is refused, not defaulted. A match that silently fell + through would have to produce a value of the match's type out of nothing, + and there is no such value for most types; and the case a union grows + tomorrow is exactly the one a reader wants to be told about today. A [_] + arm is the way to say "the rest", written where it can be seen. *) + let missing = + match subject with + | `Option _ -> List.filter (fun c -> not (Hashtbl.mem seen c)) [ "Some"; "None" ] + | `Union u -> + List.filter_map + (fun (c : Tast.variant) -> + if Hashtbl.mem seen c.Tast.vname then None + else Some (u.Tast.uname ^ "." ^ c.Tast.vname)) + u.Tast.cases + in + if not !saw_wild && missing <> [] then fail loc - "this match is not exhaustive — Option needs both Some and None, or a \ - _ arm"; + "this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \ + the rest" + (String.concat ", " missing) + (if List.length missing = 1 then "has" else "have") + (if List.length missing = 1 then "it" else "them"); let ty = match !want with Some t -> t | None -> Types.Never in mk loc ty (Tast.Match (s, arms)) @@ -3032,8 +3210,18 @@ and named_call ctx ~want loc name args = let args = map2_lr (fun p a -> check ctx ~want:p a) params args in expect loc ~want (mk loc ret (Tast.Call (name, args))) | None -> - if Hashtbl.mem ctx.env.structs name || Hashtbl.mem ctx.env.unions name - then + if Hashtbl.mem ctx.env.unions name then + fail loc + "%s is a union type — a union value names the case too, as (%s.%s {.field value ...})" + name name (first_case_name ctx.env name) + else if Hashtbl.mem ctx.env.cases name then + (* [(U.C)] and [(C)]: a case written as a call. Both are how someone + reaches for a constructor, and neither is one. *) + let uname, c = Hashtbl.find ctx.env.cases name in + fail loc + "%s is a case of the union %s — write (%s.%s {.field value ...}), or %s.%s on its own when it has no fields" + name uname uname c.Tast.vname uname c.Tast.vname + else if Hashtbl.mem ctx.env.structs name then fail loc "%s is a type — a struct value is written (%s {.field value ...})" name name @@ -3248,11 +3436,56 @@ let collect env (decls : Ast.decl list) = fields; Hashtbl.replace env.structs n { Tast.sname = n; fields } | Ast.Defunion (n, vs) -> - Hashtbl.replace env.unions n - { Tast.uname = n; - cases = List.map (fun (v : Ast.variant) -> - { Tast.vname = v.Ast.vname; - vfields = List.map field v.Ast.vfields }) vs } + (* A union with no cases has no value, so nothing could ever be given + one, and a parameter of that type would be a function nothing can + call. It parses; it is refused here rather than surviving to a + layout with a tag and no case for the tag to name. *) + if vs = [] then + fail loc + "%s declares no cases, so no value of it can exist — a union is \ + (defunion %s [(Case [field Type ...]) ...])" n n; + let cnames = List.map (fun (v : Ast.variant) -> v.Ast.vname) vs in + if List.length (List.sort_uniq compare cnames) <> List.length cnames + then fail loc "%s declares the same case twice" n; + let cases = + List.map + (fun (v : Ast.variant) -> + let fnames = + List.map (fun (f : Ast.field) -> f.Ast.fname) v.Ast.vfields + in + if List.length (List.sort_uniq compare fnames) + <> List.length fnames then + fail v.Ast.vloc "%s.%s declares the same field twice" + n v.Ast.vname; + let vfields = List.map field v.Ast.vfields in + (* The same refusal a struct field gets, for the same reason + and in the same words: a union case's fields are a struct, + the union copies bytewise on assignment, and recursive + teardown arrives with [drop]. Refusing it here rather than + at a use keeps the two declarations honest with each other + — a union that could hold a Vec where a struct could not + would be a hole in the same rule. *) + List.iter + (fun (f : Tast.field) -> + if Types.is_move_only f.Tast.fty then + fail v.Ast.vloc + "%s.%s's field %s is %s, which is move-only, and a \ + union case that owns one makes the union move-only \ + too — transitively, with recursive teardown. That \ + rule arrives with drop (step 5 in NEXT.md); until \ + then hold the %s in a local and pass it" + n v.Ast.vname f.Tast.fname (Types.to_string f.Tast.fty) + (Types.to_string f.Tast.fty)) + vfields; + { Tast.vname = v.Ast.vname; vfields }) + vs + in + Hashtbl.replace env.unions n { Tast.uname = n; cases }; + List.iter + (fun (c : Tast.variant) -> + Hashtbl.replace env.cases (n ^ "." ^ c.Tast.vname) (n, c); + Hashtbl.replace env.cases c.Tast.vname (n, c)) + cases | Ast.Defn fn -> let params = List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params diff --git a/lib/emit.ml b/lib/emit.ml index 8c77029..1050a6d 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -195,6 +195,12 @@ type m = { out : Buffer.t; strs : Buffer.t; (* string literal constants *) structs : (string, Tast.structure) Hashtbl.t; + (* The declared unions, by name. [Types.Named] covers both a struct and a + union, so which table the name is in is the only thing that says which + this is — the same arrangement the checker uses, and for the same reason: + a union is a type like any other everywhere except at its layout, its + construction and its match. *) + unions : (string, Tast.union) Hashtbl.t; globals : (string, Types.t) Hashtbl.t; (* Flan name -> C symbol, for the foreign functions. A call to one names the symbol directly; there is no thunk. *) @@ -265,7 +271,23 @@ let rec lay m (t : Types.t) : int * int = lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields) in s, a - | None -> failwith ("no layout for struct " ^ n)) + | None -> + match Hashtbl.find_opt m.unions n with + | Some u -> + (* The tag then the payload, as one struct, so the answer is the same + arithmetic every other aggregate here gets rather than a second + rule that could drift from it. *) + let size, align = payload_lay m u in + if size = 0 then 4, 4 + else + let s, a, _ = + lay_fields m + [ Types.Int Types.I32; + Types.Array (Int64.of_int (size / align), + Types.Int (int_kind (align * 8))) ] + in + s, a + | None -> failwith ("no layout for struct " ^ n)) | Types.Fn _ | Types.Var _ -> failwith ("no layout for " ^ Types.to_string t) @@ -283,6 +305,27 @@ and lay_fields m tys = tys; align_up !off !al, !al, List.rev !rev +(* The size and alignment of a union's payload: room for the largest case, with + the alignment the widest member of any case needs, and the size rounded up + to it so the blob divides evenly into [k x iA]. A union of payload-less + cases has a zero-size payload and is a bare tag. *) +and payload_lay m (u : Tast.union) : int * int = + let align = ref 1 and size = ref 0 in + List.iter + (fun (c : Tast.variant) -> + let s, a, _ = + lay_fields m (List.map (fun (f : Tast.field) -> f.Tast.fty) c.Tast.vfields) + in + if a > !align then align := a; + if s > !size then size := s) + u.Tast.cases; + align_up !size !align, !align + +(* The integer kind of a given width, for the payload blob's element type. *) +and int_kind = function + | 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64 + | n -> failwith ("no integer type of " ^ string_of_int n ^ " bits") + (* A DWARF type node for a Flan type, memoised by the type's printed form so the pool holds one node per distinct type. *) let rec dty m d (t : Types.t) : int = @@ -369,7 +412,23 @@ let rec dty m d (t : Types.t) : int = composite sn (List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty)) st.Tast.fields) - | None -> failwith ("no debug type for struct " ^ sn)) + | None -> + match Hashtbl.find_opt m.unions sn with + (* The truth about the bytes, and nothing cleverer: a tag and a blob. + DWARF 5 has DW_TAG_variant_part for exactly this, and lldb's C + support does not use it — a debugger that was handed one would + show less, not more. The reader who wants the payload reads it + through the case's own type, which is emitted beside this. *) + | Some u -> + let size, align = payload_lay m u in + composite sn + ([ ("tag", Types.Int Types.U32) ] + @ (if size = 0 then [] + else + [ ("payload", + Types.Array (Int64.of_int (size / align), + Types.Int (int_kind (align * 8)))) ])) + | None -> failwith ("no debug type for struct " ^ sn)) (* An opaque pointer under lldb, which is the truth: the allocator's fields are the runtime's C and lldb already has that type from flan_rt.c's own debug info. *) @@ -761,6 +820,10 @@ and value_at f (e : Tast.expr) : string = ins f "store %s %s, ptr %s" (ll ty) v' ptr; "zeroinitializer" | Tast.Make (_, fields) -> aggregate f e.Tast.ty fields + | Tast.MakeCase (uname, case, fields) -> + emit_make_case f uname case fields + | Tast.CaseField (target, case, i) -> + load f (case_field_addr f target case i) e.Tast.ty | Tast.Arr items -> aggregate f e.Tast.ty items | Tast.Some_ v -> let v' = value f v in @@ -959,6 +1022,58 @@ and place f (p : Tast.place) : string * Types.t = (* A struct or fixed-array value, built field by field from zeroinitializer. The checker already filled the omitted fields in with Zero, so this is simply every field in declaration order. *) +(* A union value, built in memory rather than with [insertvalue], because the + payload's declared type is a blob of integers and the case's fields are not: + the two views of the same bytes are what a gep expresses and what a chain of + [insertvalue] cannot. The alloca is what [mem2reg] removes when nobody takes + an address of it. *) +and emit_make_case f uname case fields = + let ty = Types.Named uname in + let u = Hashtbl.find f.md.unions uname in + let tag = match Tast.case_index u case with + | Some (i, _) -> i + | None -> failwith ("no case " ^ case ^ " of " ^ uname) + in + let tmp = alloca f ty in + ins f "store %s zeroinitializer, ptr %s" (ll ty) tmp; + let tp = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname uname) tmp; + ins f "store i32 %d, ptr %s" tag tp; + if fields <> [] then begin + let pp = payload_addr f uname tmp in + let cty = sname (uname ^ "." ^ case) in + List.iteri + (fun i (p : Tast.expr) -> + let v = value f p in + let fp = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" fp cty pp i; + ins f "store %s %s, ptr %s" (ll p.Tast.ty) v fp) + fields + end; + load f tmp ty + +(* The payload blob's address. A union with no payload has no field 1, so this + is only ever reached for one that has fields to reach. *) +and payload_addr f uname base = + let p = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 1" p (sname uname) base; + p + +(* The address of one field of one case of a union value. The single place in + this backend that knows how a payload is read, so [match]'s binds and the + structural printer cannot come to different conclusions about it. *) +and case_field_addr f (target : Tast.expr) case i = + let uname = match target.Tast.ty with + | Types.Named n -> n + | t -> failwith ("case field of " ^ Types.to_string t) + in + let base = addr f target in + let pp = payload_addr f uname base in + let p = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" + p (sname (uname ^ "." ^ case)) pp i; + p + and aggregate f ty parts = let t = ll ty in let acc = ref "zeroinitializer" in @@ -1343,12 +1458,60 @@ and emit_while f c body = label f le and emit_match f ty scrut arms = - let sv = value f scrut in - let sty = ll scrut.Tast.ty in - let tag = fresh f in - ins f "%s = extractvalue %s %s, 0" tag sty sv; - let payload_ty = match scrut.Tast.ty with - | Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t) + (* The two subjects are the same shape and are read differently: an [Option] + is an SSA aggregate with an i8 tag and its payload in field 1, a declared + union is read through its address because its payload is a blob that has + to be reinterpreted. So the tag and the binds are each produced by one of + two small functions and everything else below is shared. *) + let uname = + match scrut.Tast.ty with + | Types.Named n when Hashtbl.mem f.md.unions n -> Some n + | Types.Option _ -> None + | t -> failwith ("match on " ^ Types.to_string t) + in + let tag, read_tag, bind_of = + match uname with + | None -> + let sv = value f scrut in + let sty = ll scrut.Tast.ty in + let payload_ty = match scrut.Tast.ty with + | Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t) + in + let tag = fresh f in + ins f "%s = extractvalue %s %s, 0" tag sty sv; + (tag, (fun c -> ("i8", if c = "Some" then 1 else 0)), + fun _case _i slot -> + let v = fresh f in + ins f "%s = extractvalue %s %s, 1" v sty sv; + ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot); + bind_slot f slot) + | Some n -> + let u = Hashtbl.find f.md.unions n in + (* Evaluated once, into a place, so that a scrutinee that is a call is + not re-run per arm. [addr] already spills a non-place for us. *) + let base = addr f scrut in + let tp = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 0" tp (sname n) base; + let tag = fresh f in + ins f "%s = load i32, ptr %s" tag tp; + (tag, + (fun c -> + match Tast.case_index u c with + | Some (i, _) -> ("i32", i) + | None -> failwith ("no case " ^ c ^ " of " ^ n)), + fun case i slot -> + let pp = payload_addr f n base in + let fp = fresh f in + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" + fp (sname (n ^ "." ^ case)) pp i; + let fty = + match Tast.case_index u case with + | Some (_, c) -> (List.nth c.Tast.vfields i).Tast.fty + | None -> failwith ("no case " ^ case ^ " of " ^ n) + in + let v = load f fp fty in + ins f "store %s %s, ptr %s" (ll fty) v f.slots.(slot); + bind_slot f slot) in let ld = fresh_label f "endmatch" in let result = if is_void ty then None else Some (alloca f ty) in @@ -1360,17 +1523,14 @@ and emit_match f ty scrut arms = (match a.Tast.acase with | None -> term f "br label %%%s" lb | Some c -> - let want = if c = "Some" then 1 else 0 in + let ity, want = read_tag c in let t = fresh f in - ins f "%s = icmp eq i8 %s, %d" t tag want; + ins f "%s = icmp eq %s %s, %d" t ity tag want; term f "br i1 %s, label %%%s, label %%%s" t lb ln); label f lb; - List.iter - (fun slot -> - let v = fresh f in - ins f "%s = extractvalue %s %s, 1" v sty sv; - ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot); - bind_slot f slot) + List.iteri + (fun i slot -> + bind_of (match a.Tast.acase with Some c -> c | None -> "") i slot) a.Tast.binds; let v = block f a.Tast.abody in (match result with @@ -1955,6 +2115,24 @@ let rec const m (e : Tast.expr) = | _ -> "{ " ^ String.concat ", " inner ^ " }") | Tast.Some_ v -> Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m v) + (* A union's payload is declared as a blob of integers, so a constant of one + would have to be the case's fields *serialised into those integers* — + which is a byte-level encoder this compiler does not have, and which could + not express a string field at all, since that is a pointer the linker has + to relocate and a byte array has nowhere to put a relocation. Refused by + name, here, where the rest of the same rule is. A zeroed global is fine + and needs none of this: it is the first declared case, all-bytes-zero. *) + | Tast.MakeCase (uname, case, _) -> + fail e.Tast.loc + "a global cannot be initialised with %s.%s — a union's payload is a \ + blob, and writing a case into one at link time needs a byte-level \ + encoder that does not exist (a string field could not be encoded at \ + all). Declare the global zeroed, which is %s.%s, and assign the case \ + you meant in a function" + uname case uname + (match Hashtbl.find_opt m.unions uname with + | Some { Tast.cases = c :: _; _ } -> c.Tast.vname + | _ -> "its first case") | _ -> fail e.Tast.loc "a global's value must be a compile-time constant — this one is computed" @@ -2158,13 +2336,16 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) (p : Tast.program) = let m = { out = Buffer.create 8192; strs = Buffer.create 512; - structs = Hashtbl.create 16; globals = Hashtbl.create 16; + structs = Hashtbl.create 16; unions = Hashtbl.create 16; + globals = Hashtbl.create 16; externs = Hashtbl.create 32; checks; dev; known; nstr = 0; nfi = 0; sanitize; dbg = (if debug then Some (new_dbg p) else None); } in List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) p.Tast.structs; + List.iter (fun (u : Tast.union) -> Hashtbl.replace m.unions u.Tast.uname u) + p.Tast.unions; List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty) p.Tast.globals; List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym) @@ -2176,6 +2357,37 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) (String.concat ", " (List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields)))) p.Tast.structs; + (* A union is a tag and a blob, and each of its cases is a struct laid over + the blob. Both are emitted as named types so that every reader — a + construction, a match arm, the structural printer — geps rather than + computing byte offsets of its own. + + The blob is [k x iA] where A is the alignment the widest member of any + case needs: that is what makes LLVM align the payload without an explicit + [align] on a type, and it is what makes the whole agree with C's + [struct { int tag; union { ... } u; }] byte for byte. That agreement is + the point — the macro expander's [Form] has to be the same bytes in the + compiler and in the dlopened macro. *) + List.iter + (fun (u : Tast.union) -> + List.iter + (fun (c : Tast.variant) -> + Buffer.add_string m.out + (Printf.sprintf "%s = type { %s }\n" + (sname (u.Tast.uname ^ "." ^ c.Tast.vname)) + (String.concat ", " + (List.map (fun (f : Tast.field) -> ll f.Tast.fty) + c.Tast.vfields)))) + u.Tast.cases) + p.Tast.unions; + List.iter + (fun (u : Tast.union) -> + let size, align = payload_lay m u in + Buffer.add_string m.out + (Printf.sprintf "%s = type { i32%s }\n" (sname u.Tast.uname) + (if size = 0 then "" + else Printf.sprintf ", [%d x i%d]" (size / align) (align * 8)))) + p.Tast.unions; Buffer.add_char m.out '\n'; (* The foreign declarations. Every struct that crosses this boundary was flattened by a C shim, so each of these is scalars only and no calling diff --git a/lib/reach.ml b/lib/reach.ml index 50a3709..6f08e90 100644 --- a/lib/reach.ml +++ b/lib/reach.ml @@ -56,7 +56,8 @@ let rec expr_refs f (e : Tast.expr) = | Tast.Field (t, _) -> go t | Tast.Addr p -> place_refs f p | Tast.Deref t -> go t - | Tast.Make (_, es) -> gos es + | Tast.Make (_, es) | Tast.MakeCase (_, _, es) -> gos es + | Tast.CaseField (t, _, _) -> go t | Tast.Arr es -> gos es | Tast.Some_ v -> go v | Tast.Match (sc, arms) -> diff --git a/lib/tast.ml b/lib/tast.ml index a81b448..7c05b67 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -93,6 +93,22 @@ and expr_kind = | Addr of place | Deref of expr | Make of string * expr list (* struct literal, every field, in order *) + (* A union value: the union's name, the case's name, and every field of that + case in declaration order with the omitted ones filled in as [Zero] — the + same ZII rule [Make] carries, and settled here for the same reason. It is + its own node rather than a [Make] over a synthesised struct because the + value's *type* is the union and its payload is a byte blob the case is + reinterpreted into; a backend that saw only [Make] would have to rederive + which of the two it was looking at. *) + | MakeCase of string * string * expr list + (* One field of one case of a union value, by index. The case name is on the + node because the payload is untyped bytes: [Field]'s index alone cannot + say which case struct the blob is being read as. [match] is the only thing + that proves the case, so this is only ever built under an arm that + checked the tag — and by [Render], which reads a field only after the same + comparison. One node, so the payload layout is known in exactly one place + in each backend rather than once per reader. *) + | CaseField of expr * string * int | Arr of expr list (* fixed-array literal *) | Some_ of expr | None_ @@ -249,6 +265,26 @@ type program = { cshim : (string * string) list; } +(* The declared position of a case, which is its tag, and the case itself. Tags + are declaration order from zero, so an all-bytes-zero union is the first + case with a zeroed payload — the same rule that makes an [Option]'s zero a + [None], and the reason case order is part of a union's contract. *) +let case_index (u : union) name = + let rec go i = function + | [] -> None + | (c : variant) :: rest -> + if String.equal c.vname name then Some (i, c) else go (i + 1) rest + in + go 0 u.cases + +let vfield_index (c : variant) name = + let rec go i = function + | [] -> None + | (f : field) :: rest -> + if String.equal f.fname name then Some i else go (i + 1) rest + in + go 0 c.vfields + let field_index (s : structure) name = let rec go i = function | [] -> None