diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 375be79a..83ac74d8 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1540,56 +1540,97 @@ static void mark_desc(char *base, const flan_desc *d) { * Rooting the text in the crossing's frame would be shorter than that and * wrong for a str returned or stored, and a pin for good would keep every * text a frame loop ever crossed. A copy into the temp arena would be sound - * too; this is the same lifetime without the copy. */ + * too; this is the same lifetime without the copy, and a dev build takes the + * copy instead ([into_text]) so that a str kept past free-temp reads the + * arena's poison, as i64->bytes's text does, rather than whatever text the + * allocator put there next. + * + * A text is pinned once per stamp, however often it crosses: the stamp's + * number is written into the text's [gen], which nothing else reads for a + * text, so a program that never calls free-temp and passes the same texts + * in a loop keeps a flat list. Distinct texts cost one pointer each here, + * and each keeps its own object alive until the stamp ends — heavier than + * i64->bytes's few bytes of arena, since the object has a header. The pins + * sit in runs, one per stamp, so an entry is a pointer and a run's stamp is + * kept once. */ const void *flan_temp_stamp(uint64_t *inc, uint64_t *epoch); int32_t flan_temp_stamp_live(const void *a, uint64_t inc, uint64_t epoch); -typedef struct text_pin { - flan_obj *o; +typedef struct pin_run { const void *a; uint64_t inc, epoch; -} text_pin; + int64_t start; /* its first entry in [pins] */ +} pin_run; -static text_pin *pins; -static int64_t pins_n, pins_cap; +static flan_obj **pins; +static int64_t pins_n, pins_cap; +static pin_run *runs; +static int64_t runs_n, runs_cap; +/* The number the newest run's texts carry in [gen]; never 0, which is what + a text is made with. A wrap would take four billion stamps, and costs one + duplicate entry when it lands on an old text's number. */ +static uint32_t pin_gen; + +static int64_t pins_count(void) { return pins_n; } static void pins_prune(void) { - int64_t i, k = 0; - for (i = 0; i < pins_n; i++) - if (flan_temp_stamp_live(pins[i].a, pins[i].inc, pins[i].epoch)) - pins[k++] = pins[i]; + int64_t r, k = 0, rk = 0; + for (r = 0; r < runs_n; r++) { + int64_t lo = runs[r].start; + int64_t hi = r + 1 < runs_n ? runs[r + 1].start : pins_n; + if (!flan_temp_stamp_live(runs[r].a, runs[r].inc, runs[r].epoch)) continue; + memmove(pins + k, pins + lo, (size_t)(hi - lo) * sizeof *pins); + runs[rk] = runs[r]; + runs[rk].start = k; + k += hi - lo; + rk++; + } pins_n = k; + runs_n = rk; +} + +static void *pins_grow(void *p, int64_t *cap, size_t each) { + int64_t c = *cap ? *cap * 2 : 64; + void *q = realloc(p, (size_t)c * each); + if (q == NULL) trap_oom(NULL, 0, c * (int64_t)each); + *cap = c; + return q; } static void pin_text(flan_obj *o) { uint64_t inc, epoch; const void *a = flan_temp_stamp(&inc, &epoch); - text_pin *last = pins_n > 0 ? &pins[pins_n - 1] : NULL; - if (last != NULL && last->o == o && last->a == a && last->inc == inc - && last->epoch == epoch) + pin_run *last = runs_n > 0 ? &runs[runs_n - 1] : NULL; + if (last == NULL || last->a != a || last->inc != inc + || last->epoch != epoch) { + if (runs_n == runs_cap) { + pins_prune(); + if (runs_n == runs_cap) runs = pins_grow(runs, &runs_cap, sizeof *runs); + } + runs[runs_n].a = a; + runs[runs_n].inc = inc; + runs[runs_n].epoch = epoch; + runs[runs_n].start = pins_n; + runs_n++; + if (++pin_gen == 0) pin_gen = 1; + } else if (o->gen == pin_gen) return; if (pins_n == pins_cap) { pins_prune(); - if (pins_n == pins_cap) { - int64_t cap = pins_cap ? pins_cap * 2 : 64; - text_pin *p = (text_pin *)realloc(pins, (size_t)cap * sizeof *p); - if (p == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *p); - pins = p; - pins_cap = cap; - } + if (pins_n == pins_cap) pins = pins_grow(pins, &pins_cap, sizeof *pins); } - pins[pins_n].o = o; - pins[pins_n].a = a; - pins[pins_n].inc = inc; - pins[pins_n].epoch = epoch; - pins_n++; + o->gen = pin_gen; + pins[pins_n++] = o; } +/* How many texts are pinned now, for a test that the list stays flat. */ +int64_t flan_dyn_pin_count(void) { return pins_count(); } + static void gc_mark_all(void) { int64_t i; unsigned k; pins_prune(); - for (i = 0; i < pins_n; i++) mark_push(pins[i].o); + for (i = 0; i < pins_n; i++) mark_push(pins[i]); for (i = 0; i < roots_n; i++) { const flan_desc *d = roots[i].desc; if (d == NULL) mark_value(*(flan_dyn *)roots[i].base); @@ -4219,10 +4260,23 @@ static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p); static void into_slice(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p); -/* A text's bytes as a str's two words, pinned. */ +/* A text's bytes as a str's two words, pinned — or, in a dev build, copied + * into the temp arena, whose registry note and poison catch a str kept past + * free-temp (see [pin_text]). */ static void into_text(flan_dyn x, uint8_t *p) { flan_obj *o = dyn_obj(x); const uint8_t *b = obj_text_bytes(o); + if (flan_dev_reg_enabled()) { + uint8_t *q = NULL; + if (o->len > 0) { + q = (uint8_t *)flan_temp_block(o->len, 1, 1, "u8", 2); + if (q == NULL) trap_oom(NULL, 0, o->len); + memcpy(q, b, (size_t)o->len); + } + memcpy(p, &q, 8); + memcpy(p + 8, &o->len, 8); + return; + } pin_text(o); memcpy(p, &b, 8); memcpy(p + 8, &o->len, 8); @@ -4282,9 +4336,18 @@ static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) { into_trap(s, "DynRange", "%s is %lld, which has no exact %s. Write " "it as a float, as in %lld.0", into_who(s), (long long)n, *d == 'f' ? "f32" : "f64", (long long)n); - } else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) + } else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) { f = dyn_num_value(x); - else { + /* A finite float past f32's range would become inf, which is a change + of value and not a rounding: refused, as an int out of range is. */ + if (*d == 'f' && f == f && f - f == 0 && (f > 3.4028234663852886e38 + || f < -3.4028234663852886e38)) { + char sx[SAY_MAX]; + say(sx, SAY_MAX, x); + into_trap(s, "DynRange", "%s is %s, and an f32 holds -3.4028235e38 " + "to 3.4028235e38", into_who(s), sx); + } + } else { into_wanted(why, sizeof why, d); into_wrong(s, x, why); } @@ -4348,16 +4411,60 @@ static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) { return; } memcpy(saved, s->where, sizeof saved); + /* What the value is called in a sentence: its place inside the whole, + else what it is — a struct's view, a class's instance, a map. */ + { + char what[160]; + flan_obj *m = dyn_obj(x); + int64_t i, n; + if (s->where[0]) snprintf(what, sizeof what, "%s", s->where); + else if (o != NULL) { + const char *nm; + int64_t nl; + view_struct_name(o, &nm, &nl); + snprintf(what, sizeof what, "this %.*s", (int)nl, nm); + } else if (m->u.v.klass != NULL) { + kw_entry *k = m->u.v.klass; + snprintf(what, sizeof what, "this %.*s", (int)k->len, + (const char *)kw_bytes(k)); + } else + snprintf(what, sizeof what, "this map"); + at = desc_fields(d, &off); + while (desc_next(&at, &off, &name, &namelen, &foff, &fty)) + if (!flan_dyn_truthy(flan_dyn_map_contains_at( + x, flan_dyn_kw(name, namelen), s->loc, s->loclen))) { + desc_spell(d, ty, sizeof ty); + into_trap(s, "DynType", "%s has no :%.*s, and %s %s needs every " + "field", what, (int)namelen, (const char *)name, an(ty), + ty); + } + /* A key the struct has no field for is refused, as a class refuses a + slot it does not declare: dropping it would lose what was written. */ + if (o == NULL) class_sync(m); + n = o != NULL ? view_nfields(o) : m->len; + for (i = 0; i < n; i++) { + flan_dyn k = o != NULL ? view_field_key(o, i) : m->u.v.items[2 * i]; + int64_t foff2; + if (desc_field(d, k, &foff2) == NULL) { + char sk[SAY_MAX]; + int64_t off2; + const uint8_t *at2; + say(sk, SAY_MAX, k); + desc_spell(d, ty, sizeof ty); + said_len = 0; + said_add("dyn %s: %s has %s, and %s %s has no field %s. Its fields " + "are", s->op, what, sk, an(ty), ty, sk); + at2 = desc_fields(d, &off2); + while (desc_next(&at2, &off2, &name, &namelen, &foff, &fty)) + said_add(" :%.*s", (int)namelen, (const char *)name); + flan_say(s->loc, s->loclen, "%s", said_buf); + dyn_trap((const uint8_t *)"DynType", 7); + } + } + } at = desc_fields(d, &off); while (desc_next(&at, &off, &name, &namelen, &foff, &fty)) { flan_dyn k = flan_dyn_kw(name, namelen), v; - if (!flan_dyn_truthy(flan_dyn_map_contains_at(x, k, s->loc, - s->loclen))) { - desc_spell(d, ty, sizeof ty); - into_trap(s, "DynType", "%s has no :%.*s, and %s %s needs every " - "field", s->where[0] ? s->where : "this map", - (int)namelen, (const char *)name, an(ty), ty); - } v = flan_dyn_get(x, k, s->loc, s->loclen); into_enter(s, "field :%.*s", (int)namelen, (const char *)name); into_put(s, fty, v, p + foff); diff --git a/test/programs/dyn-into-typed.flan b/test/programs/dyn-into-typed.flan index 22db7401..cc70fe4d 100644 --- a/test/programs/dyn-into-typed.flan +++ b/test/programs/dyn-into-typed.flan @@ -42,6 +42,15 @@ (defn f64s [xs [f64]] () (println (length xs))) (defn raw [xs [u8]] () (println (length xs))) +(declare pin-count [] i64 "flan_dyn_pin_count") +(defn slen [s str] i64 (length s)) +(defn f32s [xs [const f32]] () (println (length xs))) +(defclass pq [x]) + +;; A str kept in a global past free-temp: a dev build's copy is poisoned. +(defonce kept str "") +(defn stash-str [] () (set kept (keep-str (keep "kept text")))) + ;; A view of a local, kept past the call that owns the local. (defonce held dyn nil) (defn leak-local [] () @@ -72,6 +81,10 @@ (free-temp) (gc-collect) (println (< (- (gc-count) before) 100))) + ;; The same texts crossing again and again are pinned once each. + (let [t1 (keep "one") t2 (keep "two") n (i64 0)] + (dotimes [i 100000] (set n (+ n (slen t1) (slen t2)))) + (println n (< (pin-count) 10))) ;; A view of typed storage comes back as that storage. (let [a [(i64 1) 2 3]] (bump (keep a)) @@ -112,4 +125,14 @@ (= n 9) (do (raw (keep "abc")) 0) (= n 10) (let [a [(f32 1) 2]] (f64s (keep a)) 0) (= n 11) (do (println (px (the dyn {:x 1.5 :y "no"}))) 0) + (= n 12) (do (f32s (the dyn [1.5 1e300])) 0) + (= n 13) (do (println (px (pq 1.5))) 0) + (= n 14) (do (println (px (the dyn {:x 1.5 :y 2 :z 3}))) 0) + (= n 15) + (do (stash-str) + (free-temp) + (gc-collect) + (dotimes [i 1000] (text-of (keep "XXXXXXXXXX"))) + (println (at kept 0)) + 0) :else 1))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 629ffb34..d5591101 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -6106,10 +6106,10 @@ level "1" each naming the element and what it holds. Mode 8, a view of a returned call's local, traps under --dev only. *) let into_out = - "hello\n4\npinne\ntrue\n[101 102 103]\n306\n105 106\n10\n3.5\n258\n\ + "hello\n4\npinne\ntrue\n600000 true\n[101 102 103]\n306\n105 106\n10\n3.5\n258\n\ 131\nada\nbo\n3\n15\n40\n10\n3\n3.5\n5.5\n4.25\ncy 9\n" and into_traps = - [ ("1", "dyn-into-typed.flan:104:33: dyn into [const i64]: element 1 \ + [ ("1", "dyn-into-typed.flan:117:33: dyn into [const i64]: element 1 \ is a text, \"a\", and an i64 is wanted there"); ("2", "dyn into [i64]: this vec is a dyn vec, so a [i64] of it would \ be a copy, and a write through the copy would never reach the \ @@ -6123,7 +6123,13 @@ level "1" ("9", "a text is read-only, so it becomes a str or a [const u8] and \ never a [u8]"); ("10", "this vec is a view of f32 elements"); - ("11", "field :y is a text, \"no\", and an i32 is wanted there") ] + ("11", "field :y is a text, \"no\", and an i32 is wanted there"); + ("12", "element 1 is 1e+300, and an f32 holds -3.4028235e38 to \ + 3.4028235e38"); + ("13", "dyn into Point: this pq has no :y, and a Point needs every \ + field"); + ("14", "dyn into Point: this map has :z, and a Point has no field \ + :z. Its fields are :x :y") ] and into_stale = [ ("8", "dyn into [i64]: this view points into a local of leak-local, \ and that call has returned") ] @@ -6151,6 +6157,16 @@ level "1" saying %S\n" (name (", mode " ^ mode)) text code needle end) (into_traps @ if dev then into_stale else []); + (* A str from a text kept in a global past free-temp: a dev build's + copy reads the arena's poison (0xEF), never another text's bytes. *) + if dev then begin + let code, text = run exe (Some "15") in + if code <> 0 || text <> "239\n" then begin + incr failures; + Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted: %S\n" + (name ", a str kept past free-temp") text code "239\n" + end + end; (try Sys.remove exe with Sys_error _ -> ()) in dyn_into ();