From 497c9f470fe90d13a8c9a38636ce992b7e9424e4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 09:54:45 +0700 Subject: [PATCH] A dyn view's record is collected with it, a dev build ties a view of a stack address to its owning frame and finds a heap block through an address index, and a view's traps name the field, the operation and the site. --- docs/BUILT.md | 15 +- lib/check.ml | 23 +- lib/emit.ml | 16 +- lib/x86.ml | 4 + runtime/flan_dev.c | 162 +++++++++++++- runtime/flan_dyn.c | 375 +++++++++++++++++++++++++++----- test/programs/dyn-view-any.flan | 56 +++++ test/test_acceptance.ml | 33 ++- 8 files changed, 599 insertions(+), 85 deletions(-) diff --git a/docs/BUILT.md b/docs/BUILT.md index f2ea2a5a..e9f3ef4f 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3076,10 +3076,15 @@ A typed container crosses into dyn as a view of its storage wherever that storag - `check.ml`'s `frame_root` says when the storage is the calling function's own frame — a local, a parameter, a field or array element of one, a slice cut straight from a local array, or a temporary `box` bound to a slot of its own — and passes that as the view's `here` flag. -- `emit.ml` and `x86.ml` zero a `serial` word in every shadow frame at the push. +- `emit.ml` and `x86.ml` zero a `serial` word in every shadow frame at the push, and store the frame's address + (`llvm.frameaddress`, or `rbp`). - `flan_dyn.c`'s `view_make` claims a serial for the frame at the crossing (`flan_dev_frame_claim`, which numbers a - frame once) and keeps the frame's address, its serial and the function's name. Otherwise it asks the allocation - registry for the smallest live block holding the address and keeps that block's base and note sequence. + frame once) and keeps the frame's address, its serial and the function's name. Without `here` it first asks + `flan_dev_frame_owner` whether the address is on the stack: every local of a frame lies below that frame's address + and above everything its callees push, so the owner is the innermost frame whose address is above it. That is how a + slice of a local, or a slice parameter over a caller's array, is tied to the right activation. Otherwise it asks + the allocation registry, through its address index (64 KiB chunks to the bases that overlap them), for the + smallest live block holding the address and keeps that block's base and note sequence. - Every read or write checks first. A frame is alive when it is still on the chain from `flan_frame_head` *and* has the same serial: the walk is needed because dead stack keeps its old bytes, serial included, and the serial is needed because the next call at the same depth lands at the same address. A block is alive when the registry probe @@ -3088,8 +3093,8 @@ A typed container crosses into dyn as a view of its storage wherever that storag A view's aggregate element inherits its parent's record, except inside a `Vec` (checked against the `Vec`'s block, since growth moves it) and through a slice (looked up afresh). What neither table knows is not checked: a global, -rodata, C memory, and a caller's local reached through a slice parameter. That last one is deliberate — stamping it -with the callee's frame would trap on a live array after the callee returns. A release build records nothing and +rodata, C memory. Nor is a local's scope inside a live frame: a view of a `let` that has ended, whose slot a later +`let` in the same call reuses, reads the new value. A release build records nothing and checks nothing; a stale view there reads whatever the memory holds now. One case is refused at compile time instead: a dyn global's initialiser taking a view of what it built, which is gone before anything can read it. diff --git a/lib/check.ml b/lib/check.ml index 0de974a6..aa7423a1 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3759,11 +3759,10 @@ let view_not_yet loc (e : Tast.expr) (inner : Types.t) = activation and traps if the view is used after the call returns. A local, a parameter (copied into the frame, an array parameter too), a field or an array element of one, a slice cut directly from a local array, and a - temporary [box] has bound to a slot of its own are all the frame's. A - slice's data, and anything reached through a [Ptr] or a global, is not: - there the runtime looks the address up in the allocation registry instead, - and storage the registry does not know — a global, or a caller's local - seen through a slice parameter — is not checked. *) + temporary [box] has bound to a slot of its own are all the frame's. For + anything else — a slice's data, a [Ptr]'s target, a global — the dev + runtime finds the frame that owns a stack address by the address itself, + or else the registry block that holds it. *) let rec frame_root (e : Tast.expr) : bool = let rec all_array ty = function | [] -> true @@ -4348,7 +4347,8 @@ let box_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = (* [=] over a dyn pair, answering a bool. Shared by the [=] builtin and a literal [match] over a dyn, which is (= t lit) by definition. *) let dyn_eq loc u v = - unbox loc Types.Bool (rt loc Types.Dyn "flan_dyn_eq" [ box loc u; box loc v ]) + unbox loc Types.Bool + (rt loc Types.Dyn "flan_dyn_eq_at" [ box loc u; box loc v; here loc ]) let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = let oty = Types.Option t in @@ -10908,7 +10908,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = | "<" -> "flan_dyn_lt" | "<=" -> "flan_dyn_le" | ">" -> "flan_dyn_gt" | _ -> "flan_dyn_ge" in - (* [eq] never traps and takes no site; the four orderings do, and get + (* [eq] traps only on a view whose storage is gone, and [dyn_eq] gives + it the site for that; the four orderings trap on a mismatch, and get one, for the reason [dyn_fold] gives. Every pair of a chain gets the same site — the whole comparison is written at one place, and a trap from any of its pairs happened there. *) @@ -12105,8 +12106,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = if target.Tast.ty = Types.Dyn then expect ctx loc ~want (unbox loc Types.Bool - (rt loc Types.Dyn "flan_dyn_map_contains" - [ target; check ctx ~want:Types.Dyn k ])) + (rt loc Types.Dyn "flan_dyn_map_contains_at" + [ target; check ctx ~want:Types.Dyn k; here loc ])) else begin let kt, vt = map_kv loc "has-key?" target.Tast.ty in let k = check ctx ~want:kt k in @@ -12432,7 +12433,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = pair of allocations per iteration. The runtime answers a dyn; it is unboxed at once and narrowed the way the Vec's i64 above is. *) | Types.Dyn -> - let n = unbox loc (Types.Int Types.I64) (rt loc Types.Dyn "flan_dyn_len" [ a ]) in + let n = unbox loc (Types.Int Types.I64) (rt loc Types.Dyn "flan_dyn_len_at" [ a; here loc ]) in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) | other -> fail loc @@ -12957,7 +12958,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = ei64 = (fun x -> write (conv Tast.I64ToBytes x)); eu64 = (fun x -> write (conv Tast.U64ToBytes x)); ef64 = (fun x -> write (conv Tast.F64ToBytes x)); - edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print", [ x ]))) } + edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print_at", [ x; here loc ]))) } in let rc = render_ctx ctx emitter in let render_one a = diff --git a/lib/emit.ml b/lib/emit.ml index 3bef9108..97240c6e 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -251,7 +251,7 @@ module Rt = struct let flanframe = { sname = "flanframe"; fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr; "at", Ptr; - "serial", I64 ] } + "serial", I64; "fp", Ptr ] } let align_up n a = (n + a - 1) / a * a @@ -4481,6 +4481,15 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = "%%frame.n = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d" (Rt.index Rt.flanframe "serial"); "store i64 0, ptr %frame.n"; + (* The frame address: every local lies below it, so the dev runtime + can tell which frame a stack address belongs to + ([flan_dev_frame_owner]). Asking for it keeps this function's + frame pointer, which only a dev build pays. *) + "%frame.fpv = call ptr @llvm.frameaddress.p0(i32 0)"; + Printf.sprintf + "%%frame.f = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d" + (Rt.index Rt.flanframe "fp"); + "store ptr %frame.fpv, ptr %frame.f"; "store ptr %frame, ptr @flan_frame_head" ]; f.frame <- Some prev; (* The parameters are bound before the body starts, so they are recorded @@ -4922,6 +4931,7 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg) declare i32 @llvm.bswap.i32(i32) +declare ptr @llvm.frameaddress.p0(i32 immarg) declare void @flan_rt_init(i32, ptr) declare void @flan_argv(ptr) declare void @flan_write_stdout(ptr, i64) @@ -5013,6 +5023,7 @@ declare i64 @flan_dyn_map_get(i64, i64) declare i64 @flan_dyn_get(i64, i64, ptr, i64) declare void @flan_dyn_map_set(i64, i64, i64) declare i64 @flan_dyn_map_contains(i64, i64) +declare i64 @flan_dyn_map_contains_at(i64, i64, ptr, i64) ; The ones that trap carry the site as ptr+len, the way the bounds and ; arithmetic traps do: a dyn type error IS the type error in a dynamic ; program, and it used to print with no file and no line. [eq] never traps, @@ -5029,11 +5040,14 @@ declare i64 @flan_dyn_gt(i64, i64, ptr, i64) declare i64 @flan_dyn_ge(i64, i64, ptr, i64) declare i64 @flan_dyn_eq(i64, i64) declare i64 @flan_dyn_len(i64) +declare i64 @flan_dyn_eq_at(i64, i64, ptr, i64) +declare i64 @flan_dyn_len_at(i64, ptr, i64) declare i64 @flan_dyn_at(i64, i64, ptr, i64) declare i64 @flan_dyn_slice(i64, i64, i64, ptr, i64) declare void @flan_dyn_set_at(i64, i64, i64, ptr, i64) declare void @flan_dyn_push(i64, i64, ptr, i64) declare void @flan_dyn_print(i64) +declare void @flan_dyn_print_at(i64, ptr, i64) declare void @flan_dyn_emit_dev(i64) declare void @flan_dyn_emit_watch(i64) ; The watch table, which (watch "name" v) renders into. flan_dev.c is linked diff --git a/lib/x86.ml b/lib/x86.ml index c199f545..8a512401 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4219,6 +4219,10 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) store_int f.b ~src:rax ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "serial")) ~size:8; + (* The frame address, as emit.ml stores it: every local lies below it. *) + store_int f.b + ~src:rbp ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "fp")) + ~size:8; lea f.b ~dst:rax ~mm:(Frame fr); store_int f.b ~src:rax ~mm:(lmem f head ~scratch:r11) ~size:8; (* The parameters are bound before the body starts, so they are recorded diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 0ea2ed37..d4ed83fc 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1116,6 +1116,11 @@ typedef struct flan_frame { * this activation from the next call to land at the same address, which a * view kept past the return would otherwise take for its own. */ uint64_t serial; + /* The function's frame address (its rbp), stored at the push. Every local + * of the function lies below it and above everything its callees push, so + * a stack address belongs to the innermost frame whose [fp] is above it + * ([flan_dev_frame_owner]). */ + const void *fp; } flan_frame; /* The compiler names this symbol directly. A redefinition module reaches it @@ -1168,6 +1173,23 @@ int32_t flan_dev_frame_alive(const void *frame, uint64_t serial) { return 0; } +/* The frame whose storage holds the stack address [p], for a view the + * compiler could not tie to its own frame: a slice of a local, or a slice + * parameter over a caller's. The stack grows down, so [p] is on it only when + * it is above this function's own frame, and it is the innermost Flan frame + * whose frame address is above it that owns it. NULL for anything else — the + * heap, a global, or stack above every Flan frame. */ +void *flan_dev_frame_owner(const void *p) { + uintptr_t a = (uintptr_t)p; + flan_frame *f; + if (flan_frame_head == NULL + || a <= (uintptr_t)__builtin_frame_address(0)) + return NULL; + for (f = flan_frame_head; f != NULL; f = f->prev) + if (f->fp != NULL && (uintptr_t)f->fp > a) return f; + return NULL; +} + /* [i] counts from the innermost. NULL past the end, which is how a caller * learns the depth without a second walk. */ void *flan_dev_frame_at(int32_t i) { @@ -1556,6 +1578,122 @@ static size_t flan_reg_slot(uintptr_t a) { & (FLAN_REG_CAP - 1); } +/* ── The registry by address ────────────────────────────────────────── + * + * The table above answers "which block starts here"; a dyn view crossing + * asks "which live block holds this address", once per crossing, and a scan + * of every slot for that cost microseconds a crossing. So each live block's + * base is also filed under every 64 KiB chunk it overlaps, and the question + * reads one chunk's short list. A block wider than FLAN_IX_WIDE chunks goes + * on one list of its own, read every time; there are few such blocks. Only + * the game thread reads or writes it. + * + * A base is filed when its note is written and taken out when the block dies. + * An entry here is a hint, not a fact: the list names bases, and the answer + * is always the table's entry for that base, checked live and containing. */ +#define FLAN_IX_SHIFT 16 +#define FLAN_IX_WIDE 64 + +typedef struct { + uintptr_t key; /* chunk + 1; 0 for an empty bucket */ + int32_t n, cap; + uintptr_t *bases; +} flan_ix_bucket; + +static flan_ix_bucket *flan_ix; +static size_t flan_ix_cap, flan_ix_used; +static uintptr_t *flan_ix_wide; +static int32_t flan_ix_widen, flan_ix_widecap; + +static size_t flan_ix_hash(uintptr_t key) { + return (size_t)((key * 11400714819323198485ULL) >> 20); +} + +static flan_ix_bucket *flan_ix_find(uintptr_t chunk, int make) { + uintptr_t key = chunk + 1; + size_t i, mask; + if (flan_ix_cap == 0) { + if (!make) return NULL; + flan_ix = (flan_ix_bucket *)calloc(1024, sizeof *flan_ix); + if (flan_ix == NULL) return NULL; + flan_ix_cap = 1024; + } + if (make && (flan_ix_used + 1) * 2 > flan_ix_cap) { + size_t ncap = flan_ix_cap * 2, j; + flan_ix_bucket *n = (flan_ix_bucket *)calloc(ncap, sizeof *n); + if (n == NULL) return NULL; + for (j = 0; j < flan_ix_cap; j++) { + size_t k; + if (flan_ix[j].key == 0) continue; + for (k = flan_ix_hash(flan_ix[j].key) & (ncap - 1); n[k].key != 0; + k = (k + 1) & (ncap - 1)) {} + n[k] = flan_ix[j]; + } + free(flan_ix); + flan_ix = n; + flan_ix_cap = ncap; + } + mask = flan_ix_cap - 1; + for (i = flan_ix_hash(key) & mask;; i = (i + 1) & mask) { + if (flan_ix[i].key == key) return &flan_ix[i]; + if (flan_ix[i].key == 0) { + if (!make) return NULL; + flan_ix[i].key = key; + flan_ix_used++; + return &flan_ix[i]; + } + } +} + +static void flan_ix_list_add(uintptr_t **v, int32_t *n, int32_t *cap, + uintptr_t base) { + int32_t i; + for (i = 0; i < *n; i++) if ((*v)[i] == base) return; + if (*n == *cap) { + int32_t ncap = *cap ? *cap * 2 : 4; + uintptr_t *nv = (uintptr_t *)realloc(*v, (size_t)ncap * sizeof **v); + if (nv == NULL) return; + *v = nv; + *cap = ncap; + } + (*v)[(*n)++] = base; +} + +static void flan_ix_list_del(uintptr_t *v, int32_t *n, uintptr_t base) { + int32_t i; + for (i = 0; i < *n; i++) + if (v[i] == base) { v[i] = v[--*n]; return; } +} + +static void flan_ix_file(uintptr_t base, int64_t bytes, int add) { + uintptr_t c, lo = base >> FLAN_IX_SHIFT, + hi = (base + (uintptr_t)bytes - 1) >> FLAN_IX_SHIFT; + if (bytes <= 0) return; + if (hi - lo >= FLAN_IX_WIDE) { + if (add) flan_ix_list_add(&flan_ix_wide, &flan_ix_widen, &flan_ix_widecap, base); + else flan_ix_list_del(flan_ix_wide, &flan_ix_widen, base); + return; + } + for (c = lo; c <= hi; c++) { + flan_ix_bucket *b = flan_ix_find(c, add); + if (b == NULL) continue; + if (add) flan_ix_list_add(&b->bases, &b->n, &b->cap, base); + else flan_ix_list_del(b->bases, &b->n, base); + } +} + +/* The live entry for [base], by the probe a free takes. */ +static flan_reg_entry *flan_reg_live_at(uintptr_t base) { + size_t s = flan_reg_slot(base); + int64_t probe; + for (probe = 0; probe < FLAN_REG_CAP; probe++) { + size_t j = (s + (size_t)probe) & (FLAN_REG_CAP - 1); + if (flan_reg[j].base == 0) return NULL; + if (flan_reg[j].base == base && flan_reg[j].died == 0) return &flan_reg[j]; + } + return NULL; +} + /* Drop every dead entry and re-insert the live ones. Called when the table is * filling *and* there is a worthwhile number of dead in it: in a long-running * program the dead are the bulk of it, and losing them is much cheaper than @@ -1678,6 +1816,7 @@ static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem, flan_reg[j].owner = owner; flan_reg[j].sliced = sliced; flan_reg_end(&flan_reg[j]); + flan_ix_file(a, bytes, 1); return; } /* Every slot in use, and the compaction above declined to run because what @@ -1770,6 +1909,7 @@ void flan_dev_reg_dead(void *base) { flan_reg[j].died = ++flan_reg_seq; flan_reg_end(&flan_reg[j]); flan_reg_dead++; + flan_ix_file(a, flan_reg[j].bytes, 0); } return; } @@ -1794,6 +1934,7 @@ void flan_dev_reg_dead_range(void *base, int64_t bytes) { e->died = now; flan_reg_end(e); flan_reg_dead++; + flan_ix_file(e->base, e->bytes, 0); } } } @@ -1814,18 +1955,25 @@ int32_t flan_dev_reg_live(const void *p) { * same note is still alive. The smallest, because an arena's own region can * be a block too, and it outlives the allocation inside it that a free-all * ends. 0 when no live block holds [p] — a global, a frame, C memory — and - * always in a release build. A scan, once per crossing, in a dev build. */ + * always in a release build. Read through the address index above. */ int32_t flan_dev_reg_claim(const void *p, uintptr_t *base, int64_t *seq, const char **type, int64_t *typelen) { uintptr_t a = (uintptr_t)p; flan_reg_entry *best = NULL; - int64_t i; + flan_ix_bucket *b; + int32_t i, pass; if (!flan_reg_on || a == 0) return 0; - for (i = 0; i < FLAN_REG_CAP; i++) { - flan_reg_entry *e = &flan_reg[i]; - if (e->base == 0 || e->died != 0) continue; - if (a < e->base || a >= e->base + (uintptr_t)e->bytes) continue; - if (best == NULL || e->bytes < best->bytes) best = e; + b = flan_ix_find(a >> FLAN_IX_SHIFT, 0); + for (pass = 0; pass < 2; pass++) { + uintptr_t *v = pass == 0 ? (b ? b->bases : NULL) : flan_ix_wide; + int32_t n = pass == 0 ? (b ? b->n : 0) : flan_ix_widen; + for (i = 0; i < n; i++) { + flan_reg_entry *e; + if (a < v[i]) continue; + e = flan_reg_live_at(v[i]); + if (e == NULL || a >= e->base + (uintptr_t)e->bytes) continue; + if (best == NULL || e->bytes < best->bytes) best = e; + } } if (best == NULL) return 0; *base = best->base; diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 41899587..8c2a24e6 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -392,6 +392,20 @@ static inline int64_t obj_words(flan_obj *o) { static inline uint8_t *obj_text_bytes(flan_obj *o) { return (uint8_t *)(o + 1); } +/* What trails an OBJ_VIEW's header: the dev check's record of its storage, + * explained with the view helpers below. Allocated with every view, and + * charged to the heap and taken back by the sweep with it. */ +typedef struct view_guard { + const void *frame; /* NULL when no frame is checked */ + uint64_t serial; + const char *fname; /* whose frame, for the sentence */ + int64_t fnamelen; + uintptr_t rbase; /* 0 when no block is checked */ + int64_t rseq; + const char *rtype; + int64_t rtypelen; +} view_guard; + static flan_obj *gc_all; /* the sweep list */ static int64_t gc_bytes; /* what the live objects hold, headers included */ static int64_t gc_count; @@ -635,11 +649,18 @@ static double dyn_num_value(flan_dyn v); * they are defined, alongside the container operations below */ static int64_t view_len(const uint8_t *loc, int64_t loclen, const char *op, flan_obj *o); +static void view_guard_check(const uint8_t *loc, int64_t loclen, + const char *op, flan_obj *o); /* A struct view's fields, for the map arms of the printers. */ static int64_t view_nfields(flan_obj *o); static flan_dyn view_field_key(flan_obj *o, int64_t i); static flan_dyn view_field_val(flan_obj *o, int64_t i); static void view_struct_name(flan_obj *o, const char **name, int64_t *len); +/* 1 when element (or, with [field], field) [i] of view [o] is a u64 above + * the largest dyn int: it has no dyn value, and the printers write its + * digits instead of reading it. */ +static int view_big_u64(flan_obj *o, int64_t i, int field, + unsigned long long *out); /* forward: needed by [dyn_equal] below, defined alongside the view helpers * further down — a length and an element reader that answer correctly @@ -647,6 +668,26 @@ static void view_struct_name(flan_obj *o, const char **name, int64_t *len); static int64_t vecish_len(flan_obj *o); static flan_dyn vecish_at(flan_obj *o, int64_t i); +/* The site and operation a walk over a view reports a trap at — a print, an + * equality, a length — set by the entry point that has them and read by the + * element readers the walk calls. NULL when the entry point has no site. */ +static const uint8_t *walk_loc; +static int64_t walk_len; +static const char *walk_op = "print"; + +typedef struct { const uint8_t *loc; int64_t len; const char *op; } walk_site; + +static walk_site walk_enter(const uint8_t *loc, int64_t len, const char *op) { + walk_site was; + was.loc = walk_loc; was.len = walk_len; was.op = walk_op; + walk_loc = loc; walk_len = loc != NULL ? len : 0; walk_op = op; + return was; +} + +static void walk_leave(walk_site was) { + walk_loc = was.loc; walk_len = was.len; walk_op = was.op; +} + static void render(dyn_sink w, flan_dyn v, int depth, int nested) { char buf[64]; int32_t t = flan_dyn_tag(v); @@ -706,7 +747,12 @@ static void render(dyn_sink w, flan_dyn v, int depth, int nested) { if (i > 0) emit(w, " "); render(w, view_field_key(o, i), depth + 1, 1); emit(w, " "); - render(w, view_field_val(o, i), depth + 1, 1); + unsigned long long big; + if (view_big_u64(o, i, 1, &big)) { + snprintf(buf, sizeof buf, "%llu", big); + emit(w, buf); + } else + render(w, view_field_val(o, i), depth + 1, 1); } emit(w, "}"); return; @@ -734,7 +780,12 @@ static void render(dyn_sink w, flan_dyn v, int depth, int nested) { emit(w, "["); for (i = 0; i < n; i++) { if (i > 0) emit(w, " "); - render(w, vecish_at(o, i), depth + 1, 1); + unsigned long long big; + if (o->kind == OBJ_VIEW && view_big_u64(o, i, 0, &big)) { + snprintf(buf, sizeof buf, "%llu", big); + emit(w, buf); + } else + render(w, vecish_at(o, i), depth + 1, 1); } emit(w, "]"); return; @@ -742,19 +793,31 @@ static void render(dyn_sink w, flan_dyn v, int depth, int nested) { } } -void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); } +static void print_walk(flan_dyn v) { render(flan_write_stdout, v, 0, 0); } /* The same rendering into an evaluated expression's value, and into the watch * slot [flan_dev_watch_begin] opened. lib/render.ml's dyn arm calls these on * the inspecting side and [flan_dyn_print] on [println]'s. A text is quoted * even at the top, because the typed side's renderer quotes a string there: * the value "5" and the value 5 must not read alike. */ -void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); } -void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); } +void flan_dyn_emit_dev(flan_dyn v) { + walk_site was = walk_enter(NULL, 0, "print"); + render(flan_dev_emit, v, 0, 1); + walk_leave(was); +} +void flan_dyn_emit_watch(flan_dyn v) { + walk_site was = walk_enter(NULL, 0, "print"); + render(flan_dev_watch_emit, v, 0, 1); + walk_leave(was); +} /* And into a condition's message, which flan_rt.c's sink bounds. */ void flan_msg_emit(const uint8_t *p, int64_t n); -void flan_dyn_emit_msg(flan_dyn v) { render(flan_msg_emit, v, 0, 1); } +void flan_dyn_emit_msg(flan_dyn v) { + walk_site was = walk_enter(NULL, 0, "print"); + render(flan_msg_emit, v, 0, 1); + walk_leave(was); +} /* The same walk into a buffer, for a trap's sentence. Bounded and truncated * rather than allocating: a trap is the one moment when allocating would be a @@ -836,7 +899,13 @@ static void say_render(sayer *s, flan_dyn v, int depth) { if (i > 0) say_puts(s, " "); say_render(s, view_field_key(o, i), depth + 1); say_puts(s, " "); - say_render(s, view_field_val(o, i), depth + 1); + unsigned long long big; + if (view_big_u64(o, i, 1, &big)) { + char nb[32]; + snprintf(nb, sizeof nb, "%llu", big); + say_puts(s, nb); + } else + say_render(s, view_field_val(o, i), depth + 1); } say_puts(s, i == n ? "}" : i > 0 ? " ...}" : "...}"); return; @@ -871,7 +940,13 @@ static void say_render(sayer *s, flan_dyn v, int depth) { say_puts(s, "["); for (i = 0; i < n && s->n < s->cap - 8; i++) { if (i > 0) say_puts(s, " "); - say_render(s, vecish_at(o, i), depth + 1); + unsigned long long big; + if (o->kind == OBJ_VIEW && view_big_u64(o, i, 0, &big)) { + char nb[32]; + snprintf(nb, sizeof nb, "%llu", big); + say_puts(s, nb); + } else + say_render(s, vecish_at(o, i), depth + 1); } say_puts(s, i == n ? "]" : i > 0 ? " ...]" : "...]"); return; @@ -1466,6 +1541,7 @@ static void gc_sweep(void) { } else { int64_t held = (int64_t)sizeof(flan_obj); if (o->kind == OBJ_TEXT || o->kind == OBJ_ENV) held += o->len; + if (o->kind == OBJ_VIEW) held += (int64_t)sizeof(view_guard); if (o->kind == OBJ_ENV) envset_del((uintptr_t)(o + 1)); if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) { int64_t per = o->kind == OBJ_MAP ? 2 : 1; @@ -2896,7 +2972,15 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { return 0; } -flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) { +static flan_dyn eq_walk(flan_dyn a, flan_dyn b) { + /* A view is checked before the identity shortcut, so a gone one traps + even compared with itself. */ + if (dyn_boxed(a) && dyn_box(a) == BOX_OBJ && dyn_obj(a) != NULL + && dyn_obj(a)->kind == OBJ_VIEW) + view_guard_check(walk_loc, walk_len, walk_op, dyn_obj(a)); + if (dyn_boxed(b) && dyn_box(b) == BOX_OBJ && dyn_obj(b) != NULL + && dyn_obj(b)->kind == OBJ_VIEW) + view_guard_check(walk_loc, walk_len, walk_op, dyn_obj(b)); return flan_dyn_from_bool((uint8_t)dyn_equal(a, b, 0)); } @@ -3107,19 +3191,12 @@ static void desc_spell(const uint8_t *d, char *buf, size_t cap) { * which a free, a free-all, an arena's destroy and a Vec's * growth (for the block it left) all end. * - * A release build keeps neither table, so a view there records nothing and - * checks nothing. Storage neither table knows — a global, rodata, C memory, - * a caller's local reached through a slice parameter — is not checked. */ -typedef struct view_guard { - const void *frame; /* NULL when no frame is checked */ - uint64_t serial; - const char *fname; /* whose frame, for the sentence */ - int64_t fnamelen; - uintptr_t rbase; /* 0 when no block is checked */ - int64_t rseq; - const char *rtype; - int64_t rtypelen; -} view_guard; + * A frame is found by the compiler's word ([here]) or, for a stack address + * it could not tie to the calling frame, by address (flan_dev.c, + * [flan_dev_frame_owner]). A release build keeps neither table, so a view + * there records nothing and checks nothing. Storage neither table knows — a + * global, rodata, C memory — is not checked. */ +/* [view_guard] is defined beside [flan_obj], since the sweep charges it. */ uint64_t flan_dev_frame_claim(void *frame, const char **name, int64_t *namelen); int32_t flan_dev_frame_alive(const void *frame, uint64_t serial); @@ -3136,12 +3213,26 @@ extern struct flan_frame *flan_frame_head; /* runtime/flan_dev.c */ static inline view_guard *view_g(flan_obj *o) { return (view_guard *)(o + 1); } static inline int view_shape(flan_obj *o) { return (int)o->gen; } -static void guard_block(view_guard *g, const void *p) { +void *flan_dev_frame_owner(const void *p); + +/* What a dev build records of storage the compiler could not tie to the + * calling frame: the frame that owns it when it is on the stack (a slice of + * a local, a slice parameter over a caller's), else the registry block that + * holds it. Neither, and nothing is checked. */ +static void guard_storage(view_guard *g, const void *p) { + void *f; + g->frame = NULL; g->rbase = 0; - if (p != NULL) - flan_dev_reg_claim(p, &g->rbase, &g->rseq, &g->rtype, &g->rtypelen); + if (p == NULL) return; + if ((f = flan_dev_frame_owner(p)) != NULL) { + g->frame = f; + g->serial = flan_dev_frame_claim(f, &g->fname, &g->fnamelen); + return; + } + flan_dev_reg_claim(p, &g->rbase, &g->rseq, &g->rtype, &g->rtypelen); } + /* A new view record, its guard empty. */ static flan_obj *view_new(void *base, int64_t len, const uint8_t *desc, int shape) { @@ -3232,7 +3323,7 @@ static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) { memcpy(&data, p, 8); memcpy(&n, p + 8, 8); c = view_new(data, n, d + 1, VIEW_FLAT); - guard_block(view_g(c), data); + guard_storage(view_g(c), data); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c); } case 'a': { @@ -3244,7 +3335,7 @@ static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) { case 'v': c = view_new(p, 0, d + 1, VIEW_VEC); break; default: c = view_new(p, 0, d, VIEW_STRUCT); break; } - if (view_shape(parent) == VIEW_VEC) guard_block(view_g(c), p); + if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p); else *view_g(c) = *view_g(parent); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c); } @@ -3309,25 +3400,103 @@ static int int_range(uint8_t c, int64_t *lo, int64_t *hi) { * holds it exactly, the rule a class's typed float slot follows, and traps * when it does not. A float into an f32 narrows, as (f32 x) does. [v] is the * view and [x] the value, for the sentence. */ +/* "an" before a word said with a vowel sound: an i8, an f32, an Item; a + * u8, a bool, a [3 i32]. */ +static const char *an(const char *w) { + if (w[0] == 'u' && w[1] >= '0' && w[1] <= '9') return "a"; + if (w[0] != '\0' && strchr("aeiouAEIOU", w[0]) != NULL) return "an"; + if (w[0] == 'f' && w[1] >= '0' && w[1] <= '9') return "an"; + return "a"; +} + +/* A write into a struct field that the field refuses: the field by name, its + * type, what was wrong, and the call with the key in it. [why] finishes the + * sentence after the field's type. */ +static _Noreturn void field_refuse(const uint8_t *loc, int64_t loclen, + const char *op, flan_dyn v, flan_dyn key, + const uint8_t *d, flan_dyn x, + const char *trap, const char *why) { + char ty[128], sn[96], sv[SAY_MAX], sx[SAY_MAX]; + const char *nm; + int64_t nl; + kw_entry *k = dyn_kw(key); + desc_spell(d, ty, sizeof ty); + view_struct_name(dyn_obj(v), &nm, &nl); + snprintf(sn, sizeof sn, "%.*s", (int)nl, nm); + say(sv, SAY_MAX, v); + say(sx, SAY_MAX, x); + said_len = 0; + said_add("dyn %s: field :%.*s of %s %s is %s %s%s — ", op, (int)k->len, + (const char *)kw_bytes(k), an(sn), sn, an(ty), ty, why); + if (strcmp(op, "set") == 0) + said_add("(set (get %s :%.*s) %s)", sv, (int)k->len, + (const char *)kw_bytes(k), sx); + else + said_add("(put %s :%.*s %s)", sv, (int)k->len, (const char *)kw_bytes(k), + sx); + flan_say(loc, loclen, "%s", said_buf); + flan_trap((const uint8_t *)trap, (int64_t)strlen(trap)); +} + +/* ", and 1.5 is a float": what the refused value is, for a field's sentence. */ +static void value_is(char *buf, size_t cap, flan_dyn x) { + char sx[SAY_MAX]; + const char *t = tag_of(x); + if (flan_dyn_tag(x) == FLAN_DYN_TAG_NIL) { + snprintf(buf, cap, ", and the value is nil"); + return; + } + say(sx, SAY_MAX, x); + snprintf(buf, cap, ", and %s is %s %s", sx, an(t), t); +} + +/* One element or field, unboxed on the way in. The dyn value's tag must be + * the one the element's type wants, or this traps by name and never coerces a + * mismatched value into the slot; an int the element's width cannot hold + * traps too, naming both. An int goes into a float element when the float + * holds it exactly, the rule a class's typed float slot follows, and traps + * when it does not. A float into an f32 narrows, as (f32 x) does. [v] is the + * view and [x] the value, for the sentence; [key] is the field's keyword + * when [v] is a struct's view and nil for an element, and a field's refusal + * names the field. */ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, - flan_dyn v, const uint8_t *d, flan_dyn x, uint8_t *p) { - char ty[128]; + flan_dyn v, flan_dyn key, const uint8_t *d, flan_dyn x, + uint8_t *p) { + char ty[128], why[160]; int64_t lo, hi; + int field = flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD; + desc_spell(d, ty, sizeof ty); if (int_range(*d, &lo, &hi)) { int64_t n; - if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) + if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) { + if (field) { + value_is(why, sizeof why, x); + field_refuse(loc, loclen, op, v, key, d, x, "DynType", why); + } trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are int", v, x); + } n = dyn_int_value(x); if (n < lo || n > hi) { - desc_spell(d, ty, sizeof ty); + if (field) { + if (*d == 'L') + snprintf(why, sizeof why, + ", which holds no negative number, and %lld does not fit", + (long long)n); + else + snprintf(why, sizeof why, + ", which holds %lld to %lld, and %lld does not fit", + (long long)lo, (long long)hi, (long long)n); + field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why); + } if (*d == 'L') flan_say(loc, loclen, "dyn %s: %lld does not fit a u64 element, which holds no " "negative number", op, (long long)n); else flan_say(loc, loclen, - "dyn %s: %lld does not fit a %s element, which holds %lld " - "to %lld", op, (long long)n, ty, (long long)lo, (long long)hi); + "dyn %s: %lld does not fit %s %s element, which holds %lld " + "to %lld", op, (long long)n, an(ty), ty, (long long)lo, + (long long)hi); flan_trap((const uint8_t *)"DynRange", 8); } switch (*d) { @@ -3347,7 +3516,12 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, f = *d == 'f' ? (double)(float)n : (double)n; if (!(f >= -9223372036854775808.0 && f < 9223372036854775808.0) || (int64_t)f != n) { - desc_spell(d, ty, sizeof ty); + if (field) { + snprintf(why, sizeof why, + ", and %lld has no exact %s. Write it as a float, as in " + "%lld.0", (long long)n, ty, (long long)n); + field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why); + } flan_say(loc, loclen, "dyn %s: %lld has no exact %s, so it does not go into this " "element. Write it as a float, as in %lld.0", @@ -3356,29 +3530,45 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, } } else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) f = dyn_num_value(x); - else + else { + if (field) { + value_is(why, sizeof why, x); + field_refuse(loc, loclen, op, v, key, d, x, "DynType", why); + } trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are float", v, x); + } if (*d == 'f') { float g = (float)f; memcpy(p, &g, 4); } else memcpy(p, &f, 8); return; } case '?': - if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL) + if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL) { + if (field) { + value_is(why, sizeof why, x); + field_refuse(loc, loclen, op, v, key, d, x, "DynType", why); + } trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are bool", v, x); + } *p = dyn_payload(x) ? 1 : 0; return; case 't': + if (field) + field_refuse(loc, loclen, op, v, key, d, x, "DynType", + ", which is read-only through a dyn view"); trap2(loc, loclen, TYPE_TRAP, op, "a str element is read-only through a dyn view", v, x); default: { char sx[SAY_MAX]; - desc_spell(d, ty, sizeof ty); + if (field) + field_refuse(loc, loclen, op, v, key, d, x, "DynType", + ", which a dyn view does not replace whole. Write into " + "its own elements or fields instead"); say(sx, SAY_MAX, x); flan_say(loc, loclen, - "dyn %s: this element is a %s, and a dyn view does not replace " + "dyn %s: this element is %s %s, and a dyn view does not replace " "it whole — write into its own elements or fields instead of " "storing %s", - op, ty, sx); + op, an(ty), ty, sx); flan_trap((const uint8_t *)"DynType", 7); } } @@ -3394,12 +3584,13 @@ static uint8_t *view_elem_at(flan_obj *o, int64_t i) { * typed container (OBJ_VIEW, native bytes boxed on the way out) — the pair * [dyn_equal]'s VEC arm and the printers need. */ static int64_t vecish_len(flan_obj *o) { - return o->kind == OBJ_VIEW ? view_len(NULL, 0, "=", o) : o->len; + return o->kind == OBJ_VIEW ? view_len(walk_loc, walk_len, walk_op, o) : o->len; } static flan_dyn vecish_at(flan_obj *o, int64_t i) { if (o->kind == OBJ_VIEW) - return view_read(NULL, 0, "print", o, o->u.view.desc, view_elem_at(o, i)); + return view_read(walk_loc, walk_len, walk_op, o, o->u.view.desc, + view_elem_at(o, i)); return o->u.v.items[i]; } @@ -3433,8 +3624,8 @@ static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op, * array's or the struct's first byte) or a slice's data, [len] a flat * view's element count, [desc] the element's descriptor (the struct's own, * for a struct view). [here] is the checker's word that the storage is the - * calling function's own frame; otherwise a dev build looks the address up - * in the allocation registry. */ + * calling function's own frame; otherwise a dev build finds the frame that + * owns a stack address, or the registry block that holds a heap one. */ static flan_dyn view_make(void *base, int64_t len, const uint8_t *desc, int shape, int32_t here) { flan_obj *o = view_new(base, len, desc, shape); @@ -3446,7 +3637,7 @@ static flan_dyn view_make(void *base, int64_t len, const uint8_t *desc, flan_dev_frame_claim(flan_frame_head, &g->fname, &g->fnamelen); } } else - guard_block(g, base); + guard_storage(g, base); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } @@ -3464,7 +3655,7 @@ flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc, /* A struct view's fields by position, for the printers and equality. */ static int64_t view_nfields(flan_obj *o) { - view_guard_check(NULL, 0, "print", o); + view_guard_check(walk_loc, walk_len, walk_op, o); return desc_nfields(o->u.view.desc); } @@ -3488,7 +3679,28 @@ static flan_dyn view_field_val(flan_obj *o, int64_t i) { const uint8_t *name, *fty; int64_t namelen, foff; if (!view_nth(o, i, &name, &namelen, &foff, &fty)) return flan_dyn_nil(); - return view_read(NULL, 0, "print", o, fty, (uint8_t *)o->u.view.base + foff); + return view_read(walk_loc, walk_len, walk_op, o, fty, + (uint8_t *)o->u.view.base + foff); +} + +static int view_big_u64(flan_obj *o, int64_t i, int field, + unsigned long long *out) { + const uint8_t *d, *p; + uint64_t x; + if (field) { + const uint8_t *name; + int64_t namelen, foff; + if (!view_nth(o, i, &name, &namelen, &foff, &d)) return 0; + p = (const uint8_t *)o->u.view.base + foff; + } else { + d = o->u.view.desc; + p = view_elem_at(o, i); + } + if (*d != 'L') return 0; + memcpy(&x, p, 8); + if (x <= (uint64_t)INT64_MAX) return 0; + *out = (unsigned long long)x; + return 1; } static void view_struct_name(flan_obj *o, const char **name, int64_t *len) { @@ -3498,6 +3710,54 @@ static void view_struct_name(flan_obj *o, const char **name, int64_t *len) { *len = (int64_t)(e - d - 2); } +/* print, =, length and has-key? with the site they were written at, so a + * view that traps inside one — gone, or a u64 too wide to compare — says + * where, and names the operation. The compiler calls these; the site-less + * ones stay for test/dyn_ops.c and the runtime's own callers. */ +static flan_dyn len_walk(flan_dyn v); +static flan_dyn contains_walk(flan_dyn m, flan_dyn k); + +void flan_dyn_print_at(flan_dyn v, const uint8_t *loc, int64_t loclen) { + walk_site was = walk_enter(loc, loclen, "print"); + print_walk(v); + walk_leave(was); +} + +void flan_dyn_print(flan_dyn v) { flan_dyn_print_at(v, NULL, 0); } + +flan_dyn flan_dyn_eq_at(flan_dyn a, flan_dyn b, const uint8_t *loc, + int64_t loclen) { + walk_site was = walk_enter(loc, loclen, "="); + flan_dyn r = eq_walk(a, b); + walk_leave(was); + return r; +} + +flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) { + return flan_dyn_eq_at(a, b, NULL, 0); +} + +flan_dyn flan_dyn_len_at(flan_dyn v, const uint8_t *loc, int64_t loclen) { + walk_site was = walk_enter(loc, loclen, "length"); + flan_dyn r = len_walk(v); + walk_leave(was); + return r; +} + +flan_dyn flan_dyn_len(flan_dyn v) { return flan_dyn_len_at(v, NULL, 0); } + +flan_dyn flan_dyn_map_contains_at(flan_dyn m, flan_dyn k, const uint8_t *loc, + int64_t loclen) { + walk_site was = walk_enter(loc, loclen, "has-key?"); + flan_dyn r = contains_walk(m, k); + walk_leave(was); + return r; +} + +flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { + return flan_dyn_map_contains_at(m, k, NULL, 0); +} + /* The first ABI, kept for test/dyn_ops.c: FLAN_VIEW_I64/F64/BOOL. */ static const uint8_t *old_elem_desc(int32_t elem) { return (const uint8_t *)(elem == FLAN_VIEW_I64 ? "l" @@ -3512,23 +3772,21 @@ flan_dyn flan_dyn_view_flat(void *data, int64_t len, int32_t elem) { return view_make(data, len, old_elem_desc(elem), VIEW_FLAT, 0); } -flan_dyn flan_dyn_len(flan_dyn v) { +static flan_dyn len_walk(flan_dyn v) { if (is_text(v)) return flan_dyn_from_i64(dyn_obj(v)->len); /* A map's length is its slot count, so a stale instance would answer the count of a definition that no longer exists. Migrated first for the same reason [get] is. */ if (is_map(v)) { flan_obj *o = dyn_obj(v); - if (o->kind == OBJ_VIEW) { - view_guard_check(NULL, 0, "length", o); - return flan_dyn_from_i64(view_nfields(o)); - } + if (o->kind == OBJ_VIEW) return flan_dyn_from_i64(view_nfields(o)); class_sync(o); return flan_dyn_from_i64(o->len); } if (is_vec(v)) { flan_obj *o = dyn_obj(v); - if (o->kind == OBJ_VIEW) return flan_dyn_from_i64(view_len(NULL, 0, "length", o)); + if (o->kind == OBJ_VIEW) + return flan_dyn_from_i64(view_len(walk_loc, walk_len, walk_op, o)); return flan_dyn_from_i64(o->len); } trap1(NULL, 0, TYPE_TRAP, "length", "only a text, a vec or a map has one", v); @@ -3616,7 +3874,8 @@ void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, if (o->kind == OBJ_VIEW) { int64_t len = view_len(loc, loclen, "set-at", o); if (k < 0 || k >= len) trap_range(loc, loclen, "set-at", v, k, len); - view_write(loc, loclen, "set-at", v, o->u.view.desc, x, view_elem_at(o, k)); + view_write(loc, loclen, "set-at", v, flan_dyn_nil(), o->u.view.desc, x, + view_elem_at(o, k)); return; } if (k < 0 || k >= o->len) trap_range(loc, loclen, "set-at", v, k, o->len); @@ -3648,7 +3907,7 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen) { /* Only a number or a bool is ever written, and [view_write] refuses the rest before a byte of [buf] is used. */ memset(buf, 0, sizeof buf); - view_write(loc, loclen, "push", v, o->u.view.desc, x, buf); + view_write(loc, loclen, "push", v, flan_dyn_nil(), o->u.view.desc, x, buf); if (!flan_vec_push(o->u.view.base, buf, size, align, site, sitelen)) trap_oom(loc, loclen, size); return; @@ -3745,11 +4004,11 @@ flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc, return flan_dyn_map_get(m, k); } -flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { +static flan_dyn contains_walk(flan_dyn m, flan_dyn k) { flan_obj *o = want_map("has-key?", m, k); if (o->kind == OBJ_VIEW) { int64_t off; - view_guard_check(NULL, 0, "has-key?", o); + view_guard_check(walk_loc, walk_len, walk_op, o); return flan_dyn_from_bool(desc_field(o->u.view.desc, k, &off) != NULL); } return flan_dyn_from_bool(map_find(o, k) >= 0); @@ -3878,7 +4137,7 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, if (is_map(m) && dyn_obj(m)->kind == OBJ_VIEW) { const uint8_t *fty; uint8_t *p = view_field(loc, loclen, "set", dyn_obj(m), k, &fty); - view_write(loc, loclen, "set", m, fty, v, p); + view_write(loc, loclen, "set", m, k, fty, v, p); return; } if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { @@ -3909,7 +4168,7 @@ static void map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, if (o->kind == OBJ_VIEW) { const uint8_t *fty; uint8_t *p = view_field(loc, loclen, "put", o, k, &fty); - view_write(loc, loclen, "put", m, fty, v, p); + view_write(loc, loclen, "put", m, k, fty, v, p); return; } e = class_sync(o); diff --git a/test/programs/dyn-view-any.flan b/test/programs/dyn-view-any.flan index a05512b0..8525c420 100644 --- a/test/programs/dyn-view-any.flan +++ b/test/programs/dyn-view-any.flan @@ -22,6 +22,13 @@ (defstruct Mix [a u8 b i64 c f32 d bool e [3 u16] f i32]) (defstruct Point [x f32 y i32]) (defstruct Named [name str id u32]) +(defstruct Wide [a u64 b i64]) +(defstruct Small [x i8 z bool]) + +(declare gc-collect [] () "flan_gc_collect") +(declare gc-live-bytes [] i64 "flan_gc_live_bytes") +(defonce g3 [3 i64]) +(defn first-of [d] dyn (at d 0)) (defn make-point [] Point (Point {.x 1.5 .y 2})) @@ -40,6 +47,19 @@ (let [a [1 2 3]] (set held (keep a)))) +(defn stash [d] () (set held d)) + +;; A slice of a local, crossing where the compiler cannot tie it to a frame: +;; bound to a local first, and passed through a slice parameter. +(defn leak-slice-local [] () + (let [a [(i64 5) 6 7] + s (slice a 0 3)] + (stash s))) +(defn via-slice [xs [i64]] () (stash xs)) +(defn leak-slice-param [] () + (let [a [(i64 5) 6 7]] + (via-slice (slice a 0 3)))) + (defn clobber [] i64 (let [b [(i64 7) 8 9 10 11 12]] (+ (at b 0) (at b 5)))) @@ -233,4 +253,40 @@ (let [p (Point {.x 1.0 .y 2})] (set (.z (keep p)) 3) 0) + ;; A million views made and dropped: the collector takes back every + ;; byte it charged for them. + (= n 11) + (let [s (i64 0)] + (set (at g3 0) 1) + (dotimes [i 300000] (set s (+ s (i64 (first-of g3))))) + (gc-collect) + (println s (< (gc-live-bytes) 1000000)) + 0) + ;; Stale through a slice bound to a local, and through a slice parameter. + (= n 12) + (do (leak-slice-local) (println (clobber)) (println (at held 0)) 0) + (= n 13) + (do (leak-slice-param) (println (clobber)) (println (at held 0)) 0) + ;; A field given a value of the wrong type, or nil, or out of range. + (= n 14) + (let [p (Small {.x 1 .z true})] (set (.x (keep p)) 1.5) 0) + (= n 15) + (let [p (Small {.x 1 .z true})] (set (.z (keep p)) nil) 0) + (= n 16) + (let [p (Small {.x 1 .z true})] (set (.x (keep p)) 200) 0) + ;; A stale view printed, measured and asked for a key, at their sites. + (= n 17) + (do (leak-local) (println (clobber)) (println held) 0) + (= n 18) + (do (leak-local) (println (clobber)) (println (length held)) 0) + ;; A u64 above the dyn int range prints, and reading it traps here. + (= n 19) + (let [w (Wide {.a 18000000000000000000 .b 1}) + d (keep w)] + (println d) + (println (.a d)) + 0) + ;; An element's range, with its article. + (= n 20) + (let [a [(i8 1)]] (set (at (keep a) 0) 200) 0) :else (do (println "?") 1)))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 7071fdab..ff0185a4 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5933,15 +5933,34 @@ level "1" ("2", "this u64 element is 18000000000000000000, above the largest \ dyn int"); ("3", "a Point has no field :z. Its fields are :x :y"); - ("8", "a str element is read-only through a dyn view"); + ("8", "field :name of a Named is a str, which is read-only through \ + a dyn view"); ("9", "16777217 has no exact f32"); - ("10", "dyn put: a Point has no field :z. Its fields are :x :y") ] + ("10", "dyn put: a Point has no field :z. Its fields are :x :y"); + ("14", "dyn-view-any.flan:272:39: dyn put: field :x of a Small is an \ + i8, and 1.5 is a float — (put #Small{:x 1 :z true} :x 1.5)"); + ("15", "dyn put: field :z of a Small is a bool, and the value is nil \ + — (put #Small{:x 1 :z true} :z nil)"); + ("16", "dyn put: field :x of a Small is an i8, which holds -128 to \ + 127, and 200 does not fit"); + ("19", "#Wide{:a 18000000000000000000 :b 1}\n"); + ("19", "dyn-view-any.flan:287:18: dyn get: this u64 element is \ + 18000000000000000000"); + ("20", "200 does not fit an i8 element, which holds -128 to 127") ] and any_stale = [ ("4", "this view points into a local of leak-local, and that call \ has returned"); ("5", "this view's storage, a block of i64, has been released"); ("6", "this view's storage, a block of i64, has been released"); - ("7", "this view's storage, a block of i32, has been released") ] + ("7", "this view's storage, a block of i32, has been released"); + ("12", "this view points into a local of leak-slice-local, and that \ + call has returned"); + ("13", "this view points into a local of leak-slice-param, and that \ + call has returned"); + ("17", "dyn-view-any.flan:279:44: dyn print: this view points into a \ + local of leak-local"); + ("18", "dyn-view-any.flan:281:53: dyn length: this view points into \ + a local of leak-local") ] in let dyn_view_any ?opt ?(x86 = false) ?(dev = false) () = let exe = compile ?opt ~x86 ~dev "programs/dyn-view-any.flan" in @@ -5966,6 +5985,14 @@ level "1" saying %S\n" (name (", mode " ^ mode)) text code needle end) (any_traps @ if dev then any_stale else []); + (* The collector takes back what it charged for a view: a leak here + once doubled the heap's trigger forever. *) + let code, text = run exe (Some "11") in + if code <> 0 || text <> "300000 true\n" then begin + incr failures; + Printf.printf "FAIL %s\n got: %S (exit %d)\n" + (name ", views are collected") text code + end; (try Sys.remove exe with Sys_error _ -> ()) in dyn_view_any ();