diff --git a/docs/BUILT.md b/docs/BUILT.md index 17f3f03a..8aed28bc 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -4575,8 +4575,13 @@ read of a local. So the prelude's `map`, `filter` and `reduce` are as cheap in a closure as in one that makes none: a map, filter and reduce loop measured 1.77G instructions at LLVM `-O2` with and without one unrelated escaping closure. -**What is refused.** A `Map` whose values hold a function value (`fn-in-map.flan`): a `Map`'s storage is not walked. -A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one. +**A `Map`'s values are walked the same way** (`fn-in-map.flan`). A descriptor's `maps` table names each `Map` header +and the value type's descriptor; `flan_rt.c` reports each `Map` block through the same hook, and the marker walks the +full slots of a live block, reading the slot count from the header and the stride and value offset from the block's +own head. It covers a dyn value as well as a closure, so `(Map K dyn)` holds dyn values the collector keeps. The hook +is installed by any program holding a dyn, not only one making heap closures. + +**What is refused.** A bare `Fn` field, global or array element, for its zero; `(Option (Fn ...))` holds one. **A module that makes a heap closure is never unloaded**: the environment points at the module's descriptor and code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes diff --git a/lib/check.ml b/lib/check.ml index 2a8ded87..d20806f1 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -13639,8 +13639,11 @@ let rec hidden_dyn p seen (t : Types.t) : Types.t option = | Types.Dyn -> None | Types.Array (_, e) -> hidden_dyn p seen e | Types.Vec e | Types.Option e -> under e + (* A Map's values are walked through the value type's own descriptor, so a + dyn there is found wherever that descriptor finds one. A key never holds + one: dyn is not a key type. *) | Types.Map (k, v) -> - if dyn_anywhere p seen k || dyn_anywhere p seen v then Some t else None + if dyn_anywhere p seen k then Some t else hidden_dyn p seen v (* A pointer and a slice are views of storage something else roots; see the note above. What they point at is checked where it is declared. *) | Types.Ptr (_, e) | Types.Slice (_, e) -> hidden_dyn p seen e @@ -13760,53 +13763,8 @@ let rec holds_fn p seen (t : Types.t) = | None -> false) | _ -> false -(* The first Map under this type whose values hold a function value. A - closure's environment is found by walking the storage a function value - sits in, and a Map's storage is not walked — so an (Fn ...) there would be - one the collector frees under it. A Vec's is, which is the container to - use; and a (CFn ...) carries no environment and may go in a Map freely. *) -let rec map_of_fn p seen (t : Types.t) : Types.t option = - match t with - | Types.Map (k, v) when holds_fn p [] k || holds_fn p [] v -> Some t - | Types.Array (_, e) | Types.Vec e | Types.Option e - | Types.Ptr (_, e) | Types.Slice (_, e) -> map_of_fn p seen e - | Types.Map (_, v) -> map_of_fn p seen v - | Types.Named n when not (List.mem n seen) -> - let seen = n :: seen in - let fields = - match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) - p.Tast.structs with - | Some s -> s.Tast.fields - | None -> - match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) - p.Tast.datas with - | Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases - | None -> - match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) - p.Tast.unions with - | Some u -> u.Tast.fields - | None -> [] - in - List.fold_left - (fun acc (fl : Tast.field) -> - match acc with Some _ -> acc | None -> map_of_fn p seen fl.Tast.fty) - None fields - | _ -> None - let dyn_descriptors (p : Tast.program) = let check loc what (t : Types.t) = - (match map_of_fn p [] t with - | Some at -> - Loc.failk "check/fn-in-map" loc - "%s is %s%s, a Map whose values are function values. A function \ - value's environment is found by walking the storage it sits in, \ - and a Map's storage is not walked, so the collector would free an \ - environment still in use. Keep the function values in a Vec, or \ - make them (CFn ...) if they capture nothing" - what (Types.to_string t) - (if Types.equal t at then "" - else Printf.sprintf ", and holds %s" (Types.to_string at)) - | None -> ()); (match hidden_dyn p [] t with | Some at -> Loc.failk "check/dyn-descriptor" loc diff --git a/lib/emit.ml b/lib/emit.ml index 7b6c2c49..d5bf8184 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -459,23 +459,26 @@ let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a pointer is four bytes and [goff] would name the wrong word. *) type gcword = { goff : int; gpath : (string * string list) list } -(* Every word of an instance the collector follows, by kind — the three +(* Every word of an instance the collector follows, by kind — the four tables of runtime/flan_dyn.h's [flan_desc]. [gvec] carries each Vec's - element type, whose own descriptor the entry points at. *) + element type and [gmap] each Map's value type, whose own descriptor the + entry points at. *) type gclayout = { gdyn : gcword list; genv : gcword list; gvec : (gcword * Types.t) list; + gmap : (gcword * Types.t) list; } (* A descriptor this module has to write out: its symbol, the words, the instance size, and the symbol of each Vec entry's element descriptor in - [gvec]'s order. *) + [gvec]'s order and of each Map entry's value descriptor in [gmap]'s. *) type desc = { dsym : string; dlay : gclayout; dsize : int; dvecs : string list; + dmaps : string list; } (* ── Module-level state ────────────────────────────────────────────── *) @@ -741,16 +744,12 @@ and dyn_offsets m (t : Types.t) : int list = — which is a run-time question a static descriptor cannot answer. Refused in [Check] rather than described wrongly here. *) | None -> acc) - (* [Types.Option], [Types.Vec] and [Types.Map] fall through here with no - arm of their own and answer no offsets, which is correct only because - nothing reaches this function holding one with a dyn inside it: + (* [Types.Option] and [Types.Vec] fall through here with no arm of their + own and answer no offsets, which is correct only because nothing + reaches this function holding one with a dyn inside it: [Check.hidden_dyn] refuses that at every global, parameter, return and - frame slot first. If that gate is ever relaxed — the typed-container - view the M2 queue's item 3 is building is exactly the kind of change - that would relax it for [Vec]/[Map] — this arm has to grow alongside - it, the way the array and struct arms above already walk their own - storage; until then a silent [] here would be an unrooted dyn, not a - refusal. *) + frame slot first. A [Types.Map]'s dyn values are not words of the + instance at all; [gc_layout] names the header in its [gmap] table. *) | _ -> acc in List.sort_uniq compare (go [] 0 t []) @@ -794,7 +793,7 @@ let desc_mangle (t : Types.t) = symbol. *) let rec desc_of m (t : Types.t) : string option = let l = gc_layout m t in - if l.gdyn = [] && l.genv = [] && l.gvec = [] then None + if l.gdyn = [] && l.genv = [] && l.gvec = [] && l.gmap = [] then None else let key = Types.to_string t in match Hashtbl.find_opt m.descs key with @@ -806,17 +805,19 @@ let rec desc_of m (t : Types.t) : string option = (* Claimed before the elements are asked for, so the counter a nested element's symbol takes cannot be this one's. *) Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = [] }; - let dvecs = + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = []; dmaps = [] }; + let elems what l = List.map (fun (_, e) -> match desc_of m e with | Some s -> s - | None -> internal "a Vec entry whose element has no words") - l.gvec + | None -> internal "a %s entry whose element has no words" what) + l in + let dvecs = elems "Vec" l.gvec in + let dmaps = elems "Map" l.gmap in Hashtbl.replace m.descs key - { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs }; + { dsym = sym; dlay = l; dsize = fst (lay m t); dvecs; dmaps }; Some sym (* ── The words the collector follows ───────────────────────────────── @@ -845,7 +846,7 @@ let rec desc_of m (t : Types.t) : string option = at the same x86-64 offset and at different wasm32 ones, and marking a word twice costs nothing. *) and gc_layout m (t : Types.t) : gclayout = - let dyn = ref [] and env = ref [] and vec = ref [] in + let dyn = ref [] and env = ref [] and vec = ref [] and map = ref [] in let step ty idx path = path @ [ (ty, idx) ] in let rec go ~full seen off path (t : Types.t) = match t with @@ -858,6 +859,13 @@ and gc_layout m (t : Types.t) : gclayout = [desc_of] claims before it recurses, is what closes that loop. *) | Types.Vec e when m.gcfn -> if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec + (* A Map's values, when they hold a function value's environment or a + dyn. The key never does: neither is a key type. The value type's own + descriptor is what the entry points at, so a Map of Maps is walked + through the inner one's. *) + | Types.Map (_, v) -> + if (m.gcfn && reaches_fn m [] v) || reaches_dyn m [] v then + map := ({ goff = off; gpath = path }, v) :: !map | Types.Array (n, e) -> let s, _ = lay m e in for i = 0 to Int64.to_int n - 1 do @@ -924,7 +932,8 @@ and gc_layout m (t : Types.t) : gclayout = in let uniq l = List.sort_uniq order l in { gdyn = uniq !dyn; genv = uniq !env; - gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec } + gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec; + gmap = List.sort_uniq (fun (a, _) (b, _) -> order a b) !map } (* Whether an [(Fn ...)] is anywhere in a value's storage, a Vec's elements included. A type met again on the way contributes nothing more, which @@ -933,7 +942,8 @@ and gc_layout m (t : Types.t) : gclayout = and reaches_fn m seen (t : Types.t) = match t with | Types.Fn _ -> true - | Types.Array (_, e) | Types.Vec e | Types.Option e -> reaches_fn m seen e + | Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Map (_, e) -> + reaches_fn m seen e | Types.Named nm when not (List.mem nm seen) -> let seen = nm :: seen in let fields = @@ -950,17 +960,35 @@ and reaches_fn m seen (t : Types.t) = List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields | _ -> false +(* Whether a dyn word is anywhere [gc_layout] records one: directly, in a + fixed array, in a struct field, or in a Map's values. The other places a + dyn could sit are refused by [Check.hidden_dyn]. *) +and reaches_dyn m seen (t : Types.t) = + match t with + | Types.Dyn -> true + | Types.Array (_, e) | Types.Map (_, e) -> reaches_dyn m seen e + | Types.Named nm when not (List.mem nm seen) -> + (match Hashtbl.find_opt m.structs nm with + | Some st -> + List.exists + (fun (fl : Tast.field) -> reaches_dyn m (nm :: seen) fl.Tast.fty) + st.Tast.fields + | None -> false) + | _ -> false + (* Whether the collector has anything to follow in a value of this type — the question every rooting decision asks. [dyn_offsets <> []] was that question until an [Fn] could hold an environment. *) let traced m (t : Types.t) = t = Types.Dyn - || (let l = gc_layout m t in l.gdyn <> [] || l.genv <> [] || l.gvec <> []) + || (let l = gc_layout m t in + l.gdyn <> [] || l.genv <> [] || l.gvec <> [] || l.gmap <> []) (* The words to clear before an instance at a pushed root can be marked, as x86-64 byte offsets of eight-byte words: each dyn word, each environment - word, and each Vec header's pointer and length. The LLVM backend walks - [gpath] instead; see [zero_words]. *) + word, each Vec header's pointer and length, and each Map header's block + pointer and capacity. The LLVM backend walks [gpath] instead; see + [zero_words]. *) let gc_zero_offsets m (t : Types.t) : int list = if t = Types.Dyn then [ 0 ] else @@ -968,6 +996,7 @@ let gc_zero_offsets m (t : Types.t) : int list = List.map (fun w -> w.goff) l.gdyn @ List.map (fun w -> w.goff) l.genv @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 8 ]) l.gvec + @ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 16 ]) l.gmap (* A [gpath] as an LLVM constant expression over [base]: nested constant [getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it @@ -4273,7 +4302,12 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = (fun ((w : gcword), _) -> store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]); store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ])) - l.gvec + l.gvec; + List.iter + (fun ((w : gcword), _) -> + store "ptr null" (w.gpath @ [ ("%map", [ "i32 0"; "i32 0" ]) ]); + store "i64 0" (w.gpath @ [ ("%map", [ "i32 0"; "i32 2" ]) ])) + l.gmap end in let push base (ty : Types.t) = @@ -5130,12 +5164,13 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast. dyn global's initialiser runs in the startup function below, and the very first thing it does is allocate. *) if gc then Buffer.add_string b " call void @flan_gc_init()\n"; - (* Before anything can allocate a Vec block: a program that can make a - collector-owned closure environment has flan_rt.c report every Vec block - to the collector, which reads a Vec's elements only through a block it - knows to be live (runtime/flan_dyn.c, "The Vec blocks a marker may - read"). *) - if m.gcfn then Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; + (* Before anything can allocate a Vec or Map block: a program that can make + a collector-owned closure environment, or that holds a dyn, has + flan_rt.c report every such block to the collector, which reads a + container's elements only through a block it knows to be live + (runtime/flan_dyn.c, "The Vec blocks a marker may read"). *) + if m.gcfn || gc then + Buffer.add_string b " call void @flan_dyn_track_vecs()\n"; (* The dyn globals, rooted here and never popped, which is the whole of what a global's extent means. They go on the stack *before* the startup function runs, because that function is what fills them and its first @@ -5409,21 +5444,24 @@ let descriptors m = let l = d.dlay in let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) in let envs = table d.dsym "envs" "i64" (List.map word l.genv) in - let vecs = - table d.dsym "vecs" "{ i64, ptr }" + let pairs suffix words syms = + table d.dsym suffix "{ i64, ptr }" (List.map2 (fun ((w : gcword), _) e -> Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }" (offset_const w) e) - l.gvec d.dvecs) + words syms) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "@\"%s\" = private unnamed_addr constant \ - { i64, i64, ptr, i64, ptr, i64, ptr } \ - { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n" + { i64, i64, ptr, i64, ptr, i64, ptr, i64, ptr } \ + { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s, \ + i64 %d, ptr %s }\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) - envs (List.length l.gvec) vecs)); + envs (List.length l.gvec) vecs (List.length l.gmap) maps)); Buffer.contents b (* The same table in the other backend's syntax. It lives here rather than in @@ -5467,19 +5505,22 @@ let descriptors_asm m = in let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) in let envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in - let vecs = - table "vecs" + let pairs suffix words syms = + table suffix (List.concat (List.map2 (fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ]) - l.gvec d.dvecs)) + words syms)) in + let vecs = pairs "vecs" l.gvec d.dvecs in + let maps = pairs "maps" l.gmap d.dmaps in Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t%s\n\ - \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n" + \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n\ + \t.quad\t%d\n\t.quad\t%s\n" d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) envs - (List.length l.gvec) vecs)) + (List.length l.gvec) vecs (List.length l.gmap) maps)) rows; Buffer.contents b diff --git a/lib/x86.ml b/lib/x86.ml index e7631275..6c474fa7 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4512,9 +4512,10 @@ let emit_main ?(ann = false) ?(startup = false) ?(gc = false) xor_rr b ~dst:rax ~src:rax; call_sym b "flan_gc_init" end; - (* A program that can make a collector-owned closure environment has the - collector told of every Vec block from here on; see [Emit.emit_main]. *) - if md.Emit.gcfn then begin + (* A program that can make a collector-owned closure environment, or holds + a dyn, has the collector told of every Vec and Map block from here on; + see [Emit.emit_main]. *) + if md.Emit.gcfn || gc then begin xor_rr b ~dst:rax ~src:rax; call_sym b "flan_dyn_track_vecs" end; diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 56815dd0..10f25c9d 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -131,6 +131,8 @@ typedef uint64_t flan_dyn; * - [vecs]: a (Vec T) header whose elements hold words of their own, with the * element's descriptor. The marker reads the header's pointer and length * where they are, so a push that reallocated is seen. + * - [maps]: a (Map K V) header whose values hold words of their own, with the + * value's descriptor. Read the same way, and walked over the full slots. * * [size] is the stride of one instance as the compiler's element-size * arithmetic counts it, which is what a Vec's elements are laid out at. The @@ -149,6 +151,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; #define DYN_QNAN 0xFFF8000000000000ULL @@ -248,6 +252,23 @@ void flan_dyn_vec_hdr_layout(int64_t out[6]) { out[5] = (int64_t)offsetof(flan_dyn_vec_hdr, epoch); } +/* flan_map, restated for the same reason and read the same way: only + * [data], [log2cap], [alloc] and [epoch]. With it, the three numbers of the + * block's geometry the marker needs — flan_rt.c's FLAN_MAP_HEAD, _GROUP and + * _ALIGN. If either file's table changes, change both. */ +typedef struct flan_dyn_map_hdr { + void *data; + int64_t len; + int64_t log2cap; + void *alloc; + int64_t epoch; +} flan_dyn_map_hdr; + +#define DYN_MAP_HEAD 24 +#define DYN_MAP_GROUP 8 +#define DYN_MAP_ALIGN 64 +#define DYN_MAP_FULL 0x80 + /* flan_allocator's prefix, far enough to read the one word a stale-container * check needs. The struct has more fields after [epoch]; this file never * touches them; and the alignment of a leading same-typed prefix is the same @@ -1259,6 +1280,64 @@ typedef struct { char *p; int64_t n; const flan_desc *e; } vec_work; static vec_work *vstack; static int64_t vstack_n, vstack_cap; +/* Maps still to walk: a live block's control run, its slots, the slot count, + * the stride and value offset the block's own head records, and the value's + * descriptor. Queued for the Vec queue's reason. */ +typedef struct { + const uint8_t *ctrl; char *slots; int64_t cap, stride, voff; + const flan_desc *e; +} map_work; +static map_work *mapstack; +static int64_t mapstack_n, mapstack_cap; + +/* A live block, not reset since it was made: the checks a Vec's block and a + * Map's share. The allocator header is never freed, so its epoch is always + * readable. */ +static vblock *live_block(void *p) { + vblock *b = vblock_find((uintptr_t)p); + if (b == NULL) return NULL; + if (b->alloc != NULL + && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) + return NULL; + return b; +} + +/* Queue the map whose header is at [h]. The slot count comes from the + * header and everything else from the block, and the walk is bounded by the + * block's recorded size, so a stale header copy naming a block another map + * now owns reads nothing outside that block. */ +static void queue_map(const flan_dyn_map_hdr *h, const flan_desc *e) { + vblock *b; + const int64_t *head; + int64_t cap, ctrl, stride, voff; + if (e == NULL || h->data == NULL || h->log2cap <= 0 || h->log2cap > 40) + return; + b = live_block(h->data); + if (b == NULL || b->bytes < DYN_MAP_HEAD) return; + cap = (int64_t)1 << h->log2cap; + ctrl = (DYN_MAP_HEAD + cap + (DYN_MAP_GROUP - 1) + (DYN_MAP_ALIGN - 1)) + & ~(int64_t)(DYN_MAP_ALIGN - 1); + head = (const int64_t *)h->data; + stride = head[1]; + voff = head[2]; + if (stride <= 0 || voff < 0 || voff + e->size > stride) return; + if (ctrl > b->bytes || (b->bytes - ctrl) / stride < cap) return; + if (mapstack_n == mapstack_cap) { + int64_t c = mapstack_cap ? mapstack_cap * 2 : 16; + map_work *m = (map_work *)realloc(mapstack, (size_t)c * sizeof *m); + if (m == NULL) trap_oom(NULL, 0, c * (int64_t)sizeof *m); + mapstack = m; + mapstack_cap = c; + } + mapstack[mapstack_n].ctrl = (const uint8_t *)h->data + DYN_MAP_HEAD; + mapstack[mapstack_n].slots = (char *)h->data + ctrl; + mapstack[mapstack_n].cap = cap; + mapstack[mapstack_n].stride = stride; + mapstack[mapstack_n].voff = voff; + mapstack[mapstack_n].e = e; + mapstack_n++; +} + /* The words [d] names inside the instance at [base]. A Vec entry is checked * against the live blocks above and queued; [mark_desc] drains the queue * before it returns. */ @@ -1266,17 +1345,17 @@ static void mark_words(char *base, const flan_desc *d) { int64_t j; for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[j])); for (j = 0; j < d->nenv; j++) mark_env(*(uintptr_t *)(base + d->envs[j])); + for (j = 0; j < d->nmap; j++) + queue_map((const flan_dyn_map_hdr *)(base + d->maps[j].off), + d->maps[j].elem); for (j = 0; j < d->nvec; j++) { flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off); const flan_desc *e = d->vecs[j].elem; vblock *b; int64_t n; if (e == NULL || e->size <= 0 || h->len <= 0) continue; - b = vblock_find((uintptr_t)h->ptr); + b = live_block(h->ptr); if (b == NULL) continue; - if (b->alloc != NULL - && (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch) - continue; n = b->bytes / e->size; if (h->len < n) n = h->len; if (vstack_n == vstack_cap) { @@ -1295,10 +1374,17 @@ static void mark_words(char *base, const flan_desc *d) { static void mark_desc(char *base, const flan_desc *d) { mark_words(base, d); - while (vstack_n > 0) { - vec_work w = vstack[--vstack_n]; + while (vstack_n > 0 || mapstack_n > 0) { int64_t i; - for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + if (vstack_n > 0) { + vec_work w = vstack[--vstack_n]; + for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e); + } else { + map_work w = mapstack[--mapstack_n]; + for (i = 0; i < w.cap; i++) + if (w.ctrl[i] & DYN_MAP_FULL) + mark_words(w.slots + i * w.stride + w.voff, w.e); + } } } @@ -1355,7 +1441,8 @@ static void gc_sweep(void) { void *flan_dyn_env_new(int64_t size, const flan_desc *d) { flan_obj *o = gc_alloc(OBJ_ENV, size); o->len = size; - o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0)) + o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0 + || d->nmap > 0)) ? d : NULL; memset(o + 1, 0, (size_t)size); envset_put((uintptr_t)(o + 1)); @@ -1384,7 +1471,7 @@ void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); } * compiler found no dyn in — but it still occupies an entry, because the count * is what the epilogue knows, and it is turned into an empty descriptor rather * than stored as NULL, which on this stack means something else. */ -static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL }; +static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL, 0, NULL }; void flan_dyn_root_push_desc(void *base, const flan_desc *d) { root_add(base, d == NULL ? &desc_empty : d); diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 16dfa4de..38b110f1 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -56,8 +56,11 @@ typedef uint64_t flan_dyn; * pointer-sized, holding a collector-allocated environment, null, or a * widened function's code address, told apart by the collector's own set of * environments and never by dereferencing — and [vecs], each a (Vec T) - * header at [off] whose live elements are marked through [elem]. A descriptor - * with only dyn words leaves the last four fields zero. + * header at [off] whose live elements are marked through [elem] — and + * [maps], each a (Map K V) header at [off] whose full slots' values are marked + * through [elem]; a key never holds a word the collector follows, because no + * such type is a key. A descriptor with only dyn words leaves the last six + * fields zero. * * Nothing in this ABI ever writes a descriptor. See [flan_dyn_root_push_desc] * and [flan_dyn_env_new]. */ @@ -75,6 +78,8 @@ typedef struct flan_desc { const int64_t *envs; int64_t nvec; const flan_desc_vec *vecs; + int64_t nmap; + const flan_desc_vec *maps; } flan_desc; /* ── Constructors ──────────────────────────────────────────────────── */ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index b759c63a..b18f2455 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2561,13 +2561,14 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t loclen) { loc, loclen); } -/* Told of every Vec block this file allocates, moves or frees: the old block - * (or NULL), the new one (or NULL), its size in bytes, and the allocator and - * epoch it was made under. NULL unless flan_dyn.c's [flan_dyn_track_vecs] has - * installed its own — a program that can make a collector-owned closure - * environment, which may sit in a Vec, installs it so the collector never - * reads a block a stale header copy still names. A pointer rather than a - * call so this file names nothing in flan_dyn.c. */ +/* Told of every Vec block and every Map block this file allocates, moves or + * frees: the old block (or NULL), the new one (or NULL), its size in bytes, + * and the allocator and epoch it was made under. NULL unless flan_dyn.c's + * [flan_dyn_track_vecs] has installed its own — a program that can make a + * collector-owned closure environment or holds a dyn, either of which may sit + * in a Vec or a Map, installs it so the collector never reads a block a stale + * header copy still names. A pointer rather than a call so this file names + * nothing in flan_dyn.c. */ void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes, void *alloc, int64_t epoch) = NULL; @@ -3339,6 +3340,10 @@ static int8_t flan_map_rebuild(flan_map *m, int64_t log2cap, int64_t ksize, a->proc(a, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, old_cap), 0, FLAN_MAP_ALIGN); } + if (flan_vec_block_hook) + flan_vec_block_hook(m->data, fresh.data, + flan_map_block_size(ksize, vsize, flan_map_cap(&fresh)), + m->alloc, m->epoch); m->data = fresh.data; m->log2cap = fresh.log2cap; return 1; @@ -3586,6 +3591,8 @@ void flan_map_free(flan_map *m, int64_t ksize, int64_t vsize, m->alloc->proc(m->alloc, FLAN_ALLOC_FREE, m->data, flan_map_block_size(ksize, vsize, flan_map_cap(m)), 0, FLAN_MAP_ALIGN); + if (m->data && flan_vec_block_hook) + flan_vec_block_hook(m->data, NULL, 0, NULL, 0); m->data = NULL; m->len = 0; m->log2cap = 0; diff --git a/test/programs/fn-in-map.flan b/test/programs/fn-in-map.flan index 1fabf906..95c844ed 100644 --- a/test/programs/fn-in-map.flan +++ b/test/programs/fn-in-map.flan @@ -1,9 +1,58 @@ -;; A closure's environment is found by walking the storage its function value -;; sits in — a frame slot, a global, a struct, an Option, a Vec's elements — -;; and a Map's storage is not walked. An (Fn ...) as a Map's value would hold -;; an environment the collector cannot see and would free. A Vec holds them, -;; and a (CFn ...) carries no environment and may go in a Map. +;; A Map holding closures and a Map holding dyn values, both kept alive by the +;; collector across enough allocation that it runs many times. A Map's block is +;; walked like a Vec's: the full slots' values are marked through the value +;; type's descriptor. A lost value is a use of freed memory here, not a wrong +;; number. + +(defn adder [n i32] (Fn [i32] i32) + (fn [x] (+ x n))) + +;; Garbage, and plenty of it: every pass boxes and drops a vector of four. +(defn churn [n i32] () + (dotimes [i n] + (let [junk (vec-new dyn)] + (push junk i) + (push junk "row") + (push junk 2.5) + (push junk true)))) + (defn main [] i32 - (let [ops (map-new string (Fn [i32] i32))] - (put ops "id" (fn [x] x)) - 0)) + (let [ops (map-new string (Fn [i32] i32)) + many (map-new i32 (Fn [i32] i32)) + rows (map-new i32 dyn)] + (put ops "one" (adder 1)) + (put ops "ten" (adder 10)) + (put ops "hundred" (adder 100)) + ;; Each value a dyn vector the collector allocated, reachable from + ;; nothing but the map. + (dotimes [i 64] + (let [row (vec-new dyn)] + (push row i) + (push row "row") + (put rows i row))) + (churn 40000) + ;; Grown after the churn, so a rebuilt block is walked too. + (dotimes [i 64] + (put many i (adder i))) + (churn 40000) + (let [total 0] + (dotimes [i 64] + (set total (+ total (match (get many i) (Some f) (f 0) None 0)))) + (println total)) + (dotimes [i 3] + (let [name (at ["one" "ten" "hundred"] i)] + (println (match (get ops name) (Some f) (f 1) None -1)))) + (let [cur (i64 0) + k 0 + v (the dyn nil) + sum 0 + n 0] + (while (map-next rows (addr cur) (addr k) (addr v)) + (set sum (+ sum (i32 (at v 0)))) + (set n (+ n 1))) + (println n) + (println sum)) + (free ops) + (free many) + (free rows)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 2cdd798d..1a47a9f6 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4732,8 +4732,15 @@ level "1" "programs/fn-vec-stale.flan" fn_vec_stale_out; outputs ~x86:true "a stale Vec header is not marked through, --x86" "programs/fn-vec-stale.flan" fn_vec_stale_out; - refuses "a Map cannot hold function values" "programs/fn-in-map.flan" - "a Map's storage is not walked"; + (* A Map's block is walked: closures and dyn values held only by a Map + survive enough allocation to collect many times. *) + let fn_in_map_out = "2016\n2\n11\n101\n64\n2016\n" in + outputs "a Map keeps its closures and dyn values alive" + "programs/fn-in-map.flan" fn_in_map_out; + outputs ~opt:"-O0" "a Map keeps its closures and dyn values alive, -O0" + "programs/fn-in-map.flan" fn_in_map_out; + outputs ~x86:true "a Map keeps its closures and dyn values alive, --x86" + "programs/fn-in-map.flan" fn_in_map_out; (* Capture is by value, and a store into a copy is refused rather than left to change the copy and not the local. *) refuses "a captured local is a copy and cannot be assigned"