diff --git a/lib/check.ml b/lib/check.ml index d0693b9..406866d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7423,15 +7423,21 @@ let init_order (globals : Tast.global list) (fns : Tast.fn list) = let desc_offsets_max = 4096 -(* Is there a dyn anywhere under this type at all, by value or otherwise. *) +(* Is there a dyn in the storage a value of this type *is*, which is not the + same as whether its printed form mentions dyn anywhere. A pointer and a + slice are stopped at, because what they address is somebody else's storage + and is rooted where it was declared. That is the same line [hidden_dyn] + takes for a bare [(Ptr S)], and taking it here as well is what lets + [(Vec (Ptr Cond))] be written — a vector of pointers to condition structs + holds no dyn words of its own, and refusing it with a sentence about the dyn + inside it was wrong twice over. *) let rec dyn_anywhere p seen (t : Types.t) = let go = dyn_anywhere p seen in match t with | Types.Dyn -> true - | Types.Array (_, e) | Types.Vec e | Types.Ptr e | Types.Option e - | Types.Slice e -> go e + | Types.Array (_, e) | Types.Vec e | Types.Option e -> go e | Types.Map (k, v) -> go k || go v - | Types.Fn _ -> false + | Types.Ptr _ | Types.Slice _ | Types.Fn _ -> false | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) @@ -7462,17 +7468,32 @@ let rec dyn_anywhere p seen (t : Types.t) = (* How many dyn words a descriptor for this type would name, which is what the cap above is about. Only the by-value shapes contribute; the rest are refused by [hidden_dyn] before this number matters. *) +(* Saturated at one past the cap, because the number only ever has to be + compared with it. That is not tidiness: [(defvar big [4611686018427387904 + S])] is a length an [Int64.to_int] multiplication wraps *negative* on, so an + honest product made the test [n > desc_offsets_max] false, the declaration + was accepted, and the emitter then sat building the offset list until + something killed it. A refusal that overflows into an acceptance is worse + than no refusal. Every arm below stays at or under [desc_offsets_max + 1], + so nothing here can multiply two numbers large enough to wrap. *) +let sat n = if n > desc_offsets_max then desc_offsets_max + 1 else n + let rec dyn_words p seen (t : Types.t) = match t with | Types.Dyn -> 1 - | Types.Array (n, e) -> Int64.to_int n * dyn_words p seen e + | Types.Array (n, e) -> + let w = dyn_words p seen e in + if w = 0 then 0 + else if Int64.compare n (Int64.of_int (desc_offsets_max + 1)) > 0 then + desc_offsets_max + 1 + else sat (Int64.to_int n * w) | Types.Named nm when not (List.mem nm seen) -> (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = nm) p.Tast.structs with | Some s -> List.fold_left (fun acc (fl : Tast.field) -> - acc + dyn_words p (nm :: seen) fl.Tast.fty) + sat (acc + dyn_words p (nm :: seen) fl.Tast.fty)) 0 s.Tast.fields | None -> 0) | _ -> 0 @@ -7541,15 +7562,48 @@ let dyn_descriptors (p : Tast.program) = dyn in a struct field, or wait for the typed container view" what (Types.to_string t) (Types.to_string at) (Types.to_string at) | None -> ()); - let n = dyn_words p [] t in - if n > desc_offsets_max then + (* The count is saturated, so the message says more-than rather than a + figure the reader could check — which is the honest thing to print, + since the figure it would otherwise print is the one that wrapped. *) + if dyn_words p [] t > desc_offsets_max then Loc.failk "check/dyn-descriptor" loc - "%s is %s, whose descriptor would name %d dyn words. The offsets of an \ - array are flattened one element at a time, and %d is the most this \ - compiler will write out — the repeat form that would avoid it arrives \ - with the typed container view" - what (Types.to_string t) n desc_offsets_max + "%s is %s, whose descriptor would name more than %d dyn words. The \ + offsets of an array are flattened one element at a time, and %d is \ + the most this compiler will write out — the repeat form that would \ + avoid it arrives with the typed container view" + what (Types.to_string t) desc_offsets_max desc_offsets_max in + (* The foreign boundary, which is the one place the note above admits an + honest hole. A [(Ptr S)] is fine when the storage is this compiler's, + because every slot, global and array that can hold an S is rooted with its + descriptor. Storage that came from C is not: nothing pushed a root for it, + nothing ever will, and the dyn word sitting in it is a live value the + collector cannot see. A bare dyn is already refused by name at this + boundary for a different reason — C has no way to ask what the word means + — and this is the same sentence one level down. + + Reported at [Loc.unknown] because a [Tast.extern] carries no location; the + Flan name and the C symbol are what a reader needs to find it, and both + are in the message. *) + List.iter + (fun (e : Tast.extern) -> + let across what (t : Types.t) = + match t with + | Types.Ptr pointee when dyn_anywhere p [] pointee -> + Loc.failk "check/dyn-descriptor" Loc.unknown + "%s of %s (the C symbol %s) is %s, and %s holds a dyn. What C \ + hands back points at storage this compiler never rooted, so the \ + collector cannot mark that word and will free what it names — \ + pass the fields across at written types instead" + what e.Tast.ename e.Tast.esym (Types.to_string t) + (Types.to_string pointee) + | _ -> () + in + List.iteri + (fun i t -> across (Printf.sprintf "parameter %d" (i + 1)) t) + e.Tast.eparams; + across "the return type" e.Tast.eret) + p.Tast.externs; List.iter (fun (g : Tast.global) -> check g.Tast.ginit.Tast.loc diff --git a/lib/emit.ml b/lib/emit.ml index e188d5a..560b2cf 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -271,8 +271,11 @@ type m = { A table and not a buffer, because the two backends write the same data in two syntaxes: this is what they agree about, and each renders it at the - end of its own module. Keyed by symbol so a type asked for twice is - emitted once. + end of its own module. Keyed by [Types.to_string] — which is an identity, + since two types are the same type exactly when their printed forms agree + — and never by the symbol, which is a mangle and therefore many-to-one. + The value carries the symbol the backend writes it under, so a type asked + for twice is emitted once. Not counted in [nstr], and for [nfi]'s reason rather than by oversight. A string literal in a module image is something the program may still be @@ -282,7 +285,7 @@ type m = { and no value of any type points at one. A redefinition module naming a type the base program already named therefore gets its own copy, which is harmless — a descriptor is read-only and has no identity. *) - descs : (string, int list * int) Hashtbl.t; + descs : (string, string * int list * int) Hashtbl.t; } (* The attribute group every emitted function names, empty unless sanitizing. @@ -452,11 +455,21 @@ and dyn_offsets m (t : Types.t) : int list = in List.sort_uniq compare (go [] 0 t []) -(* The symbol a type's descriptor is written under. Mangled from the type's - printed form, so two spellings of one type share an entry and no two types - share a symbol; private or local in both backends, so a redefinition module - naming the same type as the program it patches is not a duplicate symbol. *) -let desc_sym (t : Types.t) = +(* The readable half of a descriptor's symbol: the type's printed form with + every character an assembler would not take replaced. It is a *label* and + not an identity — the mangle is many-to-one, because a Flan name may hold + [-], [+], [*], [?] and [/], all of which come out as the same character + here, so [row-a] and [row+a] mangle alike. The identity is the printed form + itself, which is what [descs] is keyed by; the number [desc_of] appends is + what keeps two types that mangle alike from sharing a symbol. + + That was a real defect and not a hypothetical: keyed by the mangle, the + first of the two registered won, the second was pushed with the first's + descriptor, and the collector read at offsets belonging to another type — + past the end of the object when the first was the larger, and never at the + offset where the second's dyn actually sat. The same corruption [root_plan] + pools its temporaries to avoid, arriving through the name instead. *) +let desc_mangle (t : Types.t) = let b = Buffer.create 32 in String.iter (fun c -> @@ -465,20 +478,33 @@ let desc_sym (t : Types.t) = then Buffer.add_char b c else Buffer.add_char b '.') (Types.to_string t); - "flan.desc." ^ Buffer.contents b + Buffer.contents b (* The descriptor for a type, recorded on the module and named. [None] when the type holds no dyn, which is the answer for almost every type in almost every program and is what keeps a dyn-free program's output byte for byte what it - was. *) + was. + + Keyed by [Types.to_string], which is an identity: two types are the same + type exactly when their printed forms agree. The symbol carries a counter so + that two distinct types cannot collide however they mangle; it is stable for + a given program because registration order is emission order and emission + order is deterministic. Private or local in both backends, so a redefinition + module naming the same type as the program it patches is not a duplicate + symbol. *) let desc_of m (t : Types.t) : string option = match dyn_offsets m t with | [] -> None | offs -> - let sym = desc_sym t in - if not (Hashtbl.mem m.descs sym) then - Hashtbl.replace m.descs sym (offs, fst (lay m t)); - Some sym + let key = Types.to_string t in + match Hashtbl.find_opt m.descs key with + | Some (sym, _, _) -> Some sym + | None -> + let sym = + Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs) + in + Hashtbl.replace m.descs key (sym, offs, fst (lay m t)); + Some sym (* A DWARF type node for a Flan type, memoised by the type's printed form so the pool holds one node per distinct type. *) @@ -3677,7 +3703,7 @@ let descriptors m = Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs [] |> List.sort (fun (a, _) (c, _) -> String.compare a c) |> List.iter - (fun (sym, (offs, size)) -> + (fun (_, (sym, offs, size)) -> Buffer.add_string b (Printf.sprintf "@\"%s.offs\" = private unnamed_addr constant [%d x i64] [%s]\n" @@ -3709,7 +3735,7 @@ let descriptors_asm m = # Read by the collector through flan_dyn_root_push_desc and by nothing\n\ # else; no value points at one.\n\t.section\t.rodata\n"; List.iter - (fun (sym, (offs, size)) -> + (fun (_, (sym, offs, size)) -> Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym); List.iter (fun o -> Buffer.add_string b (Printf.sprintf "\t.quad\t%d\n" o)) diff --git a/test/dyn_ops.c b/test/dyn_ops.c index fd6ed61..a9a1749 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -558,15 +558,20 @@ static void unrooted(void) { * runtime that read them wrongly would be wrong in both lanes at once. * * The shape deliberately has a gap and a nesting in it: a header word that is - * not a dyn, an inner struct that carries one, and a trailing one. If the - * marker walked the struct as a run of words rather than by the offsets it was - * given, it would decode [n] as a value and miss nothing — which is why [n] - * holds a bit pattern that is a plausible boxed pointer. */ + * not a dyn, an inner struct that carries one, and a trailing one. + * + * Two assertions, and the second is the one that tells an offset-driven marker + * from a word-driven one. The first — that the named fields survive — passes + * under both, because a marker that walked every word of the struct would keep + * them too. So [hidden] sits at an offset the descriptor does not name and + * holds five hundred objects: an offset-driven marker lets the lot go, and a + * word-driven one keeps them. The count is what says which happened. */ typedef struct { int64_t n; flan_dyn label; struct { int32_t k; flan_dyn note; } inner; flan_dyn tail; + flan_dyn hidden; /* deliberately absent from [offs] below */ } desc_row; static void desc(void) { @@ -580,6 +585,7 @@ static void desc(void) { }; desc_row row; flan_dyn was_label, was_note; + int64_t before; int i, ok = 1; flan_gc_init(); @@ -590,7 +596,8 @@ static void desc(void) { row.label = flan_dyn_nil(); row.inner.note = flan_dyn_nil(); row.tail = flan_dyn_nil(); - row.n = (int64_t)0xFFFB000000001234LL; /* looks boxed, is not a dyn slot */ + row.hidden = flan_dyn_nil(); + row.n = 0; row.inner.k = 7; flan_dyn_root_push_desc(&row, &row_desc); @@ -613,8 +620,29 @@ static void desc(void) { if (flan_dyn_need_i64(flan_dyn_at(row.tail, flan_dyn_from_i64(0))) != 99) ok = 0; printf("aggregate root survives collection: %s\n", ok ? "yes" : "no"); - printf("the word at a non-dyn offset is untouched: %s\n", - row.n == (int64_t)0xFFFB000000001234LL ? "yes" : "no"); + + /* And the half that discriminates. [hidden] is a dyn word inside the very + object the collector was handed, at an offset the descriptor leaves out, + and it holds five hundred and one objects. A marker that walked the struct + rather than the offsets would keep every one of them; one that reads the + offsets it was given lets them go. The ring holds the last sixty-four + allocations unconditionally, so the noise below is what puts them out of + its reach, and sixty-four is the slack the test allows. */ + flan_gc_collect(); + before = flan_gc_count(); + /* Built under a dyn root of its own, because the descriptor does not name + this word and a collection in the middle of five hundred pushes would + free what the next push writes into. The pop is what leaves it reachable + from the unnamed offset and from nowhere else, which is the state the + question is about. */ + flan_dyn_root_push(&row.hidden); + row.hidden = flan_dyn_vec_new(); + for (i = 0; i < 500; i++) flan_dyn_push(row.hidden, text("hidden")); + flan_dyn_root_pop(1); + for (i = 0; i < 200; i++) (void)text("noise"); + flan_gc_collect(); + printf("a dyn at an offset the descriptor omits is not marked: %s\n", + flan_gc_count() <= before + 64 ? "yes" : "no"); /* And the positive control, which is the same one [unrooted] makes: drop the fields and the objects go. One pop takes the aggregate entry off exactly @@ -622,6 +650,7 @@ static void desc(void) { row.label = flan_dyn_nil(); row.inner.note = flan_dyn_nil(); row.tail = flan_dyn_nil(); + row.hidden = flan_dyn_nil(); flan_dyn_root_pop(1); for (i = 0; i < 5000; i++) (void)text("noise"); flan_gc_collect(); diff --git a/test/programs/dyn-struct.flan b/test/programs/dyn-struct.flan index f7a4939..9906d20 100644 --- a/test/programs/dyn-struct.flan +++ b/test/programs/dyn-struct.flan @@ -38,6 +38,18 @@ (defstruct Row [id i32 tag Tag rows dyn]) (defstruct Stalled [why dyn id i32]) +;;; Two types whose names differ only in a character a descriptor symbol's +;;; mangle flattens: - and + both come out as a dot, so these two once shared +;;; one entry in the emitter's table and the second of them was pushed with the +;;; first's descriptor. Three words apart in size and one dyn each at opposite +;;; ends, so the mistake is not a subtle one — the collector read twenty-four +;;; bytes past an eight-byte stack object and never marked the word that was +;;; actually there. ASan called it what it was, a stack-buffer-overflow inside +;;; gc_mark_all. They are held live across the churn below, which is where a +;;; descriptor pointing at the wrong offsets shows. +(defstruct dyn-row [a i64 b i64 c i64 d dyn]) +(defstruct dyn+row [e dyn]) + ;;; A global holding dyn words, which main roots before a line of the program ;;; runs and never pops. Zero until its field is set, and a zero word is not a ;;; value the collector follows. @@ -90,25 +102,39 @@ (set (.rows registry) (.rows keep)) total)) +(defn boxed [n i64] dyn + (let [v (vec-new dyn)] + (push v n) + v)) + (defn main [] () (set (.name (.tag registry)) "registry") (set (.rows registry) (vec-new dyn)) - (handler-bind [(Stalled [c] - ;; Allocate first, then read the payload: if the payload's - ;; vector were unrooted across the transfer, this is the - ;; allocation that would free it. - (let [noise (vec-new dyn)] - (push noise "noise")) - (set stalls (+ stalls 1)) - (set echoed (at (.why c) 0)))] - (print (churn 40000)) (print "\n")) - (print stalls) (print "\n") - (print echoed) (print "\n") - (print (.name (.tag registry))) (print "\n") - (print (len (.rows registry))) (print "\n") - (print (at (.rows registry) 0)) (print "\n") - ;; And the heap after a final collection, which is the leak question asked - ;; rather than assumed. Everything the run built is unreachable by now except - ;; the registry's vector and the handful of words it holds. - (gc-collect) - (if (< (gc-count) 2000) (print "bounded\n") (print "LEAKED\n"))) + ;; Bound before the churn and read after it, wide first so that its + ;; descriptor is the one registered first and the narrow one is what a + ;; shared entry would corrupt. + (let [wide (dyn-row {.a 1 .b 2 .c 3 .d (boxed 7)}) + narrow (dyn+row {.e (boxed 11)})] + (handler-bind [(Stalled [c] + ;; Allocate first, then read the payload: if the payload's + ;; vector were unrooted across the transfer, this is the + ;; allocation that would free it. + (let [noise (vec-new dyn)] + (push noise "noise")) + (set stalls (+ stalls 1)) + (set echoed (at (.why c) 0)))] + (print (churn 40000)) (print "\n")) + (print stalls) (print "\n") + (print echoed) (print "\n") + (print (.name (.tag registry))) (print "\n") + (print (len (.rows registry))) (print "\n") + (print (at (.rows registry) 0)) (print "\n") + ;; The two that mangle alike, read after forty thousand rows of churn + ;; collected over them many times. + (print (at (.d wide) 0)) (print "\n") + (print (at (.e narrow) 0)) (print "\n") + ;; And the heap after a final collection, which is the leak question asked + ;; rather than assumed. Everything the run built is unreachable by now + ;; except the registry's vector and the handful of words it holds. + (gc-collect) + (if (< (gc-count) 2000) (print "bounded\n") (print "LEAKED\n")))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index d72d893..0c3c773 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3330,9 +3330,20 @@ level "1" which is the leak question asked rather than assumed. With the descriptor walk disabled in the marker, the 628 comes out 24 and the 0 comes out a stale word — which is how this row was checked to have - teeth. *) + teeth. + + The 7 and the 11 at the end are two types whose names differ only in a + character the descriptor symbol's mangle flattens — [dyn-row] and + [dyn+row]. Keyed by that mangle the emitter kept one entry for the two, + and the narrower object was pushed with the wider one's descriptor: + reading twenty-four bytes into an eight-byte stack object, which ASan + called a stack-buffer-overflow inside [gc_mark_all]. These two lines + are the values under a collector that actually ran, and they are the + weaker half of the check — whether an overread off the end of a frame + slot lands on anything is luck. The assertion with teeth is + [distinct_descriptors] below, which asks the emitter directly. *) let dyn_struct_out = - "120000\n10\nstalled\nregistry\n628\n0\nbounded\n" + "120000\n10\nstalled\nregistry\n628\n0\n7\n11\nbounded\n" in outputs "dyn: a struct with dyn fields, under collection" "programs/dyn-struct.flan" dyn_struct_out; @@ -3427,6 +3438,37 @@ level "1" end) [ ("%dx", "dyn"); ("%ax", "aggregate") ] in + (* And that two types which mangle to the same label get two descriptors. + The symbol a descriptor is written under is [Types.to_string] with every + character an assembler would refuse replaced by a dot, so [dyn-row] and + [dyn+row] produce the same label — and keyed by that label the second of + them silently inherited the first's offsets and size. The identity is + the printed type and the symbol carries a counter; this is the assertion + that says so, at the only place it is visible. + + Asked of the definitions rather than the uses, because a use names + whatever symbol it was given and two uses of one wrong symbol look + exactly like two uses of two right ones. *) + let distinct_descriptors path prefix want = + let l = Load.program ~file:path (Reader.read_file path) in + let ir = Emit.program (Check.program_all l.Load.decls) in + let n = + List.length + (List.filter + (fun line -> + contains line prefix + && contains line "constant { i64, i64, ptr }") + (String.split_on_char '\n' ir)) + in + if n <> want then begin + incr failures; + Printf.printf + "FAIL %s emits %d descriptors under %s, wanted %d — two types that \ + mangle alike are sharing one\n" + path n prefix want + end + in + distinct_descriptors "programs/dyn-struct.flan" "@\"flan.desc.dyn.row" 2; List.iter no_fallback_slots [ "programs/dyn-basic.flan"; "programs/dyn-vec.flan"; "programs/dyn-struct.flan"; diff --git a/test/test_dyn.ml b/test/test_dyn.ml index b4b2eed..394cb83 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -100,13 +100,17 @@ let () = (* The aggregate roots the per-type descriptors added: a struct with dyn fields at three offsets, one of them inside a nested struct, rooted by - address and descriptor rather than word by word. The second line is the - one that would catch a marker walking the struct as a run of words: the - header holds a bit pattern that looks boxed and is not a dyn slot. *) + address and descriptor rather than word by word. + + The second line is the one that discriminates, and the first on its own + does not: a marker that walked every word of the struct would keep the + named fields too. So the struct also holds five hundred objects behind a + dyn word at an offset the descriptor leaves out, and the claim is that + they are *not* kept. *) let code, out, _ = run "desc" in let want_desc = "aggregate root survives collection: yes\n\ - the word at a non-dyn offset is untouched: yes\n\ + a dyn at an offset the descriptor omits is not marked: yes\n\ and is reclaimed once dropped: yes\n" in if code <> 0 || out <> want_desc then diff --git a/test/test_flan.ml b/test/test_flan.ml index d44a298..1a97bc8 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -943,6 +943,30 @@ let () = "(defstruct S [x dyn])\n\ (defn main [] i32 (let [a (array 5000 S)] 0))" ~needle:"the most this compiler will write out"; + (* And the length that wrapped the multiplication rather than tripping the + cap: an honest product of this by one is negative, so the test read as + under the cap, the declaration was accepted, and the emitter then sat + building the offset list until something killed it. The count is + saturated now. *) + rejects_check "an array length that overflows the flattened count" + "(defstruct S [x dyn])\n\ + (defvar big [4611686018427387904 S])\n\ + (defn main [] i32 0)" + ~needle:"the most this compiler will write out"; + (* A pointer is not storage. A vector of pointers to structs that hold dyn + holds no dyn words of its own, and refusing it said the opposite. *) + accepts "a typed container of pointers to a dyn-bearing struct" + "(defstruct Cond [why dyn])\n\ + (defn f [v (Vec (Ptr Cond))] i32 0)\n\ + (defn main [] i32 0)"; + (* The one honest hole, named at the boundary where it opens. Storage C + hands back was never rooted and never will be, so a dyn word in it is a + live value the collector cannot see. *) + rejects_check "a pointer to a dyn-bearing struct crossing to C" + "(defstruct S [x dyn])\n\ + (declare take [p (Ptr S)] () \"c_take\")\n\ + (defn main [] i32 0)" + ~needle:"storage this compiler never rooted"; rejects_check "a dyn field under an Option" "(defstruct S [x dyn])\n\ (defn f [] (Option S) None)\n\