From 0a05d83b3b890ca19edca215edfb97651943f2c3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 10:13:01 +0700 Subject: [PATCH 1/5] A release build's dyn view carries no dev record, the dev registry grows instead of dropping notes, a container compared with itself still traps on a stale view inside it, has-key? traps at its site, and a trap clears the walk site it leaves. --- docs/BUILT.md | 4 +- runtime/flan_dev.c | 57 ++++++++- runtime/flan_dyn.c | 200 ++++++++++++++++++++++---------- runtime/flan_dyn.h | 9 ++ test/dev_limits.c | 9 +- test/dyn_ops.c | 37 ++++++ test/programs/dyn-view-any.flan | 21 ++++ test/programs/temp-frame.flan | 8 +- test/test_acceptance.ml | 8 +- test/test_dyn.ml | 20 ++++ test/test_reload.ml | 32 ++--- 11 files changed, 305 insertions(+), 100 deletions(-) diff --git a/docs/BUILT.md b/docs/BUILT.md index e9f3ef4f..160ab549 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3084,7 +3084,9 @@ A typed container crosses into dyn as a view of its storage wherever that storag 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. + smallest live block holding the address and keeps that block's base and note sequence. The registry grows when three + quarters of it is live rather than dropping notes, since a dropped note would stop this check without a word; the + old table is kept, because a listing on the agent's thread may still be reading it. - 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 diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index d4ed83fc..ec10c12a 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1293,9 +1293,17 @@ void *flan_dev_frame_slot(const void *frame, int32_t i) { * header says a module is never dlclose'd, so they outlive the table. */ -/* A power of two: the probe wraps with a mask. Fixed, and full is not fatal — - * see flan_dev_reg_note. */ -#define FLAN_REG_CAP 4096 +/* A power of two: the probe wraps with a mask. The table starts here and + * doubles when three quarters of it is live ([flan_reg_grow]): a dyn view's + * dev check asks it whether a block is still alive, and a table that dropped + * notes would answer "never heard of it" for a block that has since been + * freed, which is the check silently stopping. Read as [FLAN_REG_CAP]: the + * capacity is loaded before the table's address, and [flan_reg_grow] stores + * them the other way round, so a reader never pairs the larger capacity with + * the smaller table. */ +#define FLAN_REG_CAP0 4096 +static int64_t flan_reg_capv = FLAN_REG_CAP0; +#define FLAN_REG_CAP (__atomic_load_n(&flan_reg_capv, __ATOMIC_ACQUIRE)) /* How many dead entries make a compaction worth running. Not a tuning knob: it * is the difference between a diagnostic that works on a big program and one @@ -1523,10 +1531,10 @@ static void flan_reg_say_full(const char *why) { if (flan_reg_full) return; flan_reg_full = 1; fprintf(stderr, - "flan: the allocation registry is full (%d blocks) — %s. Blocks " + "flan: the allocation registry is full (%lld blocks) — %s. Blocks " "noted from here on are dropped, so every listing is a floor and " "not a count.\n", - FLAN_REG_CAP, why); + (long long)FLAN_REG_CAP, why); } /* Armed by the program's entry in a dev build. The free-side hooks in @@ -1537,14 +1545,17 @@ static void flan_reg_say_full(const char *why) { * repeating the claim that a release build carries nothing. */ static void flan_reg_report(void); /* the exit report, at the bottom */ +extern int flan_dev_views_checked; /* defined below */ + void flan_dev_reg_enable(void) { if (flan_reg_on) return; - flan_reg = (flan_reg_entry *)calloc(FLAN_REG_CAP, sizeof *flan_reg); + flan_reg = (flan_reg_entry *)calloc((size_t)FLAN_REG_CAP, sizeof *flan_reg); /* A registry that could not be made is not worth dying over; the flag stays off and every question about an address answers "never heard of it", which is what a release build answers too. */ if (flan_reg == NULL) return; flan_reg_on = 1; + flan_dev_views_checked = 1; /* Here and not at file scope: a destructor attribute would run in every build, since this file is linked into every build, and that would be a third place a release build is not free. Registered from inside the one @@ -1555,6 +1566,10 @@ void flan_dev_reg_enable(void) { int flan_dev_reg_enabled(void) { return flan_reg_on; } +/* The same flag as a word flan_dyn.c reads on every view's crossing: a dyn + * view carries its dev record only when this is set. */ +int flan_dev_views_checked; + /* A block a resize moved away from, filled with 0xDEADBEEF words in a dev * build. A slice is a pointer and a length and carries nothing that could say * the Vec under it grew, so a slice taken before a push that moved the storage @@ -1700,6 +1715,33 @@ static flan_reg_entry *flan_reg_live_at(uintptr_t base) { * losing the live half. When they are not the bulk of it this does nothing but * move live entries around and hold the epoch odd while it does — see * FLAN_REG_RECLAIM for the wrong answers that bought. */ +/* Twice the room, every entry carried over, live and dead alike (a dead one + * still names what died). Under the table-wide counter, as a compaction is, + * so a listing that overlapped it starts again. The old table is not freed: + * a listing on the listener thread may still be reading it, and a dev build + * can afford the half it keeps. 0 when the memory could not be had, and the + * table stays as it was. */ +static int flan_reg_grow(void) { + int64_t cap = FLAN_REG_CAP, ncap = cap * 2, i; + flan_reg_entry *n = (flan_reg_entry *)calloc((size_t)ncap, sizeof *n); + if (n == NULL) return 0; + __atomic_store_n(&flan_reg_epoch, flan_reg_epoch | 1, __ATOMIC_RELAXED); + __atomic_thread_fence(__ATOMIC_RELEASE); + for (i = 0; i < cap; i++) { + size_t j; + if (flan_reg[i].base == 0) continue; + j = (size_t)(((flan_reg[i].base >> 3) * 11400714819323198485ULL) >> 40) + & (size_t)(ncap - 1); + while (n[j].base != 0) j = (j + 1) & (size_t)(ncap - 1); + n[j] = flan_reg[i]; + n[j].gen = 0; + } + __atomic_store_n(&flan_reg, n, __ATOMIC_RELEASE); + __atomic_store_n(&flan_reg_capv, ncap, __ATOMIC_RELEASE); + __atomic_store_n(&flan_reg_epoch, (flan_reg_epoch | 1) + 1, __ATOMIC_RELEASE); + return 1; +} + static void flan_reg_compact(void) { size_t bytes = FLAN_REG_CAP * sizeof(flan_reg_entry); flan_reg_entry *old = (flan_reg_entry *)malloc(bytes); @@ -1793,6 +1835,9 @@ static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem, if (flan_reg_used * 4 > (int64_t)FLAN_REG_CAP * 3 && flan_reg_dead >= FLAN_REG_RECLAIM) flan_reg_compact(); + /* Still three quarters full once the dead are gone: the live set outgrew + the table, so the table grows rather than drop what comes next. */ + if (flan_reg_used * 4 > (int64_t)FLAN_REG_CAP * 3) flan_reg_grow(); s = flan_reg_slot(a); for (probe = 0; probe < FLAN_REG_CAP; probe++) { size_t j = (s + (size_t)probe) & (FLAN_REG_CAP - 1); diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 8c2a24e6..c4339372 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -63,6 +63,41 @@ void flan_dev_watch_emit(const uint8_t *bytes, int64_t len); * program die where it stands", which that file went to some trouble to have * only one of. So flan_rt.c exports a thin wrapper and this calls it. */ _Noreturn void flan_trap(const uint8_t *name, int64_t namelen); + +/* 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. + * Every trap in this file goes through [dyn_trap], which clears them first: + * a trap does not return to the [walk_leave] that would have, and a later + * walk must not name the site of one that was abandoned. */ +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; +} + +int flan_dev_reg_enabled(void); +/* runtime/flan_dev.c: set with the registry, so a view's crossing reads a + * word rather than making a call to learn it is in a release build. */ +extern int flan_dev_views_checked; + +static _Noreturn void dyn_trap(const uint8_t *name, int64_t namelen) { + walk_loc = NULL; + walk_len = 0; + walk_op = "print"; + flan_trap(name, namelen); +} /* A trap's sentence, printed after its site and kept for the break loop, which * shows it beside the trap's name (flan_rt.c). */ void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...); @@ -538,7 +573,7 @@ int32_t flan_dyn_tag(flan_dyn v) { case OBJ_VEC: return FLAN_DYN_TAG_VEC; /* ...and a struct's view answers a map's, [gen] being its shape (VIEW_STRUCT, below). */ - case OBJ_VIEW: return o->gen == 2 ? FLAN_DYN_TAG_MAP : FLAN_DYN_TAG_VEC; + case OBJ_VIEW: return (o->gen & 0xff) == 2 ? FLAN_DYN_TAG_MAP : FLAN_DYN_TAG_VEC; case OBJ_MAP: return FLAN_DYN_TAG_MAP; default: return FLAN_DYN_TAG_INT; } @@ -649,7 +684,7 @@ 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, +static inline 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); @@ -668,25 +703,6 @@ static int view_big_u64(flan_obj *o, int64_t i, int field, 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]; @@ -1022,7 +1038,7 @@ static _Noreturn void trap2(const uint8_t *loc, int64_t loclen, say(sb, SAY_MAX, b); flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op, tag_of(a), tag_of(b), why, op, sa, sb); - flan_trap((const uint8_t *)name, namelen); + dyn_trap((const uint8_t *)name, namelen); } static _Noreturn void trap1(const uint8_t *loc, int64_t loclen, @@ -1032,7 +1048,7 @@ static _Noreturn void trap1(const uint8_t *loc, int64_t loclen, say(sa, SAY_MAX, a); flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op, sa); - flan_trap((const uint8_t *)name, namelen); + dyn_trap((const uint8_t *)name, namelen); } #define TYPE_TRAP "DynType", 7 @@ -1047,7 +1063,7 @@ static _Noreturn void trap_range(const uint8_t *loc, int64_t loclen, flan_say(loc, loclen, "dyn %s: index %lld is out of bounds for %s of length %lld — %s", op, (long long)i, tag_of(v), (long long)len, sv); - flan_trap((const uint8_t *)"DynRange", 8); + dyn_trap((const uint8_t *)"DynRange", 8); } /* ── Allocation and collection ───────────────────────────────────────── @@ -1120,7 +1136,7 @@ static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen, flan_say(loc, loclen, "dyn heap: %lld bytes could not be allocated, with %lld live", (long long)want, (long long)gc_bytes); - flan_trap((const uint8_t *)"DynHeap", 7); + dyn_trap((const uint8_t *)"DynHeap", 7); } static flan_obj *gc_alloc(uint8_t kind, int64_t extra) { @@ -1541,7 +1557,8 @@ 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_VIEW && (o->gen & 0x100)) + 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; @@ -2143,7 +2160,7 @@ static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added, "slots matched by name. Take migrate-by-name, or handle the " "condition inside the method", (int)c->len, (const char *)(c + 1)); - flan_trap((const uint8_t *)"DynMigrate", 10); + dyn_trap((const uint8_t *)"DynMigrate", 10); } } @@ -2869,9 +2886,33 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc, #define EQ_DEPTH 64 +/* A container compared with itself is equal without reading an element, but + * in a dev build that shortcut would let a view inside it that has gone + * stale pass unremarked, where comparing any other container holding it + * traps. So a dev build walks the one container, as deep as equality would, + * and checks every view it holds — the same rule [eq_walk] applies at the + * top. A release build keeps no guards, and takes the shortcut. */ +static void stale_scan(flan_dyn v, int depth) { + flan_obj *o; + int64_t i, n; + if (!dyn_boxed(v) || dyn_box(v) != BOX_OBJ || depth >= EQ_DEPTH) return; + o = dyn_obj(v); + if (o == NULL) return; + if (o->kind == OBJ_VIEW) { + view_guard_check(walk_loc, walk_len, walk_op, o); + return; + } + if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return; + n = o->kind == OBJ_MAP ? o->len * 2 : o->len; + for (i = 0; i < n; i++) stale_scan(o->u.v.items[i], depth + 1); +} + static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { int32_t ta = flan_dyn_tag(a), tb = flan_dyn_tag(b); - if (a == b && ta != FLAN_DYN_TAG_FLOAT) return 1; + if (a == b && ta != FLAN_DYN_TAG_FLOAT) { + if (flan_dev_views_checked) stale_scan(a, depth); + return 1; + } if (is_num(a) && is_num(b)) { if (ta == FLAN_DYN_TAG_INT && tb == FLAN_DYN_TAG_INT) return dyn_int_value(a) == dyn_int_value(b); @@ -2887,7 +2928,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { if (ta == FLAN_DYN_TAG_VEC) { flan_obj *x = dyn_obj(a), *y = dyn_obj(b); int64_t i, xn, yn; - if (x == y) return 1; + if (x == y) { + if (flan_dev_views_checked) stale_scan(a, depth); + return 1; + } if (depth >= EQ_DEPTH) return 0; /* [x]/[y] may each be an ordinary heap vec or a view (M2 item 3) — the tag does not say which, so [vecish_len]/[vecish_at] below read either @@ -2915,7 +2959,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { if (ta == FLAN_DYN_TAG_MAP) { flan_obj *x = dyn_obj(a), *y = dyn_obj(b); int64_t i, j; - if (x == y) return 1; + if (x == y) { + if (flan_dev_views_checked) stale_scan(a, depth); + return 1; + } if (depth >= EQ_DEPTH) return 0; /* A struct's view is equal to another view of the same struct type with equal fields, and to nothing else — the answer an instance gets beside @@ -3083,8 +3130,15 @@ static void desc_lay(const uint8_t *d, int64_t *size, int64_t *align) { } } -static int64_t desc_size(const uint8_t *d) { +static inline int64_t desc_size(const uint8_t *d) { int64_t s, a; + switch (*d) { /* the scalars, without the walk */ + case 'b': case 'B': case '?': return 1; + case 'h': case 'H': return 2; + case 'i': case 'I': case 'f': return 4; + case 'l': case 'L': case 'd': return 8; + default: break; + } desc_lay(d, &s, &a); return s; } @@ -3210,8 +3264,14 @@ extern struct flan_frame *flan_frame_head; /* runtime/flan_dev.c */ #define VIEW_VEC 1 /* [base] is a Vec's header, read live */ #define VIEW_STRUCT 2 /* [base] is the struct, [desc] the struct's own */ -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; } +/* A view carries a guard only when the dev registry is on: a release build + * would allocate and zero it for nothing, and a crossing is on the hot path. + * VIEW_GUARDED in [gen] says the guard is there. */ +#define VIEW_GUARDED 0x100 /* bits 16-31 hold the element size */ +static inline view_guard *view_g(flan_obj *o) { + return (o->gen & VIEW_GUARDED) ? (view_guard *)(o + 1) : NULL; +} +static inline int view_shape(flan_obj *o) { return (int)(o->gen & 0xff); } void *flan_dev_frame_owner(const void *p); @@ -3236,20 +3296,35 @@ static void guard_storage(view_guard *g, const void *p) { /* A new view record, its guard empty. */ static flan_obj *view_new(void *base, int64_t len, const uint8_t *desc, int shape) { - flan_obj *o = gc_alloc(OBJ_VIEW, (int64_t)sizeof(view_guard)); + int dev = flan_dev_views_checked; + flan_obj *o = + gc_alloc(OBJ_VIEW, dev ? (int64_t)sizeof(view_guard) : 0); o->u.view.base = base; o->u.view.desc = desc; o->u.view.nul = NULL; - o->gen = (uint32_t)shape; + o->gen = (uint32_t)shape | (dev ? VIEW_GUARDED : 0); + /* A flat or Vec view's element size, kept so an access does not read the + descriptor again; 0 when it does not fit the 16 bits, and then it does. */ + if (shape != VIEW_STRUCT) { + int64_t sz = desc_size(desc); + if (sz > 0 && sz < 0x10000) o->gen |= (uint32_t)sz << 16; + } o->len = len; - memset(view_g(o), 0, sizeof(view_guard)); + if (dev) memset(view_g(o), 0, sizeof(view_guard)); return o; } /* The stale-storage check. The sentence never renders the view: it has just * been found to point at storage that is gone, and rendering reads it. */ -static void view_guard_check(const uint8_t *loc, int64_t loclen, +static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen, + const char *op, flan_obj *o); +static inline __attribute__((always_inline)) void view_guard_check(const uint8_t *loc, int64_t loclen, const char *op, flan_obj *o) { + if (o->gen & VIEW_GUARDED) view_guard_slow(loc, loclen, op, o); +} + +static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen, + const char *op, flan_obj *o) { view_guard *g = view_g(o); if (g->frame != NULL && !flan_dev_frame_alive(g->frame, g->serial)) { flan_say(loc, loclen, @@ -3257,7 +3332,7 @@ static void view_guard_check(const uint8_t *loc, int64_t loclen, "has returned. A view of a local lasts as long as the call that " "made it", op, (int)g->fnamelen, g->fname); - flan_trap((const uint8_t *)"DynStale", 8); + dyn_trap((const uint8_t *)"DynStale", 8); } if (g->rbase != 0 && !flan_dev_reg_alive(g->rbase, g->rseq)) { flan_say(loc, loclen, @@ -3265,7 +3340,7 @@ static void view_guard_check(const uint8_t *loc, int64_t loclen, "released — freed, cleared by free-all, or left behind when a " "Vec grew. Take the view again after the change", op, (int)g->rtypelen, g->rtype); - flan_trap((const uint8_t *)"DynStale", 8); + dyn_trap((const uint8_t *)"DynStale", 8); } } @@ -3285,7 +3360,7 @@ static void view_vec_check(const uint8_t *loc, int64_t loclen, const char *op, "dyn %s: this view's container's allocator was released — the " "Vec was made at epoch %lld and the allocator is at %lld now", op, (long long)h->epoch, (long long)(int64_t)a->epoch); - flan_trap((const uint8_t *)"DynRange", 8); + dyn_trap((const uint8_t *)"DynRange", 8); } } } @@ -3323,7 +3398,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_storage(view_g(c), data); + if (view_g(c) != NULL) guard_storage(view_g(c), data); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c); } case 'a': { @@ -3335,8 +3410,9 @@ 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_storage(view_g(c), p); - else *view_g(c) = *view_g(parent); + if (view_g(c) == NULL) {} + else if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p); + else if (view_g(parent) != NULL) *view_g(c) = *view_g(parent); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c); } @@ -3360,7 +3436,7 @@ static flan_dyn view_read(const uint8_t *loc, int64_t loclen, const char *op, "dyn %s: this u64 element is %llu, above the largest dyn int " "(9223372036854775807), so it has no dyn value", op, (unsigned long long)x); - flan_trap((const uint8_t *)"DynRange", 8); + dyn_trap((const uint8_t *)"DynRange", 8); } return flan_dyn_from_i64((int64_t)x); } @@ -3435,7 +3511,7 @@ static _Noreturn void field_refuse(const uint8_t *loc, int64_t loclen, 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)); + dyn_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. */ @@ -3497,7 +3573,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, "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); + dyn_trap((const uint8_t *)"DynRange", 8); } switch (*d) { case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; } @@ -3526,7 +3602,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, "dyn %s: %lld has no exact %s, so it does not go into this " "element. Write it as a float, as in %lld.0", op, (long long)n, ty, (long long)n); - flan_trap((const uint8_t *)"DynRange", 8); + dyn_trap((const uint8_t *)"DynRange", 8); } } else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) f = dyn_num_value(x); @@ -3569,14 +3645,16 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, "it whole — write into its own elements or fields instead of " "storing %s", op, an(ty), ty, sx); - flan_trap((const uint8_t *)"DynType", 7); + dyn_trap((const uint8_t *)"DynType", 7); } } } /* Element [i] of a vec-shaped view. The caller has checked the bounds. */ static uint8_t *view_elem_at(flan_obj *o, int64_t i) { - return (uint8_t *)view_base(o) + i * desc_size(o->u.view.desc); + int64_t sz = (int64_t)(o->gen >> 16); + if (sz == 0) sz = desc_size(o->u.view.desc); + return (uint8_t *)view_base(o) + i * sz; } /* A length and an element reader that answer correctly whether [o] is an @@ -3615,7 +3693,7 @@ static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op, while (desc_next(&at, &o2, &name, &namelen, &foff, &t)) said_add(" :%.*s", (int)namelen, (const char *)name); flan_say(loc, loclen, "%s", said_buf); - flan_trap((const uint8_t *)"DynType", 7); + dyn_trap((const uint8_t *)"DynType", 7); } return (uint8_t *)o->u.view.base + off; } @@ -3630,7 +3708,8 @@ 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); view_guard *g = view_g(o); - if (here) { + if (g == NULL) {} + else if (here) { if (flan_frame_head != NULL) { g->frame = flan_frame_head; g->serial = @@ -3849,7 +3928,7 @@ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, flan_say(loc, loclen, "dyn slice: [%lld %lld) is out of bounds for text of length %lld " "— %s", (long long)a, (long long)b, (long long)len, sv); - flan_trap((const uint8_t *)"DynRange", 8); + dyn_trap((const uint8_t *)"DynRange", 8); } return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a); } @@ -3957,9 +4036,10 @@ static int64_t map_find(flan_obj *o, flan_dyn k) { return -1; } -static flan_obj *want_map(const char *op, flan_dyn m, flan_dyn k) { +static flan_obj *want_map(const uint8_t *loc, int64_t loclen, const char *op, + flan_dyn m, flan_dyn k) { flan_obj *o; - if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, op, "only a map answers it", m, k); + if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, op, "only a map answers it", m, k); o = dyn_obj(m); /* The lazy half of the redefinition protocol: [get], [put] and [has-key?] all arrive here, and CLHS 4.3.6 asks for the update to happen no later @@ -3970,7 +4050,7 @@ static flan_obj *want_map(const char *op, flan_dyn m, flan_dyn k) { } flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k) { - flan_obj *o = want_map("get", m, k); + flan_obj *o = want_map(NULL, 0, "get", m, k); if (o->kind == OBJ_VIEW) { const uint8_t *fty; uint8_t *p = view_field(NULL, 0, "get", o, k, &fty); @@ -4005,7 +4085,7 @@ flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc, } static flan_dyn contains_walk(flan_dyn m, flan_dyn k) { - flan_obj *o = want_map("has-key?", m, k); + flan_obj *o = want_map(walk_loc, walk_len, walk_op, m, k); if (o->kind == OBJ_VIEW) { int64_t off; view_guard_check(walk_loc, walk_len, walk_op, o); @@ -4069,7 +4149,7 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, flan_say(by == BY_NEW && site_building != NULL ? site_building : loc, by == BY_NEW && site_building != NULL ? site_building_len : loclen, "%s", said_buf); - flan_trap((const uint8_t *)"DynType", 7); + dyn_trap((const uint8_t *)"DynType", 7); } /* The value a store into [o] under [k] actually stores: [v], or the float an @@ -4110,7 +4190,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen, said_add(" :%.*s", (int)e->slots[i]->len, (const char *)(e->slots[i] + 1)); flan_say(loc, loclen, "%s", said_buf); - flan_trap((const uint8_t *)"DynType", 7); + dyn_trap((const uint8_t *)"DynType", 7); } /* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for @@ -4118,7 +4198,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen, * wrote, and placed at the slot's declaration. */ void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, int64_t loclen) { - flan_obj *o = want_map("construct", m, k); + flan_obj *o = want_map(loc, loclen, "construct", m, k); class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass); map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v)); } @@ -4148,7 +4228,7 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, "this is %s%s — %s. A map's entries are written with put", is_map(m) ? "a map with no class" : "a ", is_map(m) ? "" : tag_of(m), sm); - flan_trap((const uint8_t *)"DynType", 7); + dyn_trap((const uint8_t *)"DynType", 7); } o = dyn_obj(m); e = class_sync(o); diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 5e6a118b..01a29f12 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -348,6 +348,15 @@ flan_dyn flan_dyn_view_slice(void *data, int64_t len, const uint8_t *desc, flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc, int64_t desclen, int32_t shape, int32_t here); +/* print, =, length and has-key? with the site they were written at: a view + * that traps inside one names it. */ +void flan_dyn_print_at(flan_dyn v, const uint8_t *loc, int64_t loclen); +flan_dyn flan_dyn_eq_at(flan_dyn a, flan_dyn b, const uint8_t *loc, + int64_t loclen); +flan_dyn flan_dyn_len_at(flan_dyn v, const uint8_t *loc, int64_t loclen); +flan_dyn flan_dyn_map_contains_at(flan_dyn m, flan_dyn k, const uint8_t *loc, + int64_t loclen); + /* ── The collector ───────────────────────────────────────────────────── * * Mark-sweep, precise, and never moving. [flan_gc_init] is idempotent, and the diff --git a/test/dev_limits.c b/test/dev_limits.c index 06ba770a..33480c7f 100644 --- a/test/dev_limits.c +++ b/test/dev_limits.c @@ -264,12 +264,9 @@ static int regchurn(void) { return 0; } -/* And a table that really is full, which is the case the trigger above must - * not paper over: 4096 live blocks and nothing dead anywhere, then one more. - * The note is dropped — that is the standing decision, and dying because a - * diagnostic ran out of room would be worse — and what is checked here is that - * the drop is *said*, once, rather than only being discoverable by asking the - * flag. A second and third dropped note must add nothing. */ +/* A live set larger than the table's first size: 4096 live blocks and + * nothing dead anywhere, then three more. The table grows, so none is + * dropped and the overflow flag stays clear. */ static int regoverflow(void) { flan_dev_reg_enable(); for (int i = 0; i < CAP; i++) diff --git a/test/dyn_ops.c b/test/dyn_ops.c index 692725cf..7a0c1a33 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -32,6 +32,7 @@ #include #include #include +#include /* Resolved because [Build] drops runtime/flan_dyn.h into the directory it * compiles each translation unit in, beside the .c it writes there. That is @@ -1372,6 +1373,41 @@ static void hook_reentry(void) { printf(failures == 0 ? "hook ok\n" : "hook failed\n"); } +/* A trap inside a walk that a trap hook leaves by longjmp — what the dev + * agent does when it abandons an evaluation — must not leave that walk's site + * behind for the next walk that has none. The first comparison traps at + * "walk-site:1:1" reading a u64 too wide for a dyn int; the map lookup after + * it compares the same two views with no site of its own, and traps again. + * The site may appear once, in the first sentence, and not in the second. */ +extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen); +static jmp_buf walk_out; +static void walk_hook(const uint8_t *name, int64_t namelen) { + (void)name; (void)namelen; + longjmp(walk_out, 1); +} + +static void walkreset(void) { + static uint64_t big[1] = { UINT64_MAX }; + flan_dyn v, w, m; + flan_gc_init(); + v = flan_dyn_view_at(big, 1, (const uint8_t *)"L", 1, 0, 0); + flan_dyn_root_push(&v); + w = flan_dyn_view_at(big, 1, (const uint8_t *)"L", 1, 0, 0); + flan_dyn_root_push(&w); + m = flan_dyn_map_new(); + flan_dyn_root_push(&m); + flan_dyn_map_set(m, v, flan_dyn_from_i64(1)); + flan_trap_hook = walk_hook; + if (setjmp(walk_out) == 0) + (void)flan_dyn_eq_at(v, w, (const uint8_t *)"walk-site:1:1", 13); + fflush(stderr); + fprintf(stderr, "--\n"); + if (setjmp(walk_out) == 0) (void)flan_dyn_map_get(m, w); + flan_trap_hook = NULL; + flan_dyn_root_pop(3); + printf("walkreset done\n"); +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 2) { @@ -1401,6 +1437,7 @@ int main(int argc, char **argv) { view(); return failures == 0 ? 0 : 1; } + if (strcmp(argv[1], "walkreset") == 0) { walkreset(); return 0; } if (strcmp(argv[1], "layout") == 0) { layout(); return failures == 0 ? 0 : 1; diff --git a/test/programs/dyn-view-any.flan b/test/programs/dyn-view-any.flan index 8525c420..8d30914b 100644 --- a/test/programs/dyn-view-any.flan +++ b/test/programs/dyn-view-any.flan @@ -289,4 +289,25 @@ ;; An element's range, with its article. (= n 20) (let [a [(i8 1)]] (set (at (keep a) 0) 200) 0) + ;; More live blocks than the registry's first size, then a free: the + ;; registry grows rather than dropping notes, so the check still holds. + (= n 21) + (let [hold (vec-new [i64])] + (dotimes [i 6000] (push hold (clone (slice [(i64 i) 1] 0 2)))) + (let [c (at hold 5999) + d (keep c)] + (println (at d 0)) + (free c) + (println (at d 0))) + 0) + ;; A container holding a stale view, compared with itself. + (= n 22) + (do (leak-local) + (println (clobber)) + (let [box (the dyn [held 1])] + (println (= box box))) + 0) + ;; has-key? on a value that is not a map, at its site. + (= n 23) + (do (println (has-key? (keep 5) :x)) 0) :else (do (println "?") 1)))) diff --git a/test/programs/temp-frame.flan b/test/programs/temp-frame.flan index 2b287e1f..15d35a2e 100644 --- a/test/programs/temp-frame.flan +++ b/test/programs/temp-frame.flan @@ -8,8 +8,10 @@ ;;;; ;;;; The argument is the frame count. A negative one runs that many frames and ;;;; never calls free-temp, which is the control: memory grows and a dev -;;;; build's registry fills. The last line is whether the registry overflowed. -(declare-c reg-overflowed [] i32 "flan_dev_reg_overflowed") +;;;; build's registry fills. The last line is whether more blocks are live +;;;; than the registry's first size, 4096 — it grows past that rather than +;;;; drop notes, so the live count is what says it filled. +(declare-c reg-live [live-only i32] i64 "flan_dev_reg_count") (defn main [args [str]] i32 (let [arg (bytes->i64 (bytes-view (at args 1))) @@ -26,5 +28,5 @@ (free-temp))) (println total) (println (str kept)) - (println (reg-overflowed))) + (println (if (> (reg-live 1) 4096) 1 0))) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index ff0185a4..2c5803f9 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5946,7 +5946,8 @@ level "1" ("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") ] + ("20", "200 does not fit an i8 element, which holds -128 to 127"); + ("23", "dyn-view-any.flan:312:20: dyn has-key?: int and keyword") ] and any_stale = [ ("4", "this view points into a local of leak-local, and that call \ has returned"); @@ -5960,7 +5961,10 @@ level "1" ("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") ] + a local of leak-local"); + ("21", "5999\n"); + ("21", "this view's storage, a block of i64, has been released"); + ("22", "dyn =: 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 diff --git a/test/test_dyn.ml b/test/test_dyn.ml index 263bdc94..2f13a966 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -197,6 +197,26 @@ let () = (* The three restatements of flan_vec's layout, compared field by field — see dyn_ops.c's [layout] and [hand_vec]'s comment for what ties them together and why nothing at compile time otherwise does. *) + (* A walk's site does not outlive a trap that leaves the walk: the second + sentence, from a lookup with no site, must not carry the first's. *) + let code, out, err = run "walkreset" in + (match String.split_on_char '-' err with + | _ when code <> 0 || out <> "walkreset done\n" -> + fail "a walk left by a trap\n got: %S (exit %d, err %S)" out + code err + | _ -> + let after = + match String.index_opt err '\n' with + | Some i -> String.sub err i (String.length err - i) + | None -> "" + in + if not (has err "walk-site:1:1") then + fail "the first walk's trap did not name its site: %S" err + else if has after "walk-site" then + fail "a later walk named an abandoned walk's site: %S" err + else if not (has after "above the largest dyn int") then + fail "the second walk did not trap: %S" err); + let code, out, err = run "layout" in if code <> 0 || out <> "layout ok\n" then fail "flan_vec's three restatements\n got: %S (exit %d, err %S)" diff --git a/test/test_reload.ml b/test/test_reload.ml index 8109b2ba..919508df 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -640,30 +640,18 @@ let () = "a listing taken during a compaction\n got: %S (exit %d, err %S)\n wanted no zero-row and no wrong-count answers" out code err; - (* And a table that is genuinely full, which is the state the trigger above - must not paper over. The note is dropped — a diagnostic that killed the - program because it ran out of room would be the diagnostic shooting the - patient — and the decision this pins is that the drop is *said*, once. - Once matters: this is the game thread inside the allocation hook, and a - line per dropped note would be sixty a second down a pipe nobody drains - while a request is being served. *) + (* And a table whose live set outgrows it: 4096 live blocks and nothing + dead, then three more. The table grows rather than dropping them — a + dyn view's dev check asks it whether a block is alive, and a dropped + note would stop that check without a word — so nothing overflows and + every block is counted. *) let code, out, err = mode "regoverflow" in - let want_over = "live 4096\noverflowed 0\noverflowed 1\nlive 4096\n" in + let want_over = "live 4096\noverflowed 0\noverflowed 0\nlive 4099\n" in if code <> 0 || out <> want_over then - fail "a full registry\n got: %S (exit %d)\n wanted: %S" out - code want_over; - let said_full = - let needle = "the allocation registry is full" in - let rec go i n = - if i + String.length needle > String.length err then n - else if String.sub err i (String.length needle) = needle then - go (i + 1) (n + 1) - else go (i + 1) n - in - go 0 0 - in - if said_full <> 1 then - fail "a full registry said so %d times, not once: %S" said_full err; + fail "a registry past its first size\n got: %S (exit %d)\n wanted: %S" + out code want_over; + if has err "the allocation registry is full" then + fail "a registry that grows said it was full: %S" err; Printf.printf "reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n" From fc463cf320e49bea567de29a6e2574187d9f0475 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 10:31:53 +0700 Subject: [PATCH 2/5] The .fln reader refuses loop and recur, flan convert refuses a .flan file that uses them, and every loop outside recur.flan is a while or until. --- TODO.org | 4 ++ emacs/MANUAL.md | 2 +- emacs/flan-fln-mode.el | 10 ++-- emacs/test-flan-fln-live.el | 26 +++++---- emacs/test-flan-fln.el | 30 ++++++----- lib/indent_printer.ml | 51 +++++++++--------- lib/indent_reader.ml | 77 +++++++++++++++------------ spec-syntax.md | 11 ++-- test/programs/fn-capture.flan | 16 +++--- test/programs/generic-struct.flan | 10 ++-- test/programs/match-enum.flan | 12 +++-- test/programs/match-literal.flan | 12 +++-- test/syntax/flat/shadows.flan | 12 +++-- test/syntax/handwritten/inventory.fln | 9 +++- test/test_syntax.ml | 48 ++++++++++++----- 15 files changed, 197 insertions(+), 133 deletions(-) diff --git a/TODO.org b/TODO.org index 08a02ae2..6a35158f 100644 --- a/TODO.org +++ b/TODO.org @@ -675,6 +675,10 @@ Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T more bindings of the same let; anything else there stays refused. flan convert writes consecutive lets this way. +** DONE .fln has no loop or recur (decision 122) +Rules out ~loop~/~recur~ anywhere the .fln reader reads, ~quote~ included; loops are +~while~/~until~/~dotimes~/~for~. The Lisp syntax and its macros' expansions keep them. + ** TODO Hard-coded code in messages is still paren syntax in a .fln file Types follow the code's syntax now (=Types.spell=). Hints written into a message's text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 6f044e41..6b74c2e2 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames. | `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | | `C-M-u` | same | up to the enclosing bracket, or the line that owns the block | | `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere | -| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, `= loop i = 0`, a lambda header). After a line ending in `=>`, one level in from that line, inside brackets too; a line of that block keeps to the block's columns | +| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, a lambda header). After a line ending in `=>`, one level in from that line, inside brackets too; a line of that block keeps to the block's columns | | `DEL` in indentation | same | drop one level | | `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | | `M-` / `M-` | same | move the statement past its neighbour | diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 96e0c01c..ba5f631e 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -104,8 +104,7 @@ fine here. Brackets and strings are still paired." '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" "continue" "defer" "handler-case" "handler-bind" "restart-case" "on" - "restart" "quote" "macro" "loop" "type" "class" "generic" "multi" - "method")) + "restart" "quote" "macro" "type" "class" "generic" "multi" "method")) ;; The headers whose block follows on the lines under them. `defer' and ;; `quote' open one only when nothing follows them on the line; `fn' does not @@ -114,8 +113,7 @@ fine here. Brackets and strings are still paired." (defconst flan-fln--opener-words '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" "until" "for" "match" "defer" "handler-case" "handler-bind" - "restart-case" "on" "restart" "quote" "macro" "loop" "class" "multi" - "method")) + "restart-case" "on" "restart" "quote" "macro" "class" "multi" "method")) (defconst flan-fln--declaration-words '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") @@ -402,7 +400,7 @@ or, when the line ends in `=>', at the end of the lambda's block under it." (defun flan-fln--value-opens-p (l) "Non-nil if the value the joined line L binds or assigns goes on under it: `= match x', `= if c' with no `then', `= handler-case', `= restart-case', -`= loop i = 0', or a lambda header. These are the values +or a lambda header. These are the values lib/indent_reader.ml's `value_line' reads a block for, besides a bare `=' and a call ending in `:'." (let ((v (flan-fln--value-start l)) @@ -410,7 +408,7 @@ and a call ending in `:'." (and v (< v end) (save-excursion (goto-char v) - (or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\|loop\\)\\(?:[ \t]\\|$\\)") + (or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)") (and (looking-at "if[ \t]") (not (flan-fln--then l))) (flan-fln--lambda-header-p v end)))))) diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el index 62f41a79..622cdffd 100644 --- a/emacs/test-flan-fln-live.el +++ b/emacs/test-flan-fln-live.el @@ -137,13 +137,21 @@ macro dbl-of(x, & more) fn use-mac(k: i64) -> i64 = dbl-of(k) fn gcd(a: i64, b: i64) -> i64 - loop x = a, y = b - if y == 0 then x else recur(y, x % y) + let x = a + let y = b + while y != 0 + let r = x % y + x = y + y = r + x fn sum-to(n: i64) -> i64 - let r = loop i = 0, acc = 0 - if i > n then acc else recur(i + 1, acc + i) - r + let i = 0 + let acc = 0 + until i > n + acc += i + i += 1 + acc comment(): if 1 < 2 and @@ -400,10 +408,10 @@ comment(): ("Dir.north" "an enum member's arm, at its value") ("let b = 2" "a let the let above takes in, at its value") ("let c: i64" "a typed one, at its value") - ("loop x = a" "a loop, at its word") - ("if y == 0" "a loop's block") - ("let r = loop" "a let-bound loop, at its let") - ("if i > n" "a let-bound loop's block"))) + ("while y != 0" "a while, at its word") + ("let r = x % y" "a while's block") + ("until i > n" "an until, at its word") + ("acc += i" "an until's block"))) (funcall goto (car c)) (let ((reply (flan-fln-eval-defun '(4)))) (test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it" diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index 1a69fbd1..1a36cefe 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -722,8 +722,13 @@ macro repeat(i, n, & body) ~@body fn gcd(a: i32, b: i32) -> i32 - loop x = a, y = b - if y == 0 then x else recur(y, x % y) + let x = a + let y = b + while y != 0 + let r = x % y + x = y + y = r + x " (font-lock-ensure) (let ((face (lambda (needle) @@ -733,7 +738,6 @@ fn gcd(a: i32, b: i32) -> i32 (test-flan-fln--is "and :parent a keyword" (funcall face ":parent") 'font-lock-constant-face) (test-flan-fln--is "macro is a keyword" (funcall face "macro") 'font-lock-keyword-face) (test-flan-fln--is "and its name a function's" (funcall face "repeat") 'font-lock-function-name-face) - (test-flan-fln--is "loop is a keyword" (funcall face "loop") 'font-lock-keyword-face) (test-flan-fln--is "type is a keyword" (funcall face "type") 'font-lock-keyword-face) (test-flan-fln--is "an alias's name is a type" (funcall face "Row") 'font-lock-type-face) (test-flan-fln--is "and so is what it names" (funcall face "Vec(i64)") 'font-lock-type-face)) @@ -752,15 +756,13 @@ fn gcd(a: i32, b: i32) -> i32 (test-flan-fln--is "installed as a defmacro" (flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point)))) "defmacro") - (search-forward "recur") - (test-flan-fln--is "a loop's statement is its header and block" - (progn (forward-line -1) - (test-flan-fln--thing 'flan-fln-statement)) - "loop x = a, y = b - if y == 0 then x else recur(y, x % y)") - (test-flan-fln--is "and its body the block" - (test-flan-fln--thing 'flan-fln-body) - "if y == 0 then x else recur(y, x % y)") + (search-forward "while y") + (test-flan-fln--is "a while's statement is its header and block" + (test-flan-fln--thing 'flan-fln-statement) + "while y != 0 + let r = x % y + x = y + y = r") (goto-char (point-min)) (test-flan-fln--is "the struct's head is defstruct" (flan-fln--declaration-head-at (point)) "defstruct") @@ -879,13 +881,13 @@ defconst(k, 3) ("let f = fn(a, b) =>" "a lambda header") ("let f = fn(a: i64, b) -> i64 =>" "a typed lambda header") ("let f = fn(g: Fn(i64) -> i64) -> Option(i64) =>" "one with a function type in it") - ("let r = loop i = 0, acc = 1" "a let's loop") - ("loop i = 0, acc = 1" "a loop") ("fn(a: i64) -> i64 =>" "a typed lambda as a statement"))) (test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c)) (test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4)) (test-flan-fln--is "but not a typed lambda with its body on the line" (test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 => a\n|" 1) 2) +(test-flan-fln--is "loop is no header in .fln, and opens nothing" + (test-flan-fln--tabs "fn f()\n let r = loop i = 0\n|" 1) 2) (test-flan-fln--is "a header word being assigned opens nothing" (test-flan-fln--tabs "fn f()\n for = 1\n|" 1) 2) (test-flan-fln--in "fn f()\n handler-case\n g()\n on E(c)\n h(c)\n on = 2\n data += 1\n" diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index a86235e1..a412e3fd 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -585,12 +585,12 @@ let body_guess (h : Form.t) args = match a.v with Form.List _ -> false | _ -> true) args) in (match base with | "comment" | "do" -> Some 0 - | "unless" | "loop" -> Some 1 + | "unless" -> Some 1 | "defmacro" -> Some 2 | "defmethod" -> Some 3 | _ -> (* A with- macro, or any call whose last argument is a statement — - a let, a loop, an assignment — has a body: the trailing run of + a let, a while, an assignment — has a body: the trailing run of lists goes in the block. *) let stmt_like (a : Form.t) = match a.v with @@ -920,9 +920,6 @@ and value_lines n prefix (v : Form.t) = | _ -> false in if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) - else if loop_head v <> None then - let head, body = Option.get (loop_head v) in - [ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body else match lambda_value n prefix v with | Some ls -> ls @@ -939,23 +936,6 @@ and value_lines n prefix (v : Form.t) = and slot n (f : Form.t) = block n (stmts_of f) -(* [(loop [x a y b] body ...)] as the header [loop x = a, y = b] and its - body, when every binding is a plain name. A lambda or one-line if as a - value is parenthesised, so its else cannot run on into the next binding. *) -and loop_head (f : Form.t) = - match f.v with - | Form.List ({ v = Form.Sym "loop"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) -> - (match pairs bs with - | Some (_ :: _ as prs) - when List.for_all (fun ((x : Form.t), _) -> - match x.v with Form.Sym x -> def_name x | _ -> false) prs -> - Some - ("loop " - ^ String.concat ", " (List.map (fun (x, v) -> fst (expr x) ^ " = " ^ at 1 v) prs), - body) - | _ -> None) - | _ -> None - and label_of = function | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) | rest -> ("", rest) @@ -1164,9 +1144,6 @@ and sugar n (f : Form.t) : string list option = | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ] | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | _ -> None) - | Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None -> - let head, body = Option.get (loop_head f) in - Some ((i ^ head) :: block (n + 2) body) | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body)) when def_name name -> @@ -1365,10 +1342,34 @@ and let_lines n prs body = let lines n b = let p, v = bind b in tagged b (value_lines n p v) in List.concat_map (lines n) prs @ block n body +(* A .flan file that uses [loop] or [recur] has no indented spelling: the + indented syntax loops with [while], [until], [dotimes] and [for]. The + refusal names every line, so the file is rewritten in one pass. *) +let refuse_loops (fs : Form.t list) = + match R.loop_forms fs with + | [] -> () + | (first : Form.t) :: rest as uses -> + let word (f : Form.t) = + match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop" + in + let lines = List.sort_uniq compare (List.map (fun (f : Form.t) -> f.loc.Loc.line) uses) in + let notes = List.map (fun (f : Form.t) -> Loc.note f.loc (word f ^ " is here")) rest in + Loc.failk ~notes "convert/no-loop" first.loc + "this file uses loop or recur on line%s %s, and the indented syntax \ + has neither. Rewrite each one in the .flan file as a while or until \ + over let variables it changes, then convert again:\n\n\ + \ (let [i 0 total 0]\n\ + \ (while (< i 10)\n\ + \ (set total (+ total i))\n\ + \ (set i (+ i 1))))" + (if List.length lines = 1 then "" else "s") + (String.concat ", " (List.map string_of_int lines)) + (** A whole file: top-level forms with a blank line between them. [macros] is [Body_macros.table] of the file; without it, the prelude's and the file's own macros are known and no imported package's. *) let program ?source ?macros:m (fs : Form.t list) : string = + refuse_loops fs; macros := (match m with Some m -> m | None -> Body_macros.table fs); classes := List.filter_map diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index b703d7f4..f3cbc56f 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -659,6 +659,17 @@ let refuse_ws ?(brace = false) loc e = [not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it has an operator at its top, so it cannot sit in a list separated only by whitespace. *) +(* [loop] and [recur] are Lisp-syntax forms. A .fln loop is a [while], + [until], [dotimes] or [for]; [read_all] refuses any that gets past the + parser, in a [quote] or a quoted datum too. *) +let no_loop loc word = + failk "no-loop" loc + "%s is not part of the indented syntax. A loop here is a while, until, \ + dotimes or for, with let variables it changes:\n\n\ + \ let i = 0\n let total = 0\n while i < 10\n total += i\n i += 1\n\n\ + break leaves the loop early, and continue goes on to the next round." + word + let rec expr p : Form.t * int = binary p 1 and binary p lvl : Form.t * int = @@ -765,6 +776,14 @@ and primary p : Form.t * int = let glued_lp = nxt.tok = LP && not nxt.sp in if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p else if s = "fn" && glued_lp then fn_expr p + else if (s = "loop" || s = "recur") + && (glued_lp || nxt.tok = COLON + || (nxt.sp && starts_value nxt.tok + && (match nxt.tok with + | NAME x -> not (x = "=" || List.mem_assoc x assign_ops || is_op_word x) + | _ -> true)) + || (nxt.tok = NEWLINE && (peek_at p 2).tok = INDENT)) then + no_loop l0 s else if is_op_word s then begin if glued_lp || ends_value nxt.tok then begin ignore (advance p); @@ -1222,13 +1241,6 @@ let header_follow p s = && (let a = peek_at p 2 in a.tok = LP && not a.sp) (* [type Row = Vec(i32)]: a name and its [=]. *) | "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "=" - (* [loop x = a, ...]: a name and its [=]. A name and a comma or the end - of the line, or [loop] alone over a block, is a loop missing its first - values, which [header] answers. *) - | "loop" -> - (n.sp && plain_name n.tok - && (match (peek_at p 2).tok with NAME "=" | COMMA | NEWLINE -> true | _ -> false)) - || (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) | "break" | "continue" -> n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) @@ -1392,7 +1404,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t = match (peek p).tok with (* [let r = match a] with its arms under it, and [let r = if c] with its branches: a header read as the value, block and all. *) - | NAME (("match" | "handler-case" | "handler-bind" | "restart-case" | "loop") as w) + | NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w) when header_follow p w -> header s w | NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if" @@ -1892,31 +1904,6 @@ and header (s : st) w : Form.t = expect_line_end p ~after:")"; let body = block s ~after:("macro " ^ text_of name ^ "(...)") in named "defmacro" (name :: pv :: body) - | "loop" -> - let missing () = - failk "loop-bindings" l0 - "loop names each variable with its first value: loop i = 0, acc = 1. \ - A loop with no variables is written loop([]):" - in - if (peek p).tok = NEWLINE then missing (); - let rec binds acc = - let n = name_tok p ~what:"a loop variable's name" in - (match (peek p).tok with - | NAME "=" -> ignore (advance p) - | _ -> - failk "loop-bindings" n.loc - "%s needs its first value: loop %s = 0. Each variable of a loop \ - takes one, separated by commas: loop i = 0, acc = 1" - (text_of n) (text_of n)); - let v, _ = expr p in - match (peek p).tok with - | COMMA -> ignore (advance p); binds (v :: n :: acc) - | _ -> List.rev (v :: n :: acc) - in - let bs = binds [] in - expect_line_end p ~after:(text_of (List.nth bs (List.length bs - 1))); - let body = block s ~after:"loop" in - form (Form.make (Form.Vec bs) (span_of_list (List.hd bs).loc bs) :: body) | "data" -> let name = name_tok p ~what:"the type's name" in expect_eol_block p ~after:("data " ^ text_of name); @@ -2257,6 +2244,29 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list = let () = block_of := fun p -> block { p; lets = [] } ~after:"=>" +(* Every [(loop ...)] and [(recur ...)] in [fs], at any depth and inside + quoted code too, in source order. The indented syntax has neither: its + loops are [while], [until], [dotimes] and [for]. The printer asks the same + question before it converts a .flan file. *) +let loop_forms (fs : Form.t list) = + let out = ref [] in + let rec walk (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym ("loop" | "recur"); _ } :: _) -> + out := f :: !out; + (match f.v with Form.List l -> List.iter walk l | _ -> ()) + | Form.List l | Form.Vec l | Form.Map l -> List.iter walk l + | _ -> () + in + List.iter walk fs; + List.rev !out + +let refuse_loops fs = + match loop_forms fs with + | [] -> () + | (f : Form.t) :: _ -> + no_loop f.loc (match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop") + (** All top-level forms in a [.fln] source string. [col] is the column the text's top level starts at, 1 for a file. *) let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src = @@ -2287,6 +2297,7 @@ let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src = (match (peek s.p).tok with | EOF -> () | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); + refuse_loops fs; fs) let read_file path = diff --git a/spec-syntax.md b/spec-syntax.md index bda24f0a..e7e4cfc6 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -192,7 +192,7 @@ Each item: the proposal, then the reason in one line. rebinds, the `let`'s is renamed (`x` to `x-2`, a name the top-level form does not use; a struct pattern is written as `{x-2 .x}` pairs). A macro's body counts as statements run in order when its definition splices its - rest parameter only into a `do`, a `let`/`fn`/`when`/`while`/`loop` body or + rest parameter only into a `do`, a `let`/`fn`/`when`/`while` body or another such macro's body; `comment` counts too. Where a rename cannot be trusted (the name quoted, qualified as `x/y`, or called as `x(...)`), and at the top level, among a call's other arguments and in a quasiquote, the @@ -323,9 +323,12 @@ Each item: the proposal, then the reason in one line. - `macro repeat(i, n, & body)` plus a block reads `(defmacro repeat [i n & body] …)`. A parameter is a bare name, a destructuring vector `[a b]`, or `& rest`, last. **Built.** -- `loop x = a, y = b` plus a block reads `(loop [x a y b] …)`, as a statement - or as a value, `let r = loop i = 0`. `recur(y, x % y)` is a call. A loop with - no variables is the fallback, `loop([]):`. **Built.** +- There is no `loop` or `recur`. A loop is `while`, `until`, `dotimes` or + `for`, over `let` variables it changes, with `break` and `continue`. The + reader refuses `loop` and `recur` in any spelling, inside `quote` too + (`indent/no-loop`), and `flan convert` refuses a .flan file that uses them, + naming each line (`convert/no-loop`). A macro defined in a .flan file may + still expand to them. **Built.** - `class lambda(param, body, env)`, or `class lambda` with a slot per line, reads `(defclass lambda [param body env])`; a typed slot is `pause: bool` and its type follows its name in the vector. **Built.** diff --git a/test/programs/fn-capture.flan b/test/programs/fn-capture.flan index 934e8b8e..6c34b144 100644 --- a/test/programs/fn-capture.flan +++ b/test/programs/fn-capture.flan @@ -91,15 +91,15 @@ (set total (+ total (call0 (fn [] i))))) (println total)) - ;; And the same again where the loop variable is rebound by a recur rather - ;; than stepped by a dotimes, which is a store into the slot the copy is - ;; taken from: 100 + 101 + 102. + ;; And the same again where the loop variable is stepped by a set in a + ;; while rather than by a dotimes, which is a store into the slot the copy + ;; is taken from: 100 + 101 + 102. (println - (let [base 100] - (loop [i 0 acc 0] - (if (< i 3) - (recur (+ i 1) (+ acc (call0 (fn [] (+ base i))))) - acc)))) + (let [base 100 i 0 acc 0] + (while (< i 3) + (set acc (+ acc (call0 (fn [] (+ base i))))) + (set i (+ i 1))) + acc)) ;; Called twice, so the environment is read more than once and a body that ;; consumed it would show. diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index f295fbd8..f8efc122 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -49,11 +49,13 @@ (defstruct Node [v $t next (Option (Ptr (Node $t)))]) (defn sum-list [n (Ptr (Node i64))] i64 - (loop [at n acc (the i64 0)] - (let [acc (+ acc (.v at))] + (let [at n acc (the i64 0)] + (while true + (set acc (+ acc (.v at))) (match (.next at) - (Some p) (recur p acc) - None acc)))) + (Some p) (set at p) + None (break))) + acc)) ;; A template naming another at its own parameters. (defstruct Twice [x (Small $m $u) y (Small $m $u)]) diff --git a/test/programs/match-enum.flan b/test/programs/match-enum.flan index 988b092c..83f7c5fd 100644 --- a/test/programs/match-enum.flan +++ b/test/programs/match-enum.flan @@ -25,12 +25,14 @@ (calls) :west) -;; recur from inside an arm: the arm is the loop's tail. +;; break from inside an arm leaves the while around the match. (defn steps-to-west [from Dir] i32 - (loop [d from n 0] - (match d - :west n - _ (recur (turn d) (+ n 1))))) + (let [d from n 0] + (while true + (match d + :west (break) + _ (do (set d (turn d)) (set n (+ n 1))))) + n)) (defn main [] i32 (print (steps-to-west :north)) (println "") diff --git a/test/programs/match-literal.flan b/test/programs/match-literal.flan index 2b95ed13..811dadfb 100644 --- a/test/programs/match-literal.flan +++ b/test/programs/match-literal.flan @@ -44,12 +44,14 @@ (print "(called) ") 7) -;; recur from inside an arm: the arm is the loop's tail. +;; break from inside an arm leaves the while around the match. (defn count-down [from i32] i32 - (loop [n from steps 0] - (match n - 0 steps - _ (recur (- n 1) (+ steps 1))))) + (let [n from steps 0] + (while true + (match n + 0 (break) + _ (do (set n (- n 1)) (set steps (+ steps 1))))) + steps)) (defn main [] i32 (println (small 5)) diff --git a/test/syntax/flat/shadows.flan b/test/syntax/flat/shadows.flan index 87dd7fa0..44353369 100644 --- a/test/syntax/flat/shadows.flan +++ b/test/syntax/flat/shadows.flan @@ -29,10 +29,14 @@ (println i)))) (defn loopr [] i32 - (loop [n 0 acc 0] - (let [n (* n 2)] - (println n)) - (if (< n 4) (recur (+ n 1) (+ acc n)) acc))) + (let [n 0 acc 0] + (while true + (let [n (* n 2)] + (println n)) + (if (< n 4) + (do (set acc (+ acc n)) (set n (+ n 1))) + (break))) + acc)) (defn ret [a i32] i32 (let [a (+ a 1)] diff --git a/test/syntax/handwritten/inventory.fln b/test/syntax/handwritten/inventory.fln index 79d7b494..bb1161cb 100644 --- a/test/syntax/handwritten/inventory.fln +++ b/test/syntax/handwritten/inventory.fln @@ -25,8 +25,13 @@ macro expect(test, message) println("expected:", ~message) fn gcd(a: i32, b: i32) -> i32 - loop x = a, y = b - if y == 0 then x else recur(y, x % y) + let x = a + let y = b + while y != 0 + let r = x % y + x = y + y = r + x fn line(it: stock/Item) -> () let price = stock/money(stock/value(it)) diff --git a/test/test_syntax.ml b/test/test_syntax.ml index a623b0a4..4adf305a 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -359,13 +359,17 @@ let attached_ok ~what path (src, forms) (out, back) = (* Every .flan the build tree holds. [..] is the workspace root from here; the deps in test/dune decide what is in it. *) let corpus () = + (* recur.flan is about the Lisp loop form, which the indented syntax does + not have. *) + let lisp_only = [ "recur.flan" ] in let rec walk dir acc = Array.fold_left (fun acc name -> let path = Filename.concat dir name in if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc else if Sys.is_directory path then walk path acc - else if Filename.check_suffix name ".flan" then path :: acc + else if Filename.check_suffix name ".flan" && not (List.mem name lisp_only) then + path :: acc else acc) acc (Sys.readdir dir) in @@ -612,12 +616,18 @@ let () = reads "macro with no parameters" "macro m()\n a" "(defmacro m [] a)"; refuses "a rest parameter not last" "macro m(& a, b)\n a" "indent/macro-rest-last" "comes last: macro m(b, & a)"; - reads "loop" "loop x = a, y = b + 1\n recur(y, x)" "(loop [x a y (+ b 1)] (recur y x))"; - reads ~global:false "a let-bound loop" "let r = loop i = 0\n recur(i)\nr" "(let [r (loop [i 0] (recur i))] r)"; - reads "the loop call stays a call" "loop([x 1]):\n x" "(loop [x 1] x)"; - refuses "a loop with no values" "loop\n g()" "indent/loop-bindings" "loop([]):"; - refuses "a loop variable with no value" "loop x, y = 1\n g()" "indent/loop-bindings" - "loop x = 0"; + (* No loop and no recur: a .fln loop is a while, until, dotimes or for. *) + refuses "a loop header" "loop x = a, y = b + 1\n recur(y, x)" "indent/no-loop" + "while i < 10"; + refuses ~global:false "a let-bound loop" "let r = loop i = 0\n i\nr" "indent/no-loop" + "loop is not part of the indented syntax"; + refuses "a loop call" "loop([x 1]):\n x" "indent/no-loop" "while, until, dotimes or for"; + refuses "a loop over a block" "loop\n g()" "indent/no-loop" "loop is not"; + refuses "a recur call" "f(recur(1))" "indent/no-loop" "recur is not part of the indented syntax"; + refuses "a loop in a macro's quote" "macro m(a)\n quote\n loop([i ~a]):\n i" + "indent/no-loop" "loop is not"; + refuses "a quoted loop" "f('(loop [i 0] (recur i)))" "indent/no-loop" "loop is not"; + reads "loop as a name" "loop = 4" "(set loop 4)"; reads "read-only pointer" "let p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; (* Statements that fit on a line, in one-line slots. *) reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" @@ -989,12 +999,24 @@ let () = prints "a parent with no fields" "(defstruct D :parent Io)" "struct D :parent Io"; prints "an empty field vector under a parent keeps the fallback" "(defstruct D :parent Io [])" "defstruct(D, :parent, Io, [])"; - prints "a loop" "(defn f [a i32] i32 (loop [x a y 0] (if (= x 0) y (recur (- x 1) (+ y 1)))))" - " loop x = a, y = 0\n if x == 0 then y"; - prints "a let-bound loop" "(defn f [] i32 (let [r (loop [i 0] (recur i))] r))" - " let r = loop i = 0\n recur(i)"; - prints "a lambda as a loop's value is parenthesised" - "(defn f [] () (loop [g (fn [x] x) n 0] (recur g n)))" "loop g = (fn(x) => x), n = 0" + (* A .flan file with loop or recur is refused, every line named. *) + (match + Reader.read_all ~file:"

" + "(defn f [a i32] i32\n (loop [x a y 0]\n (if (= x 0) y (recur (- x 1) (+ y 1)))))\n\n(defn g [] i32 (loop [i 0] i))" + with + | forms -> + (match Indent_printer.program forms with + | text -> fail "a loop printed: %s" text + | exception Loc.Error d -> + if d.Loc.kind <> "convert/no-loop" then fail "a loop refused as %s" d.Loc.kind; + List.iter + (fun n -> + if not (Test_support.contains d.Loc.dmsg n) then + fail "the loop refusal does not say %S: %s" n d.Loc.dmsg) + [ "on lines 2, 3, 5"; "(while (< i 10)" ]; + if List.length d.Loc.notes <> 2 then + fail "the loop refusal points at %d more places, wanted 2" (List.length d.Loc.notes)) + | exception e -> fail "a loop: %s" (diag_text e)) (* ── Spans, for pause marks and error overlays ──────────────────────── *) From 9644b8a61603be74a27d7f431a6a2bea9b17c708 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 10:41:12 +0700 Subject: [PATCH 3/5] A dev build's self-equality scan walks each container once, a free finds its block by the keyed probe, a registry listing waits out a growth, and a view's crossing and scalar read take fewer instructions. --- runtime/flan_dev.c | 51 ++++++++++++++++++-- runtime/flan_dyn.c | 82 ++++++++++++++++++++++++++++++--- test/programs/dyn-view-any.flan | 21 +++++++++ test/test_acceptance.ml | 25 ++++++++-- 4 files changed, 163 insertions(+), 16 deletions(-) diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index ec10c12a..5865d877 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1475,13 +1475,30 @@ static int flan_reg_snap(flan_reg_entry *e, flan_reg_entry *out) { /* The table-wide counter, read on the way into a scan and again on the way * out: a compaction between the two moved entries, so the scan saw some of * them twice and some not at all. */ +static uint64_t flan_reg_grows; /* how many times the table has grown */ + +static void flan_reg_wait(void); static int flan_reg_scan_open(uint64_t *at) { uint64_t g = __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE); + /* A growth copies the whole table and takes longer than a compaction, long + enough to use up a listing's attempts one wait at a time. So a listing + that meets one waits it out, up to a tenth of a second, rather than + counting each look as a lost attempt. */ + for (int w = 0; (g & 1) && w < 400; w++) { + flan_reg_wait(); + g = __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE); + } if (g & 1) return 0; *at = g; return 1; } +/* Did the table grow since [grows0]? A walk that a growth overlapped is + retried without counting against its attempts: a growth ends. */ +static int flan_reg_grew(uint64_t grows0) { + return __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE) != grows0; +} + static int flan_reg_scan_ok(uint64_t at) { __atomic_thread_fence(__ATOMIC_ACQUIRE); return __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE) == at; @@ -1738,6 +1755,7 @@ static int flan_reg_grow(void) { } __atomic_store_n(&flan_reg, n, __ATOMIC_RELEASE); __atomic_store_n(&flan_reg_capv, ncap, __ATOMIC_RELEASE); + __atomic_store_n(&flan_reg_grows, flan_reg_grows + 1, __ATOMIC_RELEASE); __atomic_store_n(&flan_reg_epoch, (flan_reg_epoch | 1) + 1, __ATOMIC_RELEASE); return 1; } @@ -1896,11 +1914,29 @@ int flan_dev_reg_overflowed(void) { return flan_reg_full; } * block handed out as a slice. */ static flan_reg_entry *flan_reg_find(uintptr_t a); +/* The entry for a block that starts at [base], live before dead, by the + * probe a free takes: (free s) always hands over a block's start, so the + * question is equality and a scan of the whole table — which grows — would + * make every free cost the table's size. NULL when no block starts there. */ +static flan_reg_entry *flan_reg_at_base(uintptr_t base) { + flan_reg_entry *dead = NULL; + int64_t cap = FLAN_REG_CAP, probe; + size_t s0 = flan_reg_slot(base); + for (probe = 0; probe < cap; probe++) { + size_t j = (s0 + (size_t)probe) & (size_t)(cap - 1); + if (flan_reg[j].base == 0) break; + if (flan_reg[j].base != base) continue; + if (flan_reg[j].died == 0) return &flan_reg[j]; + if (dead == NULL) dead = &flan_reg[j]; + } + return dead; +} + int32_t flan_dev_reg_owner_check(const void *p, const void *owner, const void **found) { flan_reg_entry *e; if (!flan_reg_on) return 0; - e = flan_reg_find((uintptr_t)p); + e = flan_reg_at_base((uintptr_t)p); if (e == NULL) return flan_reg_full ? 0 : 1; if (e->base != (uintptr_t)p) return 1; if (e->died != 0) return 3; @@ -2153,8 +2189,9 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, rearrangement they are all losing to — and leaving one bare retry in the file next to the note explaining why they are wrong is how the next person learns the rule has exceptions it does not have. */ + int regrown = 0; for (attempt = 0; attempt < 8; attempt++) { - uint64_t at; + uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE); int64_t i; have = 0; if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; } @@ -2168,6 +2205,7 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, } if (flan_reg_scan_ok(at)) break; have = 0; + if (flan_reg_grew(grows0) && regrown++ < 64) attempt--; flan_reg_wait(); } if (!have) return 0; @@ -2238,8 +2276,9 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, the end of a string literal. The whole walk is retried when a compaction ran through the middle of it, since entries moved and the counts would hold some blocks twice and some not at all. */ + int regrown = 0; for (attempt = 0; attempt < 8; attempt++) { - uint64_t at; + uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE); n = 0; missed = 0; if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; } @@ -2270,7 +2309,11 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, } n++; } - if (!flan_reg_scan_ok(at)) { flan_reg_wait(); continue; } + if (!flan_reg_scan_ok(at)) { + if (flan_reg_grew(grows0) && regrown++ < 64) attempt--; + flan_reg_wait(); + continue; + } /* A stable epoch and every slot copied: this is a table that existed. */ if (missed == 0) return n; /* A stable epoch but slots that would not hold still. Worth another walk — diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index c4339372..cc6932cd 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -2892,7 +2892,39 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc, * traps. So a dev build walks the one container, as deep as equality would, * and checks every view it holds — the same rule [eq_walk] applies at the * top. A release build keeps no guards, and takes the shortcut. */ -static void stale_scan(flan_dyn v, int depth) { +/* The containers one scan has already walked. A container reached twice — + * shared, or holding itself — is walked once, so a scan is linear in what it + * can reach rather than exponential, and a cycle ends. Cleared at the start + * of each scan; open addressing over the object's address. */ +static flan_obj **scan_seen; +static size_t scan_cap, scan_n; + +static int scan_first_visit(flan_obj *o) { + size_t i, mask; + if (scan_n * 2 >= scan_cap) { + size_t ncap = scan_cap ? scan_cap * 2 : 64, j; + flan_obj **n = (flan_obj **)calloc(ncap, sizeof *n); + if (n == NULL) return 0; /* no room to remember: stop descending */ + for (j = 0; j < scan_cap; j++) { + size_t k; + if (scan_seen[j] == NULL) continue; + for (k = ((uintptr_t)scan_seen[j] >> 4) & (ncap - 1); n[k] != NULL; + k = (k + 1) & (ncap - 1)) {} + n[k] = scan_seen[j]; + } + free(scan_seen); + scan_seen = n; + scan_cap = ncap; + } + mask = scan_cap - 1; + for (i = ((uintptr_t)o >> 4) & mask; scan_seen[i] != NULL; i = (i + 1) & mask) + if (scan_seen[i] == o) return 0; + scan_seen[i] = o; + scan_n++; + return 1; +} + +static void stale_walk(flan_dyn v, int depth) { flan_obj *o; int64_t i, n; if (!dyn_boxed(v) || dyn_box(v) != BOX_OBJ || depth >= EQ_DEPTH) return; @@ -2903,8 +2935,23 @@ static void stale_scan(flan_dyn v, int depth) { return; } if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return; + if (!scan_first_visit(o)) return; n = o->kind == OBJ_MAP ? o->len * 2 : o->len; - for (i = 0; i < n; i++) stale_scan(o->u.v.items[i], depth + 1); + for (i = 0; i < n; i++) stale_walk(o->u.v.items[i], depth + 1); +} + +/* Only when some guarded view has ever been made: until then there is + * nothing a scan could find, and a program that never crosses a typed value + * into dyn pays nothing for it. */ +static int64_t views_guarded; + +static void stale_scan(flan_dyn v, int depth) { + if (views_guarded == 0) return; + if (scan_n > 0) { + memset(scan_seen, 0, scan_cap * sizeof *scan_seen); + scan_n = 0; + } + stale_walk(v, depth); } static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { @@ -3268,6 +3315,10 @@ extern struct flan_frame *flan_frame_head; /* runtime/flan_dev.c */ * would allocate and zero it for nothing, and a crossing is on the hot path. * VIEW_GUARDED in [gen] says the guard is there. */ #define VIEW_GUARDED 0x100 /* bits 16-31 hold the element size */ +/* Bits 9-10: an element kind [flan_dyn_at] boxes inline. */ +#define VIEW_FAST_I64 1 +#define VIEW_FAST_F64 2 +#define VIEW_FAST_BOOL 3 static inline view_guard *view_g(flan_obj *o) { return (o->gen & VIEW_GUARDED) ? (view_guard *)(o + 1) : NULL; } @@ -3294,7 +3345,8 @@ static void guard_storage(view_guard *g, const void *p) { /* A new view record, its guard empty. */ -static flan_obj *view_new(void *base, int64_t len, const uint8_t *desc, +static inline __attribute__((always_inline)) flan_obj * +view_new(void *base, int64_t len, const uint8_t *desc, int shape) { int dev = flan_dev_views_checked; flan_obj *o = @@ -3308,9 +3360,16 @@ static flan_obj *view_new(void *base, int64_t len, const uint8_t *desc, if (shape != VIEW_STRUCT) { int64_t sz = desc_size(desc); if (sz > 0 && sz < 0x10000) o->gen |= (uint32_t)sz << 16; + /* The three element kinds [flan_dyn_at] reads without a call. */ + o->gen |= (uint32_t)(*desc == 'l' ? VIEW_FAST_I64 + : *desc == 'd' ? VIEW_FAST_F64 + : *desc == '?' ? VIEW_FAST_BOOL : 0) << 9; } o->len = len; - if (dev) memset(view_g(o), 0, sizeof(view_guard)); + if (dev) { + memset(view_g(o), 0, sizeof(view_guard)); + views_guarded++; + } return o; } @@ -3651,7 +3710,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, } /* Element [i] of a vec-shaped view. The caller has checked the bounds. */ -static uint8_t *view_elem_at(flan_obj *o, int64_t i) { +static inline uint8_t *view_elem_at(flan_obj *o, int64_t i) { int64_t sz = (int64_t)(o->gen >> 16); if (sz == 0) sz = desc_size(o->u.view.desc); return (uint8_t *)view_base(o) + i * sz; @@ -3704,7 +3763,8 @@ static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op, * for a struct view). [here] is the checker's word that the storage is the * 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, +static inline __attribute__((always_inline)) 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); view_guard *g = view_g(o); @@ -3899,7 +3959,15 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, if (o->kind == OBJ_VIEW) { int64_t len = view_len(loc, loclen, "at", o); if (k < 0 || k >= len) trap_range(loc, loclen, "at", v, k, len); - return view_read(loc, loclen, "at", o, o->u.view.desc, view_elem_at(o, k)); + { + uint8_t *p = view_elem_at(o, k); + switch ((o->gen >> 9) & 3) { + case VIEW_FAST_I64: { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); } + case VIEW_FAST_F64: { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); } + case VIEW_FAST_BOOL: return flan_dyn_from_bool(*p ? 1 : 0); + default: return view_read(loc, loclen, "at", o, o->u.view.desc, p); + } + } } if (k < 0 || k >= o->len) trap_range(loc, loclen, "at", v, k, o->len); if (o->kind == OBJ_TEXT) return flan_dyn_from_i64(obj_text_bytes(o)[k]); diff --git a/test/programs/dyn-view-any.flan b/test/programs/dyn-view-any.flan index 8d30914b..a989aa37 100644 --- a/test/programs/dyn-view-any.flan +++ b/test/programs/dyn-view-any.flan @@ -60,6 +60,11 @@ (let [a [(i64 5) 6 7]] (via-slice (slice a 0 3)))) +(defn doubled [n i32] dyn + (let [v (the dyn [1 2])] + (dotimes [i n] (set v (the dyn [v v]))) + v)) + (defn clobber [] i64 (let [b [(i64 7) 8 9 10 11 12]] (+ (at b 0) (at b 5)))) @@ -310,4 +315,20 @@ ;; has-key? on a value that is not a map, at its site. (= n 23) (do (println (has-key? (keep 5) :x)) 0) + ;; A container compared with itself, once a view exists: shared thirty + ;; levels deep, and holding itself. Each must answer at once. + (= n 24) + (let [a [(i64 1)] + k (keep a) + v (doubled 30)] + (println (= v v)) + 0) + (= n 25) + (let [a [(i64 1)] + k (keep a) + c (the dyn [1])] + (push c c) + (push c c) + (println (= c c)) + 0) :else (do (println "?") 1)))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 2c5803f9..ed0619f6 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5937,17 +5937,17 @@ level "1" a dyn view"); ("9", "16777217 has no exact f32"); ("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 \ + ("14", "dyn-view-any.flan:277: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 \ + ("19", "dyn-view-any.flan:292:18: dyn get: this u64 element is \ 18000000000000000000"); ("20", "200 does not fit an i8 element, which holds -128 to 127"); - ("23", "dyn-view-any.flan:312:20: dyn has-key?: int and keyword") ] + ("23", "dyn-view-any.flan:317:20: dyn has-key?: int and keyword") ] and any_stale = [ ("4", "this view points into a local of leak-local, and that call \ has returned"); @@ -5958,9 +5958,9 @@ level "1" 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 \ + ("17", "dyn-view-any.flan:284: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 \ + ("18", "dyn-view-any.flan:286:53: dyn length: this view points into \ a local of leak-local"); ("21", "5999\n"); ("21", "this view's storage, a block of i64, has been released"); @@ -5989,6 +5989,21 @@ level "1" saying %S\n" (name (", mode " ^ mode)) text code needle end) (any_traps @ if dev then any_stale else []); + (* A container compared with itself walks what it holds for stale + views in a dev build; shared and cyclic containers are walked once + each, so both answer in well under a second rather than in time + exponential in the sharing, or never. *) + List.iter + (fun mode -> + let t0 = Unix.gettimeofday () in + let code, text = run exe (Some mode) in + let dt = Unix.gettimeofday () -. t0 in + if code <> 0 || text <> "true\n" || dt > 1.0 then begin + incr failures; + Printf.printf "FAIL %s\n got: %S (exit %d) in %.2fs\n" + (name (", self-equality, mode " ^ mode)) text code dt + end) + [ "24"; "25" ]; (* 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 From 17a7afb29742633ed5114dc8983028aebc4ace68 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 10:43:10 +0700 Subject: [PATCH 4/5] The .fln reader takes loop and recur as names wherever the Lisp loop's spellings are not written, and the convert refusal lists its lines in a sentence of their own. --- lib/indent_printer.ml | 7 +++++-- lib/indent_reader.ml | 21 ++++++++++++++------- test/test_syntax.ml | 10 +++++++++- 3 files changed, 28 insertions(+), 10 deletions(-) diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index a412e3fd..62325b7a 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -1355,7 +1355,7 @@ let refuse_loops (fs : Form.t list) = let lines = List.sort_uniq compare (List.map (fun (f : Form.t) -> f.loc.Loc.line) uses) in let notes = List.map (fun (f : Form.t) -> Loc.note f.loc (word f ^ " is here")) rest in Loc.failk ~notes "convert/no-loop" first.loc - "this file uses loop or recur on line%s %s, and the indented syntax \ + "this file uses loop or recur on line%s %s. The indented syntax \ has neither. Rewrite each one in the .flan file as a while or until \ over let variables it changes, then convert again:\n\n\ \ (let [i 0 total 0]\n\ @@ -1363,7 +1363,10 @@ let refuse_loops (fs : Form.t list) = \ (set total (+ total i))\n\ \ (set i (+ i 1))))" (if List.length lines = 1 then "" else "s") - (String.concat ", " (List.map string_of_int lines)) + (match List.rev_map string_of_int lines with + | last :: (_ :: _ as before) -> + String.concat ", " (List.rev before) ^ " and " ^ last + | ls -> String.concat "" ls) (** A whole file: top-level forms with a blank line between them. [macros] is [Body_macros.table] of the file; without it, the prelude's and the diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index f3cbc56f..03b13c6f 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -776,13 +776,20 @@ and primary p : Form.t * int = let glued_lp = nxt.tok = LP && not nxt.sp in if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p else if s = "fn" && glued_lp then fn_expr p - else if (s = "loop" || s = "recur") - && (glued_lp || nxt.tok = COLON - || (nxt.sp && starts_value nxt.tok - && (match nxt.tok with - | NAME x -> not (x = "=" || List.mem_assoc x assign_ops || is_op_word x) - | _ -> true)) - || (nxt.tok = NEWLINE && (peek_at p 2).tok = INDENT)) then + (* Only the Lisp loop's spellings are refused here, for a message at the + word: [loop x = a, ...], [loop([...]):], a bare [loop] over a block + where a statement or a let's value starts, and [recur(...)]. Anywhere + else [loop] and [recur] are names; [refuse_loops] catches the rest. *) + else if glued_lp && (s = "loop" || s = "recur") then no_loop l0 s + else if s = "loop" + && ((nxt.sp + && (match nxt.tok with NAME x -> not (is_op_word x) | _ -> false) + && (match (peek_at p 2).tok with NAME "=" | COMMA -> true | _ -> false)) + || (nxt.tok = NEWLINE && (peek_at p 2).tok = INDENT + && (p.i = 0 + || (match (last p).tok with + | NEWLINE | INDENT | DEDENT | NAME "=" -> true + | _ -> false)))) then no_loop l0 s else if is_op_word s then begin if glued_lp || ends_value nxt.tok then begin diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 4adf305a..fc970edb 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -628,6 +628,14 @@ let () = "indent/no-loop" "loop is not"; refuses "a quoted loop" "f('(loop [i 0] (recur i)))" "indent/no-loop" "loop is not"; reads "loop as a name" "loop = 4" "(set loop 4)"; + reads "if over loop" "if loop\n 1" "(when loop 1)"; + reads "while over loop" "while loop\n g()" "(while loop (g))"; + reads "until over loop" "until loop\n g()" "(until loop (g))"; + reads "elif over loop" "if recur\n 1\nelif loop\n 2" "(cond recur 1 loop 2)"; + reads "a one-line if over loop" "if loop then 1 else 2" "(if loop 1 2)"; + reads "a one-line if over recur" "if recur > 0 then recur else 0" "(if (> recur 0) recur 0)"; + reads ~global:false "a typed let of loop" "let loop: i32 = 1\nloop" "(let [loop (the i32 1)] loop)"; + reads "a match over loop, and an arm of it" "match loop\n loop -> loop" "(match loop loop loop)"; reads "read-only pointer" "let p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; (* Statements that fit on a line, in one-line slots. *) reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" @@ -1013,7 +1021,7 @@ let () = (fun n -> if not (Test_support.contains d.Loc.dmsg n) then fail "the loop refusal does not say %S: %s" n d.Loc.dmsg) - [ "on lines 2, 3, 5"; "(while (< i 10)" ]; + [ "on lines 2, 3 and 5. The indented syntax"; "(while (< i 10)" ]; if List.length d.Loc.notes <> 2 then fail "the loop refusal points at %d more places, wanted 2" (List.length d.Loc.notes)) | exception e -> fail "a loop: %s" (diag_text e)) From 4188c47b768b3ab3ce5eb9ba7b0cb6cf46d627b0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 10:52:59 +0700 Subject: [PATCH 5/5] A dev build's self-equality scan starts by bumping a stamp rather than clearing its table, so one large scan leaves later ones as cheap as their own size. --- runtime/flan_dyn.c | 33 +++++++++++++++++++-------------- test/programs/dyn-view-any.flan | 13 +++++++++++++ test/test_acceptance.ml | 9 ++++++--- 3 files changed, 38 insertions(+), 17 deletions(-) diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index cc6932cd..00dced35 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -2894,22 +2894,27 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc, * top. A release build keeps no guards, and takes the shortcut. */ /* The containers one scan has already walked. A container reached twice — * shared, or holding itself — is walked once, so a scan is linear in what it - * can reach rather than exponential, and a cycle ends. Cleared at the start - * of each scan; open addressing over the object's address. */ -static flan_obj **scan_seen; + * can reach rather than exponential, and a cycle ends. Open addressing over + * the object's address, each slot stamped with the scan that filled it. */ +typedef struct { flan_obj *o; uint64_t stamp; } scan_slot; +static scan_slot *scan_seen; static size_t scan_cap, scan_n; +/* The scan a slot was filled by. A slot from an earlier scan reads as empty, + * so starting a scan costs a counter bump rather than clearing a table that + * one large scan left large. */ +static uint64_t scan_stamp; static int scan_first_visit(flan_obj *o) { size_t i, mask; if (scan_n * 2 >= scan_cap) { size_t ncap = scan_cap ? scan_cap * 2 : 64, j; - flan_obj **n = (flan_obj **)calloc(ncap, sizeof *n); + scan_slot *n = (scan_slot *)calloc(ncap, sizeof *n); if (n == NULL) return 0; /* no room to remember: stop descending */ for (j = 0; j < scan_cap; j++) { size_t k; - if (scan_seen[j] == NULL) continue; - for (k = ((uintptr_t)scan_seen[j] >> 4) & (ncap - 1); n[k] != NULL; - k = (k + 1) & (ncap - 1)) {} + if (scan_seen[j].stamp != scan_stamp) continue; + for (k = ((uintptr_t)scan_seen[j].o >> 4) & (ncap - 1); + n[k].stamp == scan_stamp; k = (k + 1) & (ncap - 1)) {} n[k] = scan_seen[j]; } free(scan_seen); @@ -2917,9 +2922,11 @@ static int scan_first_visit(flan_obj *o) { scan_cap = ncap; } mask = scan_cap - 1; - for (i = ((uintptr_t)o >> 4) & mask; scan_seen[i] != NULL; i = (i + 1) & mask) - if (scan_seen[i] == o) return 0; - scan_seen[i] = o; + for (i = ((uintptr_t)o >> 4) & mask; scan_seen[i].stamp == scan_stamp; + i = (i + 1) & mask) + if (scan_seen[i].o == o) return 0; + scan_seen[i].o = o; + scan_seen[i].stamp = scan_stamp; scan_n++; return 1; } @@ -2947,10 +2954,8 @@ static int64_t views_guarded; static void stale_scan(flan_dyn v, int depth) { if (views_guarded == 0) return; - if (scan_n > 0) { - memset(scan_seen, 0, scan_cap * sizeof *scan_seen); - scan_n = 0; - } + scan_stamp++; /* never 0, which is what a fresh slot holds */ + scan_n = 0; stale_walk(v, depth); } diff --git a/test/programs/dyn-view-any.flan b/test/programs/dyn-view-any.flan index a989aa37..906ee592 100644 --- a/test/programs/dyn-view-any.flan +++ b/test/programs/dyn-view-any.flan @@ -331,4 +331,17 @@ (push c c) (println (= c c)) 0) + ;; One self-compare over 300000 containers, then twenty thousand + ;; small ones: a large scan must not make every later one pay for it. + (= n 26) + (let [a [(i64 1)] + k (keep a) + big (the dyn []) + small (the dyn [1]) + hits (i64 0)] + (dotimes [i 300000] (push big (the dyn [i]))) + (println (= big big)) + (dotimes [i 20000] (when (= small small) (set hits (+ hits 1)))) + (println hits) + 0) :else (do (println "?") 1)))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index ed0619f6..bb0d75f7 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5994,16 +5994,19 @@ level "1" each, so both answer in well under a second rather than in time exponential in the sharing, or never. *) List.iter - (fun mode -> + (fun (mode, want) -> let t0 = Unix.gettimeofday () in let code, text = run exe (Some mode) in let dt = Unix.gettimeofday () -. t0 in - if code <> 0 || text <> "true\n" || dt > 1.0 then begin + if code <> 0 || text <> want || dt > 1.0 then begin incr failures; Printf.printf "FAIL %s\n got: %S (exit %d) in %.2fs\n" (name (", self-equality, mode " ^ mode)) text code dt end) - [ "24"; "25" ]; + [ ("24", "true\n"); ("25", "true\n"); + (* And a scan that visited 300000 containers leaves nothing for + the next twenty thousand small ones to clear. *) + ("26", "true\n20000\n") ]; (* 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