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

305
lib/check.ml
View File

@ -44,6 +44,20 @@ type binding = {
type env = { type env = {
structs : (string, Tast.structure) Hashtbl.t; structs : (string, Tast.structure) Hashtbl.t;
unions : (string, Tast.union) 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; aliases : (string, Ast.texpr) Hashtbl.t;
consts : (string, int64) Hashtbl.t; (* compile-time array lengths *) consts : (string, int64) Hashtbl.t; (* compile-time array lengths *)
locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *) locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *)
@ -64,6 +78,7 @@ type env = {
let new_env () = { let new_env () = {
structs = Hashtbl.create 16; structs = Hashtbl.create 16;
unions = Hashtbl.create 16; unions = Hashtbl.create 16;
cases = Hashtbl.create 32;
aliases = Hashtbl.create 16; aliases = Hashtbl.create 16;
consts = Hashtbl.create 16; consts = Hashtbl.create 16;
locs = 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 fail loc "the type alias %s is defined in terms of itself" n
else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n)
| _ when Hashtbl.mem env.structs n -> Types.Named n | _ when Hashtbl.mem env.structs n -> Types.Named n
(* A union has no layout in emit — nothing there mentions unions at all — (* A union is [Named] exactly as a struct is: one case in [Types.t]
so a union-typed global reached clang as a reference to an undefined covers both, and which table the name is in is what tells them apart.
%"U". Constructing one and reading a field of one are already refused, Keeping them one case is what lets a union be a field, a parameter, a
so there is nothing to lower: only a declaration that got through. *) return type and a slot without a single one of those paths learning
| _ when Hashtbl.mem env.unions n -> that unions exist. *)
unimplemented loc (Printf.sprintf "the union type %s" n) 6 | _ when Hashtbl.mem env.unions n -> Types.Named n
| _ when Hashtbl.mem env.enums n -> Types.Enum n | _ when Hashtbl.mem env.enums n -> Types.Enum n
(* A typo in a primitive is lowercase too, and the type-variable rule (* A typo in a primitive is lowercase too, and the type-variable rule
below would otherwise report [f65] as unimplemented generics and send 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 -> | t when bytewise_key t ->
Tast.Rtfn "flan_hash_flat", Tast.Rtfn "flan_eq_flat" 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 | 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) -> | Types.Array (_, e) ->
(* A fixed array of a struct or of strings would need the same per-element (* 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. walk a struct key gets, driven by a loop rather than by a field list.
@ -1076,6 +1103,25 @@ and var ctx loc ~want name =
| None -> | None ->
match Hashtbl.find_opt ctx.env.globals name with match Hashtbl.find_opt ctx.env.globals name with
| Some (ty, _) -> expect loc ~want (mk loc ty (Tast.Global name)) | Some (ty, _) -> expect loc ~want (mk loc ty (Tast.Global name))
| None ->
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 -> | None ->
if Hashtbl.mem ctx.env.fns name then if Hashtbl.mem ctx.env.fns name then
unimplemented loc unimplemented loc
@ -1414,12 +1460,33 @@ and check_if ctx ?want loc c t e =
in in
mk loc ty (Tast.If (c, t, e)) 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 = and check_struct ctx ~want loc name kvs =
match Hashtbl.find_opt ctx.env.structs name with match Hashtbl.find_opt ctx.env.structs name with
| None ->
(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 -> | None ->
if Hashtbl.mem ctx.env.unions name then if Hashtbl.mem ctx.env.unions name then
unimplemented loc "constructing a union value" 6 fail loc
else fail loc "unknown struct %s" name "%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 -> | Some s ->
let seen = Hashtbl.create 8 in let seen = Hashtbl.create 8 in
List.iter List.iter
@ -1443,6 +1510,44 @@ and check_struct ctx ~want loc name kvs =
in in
expect loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) 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 = and check_arr ctx ~want loc items =
let elem_want = let elem_want =
match want with match want with
@ -1475,9 +1580,17 @@ and check_arr ctx ~want loc items =
and check_match ctx ?want loc scrutinee arms = and check_match ctx ?want loc scrutinee arms =
let s = check ctx scrutinee in 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 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 (* 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 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 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. \ of (= k :member), but a keyword has no case in the pattern type yet. \
Use cond" n Use cond" n
| other -> | other ->
(* Union matching arrives with unions themselves, at milestone 6. *) fail loc "match works on an Option or a union, not on %s"
fail loc "match works on an Option at milestone 2, not on %s"
(Types.to_string other) (Types.to_string other)
in 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 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, (* 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 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 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 = let arms =
map_lr map_lr
(fun (a : Ast.arm) -> (fun (a : Ast.arm) ->
let ctor, binds = let ctor, binds = resolve_pat a in
match a.Ast.pat with (match ctor with
| Ast.Pwild -> saw_wild := true; None, [] | None -> saw_wild := true
| Ast.Pctor ("Some", [ x ]) -> saw_some := true; Some "Some", [ x ] | Some c ->
| Ast.Pctor ("Some", _) -> if Hashtbl.mem seen c then
fail a.Ast.aloc "the Some pattern binds exactly one name" fail a.Ast.aloc "this match has two %s arms" c;
| Ast.Pctor ("None", []) -> saw_none := true; Some "None", [] Hashtbl.add seen c ());
| 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
ctx.dead <- before; ctx.dead <- before;
let arm = let arm =
branch ctx (fun () -> branch ctx (fun () ->
let binds = 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 in
let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in
if !want = None && body.Tast.ty <> Types.Never then if !want = None && body.Tast.ty <> Types.Never then
@ -1537,10 +1697,28 @@ and check_match ctx ?want loc scrutinee arms =
arms arms
in in
ctx.dead <- !joined; 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 fail loc
"this match is not exhaustive — Option needs both Some and None, or a \ "this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \
_ arm"; 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 let ty = match !want with Some t -> t | None -> Types.Never in
mk loc ty (Tast.Match (s, arms)) 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 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))) expect loc ~want (mk loc ret (Tast.Call (name, args)))
| None -> | None ->
if Hashtbl.mem ctx.env.structs name || Hashtbl.mem ctx.env.unions name if Hashtbl.mem ctx.env.unions name then
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 fail loc
"%s is a type — a struct value is written (%s {.field value ...})" "%s is a type — a struct value is written (%s {.field value ...})"
name name name name
@ -3248,11 +3436,56 @@ let collect env (decls : Ast.decl list) =
fields; fields;
Hashtbl.replace env.structs n { Tast.sname = n; fields } Hashtbl.replace env.structs n { Tast.sname = n; fields }
| Ast.Defunion (n, vs) -> | Ast.Defunion (n, vs) ->
Hashtbl.replace env.unions n (* A union with no cases has no value, so nothing could ever be given
{ Tast.uname = n; one, and a parameter of that type would be a function nothing can
cases = List.map (fun (v : Ast.variant) -> call. It parses; it is refused here rather than surviving to a
{ Tast.vname = v.Ast.vname; layout with a tag and no case for the tag to name. *)
vfields = List.map field v.Ast.vfields }) vs } 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 -> | Ast.Defn fn ->
let params = let params =
List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params

234
lib/emit.ml
View File

@ -195,6 +195,12 @@ type m = {
out : Buffer.t; out : Buffer.t;
strs : Buffer.t; (* string literal constants *) strs : Buffer.t; (* string literal constants *)
structs : (string, Tast.structure) Hashtbl.t; 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; globals : (string, Types.t) Hashtbl.t;
(* Flan name -> C symbol, for the foreign functions. A call to one names the (* Flan name -> C symbol, for the foreign functions. A call to one names the
symbol directly; there is no thunk. *) symbol directly; there is no thunk. *)
@ -265,6 +271,22 @@ let rec lay m (t : Types.t) : int * int =
lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields) lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields)
in in
s, a s, a
| 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)) | None -> failwith ("no layout for struct " ^ n))
| Types.Fn _ | Types.Var _ -> | Types.Fn _ | Types.Var _ ->
failwith ("no layout for " ^ Types.to_string t) failwith ("no layout for " ^ Types.to_string t)
@ -283,6 +305,27 @@ and lay_fields m tys =
tys; tys;
align_up !off !al, !al, List.rev !rev 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 (* A DWARF type node for a Flan type, memoised by the type's printed form so
the pool holds one node per distinct type. *) the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int = let rec dty m d (t : Types.t) : int =
@ -369,6 +412,22 @@ let rec dty m d (t : Types.t) : int =
composite sn composite sn
(List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty)) (List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty))
st.Tast.fields) st.Tast.fields)
| 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)) | None -> failwith ("no debug type for struct " ^ sn))
(* An opaque pointer under lldb, which is the truth: the allocator's (* 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 fields are the runtime's C and lldb already has that type from
@ -761,6 +820,10 @@ and value_at f (e : Tast.expr) : string =
ins f "store %s %s, ptr %s" (ll ty) v' ptr; ins f "store %s %s, ptr %s" (ll ty) v' ptr;
"zeroinitializer" "zeroinitializer"
| Tast.Make (_, fields) -> aggregate f e.Tast.ty fields | 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.Arr items -> aggregate f e.Tast.ty items
| Tast.Some_ v -> | Tast.Some_ v ->
let v' = value f v in 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. (* 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 The checker already filled the omitted fields in with Zero, so this is
simply every field in declaration order. *) 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 = and aggregate f ty parts =
let t = ll ty in let t = ll ty in
let acc = ref "zeroinitializer" in let acc = ref "zeroinitializer" in
@ -1343,13 +1458,61 @@ and emit_while f c body =
label f le label f le
and emit_match f ty scrut arms = and emit_match f ty scrut arms =
(* 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 sv = value f scrut in
let sty = ll scrut.Tast.ty 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 let payload_ty = match scrut.Tast.ty with
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t) | Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
in 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 ld = fresh_label f "endmatch" in
let result = if is_void ty then None else Some (alloca f ty) in let result = if is_void ty then None else Some (alloca f ty) in
let reached = ref false in let reached = ref false in
@ -1360,17 +1523,14 @@ and emit_match f ty scrut arms =
(match a.Tast.acase with (match a.Tast.acase with
| None -> term f "br label %%%s" lb | None -> term f "br label %%%s" lb
| Some c -> | Some c ->
let want = if c = "Some" then 1 else 0 in let ity, want = read_tag c in
let t = fresh f 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); term f "br i1 %s, label %%%s, label %%%s" t lb ln);
label f lb; label f lb;
List.iter List.iteri
(fun slot -> (fun i slot ->
let v = fresh f in bind_of (match a.Tast.acase with Some c -> c | None -> "") i slot)
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)
a.Tast.binds; a.Tast.binds;
let v = block f a.Tast.abody in let v = block f a.Tast.abody in
(match result with (match result with
@ -1955,6 +2115,24 @@ let rec const m (e : Tast.expr) =
| _ -> "{ " ^ String.concat ", " inner ^ " }") | _ -> "{ " ^ String.concat ", " inner ^ " }")
| Tast.Some_ v -> | Tast.Some_ v ->
Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m 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 fail e.Tast.loc
"a global's value must be a compile-time constant — this one is computed" "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) = (p : Tast.program) =
let m = { let m = {
out = Buffer.create 8192; strs = Buffer.create 512; 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; externs = Hashtbl.create 32;
checks; dev; known; nstr = 0; nfi = 0; sanitize; checks; dev; known; nstr = 0; nfi = 0; sanitize;
dbg = (if debug then Some (new_dbg p) else None); dbg = (if debug then Some (new_dbg p) else None);
} in } in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
p.Tast.structs; 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) List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
p.Tast.globals; p.Tast.globals;
List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym) 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 ", " (String.concat ", "
(List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields)))) (List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
p.Tast.structs; 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'; Buffer.add_char m.out '\n';
(* The foreign declarations. Every struct that crosses this boundary was (* 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 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.Field (t, _) -> go t
| Tast.Addr p -> place_refs f p | Tast.Addr p -> place_refs f p
| Tast.Deref t -> go t | 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.Arr es -> gos es
| Tast.Some_ v -> go v | Tast.Some_ v -> go v
| Tast.Match (sc, arms) -> | Tast.Match (sc, arms) ->

36
lib/tast.ml
View File

@ -93,6 +93,22 @@ and expr_kind =
| Addr of place | Addr of place
| Deref of expr | Deref of expr
| Make of string * expr list (* struct literal, every field, in order *) | 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 *) | Arr of expr list (* fixed-array literal *)
| Some_ of expr | Some_ of expr
| None_ | None_
@ -249,6 +265,26 @@ type program = {
cshim : (string * string) list; 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 field_index (s : structure) name =
let rec go i = function let rec go i = function
| [] -> None | [] -> None