From 6cc94e00d6f36ce40289c439e57edbf24a571665 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Thu, 17 Sep 2026 19:54:32 +0700 Subject: [PATCH] defunion is C's union, and reading the member you did not write is defined The name freed up by the rename now means what C means by it: the members overlay one storage, the size is the largest of them, the alignment the strictest, and nothing anywhere records which one was written. It serves two things that wanted it. Binding a C header means holding the union the library holds and reading whichever member the library's own tag says is live -- a tag Flan cannot see, because the rule relating them is prose in a manual. Overlaying an f32 on a u32 to look at its bits is the other, and it is the same read. So that read is defined rather than refused. This is the one place in the checker where bytes win over safety on purpose, and the alternative was not a safer language, it was no feature: type punning *is* reading the member that was not written. The promise is the one C's implementations make and C's standard does not -- the layout is the target's, the bytes are the bytes, a read is a reinterpretation of them -- and what is not promised is anything about bytes nobody wrote, where a member wider than the one last stored reads a tail that is indeterminate exactly as a struct's padding is. ZII narrows that to almost nothing: a union starts all-bytes-zero unless uninit says otherwise. uninit on one is allowed, unlike on a defdata. The refusal there was never about garbage; it is that a tag steers, and a tag no case names falls past every comparison in a match into a block LLVM may treat as unreachable. An untagged union steers nothing. Which is also why three things are refused, each for a reason that does not expire with a milestone. No move-only member: nothing knows which member is live, so nothing can tear one down, and unlike the struct and defdata refusals this is not waiting on recursive teardown -- there is no fact for teardown to read. No bool at any depth: an i1 loaded from a byte that is neither 0 nor 1 is a value the optimiser may assume cannot exist, and a union is the only type that can produce one. No defdata at any depth, for the reason uninit gives, arriving the other way round. An Option member is fine and the walk says why: its match is a tag test and a branch, not a chain with an unreachable tail. Two members in one literal, a match on a union, a union map key and a member written into a global initialiser are each refused by name. A union is a field list whose every offset is zero, so it travels as a Tast.structure and the checker, the emitter and the x86 backend each grow one table rather than one shape. A value is a zeroed temporary and a store -- Set over Pfield, which every backend already has -- so there is no new IR node and no layout rule spelled out a second time per backend. The LLVM type is the blob clang gives a union, the DWARF is DW_TAG_union_type with every member at zero, and the printer names the type and does not walk it: it cannot know which member is live, and one of them may be a pointer. cimport can now check what it could not. A C record holding a union member was not recorded at all, so the defstruct beside it went unchecked rather than checked wrongly; a named union member resolves to a defunion now and the whole record is compared field by field. The defunion itself is compared against the header's union as a set and not in order -- every member is at offset zero, so a permuted one is the same type and reporting it would be a finding that is not one -- while a member the header has and Flan lacks is reported, because that is what changes the size. A defunion against a C struct, or a defstruct against a C union, is reported in both directions. An anonymous union member is still skipped, and the comment now says that the gap is on the Flan side: there is nothing to declare. --- bin/main.ml | 21 ++- emacs/flan-mode.el | 10 +- lib/ast.ml | 8 +- lib/check.ml | 322 ++++++++++++++++++++++++++++++++++++-- lib/cimport.ml | 172 +++++++++++++++++--- lib/dev.ml | 1 + lib/emit.ml | 93 ++++++++++- lib/load.ml | 42 ++++- lib/parse.ml | 60 +++++-- lib/render.ml | 22 +++ lib/session.ml | 4 + lib/shim.ml | 17 +- lib/tast.ml | 5 + lib/x86.ml | 15 +- spec-memory.md | 42 +++++ test/headers/sample.h | 17 ++ test/programs/unions.flan | 89 +++++++++++ test/test_acceptance.ml | 117 +++++++++++++- test/test_flan.ml | 227 ++++++++++++++++++++++++++- web/index.html | 3 +- 20 files changed, 1215 insertions(+), 72 deletions(-) create mode 100644 test/programs/unions.flan diff --git a/bin/main.ml b/bin/main.ml index 8945a6e..52ac753 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -40,6 +40,8 @@ let summarise (d : Flan.Ast.decl) = | Defalias (n, _) -> Printf.sprintf "defalias %s" n | Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs) | Defdata (n, vs) -> Printf.sprintf "defdata %s (%d cases)" n (List.length vs) + | Defunion (n, ms) -> + Printf.sprintf "defunion %s (%d members)" n (List.length ms) | Defvar (n, _, _) -> Printf.sprintf "defvar %s" n | Defconst (n, _, _) -> Printf.sprintf "defconst %s" n | Declare (fn, csym) -> @@ -226,6 +228,14 @@ let () = | _ -> None) ds in + let unions = + List.filter_map + (fun (d : Flan.Ast.decl) -> + match d.Flan.Ast.d with + | Flan.Ast.Defunion (n, ms) -> Some (n, ms) + | _ -> None) + ds + in let known_enums = List.filter_map (fun (d : Flan.Ast.decl) -> @@ -251,7 +261,8 @@ let () = in let imported, dump, env = Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags - ~known_structs:(List.map fst structs) ~known_enums ~taken ~bound_syms + ~known_structs:(List.map fst structs) + ~known_unions:(List.map fst unions) ~known_enums ~taken ~bound_syms ~config: (match pkg with | f :: _ -> Flan.Load.binding_config (Filename.dirname f) @@ -275,6 +286,14 @@ let () = List.iter (fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why) bad); + (match Flan.Cimport.check_unions ~env ~unions dump with + | [] -> + if unions <> [] then + Printf.printf ";; every defunion agrees with the header\n" + | bad -> + List.iter + (fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why) + bad); (* And the bindings the package already wrote by hand, against the header's own signatures. Nothing else in the build can do this: a wrong declare-c is wrong in the generated prototype too, so the two diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index deb09dd..08d7e06 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -89,7 +89,8 @@ :prefix "flan-") (defconst flan--definers - '("defn" "defvar" "defconst" "defstruct" "defdata" "defenum" "defalias" + '("defn" "defvar" "defconst" "defstruct" "defdata" "defunion" "defenum" + "defalias" "declare" "import" "package") "Forms that introduce a top-level name.") @@ -132,7 +133,7 @@ below — and not again here.") ;; that ignored the column would offer one. (defvar flan-imenu-generic-expression `(("Functions" ,(concat "^(defn\\s-+" flan--name-re) 1) - ("Types" ,(concat "^(def\\(?:struct\\|data\\|enum\\|alias\\)\\s-+" + ("Types" ,(concat "^(def\\(?:struct\\|data\\|union\\|enum\\|alias\\)\\s-+" flan--name-re) 1) ("Variables" ,(concat "^(def\\(?:var\\|const\\)\\s-+" flan--name-re) 1) @@ -434,8 +435,9 @@ decision to `calculate-lisp-indent'." (flan--count-indent method indent-point last-sexp head-column)) ((eq method :defn) (+ lisp-body-indent head-column)) ;; No spec. Anything else spelled `def…' is a definition and indents - ;; like one, which covers `defstruct', `defdata', `defenum', `defvar', - ;; `defconst' and `defalias' without naming them. + ;; like one, which covers `defstruct', `defdata', `defunion', + ;; `defenum', `defvar', `defconst' and `defalias' without naming + ;; them. ((and name (string-match-p "\\`def" name)) (+ lisp-body-indent head-column)) ;; A clause: `(name [params] body…)'. `handler-bind', `handler-case' diff --git a/lib/ast.ml b/lib/ast.ml index 75473d1..e80f8ae 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -153,6 +153,12 @@ and decl_kind = | Defalias of string * texpr | Defstruct of string * field list | Defdata of string * variant list + (* C's union: the members overlay one another at offset zero, the size is + the largest of them and the alignment the strictest. It carries the same + [field list] a struct does, because that is what it is — the difference + is entirely in the layout, and saying it with a second field type would + only mean every walk had two shapes to handle for one idea. *) + | Defunion of string * field list | Defn of fn (* No body, so no [defn]: a foreign function, and the string is the C symbol it is actually called by (plan.org, Types — [declare] is kept only where @@ -183,7 +189,7 @@ and init = Zeroed | Uninit | Init of expr let declared_name (d : decl) = match d.d with | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _) - | Defvar (n, _, _) | Defconst (n, _, _) -> Some n + | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n | Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name | Package _ | Import _ -> None diff --git a/lib/check.ml b/lib/check.ml index 2df96bb..161566e 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -44,6 +44,13 @@ type binding = { type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; + (* The untagged unions, by name, and they are [Tast.structure] values on + purpose: a union's members *are* a field list, and every one of them is at + offset zero. Giving them a record of their own would have meant a second + shape for [field_index] and for every walk over a member list, to say + nothing new — which table the name is in is already what says whether the + offsets are cumulative or all zero, exactly as it is for a data type. *) + unions : (string, Tast.structure) Hashtbl.t; (* Every data type 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 @@ -125,6 +132,7 @@ type env = { let new_env () = { structs = Hashtbl.create 16; datas = Hashtbl.create 16; + unions = Hashtbl.create 16; cases = Hashtbl.create 32; aliases = Hashtbl.create 16; consts = Hashtbl.create 16; @@ -163,7 +171,10 @@ let declared_note env name = | None -> (match Hashtbl.find_opt env.datas name with | Some u -> List.map (fun (c : Tast.variant) -> c.Tast.vname) u.Tast.cases - | None -> []) + | None -> + match Hashtbl.find_opt env.unions name with + | Some u -> List.map (fun (f : Tast.field) -> f.Tast.fname) u.Tast.fields + | None -> []) in let what = if names = [] then name ^ " is declared here" @@ -659,6 +670,7 @@ and near_miss env n = @ Hashtbl.fold (fun k _ acc -> k :: acc) env.aliases [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.structs [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.datas [] + @ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.enums [] in List.find_opt (fun c -> c <> n && one_edit n c) candidates @@ -717,6 +729,10 @@ and resolve_name env ~seen loc n = return type and a slot without a single one of those paths learning that data types exist. *) | _ when Hashtbl.mem env.datas n -> Types.Named n + (* And so is an untagged union, for the same reason: it is a value of a + size and an alignment, and nothing that carries one has to know it is + a union rather than a struct. *) + | _ 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 @@ -1262,6 +1278,17 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = 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 + (* And an untagged union is refused for the half of that reason which has + nothing to do with a tag: a member smaller than the union leaves the rest + of the storage indeterminate, so two values that agree about every byte + anybody wrote hash differently. There is no per-member walk to write here + either — nothing records which member was written, which is the type. *) + | Types.Named n when Hashtbl.mem env.unions n -> + fail loc + "%s is a union, and a union is not a map key: a member narrower than \ + the union leaves the rest of the bytes indeterminate, so two values \ + that agree about everything written would still hash differently. Key \ + on the member 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. @@ -1558,7 +1585,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = expect loc ~want (mk loc Types.Unit (Tast.Set (p, v))) | Ast.Field (target, name) -> let target, sname = struct_target ctx target in - let s = Hashtbl.find ctx.env.structs sname in + let s = Option.get (fields_named ctx.env sname) in (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) @@ -2519,6 +2546,8 @@ and check_if ctx ?(tail = false) ?want loc c t e = 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 when Hashtbl.mem ctx.env.unions name -> + check_union ctx ~want loc name kvs | None -> (match Hashtbl.find_opt ctx.env.cases name with (* The full spelling [U.C], which is how a data type value is written. Checked @@ -2573,6 +2602,69 @@ and check_struct ctx ~want loc name kvs = in expect loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) +(* [(U {.member v})] — an untagged union value. + + At most one member, because the members are one storage: giving two would + be writing two values over each other and the result would be whichever the + compiler happened to store last. That is a real question with no answer, so + it is refused rather than ordered. Giving none is the ordinary ZII value and + is all-bytes-zero, the same as a struct with every field omitted. + + The one member is lowered here into a zeroed temporary and a store, rather + than into a node of its own. A union value *is* a store into overlaid + storage — [Set] over [Pfield] is exactly that operation and every backend + already has it — so a [MakeUnion] node would have been the same three + instructions written a fourth and fifth time, in each backend, with the + layout rule spelled out again in each. Nothing downstream learns anything + new from this form. *) +and check_union ctx ~want loc name kvs = + let u = Hashtbl.find ctx.env.unions name in + List.iter + (fun (k, (v : Ast.expr)) -> + if Tast.field_index u k = None then + Loc.failk "check/unknown-field" v.Ast.loc + ~notes:(declared_note ctx.env name) + "%s has no member %s" name k) + kvs; + let seen = Hashtbl.create 8 in + List.iter + (fun (k, (v : Ast.expr)) -> + (* Before the two-member refusal below, so [(U {.i 1 .i 2})] is told it + named one member twice rather than that [i] and [i] are the same + bytes — which is true and useless. Same words and same note as the + struct path, because it is the same mistake. *) + (match Hashtbl.find_opt seen k with + | Some (first : Ast.expr) -> + Loc.failk "check/duplicate-field" v.Ast.loc + ~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ] + "member %s is given twice" k + | None -> ()); + Hashtbl.add seen k v) + kvs; + (match kvs with + | (a, _) :: (b, (second : Ast.expr)) :: _ -> + Loc.failk "check/union-two-members" second.Ast.loc + "%s is a union, so %s and %s are the same bytes and only one of them \ + can be written — give the one this value is, and read the other \ + member when you want to see those bytes that way" + name a b + | _ -> ()); + match kvs with + (* The two-member case left above, so this sees one or none. *) + | _ :: _ :: _ -> assert false + | [] -> expect loc ~want (mk loc (Types.Named name) (Tast.Zero (Types.Named name))) + | [ (k, v) ] -> + let i = Option.get (Tast.field_index u k) in + let fty = (List.nth u.Tast.fields i).Tast.fty in + let v = check ctx ~want:fty v in + let slot = fresh_slot ctx (Types.Named name) in + let here = mk loc (Types.Named name) (Tast.Local slot) in + expect loc ~want + (mk loc (Types.Named name) + (Tast.Let + ([ (slot, mk loc (Types.Named name) (Tast.Zero (Types.Named name))) ], + [ mk loc Types.Unit (Tast.Set (Tast.Pfield (here, i), v)); here ]))) + (* The cases of a data type, as written, for a message that has to name them. *) and case_list env dname = match Hashtbl.find_opt env.datas dname with @@ -2673,6 +2765,18 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = "match over the enum %s is not implemented — the lowering is a chain \ of (= k :member), but a keyword has no case in the pattern type yet. \ Use cond" n + (* An untagged union has nothing for the arms to be alternatives over. + This is not a milestone and not a missing lowering: [match] reads a tag + and decides, and the absence of a tag is the whole definition of this + type. Said by name, because the two kinds of union are one keyword + apart in the source and someone will write it. *) + | Types.Named n when Hashtbl.mem ctx.env.unions n -> + fail loc + "%s is a union, and there is nothing in one to match on: its members \ + overlay the same bytes and nothing records which was written. Read \ + the member you mean with (.member u), or keep a tag of your own \ + beside it in a struct and match on that. A tagged alternative is \ + what defdata is" n | other -> fail loc "match works on an Option or a data type, not on %s" (Types.to_string other) @@ -2803,13 +2907,25 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = (* ── Places ────────────────────────────────────────────────────────── *) -(* The target of [.field] is a struct, or one level of pointer to one. The - auto-deref is inserted here as a real node, so no backend re-derives it. *) +(* The fields a name has, whether it is a struct or an untagged union. The two + are one record and differ only in what the offsets come out as, which is a + question for the layout and not for this — so [.x] is one path and not two, + and a union member is read with the accessor everything else is read with. + That is the whole of what makes punning ordinary code. *) +and fields_named env n : Tast.structure option = + match Hashtbl.find_opt env.structs n with + | Some s -> Some s + | None -> Hashtbl.find_opt env.unions n + +(* The target of [.field] is a struct or an untagged union, or one level of + pointer to one. The auto-deref is inserted here as a real node, so no + backend re-derives it. *) and struct_target ctx (target : Ast.expr) : Tast.expr * string = let t = check ctx target in + let has n = fields_named ctx.env n <> None in match t.Tast.ty with - | Types.Named n when Hashtbl.mem ctx.env.structs n -> t, n - | Types.Ptr (Types.Named n) when Hashtbl.mem ctx.env.structs n -> + | Types.Named n when has n -> t, n + | Types.Ptr (Types.Named n) when has n -> mk t.Tast.loc (Types.Named n) (Tast.Deref t), n (* A data type's fields belong to one case, and which case it is holding is only known after the tag has been read. [.field] would have to be a read @@ -2844,7 +2960,7 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = Loc.failk "check/unknown-name" loc "unknown name %s" name) | Ast.Pfield (target, name) -> let target, sname = struct_target ctx target in - let s = Hashtbl.find ctx.env.structs sname in + let s = Option.get (fields_named ctx.env sname) in (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) @@ -3193,6 +3309,7 @@ and type_named ctx n = || List.mem n Types.primitive_names || Hashtbl.mem ctx.env.structs n || Hashtbl.mem ctx.env.datas n + || Hashtbl.mem ctx.env.unions n || Hashtbl.mem ctx.env.enums n || Hashtbl.mem ctx.env.aliases n @@ -4760,6 +4877,7 @@ and named_call ctx ~want loc name args = { Render.structs = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs []; datas = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.datas []; + unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums []; emit = emitter; (* [println] never follows a pointer, and the allocation registry does @@ -5194,6 +5312,9 @@ let collect env (decls : Ast.decl list) = | Ast.Defdata (n, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.datas n { Tast.dname = n; cases = [] } + | Ast.Defunion (n, _) -> + Hashtbl.replace env.locs n d.Ast.dloc; + Hashtbl.replace env.unions n { Tast.sname = n; fields = [] } | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t | _ -> ()) decls; @@ -5363,6 +5484,98 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.cases (n ^ "." ^ c.Tast.vname) (n, c); Hashtbl.replace env.cases c.Tast.vname (n, c)) cases + (* ── The untagged union ────────────────────────────────────────── + C's semantics, deliberately and in full: the members overlay one + storage, the size is the largest of them, the alignment the + strictest, and nothing anywhere records which member was written + last. + + {2 What Flan says about reading a member that was not written} + + It reads the bytes that are there, through that member's type. Not + undefined behaviour, and not a refusal either — a *definition*, and + this is the one place in the checker that chooses bytes over safety + on purpose, so it is worth saying why. + + Refusing it was the alternative, and it would have made the feature + nothing: type punning *is* reading the member that was not written, + and both uses this type exists for are that read. Binding a C header + means holding the union the library holds and reading whichever + member the library's own tag says is live — a tag Flan cannot see, + because it is a field of the enclosing struct and the rule that + relates them is prose in a manual. Overlaying an f32 on a u32 to look + at its bits is the other use and is the same read. A checker that + refused it would be refusing the type. + + So the promise is the one C's implementations actually make and + C's standard does not: the layout is the target's, the bytes are the + bytes, and a read is a reinterpretation of them. What is *not* + promised is anything about bytes never written — a member larger + than the one last stored reads its own size, and the tail is + indeterminate exactly as a struct's padding is. That is the honest + line, and it is narrower than it sounds: the ZII rule means a union + starts all-bytes-zero unless [uninit] says otherwise, so the tail is + zero rather than garbage in every program that did not ask for + garbage. + + {2 uninit} + + Allowed, unlike on a data type. The refusal there is not about + garbage — [uninit] is garbage everywhere and says so — it is that a + data type's tag *steers*, and a tag no case names falls past every + comparison in a [match] into a block LLVM is entitled to treat as + unreachable. An untagged union steers nothing. Reading a member of + one is already a reinterpretation of whatever bytes are there, so + [uninit] makes those bytes arbitrary and changes nothing else, which + is exactly what it means on an [i64]. + + {2 Why bool is not a member} + + An [i1] loaded out of a byte that is neither 0 nor 1 is not a + [false], it is a value the optimiser is entitled to assume cannot + exist, and a union is the one type that can hand it one — write the + [u8] member 2, read the [bool] member. Nothing about that is visible + at the read, so it cannot be refused there. The alternative was to + load a union's bool as an [i8] and compare it against zero in both + backends, which is a correct answer and a real cost paid by every + bool in the language to make one type safe. Refused at the + declaration instead, where the message can name the replacement: + [u8], compared explicitly. The check below is recursive, because a + bool inside a struct member is the same byte. + + {2 Why no member may be move-only} + + Because nothing knows which member is live, so nothing can tear one + down. That is not a limitation of today's compiler, which is what + the struct and data type refusals above say about themselves; it is + a property of the type, and it does not go away when recursive + teardown lands. A [drop] of a union would have to free whichever + member is live and there is no such fact — freeing the wrong one is + a free of a pointer that was an f64 a moment ago. *) + | Ast.Defunion (n, ms) -> + if ms = [] then + fail loc + "%s declares no members, so it has no size and nothing could be \ + read out of it — a union is (defunion %s [member Type ...])" n n; + let names = List.map (fun (f : Ast.field) -> f.Ast.fname) ms in + if List.length (List.sort_uniq compare names) <> List.length names then + fail loc "%s declares the same member twice" n; + let fields = List.map field ms in + List.iter + (fun (f : Tast.field) -> + if Types.is_move_only f.Tast.fty then + fail loc + "%s's member %s is %s, which is move-only, and a union may \ + not own one: the members overlay one storage and nothing \ + records which was written, so nothing can free the right \ + one. Unlike a struct's, this is not waiting on recursive \ + teardown — there is no fact for teardown to read. Hold the \ + %s beside the union, or in a struct with a tag you check \ + yourself" + n f.Tast.fname (Types.to_string f.Tast.fty) + (Types.to_string f.Tast.fty)) + fields; + Hashtbl.replace env.unions n { Tast.sname = n; fields } | Ast.Defn fn -> (* A signature that introduces a type variable is a *pattern*, not a signature: it goes in [gsigs] and the function goes nowhere near @@ -5454,19 +5667,89 @@ let check_finite env = | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields | None -> match Hashtbl.find_opt env.datas name with - | None -> () | Some u -> List.iter (fun (c : Tast.variant) -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) u.Tast.cases + | None -> + (* A union whose member is itself is the same infinite type a struct's + is — the size is the largest member and the largest member is the + whole thing. Nothing about overlaying storage makes the recursion + finite, so it is on the same walk rather than left to hang the + layout calculator. *) + match Hashtbl.find_opt env.unions name with + | None -> () + | Some u -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields and ty seen = function | Types.Named n -> walk seen n | Types.Array (_, e) | Types.Option e -> ty seen e | _ -> () in Hashtbl.iter (fun n _ -> walk [] n) env.structs; - Hashtbl.iter (fun n _ -> walk [] n) env.datas + Hashtbl.iter (fun n _ -> walk [] n) env.datas; + Hashtbl.iter (fun n _ -> walk [] n) env.unions + +(* No [bool] and no data type anywhere inside a union, at any depth — see the [Defunion] arm in + [collect] for why an [i1] read out of a union is the one punning hazard + Flan refuses rather than defines. It runs here, after [collect], because it + has to look through a member's *struct* to reach the fields inside it and + the struct table is only complete once every declaration has been walked. A + union that contains itself is impossible by [check_finite] above, so the + recursion terminates without a seen set — except through a [Ptr], which + this does not follow: a bool behind a pointer is a bool in someone else's + storage and is loaded from an address, not reinterpreted out of a blob. *) +let check_union_members env = + let rec walk uname where (t : Types.t) = + match t with + | Types.Bool -> + fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown) + "%s is a bool, and a union may not hold one at any depth: writing a \ + member that overlays it leaves a byte that is neither 0 nor 1, and \ + an i1 with that byte in it is a value the optimiser is entitled to \ + assume cannot exist. Hold a u8 in the union and compare it yourself" + where + (* An [Option] is deliberately not on this list, and the difference is + worth stating because a reader will ask. Its [match] lowers to a test of + the tag byte and a branch, so a scribbled tag reads as a [Some] with a + garbage payload — a number nobody stored, which is exactly what this + language says a union read is. A data type's lowers to a chain of + comparisons with an [unreachable] after the last one. *) + | Types.Array (_, e) | Types.Option e -> walk uname where e + | Types.Named n when Hashtbl.mem env.datas n -> + fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown) + "%s is %s, a data type, and a union may not hold one at any depth: a \ + data type's tag steers every match over it, and overlaying another \ + member leaves that tag arbitrary — a tag no case names falls past \ + every comparison into a block the optimiser may treat as \ + unreachable. This is the same refusal uninit on a data type gets, \ + and it arrives here because a union is the other way to hand one \ + bytes nobody wrote. Hold the %s beside the union" + where n n + | Types.Named n -> + (match Hashtbl.find_opt env.structs n with + | Some st -> + List.iter + (fun (f : Tast.field) -> + walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty) + st.Tast.fields + | None -> + match Hashtbl.find_opt env.unions n with + | None -> () + | Some u -> + List.iter + (fun (f : Tast.field) -> + walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty) + u.Tast.fields) + | _ -> () + in + Hashtbl.iter + (fun n (u : Tast.structure) -> + List.iter + (fun (f : Tast.field) -> walk n (n ^ "'s member " ^ f.Tast.fname) f.Tast.fty) + u.Tast.fields) + env.unions (* ── Declarations: pass 2, check bodies ────────────────────────────── *) @@ -5682,7 +5965,24 @@ let check_global env (d : Ast.decl) : Tast.global option = | _ -> "its first case") | _ -> ()); { Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc } - | Ast.Init v -> check (ctx ()) ~want:ty v + | Ast.Init v -> + (* A union member written into a global would have to be encoded into + the blob at link time, which is the byte-level encoder the data + type case above does not have either — and a global's initialiser + is a constant, while a union value is a store. Refused here, where + the message can name the way through, rather than at the emitter as + "this one is computed", which is true and says nothing. A zeroed + union needs none of this and is the ordinary declaration. *) + (match ty with + | Types.Named un when Hashtbl.mem env.unions un -> + fail d.Ast.dloc + "the global %s is the union %s, and a union member cannot be \ + written into a global: the initialiser is a constant and \ + storing a member is a store. Declare it zeroed — (defvar %s \ + %s) — or uninit, and write the member in a function" + n un n un + | _ -> ()); + check (ctx ()) ~want:ty v in Some { Tast.gname = n; gty = ty; ginit; gconst = false; gfolded = false } | Ast.Defconst (n, _, v) -> @@ -5758,6 +6058,7 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env = resync point that needs no resynchronising. *) collect env decls; check_finite env; + check_union_members env; let s = Loc.sink ~on:keep_going in ignore (Loc.caught s (fun () -> check_main env)); (* Every generic body, checked once with its variables left abstract, and @@ -5818,6 +6119,7 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env = in ({ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas; + unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions; globals; externs; fns; cshim }, env) diff --git a/lib/cimport.ml b/lib/cimport.ml index 6b9bdf0..bc63572 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -142,8 +142,14 @@ type cfn = { cloc : Loc.t; (* the line of the header it is on *) } -(* One C struct, for checking a [defstruct] against. *) -type crecord = { rname : string; rfields : (string * string) list } +(* One C record, for checking a [defstruct] or a [defunion] against. [runion] + is which of the two it was declared as, and it is on the record rather than + inferred at the comparison because the two are checked by different rules: + a struct's members are ordered and a union's are not, and matching a + [defstruct] against a C union would report a field order that means + nothing. *) +type crecord = + { rname : string; rfields : (string * string) list; runion : bool } type dump = { fns : cfn list; @@ -292,8 +298,17 @@ let read_dump ~header (root : Cjson.t) : dump = (* A bitfield has no address and no Flan spelling; a record holding one is not one this can check, so it is not recorded and the [defstruct] beside it is left unchecked rather than checked - wrongly. Same for an unnamed field, which is an anonymous union or - struct. *) + wrongly. Same for an unnamed field, which is an *anonymous* union + or struct — it has no name for a Flan field to carry and no way to + reach its members, so there is still nothing to compare. + + What is no longer skipped is the case this used to be read as + covering all unions: a record with a *named* union member. That + field has a name and a type, [union Overlay], and now that Flan has + a union of its own the name resolves to a [defunion] and the whole + record is checked field by field like any other. The gap that + remains is the anonymous one, and it is a gap in the Flan side + rather than here — there is nothing to declare. *) let ok = List.for_all (fun f -> @@ -302,7 +317,11 @@ let read_dump ~header (root : Cjson.t) : dump = && Cjson.str "name" f <> None)) (Cjson.arr "inner" d) in - if ok then records := { rname = nm; rfields } :: !records + if ok then + records := + { rname = nm; rfields; + runion = Cjson.str "tagUsed" d = Some "union" } + :: !records (* An enumerator with no [= n] carries no [ConstantExpr] in the dump at all, so the value has to be counted the way C counts it: one more than the one before, starting at zero. That is not an edge case — @@ -352,6 +371,7 @@ let read_dump ~header (root : Cjson.t) : dump = it either finds a Flan name for a C type here or refuses the function. *) type env = { known_structs : string list; (* the package's defstruct names *) + known_unions : string list; (* and its defunion names *) known_enums : string list; (* its defenum names *) d : dump; } @@ -431,6 +451,10 @@ let width_varies = describes, an enum, or nothing this can hold. *) let rec named env (n : string) : Ast.texpr = if List.mem n env.known_structs then tname n + (* A [union Overlay] parameter or field renders as the package's [defunion + Overlay], on the same terms a struct does: the package says the layout + exists and [check_unions] below says whether it agrees. *) + else if List.mem n env.known_unions then tname n else if List.mem n env.known_enums then tname n else if List.mem n env.d.enums then (* A C enum is an int, which is what [Shim] lowers a Flan [defenum] to, so @@ -928,17 +952,26 @@ let ptr_agrees env ~(c : string) (t : Ast.texpr) = let agrees_c env ~(c : string) (want : Ast.texpr) (got : Ast.texpr) = agrees env want got || ptr_agrees env ~c got +(* The header's record of a given name and a given kind. [want_union] is part + of the lookup rather than checked afterwards because a name is only one + half of the question: a [defstruct Overlay] and a C [union Overlay] are not + the same layout with a spelling disagreement, they are two different + layouts, and running the struct comparison over the union's members would + report a field order where a union has none. A kind mismatch is reported by + the caller, which has the Flan declaration to name. *) +let record_named (d : dump) ~want_union n = + let ofkind r = r.runion = want_union in + match List.find_opt (fun r -> r.rname = n && ofkind r) d.records with + | Some r -> Some r + | None -> + (* [defstruct Texture2D] against a header whose record is [Texture] and + whose typedef says so. *) + (match List.assoc_opt n d.typedefs with + | Some u -> List.find_opt (fun r -> r.rname = bare u && ofkind r) d.records + | None -> None) + let check_structs ~env ~(structs : (string * Ast.field list) list) (d : dump) = - let record n = - match List.find_opt (fun r -> r.rname = n) d.records with - | Some r -> Some r - | None -> - (* [defstruct Texture2D] against a header whose record is [Texture] and - whose typedef says so. *) - (match List.assoc_opt n d.typedefs with - | Some u -> List.find_opt (fun r -> r.rname = bare u) d.records - | None -> None) - in + let record n = record_named d ~want_union:false n in (* Names and widths both. Order is what a permuted [defstruct] gets wrong and what docs/BUILT.md says only a test can catch; width is the other half of the same hazard and the one it calls out by name — [f64] where the library @@ -977,10 +1010,103 @@ let check_structs ~env ~(structs : (string * Ast.field list) list) (d : dump) = List.filter_map (fun (n, (fs : Ast.field list)) -> match record n with - | None -> None - | Some r -> Option.map (fun m -> (n, m)) (field_mismatch fs r)) + | Some r -> Option.map (fun m -> (n, m)) (field_mismatch fs r) + (* The mirror of the finding [check_unions] makes, and it has to be + here or the kind mismatch goes quiet in one of its two directions: + asking for a struct of this name finds nothing when the header's + record is a union, and "nothing" is how a package the header says + nothing about is reported. Two different layouts under one name is + not that. *) + | None -> + match record_named d ~want_union:true n with + | Some r -> + Some (n, + Printf.sprintf + "%s is a union in the header and a defstruct here — its \ + members are laid out over one another there and one after \ + another here" r.rname) + | None -> None) structs +(* The same claim for a [defunion], and it is deliberately a second function + rather than a flag on the one above. + + What a struct check is *for* is order: a permuted [Texture2D] reads as five + plausible numbers, and the offsets are what moved. A union has no order to + permute. Every member is at offset zero, so a [defunion] that lists its + members in a different order from the header is not merely acceptable, it + is the same type — reporting it would be a false finding, and a check that + cries wolf is how a real disagreement gets ignored. + + So: members by name, and the type of each. A member the header has and the + [defunion] does not is still a finding, and this is the one that matters + most, because it is the one that changes the *size*: a union missing its + widest member is narrower than C's, and a struct that holds one by value + then puts every field after it in the wrong place. The reverse — a member + Flan declares and C does not — is a finding too, for the same reason read + the other way, and because it is usually a typo in a name. + + A member whose C type this cannot render says nothing, exactly as a + struct's does: the check is a second opinion, and having no opinion is not + a disagreement. *) +let check_unions ~env ~(unions : (string * Ast.field list) list) (d : dump) = + let mismatch (ms : Ast.field list) (r : crecord) = + let cnames = List.map (fun (n, _) -> kebab n) r.rfields in + let fnames = List.map (fun (f : Ast.field) -> f.Ast.fname) ms in + let missing = List.filter (fun n -> not (List.mem n fnames)) cnames in + let extra = List.filter (fun n -> not (List.mem n cnames)) fnames in + if missing <> [] then + Some + (Printf.sprintf + "%s has the member%s %s and the defunion does not — a union is as \ + wide as its widest member, so a missing one makes the whole type \ + narrower than C's" + r.rname (if List.length missing = 1 then "" else "s") + (String.concat " " missing)) + else if extra <> [] then + Some + (Printf.sprintf + "the defunion has the member%s %s and %s does not" + (if List.length extra = 1 then "" else "s") + (String.concat " " extra) r.rname) + else + List.find_map + (fun (f : Ast.field) -> + match + List.find_opt (fun (cn, _) -> kebab cn = f.Ast.fname) r.rfields + with + | None -> None + | Some (_, ct) -> + match (try Some (value_ty env ct) with Refused _ -> None) with + | None -> None + | Some want -> + let a = ty_source want and b = ty_source f.Ast.fty in + if agrees env want f.Ast.fty then None + else + Some + (Printf.sprintf + "member %s is %s in the defunion and %s (%s) in %s" + f.Ast.fname b a ct r.rname)) + ms + in + List.filter_map + (fun (n, (ms : Ast.field list)) -> + match record_named d ~want_union:true n with + | Some r -> Option.map (fun m -> (n, m)) (mismatch ms r) + (* The header has the name, and it is a struct. Two different layouts + under one name is worth saying out loud — it is the same class of + finding a permuted struct is, and the fix is the other keyword. *) + | None -> + match record_named d ~want_union:false n with + | Some r -> + Some (n, + Printf.sprintf + "%s is a struct in the header and a defunion here — its \ + members are laid out one after another there and over one \ + another here" r.rname) + | None -> None) + unions + (* ── Checking the package's constants against the header's ─────────── *) (* The half of the claim that was missing, and the one with the worst failure @@ -1305,10 +1431,10 @@ let dump_of ~loc ~header ~flags = Hashtbl.replace dumps k d; d -let env_of ~known_structs ~known_enums d = { known_structs; known_enums; d } +let env_of ~known_structs ~known_unions ~known_enums d = + { known_structs; known_unions; known_enums; d } -let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms - ~config = +let header ~loc ~header:h ~flags ~known_structs ~known_unions ~known_enums ~taken ~bound_syms ~config = let k = (* Sorted, because neither the taken table nor the declaration order is a fact about the package — two loads of the same file that enumerate them @@ -1317,6 +1443,7 @@ let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms String.concat "\000" (header_key ~header:h ~flags :: "\001" :: sorted known_structs + @ ("\001" :: sorted known_unions) @ ("\001" :: sorted known_enums) @ ("\001" :: sorted (Hashtbl.fold (fun n () acc -> n :: acc) taken [])) @ ("\001" :: sorted bound_syms) @@ -1333,7 +1460,7 @@ let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms | Some r -> r | None -> let d = dump_of ~loc ~header:h ~flags in - let env = env_of ~known_structs ~known_enums d in + let env = env_of ~known_structs ~known_unions ~known_enums d in let r = (of_dump ~env ~taken ~bound_syms ~config d, d, env) in Hashtbl.replace imports k r; r @@ -1560,7 +1687,8 @@ let regenerate ~loc ~header:h ~flags ~(ds : Ast.decl list) ~config ~out = in let imported, dump, env = header ~loc ~header:h ~flags ~known_structs:(List.map fst structs) - ~known_enums:(List.map fst enums) ~taken ~bound_syms ~config + ~known_unions:[] ~known_enums:(List.map fst enums) ~taken ~bound_syms + ~config in let gstructs = check_structs ~env ~structs dump in let gsigs = diff_bound ~env ~bound dump in diff --git a/lib/dev.ml b/lib/dev.ml index a0f4d25..7a9adfc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1223,6 +1223,7 @@ let render_addr (s : Session.t) ~addr ~(ty : Types.t) let c = { Render.structs = s.Session.program.Tast.structs; datas = s.Session.program.Tast.datas; + unions = s.Session.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.Session.env.Check.enums []; emit = Session.dev_emitter; diff --git a/lib/emit.ml b/lib/emit.ml index a5aeaad..a1199a7 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -226,6 +226,10 @@ type m = { a data type is a type like any other everywhere except at its layout, its construction and its match. *) datas : (string, Tast.data) Hashtbl.t; + (* The untagged unions, by name. A third table for the same [Types.Named], + on the same principle as the second: the name says which, and the members + are a field list whose offsets are all zero. *) + unions : (string, Tast.structure) 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. *) @@ -268,8 +272,14 @@ type m = { Spelled once so the [define] sites and [finish] cannot disagree. *) let attrs m = if m.sanitize then " #0" else "" +(* The type of one member, of a struct or of a union alike — the index means + the same thing in both, and only the offset it lands at differs. *) let field_ty m sn i = - let s = Hashtbl.find m.structs sn in + let s = + match Hashtbl.find_opt m.structs sn with + | Some s -> s + | None -> Hashtbl.find m.unions sn + in (List.nth s.Tast.fields i).Tast.fty (* Size and alignment in bytes. *) @@ -315,7 +325,10 @@ let rec lay m (t : Types.t) : int * int = Types.Int (int_kind (align * 8))) ] in s, a - | None -> failwith ("no layout for struct " ^ n)) + | None -> + match Hashtbl.find_opt m.unions n with + | Some u -> union_lay m u + | None -> failwith ("no layout for struct " ^ n)) | Types.Var _ -> failwith ("no layout for " ^ Types.to_string t) (* Size, alignment, and the offset of every member. *) @@ -332,6 +345,24 @@ and lay_fields m tys = tys; align_up !off !al, !al, List.rev !rev +(* C's union rule, and it is the only thing about this type that is not a + struct's: room for the largest member, the alignment the strictest member + needs, and the size rounded up to that alignment so an array of the union + keeps every element aligned. Written through [lay] and [align_up] rather + than with arithmetic of its own, so it cannot drift from the payload + measurement below — which is the same rule over a data type's cases, and + was here first. *) +and union_lay m (u : Tast.structure) : int * int = + let align = ref 1 and size = ref 0 in + List.iter + (fun (fl : Tast.field) -> + let s, a = lay m fl.Tast.fty in + let a = if a < 1 then 1 else a in + if a > !align then align := a; + if s > !size then size := s) + u.Tast.fields; + align_up !size !align, !align + (* The size and alignment of a data type'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 data type of payload-less @@ -455,7 +486,37 @@ let rec dty m d (t : Types.t) : int = [ ("payload", Types.Array (Int64.of_int (size / align), Types.Int (int_kind (align * 8)))) ])) - | None -> failwith ("no debug type for struct " ^ sn)) + | None -> + (* DW_TAG_union_type, which is the one place a DWARF tag says + exactly what the Flan type is — every member at offset zero, + each with its own type. lldb's C support reads this and prints + every member of a union side by side, which is the only honest + thing to show: the debugger cannot know which one is live + either. *) + match Hashtbl.find_opt m.unions sn with + | Some u -> + let id = dalloc d in + Hashtbl.replace d.dtys key id; + let size, al = union_lay m u in + let ms = + List.map + (fun (fl : Tast.field) -> + let fs, fa = lay m fl.Tast.fty in + let base = dty m d fl.Tast.fty in + dnode d + (Printf.sprintf + "!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: 0)" + (dstr fl.Tast.fname) base (fs * 8) (fa * 8))) + u.Tast.fields + in + dput d id + (Printf.sprintf + "!DICompositeType(tag: DW_TAG_union_type, name: \"%s\", size: %d, align: %d, elements: !{%s})" + (dstr sn) (size * 8) (al * 8) + (String.concat ", " + (List.map (fun i -> Printf.sprintf "!%d" i) ms))); + id + | 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. *) @@ -1248,6 +1309,16 @@ and addr f (e : Tast.expr) : string = and field_addr f (target : Tast.expr) i = let base = addr f target in + (* A union's members all start where the union starts, so the address of one + is the address of the whole thing and there is no gep to do. The member's + own type is what the load or the store that follows uses, which is what + makes the read a reinterpretation of the bytes — with opaque pointers + that is the entire implementation of punning, and the [i32] and the [f32] + views of one storage differ in nothing but the instruction that reads + them. *) + match target.Tast.ty with + | Types.Named n when Hashtbl.mem f.md.unions n -> base + | _ -> (* An Option is { i8, T } and has no declared name to gep through, so its layout is spelled out instead. Nothing in the surface language reaches a field of one -- [match] and [some] are how an Option is opened -- but the @@ -2808,6 +2879,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) let m = { out = Buffer.create 8192; strs = Buffer.create 512; structs = Hashtbl.create 16; datas = Hashtbl.create 16; + unions = Hashtbl.create 16; globals = Hashtbl.create 16; externs = Hashtbl.create 32; checks; dev; known; nstr = 0; nfi = 0; sanitize; @@ -2817,6 +2889,8 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) p.Tast.structs; List.iter (fun (u : Tast.data) -> Hashtbl.replace m.datas u.Tast.dname u) p.Tast.datas; + List.iter (fun (u : Tast.structure) -> Hashtbl.replace m.unions u.Tast.sname 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) @@ -2828,6 +2902,19 @@ 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 its blob and nothing else: [k x iA], where A is the alignment + the strictest member needs and k*A is the size of the largest. LLVM has no + union type, and this is the shape clang gives one — the same shape the + data type payload below uses, for the same reason, which is that it makes + LLVM align the storage without an explicit [align] anywhere. Nothing geps + into it: a member is read through the union's own address. *) + List.iter + (fun (u : Tast.structure) -> + let size, align = union_lay m u in + Buffer.add_string m.out + (Printf.sprintf "%s = type { [%d x i%d] }\n" (sname u.Tast.sname) + (if align = 0 then 0 else size / align) (align * 8))) + p.Tast.unions; (* A data type 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 diff --git a/lib/load.ml b/lib/load.ml index c5382be..b2d01df 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -308,6 +308,14 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = rename_expr owned alias [] v) | Ast.Defstruct (n, fs) -> Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs) + (* An untagged union imports exactly as a struct does, and for the reason + the data type above does not: it is a field list and a layout, with no + case table for the use site to resolve names against. The FFI is the + use that asked for it — a package binding a C library holds the union + its header declares, and the file that imports the package has to be + able to name the type. *) + | Ast.Defunion (n, ms) -> + Ast.Defunion (qualify alias n, List.map (rename_field owned alias) ms) | Ast.Defvar (n, t, init) -> Ast.Defvar (qualify alias n, Option.map (rename_texpr owned alias) t, (match init with @@ -593,7 +601,7 @@ let decl_uses acc (d : Ast.decl) = match d.Ast.d with | Ast.Package _ | Ast.Import _ | Ast.Defenum _ -> () | Ast.Defalias (_, t) -> texpr_uses acc t - | Ast.Defstruct (_, fs) -> List.iter field fs + | Ast.Defstruct (_, fs) | Ast.Defunion (_, fs) -> List.iter field fs | Ast.Defdata (_, vs) -> List.iter (fun (v : Ast.variant) -> List.iter field v.Ast.vfields) vs | Ast.Defn f -> fn f @@ -923,6 +931,13 @@ let rec import ~seen ~open_ ~loc alias dir = | Ast.Defstruct (n, _) -> Some n | _ -> None) ds + and known_unions = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defunion (n, _) -> Some n + | _ -> None) + ds and enums = List.filter_map (fun (d : Ast.decl) -> @@ -953,7 +968,7 @@ let rec import ~seen ~open_ ~loc alias dir = in let config = binding_config dir in let r, dump, env = - Cimport.header ~loc ~header:h ~flags ~known_structs + Cimport.header ~loc ~header:h ~flags ~known_structs ~known_unions ~known_enums:(List.map fst enums) ~taken ~bound_syms ~config in (* The point of reading the header, and the reason it is not @@ -997,6 +1012,29 @@ let rec import ~seen ~open_ ~loc alias dir = "the defstruct %s disagrees with %s: %s" n h why) (Cimport.check_structs ~env ~structs:(List.map (fun (n, fs, _) -> (n, fs)) structs) dump); + (* And the same claim for the package's unions, which the header + read could not make at all until Flan had a union: a record + with a union member was skipped entirely, so the [defstruct] + beside it went unchecked as well. *) + let unions = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defunion (n, ms) -> Some (n, ms, d.Ast.dloc) + | _ -> None) + ds + in + List.iter + (fun (n, why) -> + let at = + List.find_map + (fun (m, _, l) -> if String.equal m n then Some l else None) + unions + in + fail (Option.value ~default:loc at) + "the defunion %s disagrees with %s: %s" n h why) + (Cimport.check_unions ~env + ~unions:(List.map (fun (n, ms, _) -> (n, ms)) unions) dump); (* And the hand-written bindings, against the header's own signatures. These are the lines the importer deliberately leaves alone, which is exactly why they are the ones nothing diff --git a/lib/parse.ml b/lib/parse.ml index fbf5edf..a511938 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -456,6 +456,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = output rather than a dependency. Building a declaration as a value is what a macro is for. *) | Sym ("defmacro" | "defn" | "defvar" | "defconst" | "defstruct" | "defdata" + | "defunion" | "defenum" | "defalias" | "import" as name) -> fail f "%s is a top-level declaration, not an expression. A quasiquoted one is \ @@ -855,21 +856,50 @@ let rec decl (f : Form.t) : Ast.decl = | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (sym n, List.map variant vs)) | _ -> fail f "defdata is (defdata Name [(Case [field Type ...]) ...])") - (* The tagged sum used to be spelled [defunion], and every file in the tree - said so until this rename. The old spelling is not an alias, and it is not - silently accepted either: the name is being reserved for a different type - — C's untagged union, where the members overlay one another and nothing - says which is live — so a [defunion] left behind by a stale file must not - keep meaning what it used to. Accepting it as an alias is the one option - that cannot be taken: the day the untagged form lands, the same text would - go on compiling and would mean the opposite thing, which is the silent - misparse the [defn] case below was rewritten to make impossible. *) - | List ({ v = Sym "defunion"; _ } :: _) -> - Loc.failk "parse/defunion-renamed" f.loc - "defunion is now defdata — (defdata Name [(Case [field Type ...]) ...]). \ - The name defunion is reserved for a different type, so this is renamed \ - rather than aliased: a file that kept the old spelling would otherwise \ - go on compiling and mean something else" + (* C's union: one storage, as many ways of reading it as there are members. + It carries a field list and not a case list, which is the whole surface + difference from [defdata] — there is no tag, so there is nothing to name + a case with. + + The tagged sum was spelled [defunion] until this form wanted the name, and + a file written before the rename is the hazard this arm exists for. It is + not an alias and it is not a near-miss: the old text would *parse* under + the new meaning. [(defunion U [A B])] is two bare symbols, which is + exactly the shape of one member [A] of type [B], and it would have gone on + compiling as an untagged union of one member — the silent misparse the + [defn] case above was rewritten to make impossible, with no diagnostic + anywhere and nothing in the source that looks wrong. + + So the name slots are read before anything is built. A member name is + lowercase and a case name is capitalised, and a case *with* fields is a + list where a member name would be; either one means the text in hand is a + tagged sum wearing the old spelling, and it is refused by name. A file + that really did mean an untagged union whose first member is capitalised + is refused too, and it is the right trade: that is not a thing anyone has + written, and being told to rename a member is nothing beside being given + the wrong type in silence. *) + | List ({ v = Sym "defunion"; _ } :: args) -> + (match args with + | [ n; { v = Vec ms; _ } ] -> + List.iteri + (fun i (m : Form.t) -> + let looks_tagged = + i mod 2 = 0 + && (match m.v with + | List _ -> true + | Sym s -> s <> "" && s.[0] = Char.uppercase_ascii s.[0] + | _ -> false) + in + if looks_tagged then + Loc.failk "parse/defunion-renamed" f.loc + "the tagged sum is defdata now — (defdata Name [(Case [field \ + Type ...]) ...]) — and defunion is C's untagged union, whose \ + members overlay one storage: (defunion Name [member Type \ + ...]). This reads as the tagged one, so it is refused rather \ + than quietly given the other meaning") + ms; + mk (Ast.Defunion (sym n, fields f ms)) + | _ -> fail f "defunion is (defunion Name [member Type ...])") (* The slot after the parameters is unconditionally the return type. It used to be optional, and the parser decided return-type-versus-body by looking diff --git a/lib/render.ml b/lib/render.ml index 04a2c05..384231e 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -62,6 +62,9 @@ type ctx = { which list the name is in is what says which this is — the same arrangement the checker and the emitter use. *) datas : Tast.data list; + (* The untagged unions, which this prints by name and does not walk. See the + arm below for why. *) + unions : Tast.structure list; enums : (string * (string * int64) list) list; emit : emitter; (* [None] in a build with no registry to ask, which is every release build @@ -279,6 +282,25 @@ let rec render c depth (e : Tast.expr) : Tast.expr list = in [ List.fold_left (fun acc x -> x acc) base (List.rev (List.mapi one u.Tast.cases)) ] + (* A union, named and not walked, and this is the one value in the language + the printer refuses to show the contents of. + + Not squeamishness about indeterminate bytes — a printer that showed a + number nobody stored would be fine, and every member of a union is a + legal read by this language's own rule. It is that one of those members + may be a [string] or a [Ptr], and rendering it would dereference + whatever bytes happen to be in the union's storage. A tagged data type + is safe to print because its tag says which case is live; there is no + such fact here, so the printer would be following a pointer it invented. + Showing four members of which three are made up is also not obviously + better than showing none. + + So: the type, and nothing else. What the value means is the caller's + knowledge, and [(.member u)] prints whichever member that is. *) + | Types.Named n + when List.exists (fun (u : Tast.structure) -> String.equal u.Tast.sname n) + c.unions -> + [ lit ("<" ^ n ^ " union>") ] | Types.Named n -> (match List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) diff --git a/lib/session.ml b/lib/session.ml index 89d20bc..0a3e4cb 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -749,6 +749,7 @@ let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound let c = { Render.structs = t.program.Tast.structs; datas = t.program.Tast.datas; + unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; emit = dev_emitter; ptrs = Some dev_pointers; @@ -1046,6 +1047,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path let c = { Render.structs = t.program.Tast.structs; datas = t.program.Tast.datas; + unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; emit = dev_emitter; ptrs = Some dev_pointers; @@ -1138,6 +1140,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) let c = { Render.structs = t.program.Tast.structs; datas = t.program.Tast.datas; + unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; emit = dev_emitter; ptrs = Some dev_pointers; @@ -1245,6 +1248,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = let c = { Render.structs = t.program.Tast.structs; datas = t.program.Tast.datas; + unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; emit = dev_emitter; ptrs = Some dev_pointers; diff --git a/lib/shim.ml b/lib/shim.ml index ff5ea89..c3958cf 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -122,13 +122,15 @@ type env = { structs : (string, Ast.field list) Hashtbl.t; enums : (string, unit) Hashtbl.t; datas : (string, unit) Hashtbl.t; + unions : (string, unit) Hashtbl.t; aliases : (string, Ast.texpr) Hashtbl.t; } let scan (decls : Ast.decl list) = let env = { structs = Hashtbl.create 32; enums = Hashtbl.create 32; - datas = Hashtbl.create 8; aliases = Hashtbl.create 16 } + datas = Hashtbl.create 8; unions = Hashtbl.create 8; + aliases = Hashtbl.create 16 } in List.iter (fun (d : Ast.decl) -> @@ -136,6 +138,7 @@ let scan (decls : Ast.decl list) = | Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs | Ast.Defenum (n, _) -> Hashtbl.replace env.enums n () | Ast.Defdata (n, _) -> Hashtbl.replace env.datas n () + | Ast.Defunion (n, _) -> Hashtbl.replace env.unions n () | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t | _ -> ()) decls; @@ -195,6 +198,18 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = "%s is %s, a data type, and a Flan data type has no C layout — the shim \ cannot be generated for it" what n + (* A union is the one refusal here that is not about the type. It has a + C layout — it *is* a C layout, which is the whole reason it exists — + and what is missing is the generator: [typedefs] writes structs, and + a union would need its own spelling and its own closure over the + member types. Refused by name rather than written untested, and the + way through is the way every other aggregate crosses. *) + else if Hashtbl.mem env.unions n then + fail loc + "%s is %s, a union, and the shim generator writes structs only — a \ + union has a C layout but nothing here emits the declaration for \ + it yet. Pass (Ptr %s) and let the C side read it" + what n n else if String.equal n "string" then fail loc "%s is a string, and a string only crosses as a parameter — a C \ diff --git a/lib/tast.ml b/lib/tast.ml index bba09df..5335f16 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -302,6 +302,11 @@ type extern = { type program = { structs : structure list; datas : data list; + (* The untagged unions, carried as [structure] values: a union's members are + a field list whose every offset is zero, so the record a struct uses says + all of it. Which list a name came out of is what a backend reads to know + whether to accumulate the offsets or not. *) + unions : structure list; globals : global list; (* in declaration order *) externs : extern list; fns : fn list; diff --git a/lib/x86.ml b/lib/x86.ml index e69b6b3..a06c10c 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -434,11 +434,14 @@ let xorps b ~dst = rex b ~w:false ~r:dst ~x:0 ~m:dst; u8 b 0x0f; u8 b 0x57; modr record has no signature hiding it and every field it needs is inert. *) let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m = let structs = Hashtbl.create 16 and datas = Hashtbl.create 16 in + let unions = Hashtbl.create 16 in List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s) p.Tast.structs; List.iter (fun (u : Tast.data) -> Hashtbl.replace datas u.Tast.dname u) p.Tast.datas; - { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; + List.iter (fun (u : Tast.structure) -> Hashtbl.replace unions u.Tast.sname u) + p.Tast.unions; + { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions; globals = Hashtbl.create 1; externs = Hashtbl.create 1; checks; dev; known = (fun _ -> true); dbg = None; sanitize = false; nstr = 0; nfi = 0 } @@ -1094,7 +1097,15 @@ let field_offsets f (sn : string) = without unwrapping the value. *) (match Hashtbl.find_opt f.md.Emit.datas sn with | Some (u : Tast.data) -> [ 0; data_payload_off f u ] - | None -> unsupported "no struct %s" sn) + | None -> + (* And a union is a struct at this level too, with the one difference + that makes it a union: every member starts where the union starts, + so the offsets are zeros and the member's own type is what the load + or the store reads the bytes as. One list per member and not a + single zero, because the caller indexes it by member. *) + match Hashtbl.find_opt f.md.Emit.unions sn with + | Some (u : Tast.structure) -> List.map (fun _ -> 0) u.Tast.fields + | None -> unsupported "no struct %s" sn) (* A data type is { i32 tag, [k x iA] payload }, the same two fields [Emit.lay] measures it as — so the payload's offset is whatever [lay_fields] puts the diff --git a/spec-memory.md b/spec-memory.md index 5eb17f6..90f45ed 100644 --- a/spec-memory.md +++ b/spec-memory.md @@ -447,6 +447,48 @@ type**, so that every site computing `align-of T` gets the raised number with no further plumbing. The surface syntax for that declaration is deliberately not fixed here; nothing is built that needs it yet. +### Untagged unions and what a read of one means + +`defunion` is C's union: the members overlay one storage, the size is the +largest of them, the alignment the strictest, and **nothing records which +member was written**. It is not `defdata`, which is the tagged sum — a case, its +fields, and a tag that steers every `match`. + +**Reading a member that was not the one last written is defined**, and it is +the one place in this language where bytes win over safety on purpose. It reads +the storage through that member's type: the layout is the target's, the bytes +are the bytes, and the read is a reinterpretation of them. C leaves this to the +implementation; Flan does not, because both uses the type exists for *are* that +read. Binding a C header means holding the union the library holds and reading +whichever member the library's own tag says is live — a tag the compiler cannot +see, since the rule relating them is prose in a manual. Overlaying an `f32` on a +`u32` to look at its bits is the same read. A rule that refused it would be +refusing the type. + +What is **not** promised is anything about bytes nobody wrote. A member wider +than the one last stored reads its own size, and the tail is indeterminate +exactly as a struct's padding is. ZII narrows that to almost nothing in +practice: a union is all-bytes-zero unless `uninit` says otherwise. + +Three things a union may not do, and each for a reason that does not expire: + +- **No move-only member.** Nothing knows which member is live, so nothing can + tear one down. Unlike the struct and `defdata` refusals, this is not waiting + on recursive teardown — there is no fact for teardown to read, and freeing + the wrong member is a free of a pointer that was an `f64` a moment ago. +- **No `bool` member, at any depth.** An `i1` loaded out of a byte that is + neither 0 nor 1 is a value the optimiser is entitled to assume cannot exist, + and a union is the only type that can produce one. Hold a `u8` and compare it. +- **Not a map key.** A member narrower than the union leaves the rest of the + bytes indeterminate, so two values agreeing about everything written would + still hash apart. + +`uninit` on a union **is** allowed, unlike on a `defdata`. The refusal there is +not about garbage: it is that a tag no case names falls past every comparison in +a `match` into a block the optimiser may treat as unreachable. An untagged union +steers nothing, so `uninit` makes its bytes arbitrary and changes nothing else — +which is what it means on an `i64`. + ### Allocation failure **No allocating operation returns an error, and none can fail silently.** When diff --git a/test/headers/sample.h b/test/headers/sample.h index e578c86..f1f77c7 100644 --- a/test/headers/sample.h +++ b/test/headers/sample.h @@ -81,3 +81,20 @@ Undescribed make_undescribed(void); /* no defstruct for it */ * arriving at the checker as a duplicate declaration nobody wrote. */ int Spin2D(int n); int spin2d(int n); + +/* A union, and the two records that go with it. + * + * `Slot' is the shape the FFI actually meets: a C library keeps the tag + * beside the union and states the rule relating them in prose, so the Flan + * side holds both and reads the member the tag names. It is here because the + * importer used to record *no* record containing a union member at all -- + * which meant the defstruct beside it went unchecked as well -- and now a + * named one is checked member by member like anything else. + * + * `Anon' is the case that is still skipped, and the reason is not a + * limitation of the check: an anonymous union member has no name for a Flan + * field to carry and no way to reach its members, so there is nothing on the + * Flan side to compare against. */ +typedef union Overlay { int i; float f; } Overlay; +typedef struct Slot { int kind; Overlay v; } Slot; +typedef struct Anon { int kind; union { int i; float f; }; } Anon; diff --git a/test/programs/unions.flan b/test/programs/unions.flan new file mode 100644 index 0000000..1c49454 --- /dev/null +++ b/test/programs/unions.flan @@ -0,0 +1,89 @@ +;; The untagged union: one storage, several ways of reading it. +;; +;; Every line here is a fact about *bytes*, which is the whole reason the +;; program exists rather than a checker row. A union's layout is the only +;; thing about it that can be wrong silently: reading the member that was not +;; written is defined behaviour in Flan, so nothing at run time would notice a +;; member placed at the wrong offset or a type sized to the wrong member -- +;; the numbers would simply be different ones. So the numbers are written +;; down, and both backends have to produce them. +;; +;; 0x3F800000 is 1.0f and 0x4000000000000000 is 2.0. They are here as decimal +;; literals because that is what a reader who doubts the output has to be able +;; to check by hand against IEEE 754, and a hex literal would only move the +;; question. + +(defstruct P [x f32 y f32]) + +(defunion Bits [i i32 f f32 bs [4 u8]]) +(defunion Wide [n i64 d f64 p P bs [8 u8]]) + +;; A union inside a struct, which is the FFI shape: the C library keeps the +;; tag beside the union and the rule relating them is prose in its manual, so +;; `kind' here is an ordinary field this program reads itself. +(defstruct Slot [kind i32 v Bits]) + +;; Zeroed and uninit, side by side. A data type refuses uninit because its tag +;; steers a match; this one has no tag to steer anything, so both are legal +;; and the zeroed one is all-bytes-zero. +(defvar zeroed Bits) +(defvar scratch Bits uninit) + +(defn as-float [b Bits] f32 (.f b)) + +(defn of-float [x f32] Bits (Bits {.f x})) + +(defn main [] i32 + ;; Punning, both directions, through the same storage. + (let [b (Bits {.i 1065353216})] + (println (.f b)) + (println (.i b)) + ;; The bytes little-endian: 0x3F800000 is 00 00 80 3F. + (println (at (.bs b) 0)) + (println (at (.bs b) 3)) + ;; A member written through a place, which is the other half of the same + ;; claim -- the read above could have been folded from the literal, and a + ;; store into the union could not. + (set (.f b) 2.0) + (println (.i b))) + + ;; The union crosses a call boundary in both directions by value. + (println (as-float (of-float 0.5))) + + ;; A wider union: the size is the widest member and not the first one. An + ;; array of two is where that shows up -- writing element 1 would land + ;; inside element 0 if the type were sized to its i64 member alone and the + ;; f64 or the [8 u8] were wider, and every element's value would change + ;; under the other's write. + (let [w (Wide {.d 2.0})] + (println (.n w)) + (println (.x (.p w)))) + + (let [ws (array 2 Wide)] + (set (.n (at ws 0)) 11) + (set (.n (at ws 1)) 22) + (println (.n (at ws 0))) + (println (.n (at ws 1)))) + + ;; ZII: a union with no member given is all-bytes-zero, and so is a global + ;; declared with no value. + (let [empty (Bits {})] + (println (.i empty))) + (println (.i zeroed)) + ;; And a global is written and read like any other place. + (set (.i scratch) 7) + (println (.i scratch)) + + ;; A union inside a struct, with the tag the program keeps itself. + (let [s (Slot {.kind 1 .v (Bits {.f 1.5})})] + (println (.kind s)) + (println (.f (.v s))) + (set (.kind s) 2) + (set (.i (.v s)) 9) + (println (.kind s)) + (println (.i (.v s)))) + + ;; Printed by name and not walked: the printer cannot know which member is + ;; live, and a member may be a pointer. + (println zeroed) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index beb50ba..cd05671 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2466,6 +2466,26 @@ ERR@7 unexpected token: not the kind the caller was reading outputs "data types" "programs/datas.flan" datas_out; outputs ~opt:"-O0" "data types, -O0" "programs/datas.flan" datas_out; outputs ~dev:true "data types, dev" "programs/datas.flan" datas_out; + (* ── The untagged union ───────────────────────────────────────── + Reading a member that was not written is defined here rather than + refused, which means nothing at run time would notice a member at the + wrong offset or a type sized to the wrong member: the numbers would + just be different numbers. So the numbers are written down. The layout + itself is checked against the backend that computes it, through the + DWARF/LLVM oracle further down; this is what the bytes *do*. + + -O0 for the reason the data type above gets it, and more so: a union + value is a zeroed alloca and a store, and mem2reg is exactly what would + turn a store to the wrong half of one into a register nobody reads. + The x86-64 backend runs the same file under the @x86 alias, which + compares both backends on every program in this directory. *) + let unions_out = + "1\n1065353216\n0\n63\n1073741824\n0.5\n4611686018427387904\n0\n\ + 11\n22\n0\n0\n7\n1\n1.5\n2\n9\n\n" + in + outputs "unions" "programs/unions.flan" unions_out; + outputs ~opt:"-O0" "unions, -O0" "programs/unions.flan" unions_out; + outputs ~dev:true "unions, dev" "programs/unions.flan" unions_out; (* The refusals, each by name. The first is the diagnostics bug NEXT.md listed and this lane fixed: a case name written as if it were a struct @@ -2695,7 +2715,7 @@ ERR@7 unexpected token: not the kind the caller was reading in (* Every (member name, byte offset) of a named struct, in declaration order, as the emitted DWARF states it. *) - let dwarf_members ir sname = + let dwarf_members ?(tag = "DW_TAG_structure_type") ir sname = let ls = lines_of ir in let node id = List.find_opt @@ -2704,7 +2724,7 @@ ERR@7 unexpected token: not the kind the caller was reading let composite = List.find_opt (fun l -> - index_of l "!DICompositeType(tag: DW_TAG_structure_type" >= 0 + index_of l (Printf.sprintf "!DICompositeType(tag: %s" tag) >= 0 && attr l "name" = Some (Printf.sprintf "\"%s\"" sname)) ls in @@ -2899,6 +2919,97 @@ ERR@7 unexpected token: not the kind the caller was reading (defn main [] i32 (let [n (N.A {.x 3})] (match n (A x) x _ 1)))\n") "N" [ "tag"; "payload" ]; + (* An untagged union, which the case above cannot serve: its DWARF tag is + DW_TAG_union_type and its members are not a struct's, so there is no + [getelementptr] per member to compare against. What there is to check + is exactly C's three rules, and each is asked of the backend rather + than of a table beside the code: + + - every member is at offset zero, which is the DWARF's claim; + - the size is the widest member, rounded up to the alignment, which is + [ptrtoint (getelementptr (%U, ptr null, i32 1))]; + - the alignment is the strictest member's, which is where the type + lands after a single byte. + + The type here is chosen so that no two of those numbers agree by + accident: [f64] is the widest and strictest at 8, [i32] is narrower, + and [[5 u8]] is five bytes at alignment one — so the size is 8 only if + it is the max *rounded up*, and a union sized to its first member, or + to the last, or aligned to the array, comes out at a different number + and this says so. *) + let union_layout_case name src uname members = + let ir = debug_ir src in + match dwarf_members ~tag:"DW_TAG_union_type" ir uname with + | None -> + incr failures; + Printf.printf "FAIL %s\n no DWARF union type for %s\n" name uname + | Some (got, size) -> + if List.map fst got <> members then begin + incr failures; + Printf.printf "FAIL %s\n DWARF members: %s\n wanted: %s\n" + name (String.concat " " (List.map fst got)) + (String.concat " " members) + end; + List.iter + (fun (mname, off) -> + if off <> 0 then begin + incr failures; + Printf.printf + "FAIL %s\n %s.%s is at byte %d, and a union member is \ + at zero\n" name uname mname off + end) + got; + (match llvm_members ir uname 0 with + | None -> + Printf.printf "acceptance: %s — llc unavailable, size unchecked\n" name + | Some oracle -> + (match List.assoc_opt "sz" oracle with + | Some want when want <> size -> + incr failures; + Printf.printf + "FAIL %s\n %s is %d bytes in the DWARF, %d in LLVM\n" + name uname size want + | _ -> ())); + (match llvm_align ir uname with + | None -> () + | Some al -> + (* The DWARF states the alignment too, and it has to be the one + LLVM lays the type out at -- a debugger reading 8 where the + storage is aligned to 4 would step through an array of them + wrongly. *) + let dwarf_align = + List.find_map + (fun l -> + if index_of l "!DICompositeType(tag: DW_TAG_union_type" >= 0 + && attr l "name" = Some (Printf.sprintf "\"%s\"" uname) + then + Option.map (fun a -> int_of_string (String.trim a) / 8) + (attr l "align") + else None) + (lines_of ir) + in + (match dwarf_align with + | Some d when d <> al -> + incr failures; + Printf.printf + "FAIL %s\n %s is aligned to %d in the DWARF, %d in LLVM\n" + name uname d al + | _ -> ())) + in + union_layout_case "DWARF and LLVM agree on a union's layout" + ("(defunion U [n i32 d f64 bs [5 u8]])\n\ + (defn main [] i32 (let [u (U {.n 3})] (.n u)))\n") + "U" [ "n"; "d"; "bs" ]; + (* And one whose widest member is not its strictest, so the round-up is + doing something: [11 u8] is eleven bytes at alignment one and [i32] + wants four, which is 12 and not 11. A union sized to the widest member + alone is 11, and an array of them would misalign every element after + the first. *) + union_layout_case "DWARF and LLVM agree on a union that rounds up" + ("(defunion R [bs [11 u8] n i32])\n\ + (defn main [] i32 (let [r (R {.n 3})] (.n r)))\n") + "R" [ "bs"; "n" ]; + (* -- Form: the one layout two programs have to agree on -------- Every layout above is checked because a debugger reads it. This one is checked because the *compiler* reads it. A macro is compiled into a .so @@ -3254,7 +3365,7 @@ ERR@7 unexpected token: not the kind the caller was reading (match Build.executable ~opts:{ Build.default with debug = true; target = Some "wasm32-wasi" } - { Tast.structs = []; datas = []; globals = []; externs = []; fns = []; + { Tast.structs = []; datas = []; unions = []; globals = []; externs = []; fns = []; cshim = [] } ~out:(Filename.concat scratch "flan-dbg-wasm") with diff --git a/test/test_flan.ml b/test/test_flan.ml index 516e65c..b27ba4c 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -476,13 +476,13 @@ let () = which of the two it means instead of being quietly given one of them. *) parse_rejects "the old defunion spelling" "(defunion Shape [(Circle [r f32]) (Square [s f32])])" - ~needle:"defunion is now defdata"; + ~needle:"the tagged sum is defdata now"; (* The shape that would otherwise parse: two bare case names read as one - field of a type. Same refusal, because the arm dispatches on the head and - never looks at what follows it. *) + member of a type. Same refusal, and this is the one that matters — it + would have compiled. *) parse_rejects "the old defunion spelling with payload-less cases" "(defunion U [A B])" - ~needle:"defunion is now defdata"; + ~needle:"the tagged sum is defdata now"; (match read "(defunion U [A B])" |> Parse.program with | _ -> check "the old spelling has a kind" false | exception Loc.Error { Loc.kind; _ } -> @@ -1533,6 +1533,121 @@ let () = "(defn f [] i32 (let [xs [1 2]] (destructure~nth xs 0 2 1)))" ~needle:"means nothing outside a quasiquote"; + (* ── The untagged union ────────────────────────────────────────── *) + + (* Every one of these is a rule the type would be unsound or useless + without, and each says so in its own words rather than falling through to + something generic. The layout itself is pinned where a layout can only be + pinned, against the backend that computes it — see the DWARF/LLVM oracle + in test_acceptance.ml — and what it *does* is pinned by a program that + writes one member and reads another, which is the whole point of the + type. What is here is the catalogue of what it refuses. *) + (match (parse_decl "(defunion U [i i32 f f32])").Ast.d with + | Ast.Defunion ("U", [ a; b ]) -> + check "defunion parses as a member list" + (a.Ast.fname = "i" && b.Ast.fname = "f") + | _ -> check "defunion parses as a member list" false); + + (* Nothing to read out of, and no size. It parses; it is refused where the + message can name the shape. *) + rejects_check "a union with no members" + "(defunion U [])\n(defn f [u U] i32 0)" + ~needle:"declares no members"; + rejects_check "a union that declares a member twice" + "(defunion U [x i32 x f32])\n(defn f [u U] i32 0)" + ~needle:"declares the same member twice"; + (* The size is the largest member and the largest member is the whole type, + so this is the same infinite type a self-containing struct is. *) + rejects_check "a union that contains itself by value" + "(defunion U [a i32 b U])\n(defn f [u U] i32 0)" + ~needle:"contains itself by value"; + (* Not waiting on drop, unlike the struct and data type refusals: nothing + records which member is live, so there is no fact recursive teardown + could read. *) + rejects_check "a union member that is move-only" + "(defunion U [n i64 v (Vec i32)])\n(defn f [u U] i32 0)" + ~needle:"nothing records which was written"; + (* And the one the optimiser would otherwise be handed: a byte that is + neither 0 nor 1 read as an i1. Refused at any depth, which is why the + second row goes through a struct. *) + rejects_check "a bool member" + "(defunion U [b bool n u8])\n(defn f [u U] i32 0)" + ~needle:"a union may not hold one at any depth"; + rejects_check "a bool inside a struct member" + "(defstruct S [flag bool n i32])\n\ + (defunion U [s S n i64])\n(defn f [u U] i32 0)" + ~needle:"a union may not hold one at any depth"; + (* The same hazard as uninit on a data type, arriving the other way round: a + member written over the tag leaves a tag no case names, and a match on it + falls into a block the optimiser may treat as unreachable. Refused at any + depth for the reason bool is. *) + rejects_check "a data type member" + "(defdata D [A (B [x i32])])\n\ + (defunion U [d D n i64])\n(defn f [u U] i32 0)" + ~needle:"a data type's tag steers every match"; + rejects_check "a data type inside a struct member" + "(defdata D [A B])\n(defstruct S [d D n i32])\n\ + (defunion U [s S n i64])\n(defn f [u U] i32 0)" + ~needle:"a data type's tag steers every match"; + (* An Option is not on that list, and the difference is the lowering: its + match is a test of the tag byte and a branch, so a scribbled tag reads as + a Some with a payload nobody stored — which is what this language says a + union read is. *) + (match checked "(defunion U [o (Option i32) n i64])\n\ + (defn f [u U] i32 (match (.o u) (Some x) x None 0))" with + | _ -> check "an Option member is allowed" true + | exception Loc.Error { Loc.dmsg = msg; _ } -> + incr failures; + Printf.printf "FAIL an Option member is allowed: %s\n" msg); + (* One member named twice is a different mistake from two members named, and + it gets the refusal the struct path already had. *) + rejects_check "a union literal naming one member twice" + "(defunion U [i i32])\n\ + (defn f [] i32 (let [u (U {.i 1 .i 2})] (.i u)))" + ~needle:"member i is given twice"; + + (* Two members is one storage written twice, and which one survived would be + whatever the compiler happened to do last. *) + rejects_check "a union literal giving two members" + "(defunion U [i i32 f f32])\n\ + (defn f [] i32 (let [u (U {.i 1 .f 2.0})] (.i u)))" + ~needle:"only one of them can be written"; + rejects_check "a union literal giving a member it does not have" + "(defunion U [i i32])\n(defn f [] i32 (let [u (U {.z 1})] (.i u)))" + ~needle:"U has no member z"; + (* There is no tag, so there is nothing for the arms to be alternatives + over. Said by name because the two kinds of union are one keyword apart + and somebody will write it. *) + rejects_check "match on a union" + "(defunion U [i i32 f f32])\n\ + (defn f [u U] i32 (match u _ 0))" + ~needle:"there is nothing in one to match on"; + (* A member narrower than the union leaves the rest indeterminate, so two + values that agree about everything anybody wrote would hash apart. *) + rejects_check "a union as a map key" + "(defunion U [i i32 f f32])\n\ + (defn f [m (Map U i32) k U] () (put m k 1))" + ~needle:"a union is not a map key"; + (* A global's initialiser is a constant and writing a member is a store. The + zeroed and uninit forms need none of that and are accepted below. *) + rejects_check "a global initialised with a union member" + "(defunion U [i i32])\n(defvar g U (U {.i 1}))\n(defn f [] i32 0)" + ~needle:"cannot be written into a global"; + (* uninit is refused on a data type because its tag steers a match into a + block LLVM may treat as unreachable. An untagged union steers nothing, so + the argument does not carry over and the answer is different. *) + (match checked "(defunion U [i i32 f f32])\n(defvar g U uninit)\n\ + (defn f [] i32 (.i g))" with + | _ -> check "uninit on a union is allowed" true + | exception Loc.Error { Loc.dmsg = msg; _ } -> + incr failures; + Printf.printf "FAIL uninit on a union is allowed: %s\n" msg); + (* The shim writes structs and has no spelling for a union yet — a refusal + about the generator, not about the type, and it says so. *) + rejects_check "a union crossing to C by value" + "(defunion U [i i32])\n(declare-c take [u U] () \"take\")" + ~needle:"the shim generator writes structs only"; + (* ── Reading a C header (cimport.ml, cjson.ml) ─────────────────── *) (* Against test/headers/sample.h, which is one function per decision the @@ -1548,7 +1663,9 @@ let () = let fixture = "(defstruct Pair [x f32 y f32])\n\ (defstruct Shade [r u8 g u8 b u8 a u8])\n\ - (defenum Mood [calm 0 cross 1])\n" + (defenum Mood [calm 0 cross 1])\n\ + (defunion Overlay [i i32 f f32])\n\ + (defstruct Slot [kind i32 v Overlay])\n" in let ds = program fixture in let taken = Hashtbl.create 16 in @@ -1563,6 +1680,11 @@ let () = (fun (d : Ast.decl) -> match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None) ds + and known_unions = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None) + ds and known_enums = List.filter_map (fun (d : Ast.decl) -> @@ -1571,7 +1693,8 @@ let () = in let i, d, e = Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[] - ~known_structs ~known_enums ~taken ~bound_syms:[] ~config:Cimport.no_config + ~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[] + ~config:Cimport.no_config in (i, d, e, ds) in @@ -1650,6 +1773,11 @@ let () = (fun (d : Ast.decl) -> match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None) fixture_ds + and known_unions = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None) + fixture_ds and known_enums = List.filter_map (fun (d : Ast.decl) -> @@ -1658,7 +1786,7 @@ let () = in let i, _, _ = Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[] - ~known_structs ~known_enums ~taken ~bound_syms:[] ~config + ~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[] ~config in (List.map Cimport.decl_source i.Cimport.decls, i.Cimport.hidden) in @@ -1819,6 +1947,91 @@ let () = | [ ("Feel", why) ] -> contains why "i64" | _ -> false); + (* The same claim for a [defunion], and what it unlocked. A record holding a + union member used to be skipped entirely — not recorded, so the + [defstruct] beside it was unchecked too — because there was no Flan type + to compare the member against. There is one now, and [Slot] in the + fixture is checked member by member like any other struct. *) + let unions_of ds = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defunion (n, ms) -> Some (n, ms) | _ -> None) + ds + in + check "a defunion that matches the header is not reported" + (Cimport.check_unions ~env ~unions:(unions_of fixture_ds) dump = []); + check "and the struct holding it is checked rather than skipped" + (Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []); + check "a struct whose union member is given the wrong type is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Slot [kind i32 v Pair])\n")) + dump + with + | [ ("Slot", why) ] -> contains why "Overlay" + | _ -> false); + (* Order is the whole hazard for a struct and means nothing for a union: + every member is at offset zero, so a permuted defunion is the same type + and reporting it would be a finding that is not one. *) + check "a permuted defunion is not reported" + (Cimport.check_unions ~env + ~unions:(unions_of (program "(defunion Overlay [f f32 i i32])\n")) dump + = []); + (* Missing is the one that changes the size, and a union embedded by value + puts every field after it in the wrong place. *) + check "a defunion missing a member is reported" + (match + Cimport.check_unions ~env + ~unions:(unions_of (program "(defunion Overlay [i i32])\n")) dump + with + | [ ("Overlay", why) ] -> contains why "f" && contains why "widest" + | _ -> false); + check "a defunion with a member the header lacks is reported" + (match + Cimport.check_unions ~env + ~unions:(unions_of + (program "(defunion Overlay [i i32 f f32 d f64])\n")) dump + with + | [ ("Overlay", why) ] -> contains why "d" + | _ -> false); + check "a defunion whose member is the wrong width is reported" + (match + Cimport.check_unions ~env + ~unions:(unions_of (program "(defunion Overlay [i i32 f f64])\n")) dump + with + | [ ("Overlay", why) ] -> contains why "f64" && contains why "f32" + | _ -> false); + (* Two different layouts under one name, which is the same class of finding + a permuted struct is and has a one-keyword fix. *) + check "a defstruct against a union in the header is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Overlay [i i32 f f32])\n")) + dump + with + | [ ("Overlay", why) ] -> contains why "union in the header" + | _ -> false); + check "a defunion against a struct in the header is reported" + (match + Cimport.check_unions ~env + ~unions:(unions_of (program "(defunion Pair [x f32 y f32])\n")) dump + with + | [ ("Pair", why) ] -> contains why "struct in the header" + | _ -> false); + check "a union the header does not describe is left alone" + (Cimport.check_unions ~env + ~unions:(unions_of (program "(defunion Nowhere [q i32])\n")) dump + = []); + (* And the gap that remains, said out loud so it is a decision rather than + an oversight: an anonymous union member has no name and no Flan + spelling, so the record holding one is still not recorded and the + defstruct beside it is still unchecked rather than checked wrongly. *) + check "a record with an anonymous union member is still skipped" + (Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Anon [kind i32 junk i32])\n")) + dump + = []); + (* ── The constants (Cimport.check_constants) ───────────────────── *) (* The half of generate-c's claim that used to be missing. A wrong flag bit diff --git a/web/index.html b/web/index.html index dc9bebd..a4ab6ec 100644 --- a/web/index.html +++ b/web/index.html @@ -523,6 +523,7 @@ notation reads as exactly one data item.

$ta type variable — see genericswhatever it is instantiated at a structvalue typefields in declaration order a tagged data typedefdata, matched by casetag + the widest payload +an untagged uniondefunion, C's: read any member, no tagthe widest member, at the strictest alignment an enumits own type in the checkeri32 ()one value, zero sizeempty Neverfits anywhere; nothing has itempty @@ -2108,7 +2109,7 @@ disagree with the first.