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.