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

Union values: a tag, a blob, and a case laid over it

Browse Source 
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.
This commit is contained in:
Joseph Ferano 2026-09-12 16:48:43 +07:00
parent 03e8a1fd1b
commit 675241e226
4 changed files with 541 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

315
lib/check.ml
View File

@ -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

246
lib/emit.ml
View File

@ -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

3
lib/reach.ml
View File

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

36
lib/tast.ml
View File

@ -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