From ddf7ca497436a59b853b9a0fb28738b29446d10b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 10:16:02 +0700 Subject: [PATCH 1/5] The flan_dyn.h ABI has one implementation, flan_dyn.c --- TODO.org | 12 +- runtime/flan_dyn_stub.c | 410 ---------------------------------------- 2 files changed, 5 insertions(+), 417 deletions(-) delete mode 100644 runtime/flan_dyn_stub.c diff --git a/TODO.org b/TODO.org index a76e8535..7b8e242a 100644 --- a/TODO.org +++ b/TODO.org @@ -1422,13 +1422,11 @@ The opposite of what the escaping-alloca argument predicts, and the measurement that first said otherwise was comparing a 40-frame binary with a 600-frame one. That is why every number in =docs/BUILT.md= is a minimum of nine runs. -** NEXT runtime/flan_dyn_stub.c is dead -Decided 2026-09-25: delete it, as part of a sweep for dead code across the repository, each removal checked unused first. -No dune rule mentions it, no module refers to it, no test links it, and it does -not compile — two conflicting-type errors against its own header. It is maintained -by accident: one lane added a function to it, which is duplicity on the same side -of the same capability. The recommendation is delete, and the author added the -file, so it is his call. +** DONE runtime/flan_dyn_stub.c is dead +CLOSED: [2026-09-25] +Deleted, in a sweep for dead code across the repository in which each removal +was first shown unused. flan_dyn.c is the one implementation of the flan_dyn.h +ABI; a stand-in beside it is not to come back. * Dev loop diff --git a/runtime/flan_dyn_stub.c b/runtime/flan_dyn_stub.c deleted file mode 100644 index e8dfd0a5..00000000 --- a/runtime/flan_dyn_stub.c +++ /dev/null @@ -1,410 +0,0 @@ -/* flan_dyn_stub — a standing-in implementation of the flan_dyn.h ABI. - * - * THE MERGE REPLACES THIS FILE WITH runtime/flan_dyn.c. It exists so that the - * compiler side of dynamic-by-default can be built and run against the fixed - * ABI before the real runtime lands; the real one is being written in parallel - * against the same header, and flan_dyn.h is the contract the two are diffed - * against. - * - * What it is not: it mallocs and never frees, it collects nothing, and - * flan_dyn_root_push / flan_dyn_root_pop record their arguments and do nothing - * with them. That last point matters for anyone reading a passing test here — - * root emission is *not* exercised by this file. A program with entirely wrong - * root discipline passes every test that runs against this stub. The check - * that does bite is the one over the emitted IR, counting pushes against pops - * per function; see the acceptance tests. - * - * The representation is the simplest thing that satisfies the header's rule - * that the word is opaque: every value is a pointer to a heap cell, including - * the small ones. The real runtime will not do this. - */ - -#include -#include -#include -#include -#include - -/* The compiler carries this file as one string with flan_dyn.h pasted in front - * of it (lib/dune), and in that form there is no header on disk to find. The - * probe keeps the file compilable both ways: standalone against the real - * header, and concatenated, where the declarations are already above. The - * header's own include guard makes the two agree. */ -#if defined(__has_include) -# if __has_include("flan_dyn.h") -# include "flan_dyn.h" -# endif -#endif - -/* flan_rt.c's own [rt_trap] is static, so this mirrors it rather than calling - * it: print the sentence, offer the name to the dev daemon's hook, and leave - * with flan_rt's exit code so that a dyn trap is indistinguishable from any - * other trap to whoever is watching. The hook is flan_rt.c's global, and a - * program links both files. */ -extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen); - -static _Noreturn void dyn_trap(const char *name, const char *sentence) { - fflush(stdout); - fprintf(stderr, "%s\n", sentence); - fflush(stderr); - if (flan_trap_hook != NULL) - flan_trap_hook((const uint8_t *)name, (int64_t)strlen(name)); - _exit(134); -} - -enum tag { T_NIL, T_I64, T_F64, T_BOOL, T_STR, T_VEC }; - -typedef struct cell { - enum tag tag; - union { - int64_t i; - double f; - int32_t b; - struct { uint8_t *ptr; int64_t len; } s; - struct { struct cell **items; int64_t len, cap; } v; - } u; -} cell; - -static cell *alloc(enum tag t) { - cell *c = calloc(1, sizeof *c); - if (c == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); - c->tag = t; - return c; -} - -static cell *as(flan_dyn d) { return (cell *)(uintptr_t)d; } -static flan_dyn word(cell *c) { return (flan_dyn)(uintptr_t)c; } - -/* ── Construction ──────────────────────────────────────────────────── */ - -flan_dyn flan_dyn_nil(void) { return word(alloc(T_NIL)); } - -flan_dyn flan_dyn_from_i64(int64_t v) { - cell *c = alloc(T_I64); c->u.i = v; return word(c); -} - -flan_dyn flan_dyn_from_f64(double v) { - cell *c = alloc(T_F64); c->u.f = v; return word(c); -} - -flan_dyn flan_dyn_from_bool(int32_t v) { - cell *c = alloc(T_BOOL); c->u.b = (v != 0); return word(c); -} - -flan_dyn flan_dyn_from_bytes(const uint8_t *ptr, int64_t len) { - cell *c = alloc(T_STR); - c->u.s.ptr = malloc((size_t)len + 1); - if (c->u.s.ptr == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); - if (len > 0) memcpy(c->u.s.ptr, ptr, (size_t)len); - c->u.s.ptr[len] = 0; - c->u.s.len = len; - return word(c); -} - -flan_dyn flan_dyn_vec_new(void) { - cell *c = alloc(T_VEC); - c->u.v.cap = 8; - c->u.v.items = calloc((size_t)c->u.v.cap, sizeof(cell *)); - if (c->u.v.items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); - return word(c); -} - -/* ── Arithmetic ────────────────────────────────────────────────────── */ - -/* Two numbers promote to f64 when either is one, which is the rule a reader - * expects of a dynamic language and is still not the rule the typed language - * uses. The typed side widens only where nothing can be lost, and an i64 into - * an f64 can — TODO.org, "Implicit numeric widening is legal; narrowing stays - * a hard error" — so (+ i64-x 2.5) is written there and is promoted here. The - * difference is not an oversight on either side: here there - * is no annotation to have been written, so refusing would leave (+ 1 2.5) - * with no spelling that works. */ -static int numeric(cell *c) { return c->tag == T_I64 || c->tag == T_F64; } -static double as_f(cell *c) { return c->tag == T_I64 ? (double)c->u.i : c->u.f; } - -static flan_dyn arith(flan_dyn a, flan_dyn b, char op) { - cell *x = as(a), *y = as(b); - if (!numeric(x) || !numeric(y)) dyn_trap("DynArithType", "this arithmetic needs two numbers, and one of the two values is not one"); - if (x->tag == T_I64 && y->tag == T_I64) { - int64_t p = x->u.i, q = y->u.i, r = 0; - switch (op) { - case '+': r = p + q; break; - case '-': r = p - q; break; - case '*': r = p * q; break; - case '/': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p / q; break; - case '%': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p % q; break; - } - return flan_dyn_from_i64(r); - } - { - double p = as_f(x), q = as_f(y), r = 0; - switch (op) { - case '+': r = p + q; break; - case '-': r = p - q; break; - case '*': r = p * q; break; - case '/': r = p / q; break; - /* fmod without math.h, to keep the stub's link line as short as the - * real runtime's is meant to be. */ - case '%': r = p - q * (double)(int64_t)(p / q); break; - } - return flan_dyn_from_f64(r); - } -} - -flan_dyn flan_dyn_add(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return arith(a, b, '+'); -} -flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return arith(a, b, '-'); -} -flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return arith(a, b, '*'); -} -flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return arith(a, b, '/'); -} -flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return arith(a, b, '%'); -} - -/* ── Ordering and equality ─────────────────────────────────────────── */ - -static int cmp(flan_dyn a, flan_dyn b) { - cell *x = as(a), *y = as(b); - if (x->tag == T_STR && y->tag == T_STR) { - int64_t n = x->u.s.len < y->u.s.len ? x->u.s.len : y->u.s.len; - int r = memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)n); - if (r != 0) return r < 0 ? -1 : 1; - return x->u.s.len == y->u.s.len ? 0 : (x->u.s.len < y->u.s.len ? -1 : 1); - } - if (!numeric(x) || !numeric(y)) dyn_trap("DynCompareType", "these two values have no ordering between them"); - if (x->tag == T_I64 && y->tag == T_I64) - return x->u.i == y->u.i ? 0 : (x->u.i < y->u.i ? -1 : 1); - { - double p = as_f(x), q = as_f(y); - return p == q ? 0 : (p < q ? -1 : 1); - } -} - -flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return flan_dyn_from_bool(cmp(a, b) < 0); -} -flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return flan_dyn_from_bool(cmp(a, b) <= 0); -} -flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return flan_dyn_from_bool(cmp(a, b) > 0); -} -flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc, - int64_t loclen) { - (void)loc; (void)loclen; - return flan_dyn_from_bool(cmp(a, b) >= 0); -} - -/* Structural, and never traps — the header's one exception. */ -static int eq(cell *x, cell *y) { - if (numeric(x) && numeric(y)) { - if (x->tag == T_I64 && y->tag == T_I64) return x->u.i == y->u.i; - return as_f(x) == as_f(y); - } - if (x->tag != y->tag) return 0; - switch (x->tag) { - case T_NIL: return 1; - case T_BOOL: return x->u.b == y->u.b; - case T_STR: return x->u.s.len == y->u.s.len - && memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)x->u.s.len) == 0; - case T_VEC: { - if (x->u.v.len != y->u.v.len) return 0; - for (int64_t i = 0; i < x->u.v.len; i++) - if (!eq(x->u.v.items[i], y->u.v.items[i])) return 0; - return 1; - } - default: return 0; - } -} - -flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) { - return flan_dyn_from_bool(eq(as(a), as(b))); -} - -/* ── Containers ────────────────────────────────────────────────────── */ - -static cell *need_vec(flan_dyn v) { - cell *c = as(v); - if (c->tag != T_VEC) dyn_trap("DynNotAVec", "this value is not a vector, so it has no elements"); - return c; -} - -static int64_t need_index(flan_dyn i) { - cell *c = as(i); - if (c->tag != T_I64) dyn_trap("DynIndexType", "an index must be an integer"); - return c->u.i; -} - -flan_dyn flan_dyn_len(flan_dyn v) { - cell *c = as(v); - if (c->tag == T_STR) return flan_dyn_from_i64(c->u.s.len); - return flan_dyn_from_i64(need_vec(v)->u.v.len); -} - -flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i) { - cell *c = need_vec(v); - int64_t k = need_index(i); - if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds"); - return word(c->u.v.items[k]); -} - -void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x) { - cell *c = need_vec(v); - int64_t k = need_index(i); - if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds"); - c->u.v.items[k] = as(x); -} - -void flan_dyn_push(flan_dyn v, flan_dyn x) { - cell *c = need_vec(v); - if (c->u.v.len == c->u.v.cap) { - int64_t cap = c->u.v.cap * 2; - cell **items = realloc(c->u.v.items, (size_t)cap * sizeof(cell *)); - if (items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); - c->u.v.items = items; - c->u.v.cap = cap; - } - c->u.v.items[c->u.v.len++] = as(x); -} - -static void print_cell(cell *c) { - switch (c->tag) { - case T_NIL: fputs("nil", stdout); break; - case T_I64: printf("%lld", (long long)c->u.i); break; - /* %g, so that a whole-numbered f64 does not print as an i64 would and - * the two remain distinguishable in a test's expected output. */ - case T_F64: printf("%g", c->u.f); break; - case T_BOOL: fputs(c->u.b ? "true" : "false", stdout); break; - case T_STR: printf("%.*s", (int)c->u.s.len, (const char *)c->u.s.ptr); break; - case T_VEC: - fputc('[', stdout); - for (int64_t i = 0; i < c->u.v.len; i++) { - if (i > 0) fputc(' ', stdout); - print_cell(c->u.v.items[i]); - } - fputc(']', stdout); - break; - } -} - -void flan_dyn_print(flan_dyn v) { print_cell(as(v)); } - -/* ── Extraction ────────────────────────────────────────────────────── */ - -int64_t flan_dyn_need_i64(flan_dyn v) { - cell *c = as(v); - if (c->tag != T_I64) dyn_trap("DynExpectedI64", "this value was required to be an i64 and is not"); - return c->u.i; -} - -double flan_dyn_need_f64(flan_dyn v) { - cell *c = as(v); - /* An i64 satisfies an f64 slot, because a dyn integer literal is an i64 by - * the header's rule and (defonce x f64 (f 1)) would otherwise be unwritable - * for any f returning dyn. The reverse is not true: f64 to i64 loses. */ - if (c->tag == T_I64) return (double)c->u.i; - if (c->tag != T_F64) dyn_trap("DynExpectedF64", "this value was required to be an f64 and is not"); - return c->u.f; -} - -int32_t flan_dyn_need_bool(flan_dyn v) { - cell *c = as(v); - if (c->tag != T_BOOL) dyn_trap("DynExpectedBool", "this value was required to be a bool and is not"); - return c->u.b; -} - -/* The cast boundary's tag question — see flan_dyn.h. The stub keeps its own - * trap vocabulary, as every function above it does; what it must agree with - * the real runtime about is the *answer*, 1 for a float box and 0 for an int - * one, because that is what the compiler branches on. The once-per-site - * table is the real runtime's word for word: a program built against the - * stub that warns twice for one line would be a difference in the - * diagnostic, which is the thing this pair exists to keep identical. */ - -#define STUB_SITE_MAX 64 - -static struct { const uint8_t *ptr; int64_t len; } stub_warned[STUB_SITE_MAX]; -static int stub_warned_count; - -int32_t flan_dyn_cast_kind(flan_dyn v, const uint8_t *loc, int64_t loc_len, - const uint8_t *target, int64_t target_len, - int32_t want_float) { - cell *c = as(v); - if (c->tag != T_I64 && c->tag != T_F64) - dyn_trap("DynExpectedNumber", - "a numeric cast was written on this value and it is not a number"); - int32_t is_float = c->tag == T_F64 ? 1 : 0; - if (is_float != (want_float ? 1 : 0)) { - int first = 1; - for (int i = 0; i < stub_warned_count; i++) - if (stub_warned[i].len == loc_len && - memcmp(stub_warned[i].ptr, loc, (size_t)loc_len) == 0) - first = 0; - if (first) { - if (stub_warned_count < STUB_SITE_MAX) { - stub_warned[stub_warned_count].ptr = loc; - stub_warned[stub_warned_count].len = loc_len; - stub_warned_count++; - } - fflush(stdout); - fprintf(stderr, - "flan %.*s: (%.*s x) found a dyn holding %s, and converted it " - "to %.*s — warned once for this site\n", - (int)loc_len, (const char *)loc, (int)target_len, - (const char *)target, is_float ? "a float" : "an int", - (int)target_len, (const char *)target); - } - } - return is_float; -} - -/* ── Roots ───────────────────────────────────────────────────────────── - * - * Recorded and otherwise ignored. The shadow stack is kept, and its depth - * checked against the pops, only so that a badly unbalanced emission fails - * loudly here rather than silently: an over-pop is a compiler bug worth - * dying on even in a stub that collects nothing. Under-pushing is invisible, - * and stays invisible until the real collector lands. */ - -static flan_dyn **roots = NULL; -static int64_t roots_len = 0, roots_cap = 0; - -void flan_dyn_root_push(flan_dyn *slot) { - if (roots_len == roots_cap) { - int64_t cap = roots_cap == 0 ? 64 : roots_cap * 2; - flan_dyn **r = realloc(roots, (size_t)cap * sizeof(flan_dyn *)); - if (r == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); - roots = r; - roots_cap = cap; - } - roots[roots_len++] = slot; -} - -void flan_dyn_root_pop(int64_t n) { - if (n < 0 || n > roots_len) dyn_trap("DynRootUnderflow", "the dyn root stack was popped further than it was pushed - a compiler bug"); - roots_len -= n; -} - -void flan_gc_init(void) { /* nothing to initialise: this stub never collects */ } From 3636f31cbae0d99631617bb4b7625de8e12bf6d6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 10:16:25 +0700 Subject: [PATCH 2/5] A running program's reply never says it has not called (agent/start ...), because the agent's constructor has bound the socket before main --- TODO.org | 11 +++---- docs/BUILT.md | 5 ++-- lib/dev.ml | 41 +++++--------------------- test/programs/dev-noagent-running.flan | 10 +++---- 4 files changed, 19 insertions(+), 48 deletions(-) diff --git a/TODO.org b/TODO.org index 7b8e242a..a983ab15 100644 --- a/TODO.org +++ b/TODO.org @@ -1565,11 +1565,12 @@ only by an explicit call. A sentence about the shape of the gate rather than an observed problem: only the daemon sets the variable and it never runs release builds. The fix, if it is ever felt, is a narrower gate. -** NEXT The daemon's "has not called (agent/start ...)" note is unreachable -Decided 2026-09-25: retire the note in the same dead-code sweep. -Unreachable, not merely unexercised: the one state it was true of is closed by the -constructor. Retiring it is the author's call over a lane that merged days ago, so -it is left in place saying a true thing about a state nothing can be in. +** DONE The daemon's "has not called (agent/start ...)" note is unreachable +CLOSED: [2026-09-25] +Retired, with the matching arm of an evaluation's timeout. A running program +either links the agent, whose constructor binds the socket before =main=, or +links none and has its delivery refused; no reply names =(agent/start ...)= as +not yet called. ** DONE The allocation registry CLOSED: [2026-09-13] diff --git a/docs/BUILT.md b/docs/BUILT.md index 930c83da..7703ace3 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -7024,9 +7024,8 @@ registry now holds. **When it happens.** At the next frame boundary of a running program. A parked program — one whose `main` has finished — drains its ring when that sleep ends, so the store lands at the top of its next run, ahead of `main`; the run's own startup then computes the initialiser again, which is not a wart but the two events `defparameter` has: an -evaluation assigns, and a re-run re-initialises. A program that has not called `(agent/start ...)` yet installs at its -next `(agent/poll)`, and never if it has none — the reply already says so. A program stopped at a break runs it in the -break loop, like any other evaluation. +evaluation assigns, and a re-run re-initialises. A program stopped at a break runs it in the break loop, like any other +evaluation. **A brand-new `def`** gets its initialiser run too. Its storage comes from `flan_dev_global` and nothing in the host's `.init-globals` names it, so before this a new `(def n i64 (count-them))` came up as `calloc`'s zeroes and stayed diff --git a/lib/dev.ml b/lib/dev.ml index 543e719c..6169b5b2 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -124,7 +124,7 @@ let await ?(ms = 5000) f = (* Whether the program has bound the socket it receives modules on. - Cheap enough to ask on every reply — one [stat] — and asked rather than + Cheap enough to ask before every request — one [stat] — and asked rather than remembered because the answer moves in one direction at a moment this side does not get to see: [agent/start] runs on the program's own thread. *) let agent_bound t = Sys.file_exists t.agent @@ -781,7 +781,7 @@ let refusal ~parked reply = refusal; it is the difference between "queued" and "running", which is a difference only the program can close and only at a moment of its choosing. - Three of them, in the order of how far the module is from being live: + Two of them, in the order of how far the module is from being live: A PARKED program has finished [main] and is asleep in [flan_merged_park]. Its ring is drained whenever that sleep ends — for an expression to run, or @@ -796,16 +796,11 @@ let refusal ~parked reply = not per session, because the reader of a *new* park may not be the reader of the last one. - A RUNNING program that has not bound its agent socket has not called - [(agent/start ...)] yet — it may be about to, ahead of a window that is - still being created, or it may have no such call at all. Either way the - module is in the ring and the ring is drained by [(agent/poll)], so what - can honestly be promised is the poll and not a frame: a program with no - poll in it never installs this, and saying "at its next frame boundary" - would be the reply that made a redefinition look applied when it was not. - - A RUNNING program that has bound it needs no note: the reply already says - queued, and the frame boundary is the next one it reaches. *) + A RUNNING program needs no note: the reply already says queued, and the + frame boundary is the next one it reaches. A running program whose agent + socket is not bound is not a third case: the agent package binds it in a + constructor, before [main], and a program that does not link the package + has nothing to queue a module on, so the delivery is refused instead. *) let install_note t ~parked = if parked then begin let first = not t.park_noted in @@ -821,13 +816,6 @@ let install_note t ~parked = else "queued; installs no later than the parked program's next run") ] end - else if not (agent_bound t) then - [ ":note " - ^ Wire.quote - "queued, but the program has not called (agent/start ...) yet, so \ - this installs when it next reaches an (agent/poll) — and not at \ - all if it never does" - ] else [] (* [pause], when given, is the position of the form to stop at — §9. It rides @@ -1253,21 +1241,6 @@ let eval_expr t ~code ~origin ~pause = the program is stopped at an earlier break and runs \ nothing until that ends. Take a restart or abort in the \ break buffer, and evaluate this again" - (* And a third cause, which is the one a session now reaches - early enough to hit: the program has not bound its agent - socket, so it is still ahead of its own [(agent/start ...)] - — inside whatever it does first, a window being created — - and asking whether it calls [(agent/poll)] would send the - reader to look at a loop it has not got to yet. Said only - where it is a fact about *this* program: the socket is - missing, which is a stat, not a guess. *) - else if not (agent_bound t) then - error - "the program has not called (agent/start ...) yet, so \ - nothing has run the expression. It is queued and will run \ - at the program's first (agent/poll); this reply cannot \ - carry its value, so evaluate it again once the program is \ - up" else error "the program did not reach a frame boundary; is it calling \ diff --git a/test/programs/dev-noagent-running.flan b/test/programs/dev-noagent-running.flan index 0883332a..1834441c 100644 --- a/test/programs/dev-noagent-running.flan +++ b/test/programs/dev-noagent-running.flan @@ -7,12 +7,10 @@ ;;;; hand a module to and no socket to fall back on, so the daemon refuses the ;;;; delivery and says which socket it could not reach. ;;;; -;;;; That is the honest answer for it. The sentence [install_note] keeps for a -;;;; running program with no socket — queued, installs at its next -;;;; (agent/poll) — was true of a program that *links* the agent and has not -;;;; reached its (agent/start ...) yet, because there the ring is reachable -;;;; in-process while the socket is not yet bound. The package's constructor -;;;; binds before main now, so that window is gone; see TODO.org, "(agent/start) takes no argument, and binds before main". +;;;; That is the honest answer for it. A program that *links* the agent has its +;;;; socket bound by the package's constructor before main, so a running +;;;; program with no socket is always this one; see TODO.org, "(agent/start) +;;;; takes no argument, and binds before main". ;;;; ;;;; So: no (import agent ...) anywhere, and a loop that outlasts the test. (defn step [] i64 7) From e511174d3cdc9eaf8aefcd1d14c99236f5c62941 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 10:16:25 +0700 Subject: [PATCH 3/5] No top-level value in the compiler goes unreferenced --- docs/BUILT.md | 4 ++-- lib/check.ml | 13 ++----------- lib/emit.ml | 19 ++++--------------- lib/loc.ml | 8 -------- lib/x86.ml | 38 +++++--------------------------------- 5 files changed, 13 insertions(+), 69 deletions(-) diff --git a/docs/BUILT.md b/docs/BUILT.md index 7703ace3..9230c1bc 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -5478,7 +5478,7 @@ error that could actually be clicked. The source cache in `loc.ml` is process-lifetime, which is right for `flan build` — a fresh process per run. The daemon is long-lived and never calls `report`; the interactive path draws no squiggle, it takes a location and a -message. `Loc.forget_sources` exists for the day that changes. +message. A daemon that did draw one would have to reset the cache when a file changes. ### Collecting, and where it stops @@ -5504,7 +5504,7 @@ file-shaped pile of nonsense. First error, stop. That is a decision, not an omis Changing the error type without touching `dev.ml` and `session.ml` needed a compatible way to get one location and one message out. The answer is that **the single-diagnostic exception is still the single-diagnostic exception**. `Session.eval` and the daemon evaluate one form and have one failure to report; they keep catching `Loc.Error` and -take the pair out of it with `Loc.summary`. Only a driver that compiles a whole file raises `Loc.Errors`. +read `dloc` and `dmsg` out of it. Only a driver that compiles a whole file raises `Loc.Errors`. That guarantee is **structural and not conventional**. `Parse.program` / `Check.program` stop at the first refusal; `Parse.program_all` / `Check.program_all` collect. Two names rather than one function with a `~keep_going` label, diff --git a/lib/check.ml b/lib/check.ml index 64e43869..90cfd4bc 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -747,10 +747,6 @@ and captured_set ctx loc name = "Return the new value, or keep it in a local of this fn") | None -> () -(* A binding this body captured, as opposed to one it declared. Used where the - difference matters and nowhere else. *) -let is_captured ctx name = List.mem_assoc name ctx.caught - let scoped ctx f = let saved = ctx.scope in let r = f () in @@ -2338,11 +2334,6 @@ let widen loc (want : Types.t) (e : Tast.expr) = if Types.equal want e.Tast.ty then e else mk loc want (Tast.Prim (Tast.Cast want, [ e ])) -let unboxable t = - match t with - | Types.Int Types.I64 | Types.Float Types.F64 | Types.Bool -> true - | _ -> false - (* The sentence a refusal at this boundary gives. It names the type and says which direction failed, because "expected dyn, found (Vec i64)" would read as a type error the programmer could fix by writing something else, and @@ -2353,7 +2344,7 @@ let no_dyn_yet loc ~into t extra = (Types.to_string t) (if into then "dyn" else "a written type") extra (* M2 item 3: a typed container crossing into dyn as a view. The element set - is exactly [unboxable] above — i64, f64, bool — and that is not a smaller + is exactly the unboxable scalars — i64, f64, bool — and that is not a smaller version of the same cut for the same reason: every other element type would need [box] to run on IT too, and a string element's dyn form is a pointer into the collector's heap, while a typed container's storage is @@ -3416,7 +3407,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = runtime owns the storage the way (vec-new dyn) does, keys and values are both dyn words, and a typed want other than dyn refuses through [expect] like any other dyn value would. The literal lowers to a fresh slot — a - rooted one, because a slot of type dyn is what [dyn_roots] counts — so + rooted one, because a slot of type dyn is what [Emit.root_plan] counts — so the map stays reachable across the allocations its own entries make. *) | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in diff --git a/lib/emit.ml b/lib/emit.ml index a83eb80f..08aff1c6 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -35,8 +35,6 @@ through a [(Ptr Cursor)] becomes a [getelementptr] on the pointer, not on a copy of the struct. *) -let fail = Loc.fail - (* The assertions below this line are not diagnostics. Every one of them says the checker admitted something it refuses — a type with no layout, a case that is not a case of its data type, arithmetic on a struct — so no program @@ -112,11 +110,6 @@ let xfer_param = "%xfer" to have had all along. *) let env_param = "%env" -(* What a call through a [(Fn ...)] value passes when it has no environment — - a value made out of a name, or one widened from a [CFn]. Spelled once so - the sites cannot drift. *) -let no_env = "ptr null" - (* The condition's own name, for the message an unhandled [error] prints. The checker has already refused anything that is not a struct. *) let struct_name_of (t : Types.t) = @@ -936,7 +929,7 @@ type f = { It is a count and not a saved depth because the ABI offers [flan_dyn_root_pop(n)] and no way to read the stack's height; it can be a count, rather than needing one, because the number is a static property of - the function that [dyn_roots] works out before a line of the body is + the function that [root_plan] works out before a line of the body is emitted. That matters: [ret] runs *during* emission, and a count accumulated as roots were discovered would be short at every early return. *) @@ -1370,16 +1363,12 @@ let root_plan m (fn : Tast.fn) : rootplan = !agg; rpins = !pins } -let dyn_roots m (fn : Tast.fn) = - let p = root_plan m fn in - List.length p.rslots + p.rdyn + List.length p.ragg - (* The next pre-made root slot for a dyn temporary. They are all minted, zeroed and pushed in the entry block before a line of the body is emitted, and this only hands them out — which is what makes the pushes and the pops balance by construction rather than by the body being walked the same way twice. - [dyn_roots] counts the same nodes the emission visits, so the supply runs + [root_plan] counts the same nodes the emission visits, so the supply runs out only if those two disagree. If it ever does, the fallback is an ordinary unrooted slot: one temporary the collector cannot see is a bug to find, where a root stack that pops more than it pushed is memory corruption. *) @@ -3357,7 +3346,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = (* A dyn word is spilled into a rooted slot the instant it exists. It is an SSA value otherwise, and an SSA value is invisible to a collector that finds its roots by address — the next allocation could be the one - that frees what this is holding. [dyn_roots] counted this call, so the + that frees what this is holding. [root_plan] counted this call, so the slot below is one the entry block has already pushed. The value carries on being used as a register: the store is what the @@ -3574,7 +3563,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = a debugging convenience and a release build does without it, while a collector that cannot find its roots is a collector that frees live values. Every build pays this, and only a function that has a dyn in it - pays anything — [dyn_roots] is zero otherwise and not a line is emitted, + pays anything — [root_plan] is empty otherwise and not a line is emitted, which is what makes an annotated program's IR identical with and without --no-gc. diff --git a/lib/loc.ml b/lib/loc.ml index b99294d8..f8943c96 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -143,10 +143,6 @@ exception Error of diag and never raised by a path that checks a single form. *) exception Errors of diag list -(** The one location and one message a caller with a single line to print gets - out of a diagnostic. Notes are dropped here on purpose. *) -let summary (d : diag) = (d.dloc, d.dmsg) - let before (a : t) (b : t) = if a.line <> b.line then compare a.line b.line else compare a.col b.col @@ -210,8 +206,6 @@ let caught s f = | x -> Some x | exception Error d -> s.found <- d :: s.found; None -let any s = s.found <> [] - (** Raise everything found, in the order it was found, or return if the pass was clean. *) let finish s = @@ -255,8 +249,6 @@ let lines_of file = Hashtbl.replace source_cache file v; v -let forget_sources () = Hashtbl.reset source_cache - let source_line (t : t) = if t.line <= 0 then None else diff --git a/lib/x86.ml b/lib/x86.ml index 8202c26d..96e16580 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -355,7 +355,6 @@ let and_imm b ~dst n = grp1_imm b ~ext:4 ~dst n let sub_imm b ~dst n = grp1_imm b ~ext:5 ~dst n let cmp_imm b ~dst n = grp1_imm b ~ext:7 ~dst n -let neg_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:3 ~m:dst let not_r b ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xf7; modrm_r b ~r:2 ~m:dst let test_rr b ~a ~c = rex b ~w:true ~r:c ~x:0 ~m:a; u8 b 0x85; modrm_r b ~r:c ~m:a @@ -696,7 +695,7 @@ type fnctx = { A count rather than a running tally for [emit.ml]'s reason: the epilogue is emitted after the body, but the pushes are decided before it, by - [Emit.dyn_roots], which is deliberately the *same* function both backends + [Emit.root_plan], which is deliberately the *same* function both backends call. The pushes and the pops balance because one counter decides both ends, and the two backends root the same nodes because there is one counter and not two. *) @@ -943,7 +942,7 @@ let scoped f g = (* ── Moving values ───────────────────────────────────────────────────── *) -(* Scalar in [reg] <- [rbp+off], and back. A bool is a byte; everything else +(* Scalar in [reg] <- [rbp+off]. A bool is a byte; everything else is its own width, widened on load. *) let load_scalar f ~reg ~off (t : Types.t) = if is_float t then fload f.b ~dst:reg ~mm:(Frame off) ~f64:(f64_of t) @@ -951,26 +950,6 @@ let load_scalar f ~reg ~off (t : Types.t) = let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in load_int f.b ~dst:reg ~mm:(Frame off) ~size ~signed:(signed_of t) -let store_scalar f ~reg ~off (t : Types.t) = - if is_float t then fstore f.b ~src:reg ~mm:(Frame off) ~f64:(f64_of t) - else - let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in - store_int f.b ~src:reg ~mm:(Frame off) ~size - -(* Through a pointer rather than a frame offset: the same two, with the - address already in a register. *) -let load_scalar_at f ~reg ~base ~disp (t : Types.t) = - if is_float t then fload f.b ~dst:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t) - else - let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in - load_int f.b ~dst:reg ~mm:(Reg (base, disp)) ~size ~signed:(signed_of t) - -let store_scalar_at f ~reg ~base ~disp (t : Types.t) = - if is_float t then fstore f.b ~src:reg ~mm:(Reg (base, disp)) ~f64:(f64_of t) - else - let size = match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t) in - store_int f.b ~src:reg ~mm:(Reg (base, disp)) ~size - (* n bytes from the address in rsi to the address in rdi. *) let blockcopy f n = if n > 0 then begin @@ -981,13 +960,6 @@ let blockcopy f n = rep_movsb f.b end -let copy_frames f ~dst ~src n = - if n > 0 then begin - lea f.b ~dst:rdi ~mm:(Frame dst); - lea f.b ~dst:rsi ~mm:(Frame src); - blockcopy f n - end - let zero_frame f ~dst n = if n > 0 then begin note f (Printf.sprintf "rep stosb: %d bytes of zero, which is what this backend \ @@ -1448,7 +1420,7 @@ let with_pad f tag g = hands them out, which is what makes the pushes and the pops balance by construction rather than by the body being walked the same way twice. - [Emit.dyn_roots] counts the same nodes this emission visits, so the supply + [Emit.root_plan] counts the same nodes this emission visits, so the supply runs out only if those two disagree — and since both backends call that one function, disagreeing would be one of them visiting a node the other does not. The fallback is an ordinary unrooted temporary, for [emit.ml]'s @@ -3006,7 +2978,7 @@ and call_rt f ~sym ~args ~rty dst = the collector finds its roots by address. [dst] is not enough: it is often a temporary inside a [scoped] that the bump allocator is about to hand out again, and it is never a slot anything was pushed for. - [Emit.dyn_roots] counted this call, so the slot below is one the entry + [Emit.root_plan] counted this call, so the slot below is one the entry block has already zeroed and pushed. Here rather than in [call_native], which is [call_c]'s as well: a dyn @@ -3744,7 +3716,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) everything below it: the shadow stack is a debugging convenience a release build does without, while a collector that cannot find its roots is a collector that frees live values. Only a function with a dyn in it pays - anything, because [Emit.dyn_roots] is zero otherwise and not an + anything, because [Emit.root_plan] is empty otherwise and not an instruction is emitted — which is what keeps every dyn-free program in the survey byte for byte what it was before this lane. From 2b42cecdedd606100e2f3a12d86f86b2a65d29c9 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 10:16:25 +0700 Subject: [PATCH 4/5] No test program is left from the move-only rule for Vec that nothing checks any more --- test/programs/vec-double-free.flan | 8 -------- test/programs/vec-moved-in-loop.flan | 8 -------- test/programs/vec-moved.flan | 15 --------------- test/test_valgrind.ml | 4 ++-- 4 files changed, 2 insertions(+), 33 deletions(-) delete mode 100644 test/programs/vec-double-free.flan delete mode 100644 test/programs/vec-moved-in-loop.flan delete mode 100644 test/programs/vec-moved.flan diff --git a/test/programs/vec-double-free.flan b/test/programs/vec-double-free.flan deleted file mode 100644 index 049ee1c6..00000000 --- a/test/programs/vec-double-free.flan +++ /dev/null @@ -1,8 +0,0 @@ -;;;; `free` consumes its argument exactly as any other move does, so the second -;;;; one is a compile error rather than a runtime crash. Nothing analyses this -;;;; specially: it is the same dead-binding rule as passing one to a function. -(defn main [] i32 - (let [v (vec-new i32)] - (free v) - (free v) - 0)) diff --git a/test/programs/vec-moved-in-loop.flan b/test/programs/vec-moved-in-loop.flan deleted file mode 100644 index fdcd01cf..00000000 --- a/test/programs/vec-moved-in-loop.flan +++ /dev/null @@ -1,8 +0,0 @@ -;;;; A loop body that moves a binding declared outside the loop: the second -;;;; iteration would use what the first gave away. The dead set alone cannot -;;;; see this — merged once at the end of the body it counts one move, not two -;;;; — so it is a rule, and it is refused with the reason. -(defn main [] i32 - (let [v (vec-new i32)] - (dotimes [i 3] (free v)) - 0)) diff --git a/test/programs/vec-moved.flan b/test/programs/vec-moved.flan deleted file mode 100644 index 02a8bfc4..00000000 --- a/test/programs/vec-moved.flan +++ /dev/null @@ -1,15 +0,0 @@ -;;;; A Vec is move-only: passing one to a function transfers ownership, and the -;;;; source binding is dead afterwards. That rule is what makes a double free -;;;; unrepresentable, which is why `free` needs no analysis of its own. -(defn take [v (Vec i32)] i32 - (let [n (length v)] - (free v) - n)) - -(defn main [] i32 - (let [v (vec-new i32)] - (push v 1) - (println (take v)) - ;; v went with the call. Being refused here is the whole test. - (println (length v)) - 0)) diff --git a/test/test_valgrind.ml b/test/test_valgrind.ml index e881581a..ecce3a92 100644 --- a/test/test_valgrind.ml +++ b/test/test_valgrind.ml @@ -179,8 +179,8 @@ let check label path args ~checks = - dev-* and reload-*, which need a host process or a dlopen harness. - the compile-time refusals: nth-gone, pkg-hidden-main, pkg-two-aliases, pkg-two-mains, pkg-cycle, pkg-alias-clash, user-allocator, and the whole - vec-moved / vec-double-free / vec-in-struct / vec-global / vec-to-c / - vec-untyped family. These never produce a binary at all: the + vec-in-struct / vec-global / vec-to-c / vec-untyped family. These never + produce a binary at all: the checker refuses them, which is the point of them. There is nothing for memcheck to run. - shadow-pkg.flan, which is a package fragment with no main and does not From 146be41bd45e43d87d7b26ca0d2dd835832266af Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 10:43:33 +0700 Subject: [PATCH 5/5] flan dev refuses at start a TMPDIR that is missing or too deep for a socket path, and a program with no main, and tells a program with no agent how to add one The dropped (agent/start ...) note named the wrong cause rather than being unreachable: an over-long socket path fails the agent's bind while it is linked. That case is now refused before anything is built, and the comments, the TODO entry and the fixture say so. --- TODO.org | 10 +- lib/agent.ml | 4 + lib/dev.ml | 155 ++++++++++++++++++++----- lib/dynload_stubs.c | 7 ++ test/programs/dev-noagent-running.flan | 11 +- test/programs/dev-nomain.flan | 2 + test/test_dev.ml | 152 +++++++++++++++++------- 7 files changed, 259 insertions(+), 82 deletions(-) create mode 100644 test/programs/dev-nomain.flan diff --git a/TODO.org b/TODO.org index a983ab15..cd26813b 100644 --- a/TODO.org +++ b/TODO.org @@ -1567,10 +1567,12 @@ builds. The fix, if it is ever felt, is a narrower gate. ** DONE The daemon's "has not called (agent/start ...)" note is unreachable CLOSED: [2026-09-25] -Retired, with the matching arm of an evaluation's timeout. A running program -either links the agent, whose constructor binds the socket before =main=, or -links none and has its delivery refused; no reply names =(agent/start ...)= as -not yet called. +Retired, with the matching arm of an evaluation's timeout, because it named the +wrong cause: with the agent linked, its constructor binds the socket before +=main=, and the one way left to be unbound is a socket path over 107 bytes, which +=flan dev= refuses at start, naming TMPDIR. A program with no agent linked is +told it has none and how to add one. No reply says =(agent/start ...)= has not +been called. ** DONE The allocation registry CLOSED: [2026-09-13] diff --git a/lib/agent.ml b/lib/agent.ml index 30b9319d..b28e1861 100644 --- a/lib/agent.ml +++ b/lib/agent.ml @@ -21,3 +21,7 @@ the compiler thread calling C, never the other way. *) external request : string -> string option = "flan_agent_direct" + +(** Whether this process links the agent. [false] in the same binaries where + [request] is [None]. *) +external present : unit -> bool = "flan_agent_present" diff --git a/lib/dev.ml b/lib/dev.ml index 6169b5b2..5997c8f5 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -122,6 +122,28 @@ let await ?(ms = 5000) f = in go ms +(* What a program needs so that code from the editor can reach it. Spelled once + because three replies give it: a delivery, an evaluation and the daemon's + own warning. Both lines compile as written. *) +let agent_howto = + "Import the agent with (import agent \"vendor:agent\") and call \ + (agent/poll) once in each pass of the program's main loop, then start \ + flan dev again." + +let no_agent = + "the program has no agent, so nothing in it can receive code from the \ + editor. " ^ agent_howto + +(* Whether anything in this session can hand code to the program. A merged + build with no agent linked has no agent to call and never binds a socket, + and a connect to one answers "No such file or directory" about a path the + reader never chose; that is the case this names. *) +let agentless t = t.child = None && not (Agent.present ()) + +let unreachable t e = + if agentless t then no_agent + else "cannot reach the program: " ^ Unix.error_message e + (* Whether the program has bound the socket it receives modules on. Cheap enough to ask before every request — one [stat] — and asked rather than @@ -160,8 +182,8 @@ let agent_check t = otherwise repeat this on every keystroke's worth of polling. *) t.agent_watch <- None; Printf.eprintf - "flan dev: the program is not listening on %s — does it call \ - (agent/start ...)?\n%!" t.agent + "flan dev: nothing is listening on %s, so code from the editor cannot \ + reach the program. %s\n%!" t.agent agent_howto end (* ── Asking the agent ──────────────────────────────────────────────── *) @@ -797,10 +819,15 @@ let refusal ~parked reply = of the last one. A RUNNING program needs no note: the reply already says queued, and the - frame boundary is the next one it reaches. A running program whose agent - socket is not bound is not a third case: the agent package binds it in a - constructor, before [main], and a program that does not link the package - has nothing to queue a module on, so the delivery is refused instead. *) + frame boundary is the next one it reaches. That includes a running program + whose agent socket is not bound. The agent package binds it in a + constructor before [main], so the one way to be running and unbound with + the agent linked is a bind that failed — a socket path longer than + [max_socket_path], which [session_dir] refuses before building — and there + the module is still queued through the in-process call. A note saying the + program "has not called (agent/start ...)" named a cause that was not the + cause, so there is none. A program with no agent linked has nothing to + queue a module on, and its delivery is refused with [no_agent]. *) let install_note t ~parked = if parked then begin let first = not t.park_noted in @@ -920,8 +947,10 @@ let eval t ~code ~origin ~pause = | reply -> refused (refusal ~parked:parked_now reply) | exception Unix.Unix_error (e, _, _) -> refused - ("cannot reach the program on " ^ t.agent ^ ": " - ^ Unix.error_message e)) + (if agentless t then no_agent + else + "cannot reach the program on " ^ t.agent ^ ": " + ^ Unix.error_message e)) | exception Failure m -> refused m) with e when not !accepted -> Session.restore t.session before; raise e) (* Nothing to put back: the check itself raised, so [Session.eval] never @@ -972,6 +1001,7 @@ let eval t ~code ~origin ~pause = let eval_expr t ~code ~origin ~pause = match liveness t with | Gone -> error gone + | (Live | Parked) when agentless t -> error no_agent | Live | Parked -> (* The same rollback [eval] takes, for the same reason and a smaller cargo. A thunk is not a declaration and never joins the session, but the @@ -1252,7 +1282,7 @@ let eval_expr t ~code ~origin ~pause = put the session back. *) | reply -> refused (refusal ~parked:(liveness t = Parked) reply) | exception Unix.Unix_error (e, _, _) -> - refused ("cannot reach the program: " ^ Unix.error_message e)) + refused (unreachable t e)) | exception Failure m -> refused m) | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg @@ -1938,7 +1968,7 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag | None -> if stopped_only then deliver_stopped_only t out else deliver t out) with | exception Unix.Unix_error (e, _, _) -> - Error ("cannot reach the program: " ^ Unix.error_message e) + Error (unreachable t e) | "ok" -> let rec wait ms = (* Drained every tick for the reason [eval_expr]'s own wait spells @@ -2493,7 +2523,7 @@ type reg_entry = let reg_at t ~addr : (reg_entry option, string) result = match request t (Printf.sprintf "reg at %d" addr) with | exception Unix.Unix_error (e, _, _) -> - Error ("cannot reach the program: " ^ Unix.error_message e) + Error (unreachable t e) | text -> let line = String.trim (List.hd (String.split_on_char '\n' text)) in if line = "none" then Ok None @@ -2796,7 +2826,7 @@ let inspect_addr t ~addr ~want_type = let reg_rows t ~verb = match request t verb with | exception Unix.Unix_error (e, _, _) -> - Error ("cannot reach the program: " ^ Unix.error_message e) + Error (unreachable t e) | text -> (match String.split_on_char '\n' text with | [] -> Error "the program answered nothing" @@ -3160,7 +3190,7 @@ let choose_at t ~index ~name = ^ taken_note ~abandoned:(accepted reply = Some true) ] | reply -> error (String.trim reply) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e) + error (unreachable t e) let choose t ~name = match liveness t with @@ -3188,7 +3218,7 @@ let choose t ~name = ":note " ^ taken_note ~abandoned:(accepted reply = Some true) ] | reply -> error (String.trim reply) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e) + error (unreachable t e) (* The other way out. The program exits 134 where it stopped, which ends this daemon too — it owns the program's lifetime and has nothing left to serve. @@ -3215,7 +3245,7 @@ let abort t = ok [ ":note " ^ Wire.quote "the program is exiting; flan dev ends with it" ] | reply -> error (String.trim reply) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e) + error (unreachable t e) (* Run [main] again. The verb this file was missing, and the one everything above it about [Parked] is in aid of. @@ -3662,7 +3692,7 @@ let watch_enable t ~on = | "ok" -> ok [ (if on then ":watching t" else ":watching nil") ] | reply -> error ("the program refused the watch request: " ^ reply) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e) + error (unreachable t e) (* [NAME VALUE] per line, after a header of [COUNT DROPPED]. @@ -3712,7 +3742,7 @@ let watch_read t ~reset = (if overflow then ":overflow t" else ":overflow nil") ] | hdr :: _ -> error (String.trim hdr)) | exception Unix.Unix_error (e, _, _) -> - error ("cannot reach the program: " ^ Unix.error_message e) + error (unreachable t e) (* [(:op "memory")] — which lines of this session's program allocate. @@ -4283,6 +4313,74 @@ let remove_session_dirs t = remove t.dir; remove (Build.workdir ()) +(* The longest path a unix socket can be bound at: [sun_path] is 108 bytes on + Linux and the path is written into it with its terminating NUL. A longer one + fails at the bind, where the reason reaches nobody — the agent's constructor + drops it, and [connect] later answers "File name too long" with no path. *) +let max_socket_path = 107 + +let socket_fits ~what ~fix path = + let n = String.length path in + if n > max_socket_path then + failwith + (Printf.sprintf + "%s would be at %s, which is %d bytes long, and a unix socket path \ + can be at most %d bytes. %s" + what path n max_socket_path fix) + +(* The directory a session keeps its program, its modules and the agent's + socket in, checked before anything is built so that a TMPDIR that cannot + hold one is said once, at the start, in words. *) +let session_dir ~file ~sock = + let tmp = Filename.get_temp_dir_name () in + let dir = Filename.concat tmp (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) in + let shorter = + Printf.sprintf + "Set TMPDIR to a shorter directory, for example: TMPDIR=/tmp flan dev %s" + (Filename.quote file) + in + if not (Sys.file_exists tmp && Sys.is_directory tmp) then + failwith + (Printf.sprintf + "the temporary directory %s does not exist, and flan dev builds the \ + program there. Create it, or set TMPDIR to a directory that exists, \ + for example: TMPDIR=/tmp flan dev %s" + tmp (Filename.quote file)); + socket_fits ~what:"the program's agent socket" ~fix:shorter + (Filename.concat dir "agent.sock"); + socket_fits ~what:"the editor's socket" + ~fix:"Give flan dev -s a shorter path." sock; + dir + +(* Made only once the program has been found to have something to run, so a + refusal leaves nothing behind in TMPDIR. *) +let make_session_dir ~file dir = + match Unix.mkdir dir 0o700 with + | () | exception Unix.Unix_error (Unix.EEXIST, _, _) -> () + | exception Unix.Unix_error (e, _, _) -> + failwith + (Printf.sprintf + "cannot create %s: %s. flan dev builds the program under TMPDIR; set \ + it to a directory you can write to, for example: TMPDIR=/tmp flan \ + dev %s" + dir (Unix.error_message e) (Filename.quote file)) + +(* A session over a file with no [main] has nothing to run, and the build + would find that out at the link — as a missing symbol, or as the merged + build's rename finding nothing to rename. *) +let need_main ~file (session : Session.t) = + if not + (List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") + session.Session.host.Tast.fns) + then + failwith + (Printf.sprintf + "%s has no main, so flan dev has nothing to run. A program starts at \ + a function named main, for example:\n\n\ + \ (defn main [] i32\n\ + \ 0)" + file) + (* [debug] is off by default, which keeps [flan dev] exactly what it was: a -O2 host and -O2 modules. It is opt-in rather than always-on because a debug build is an -O0 build — [llvm.dbg.declare] describes an alloca and mem2reg @@ -4296,13 +4394,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = src/game.flan] run from a project root would otherwise send back "src/game.flan:12:7", which the editor can only resolve by guessing which directory it was relative to. *) + let dir = session_dir ~file ~sock in + let given = file in let file = try Unix.realpath file with Unix.Unix_error _ -> file in let session, l = Session.create ~debug ~x86 ~file () in - let dir = - Filename.concat (Filename.get_temp_dir_name ()) - (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) - in - (try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); + need_main ~file:given session; + make_session_dir ~file:given dir; let exe = Filename.concat dir "program" in (* [keep] so the host's own IR survives the build. It is the text [llc] was actually given, not a second emission of it, which is the difference @@ -4369,8 +4466,9 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = if not (await (fun () -> Sys.file_exists agent)) then begin (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); failwith - ("the program never listened on " ^ agent - ^ " — does it call (agent/start ...)?") + ("the program did not open its agent socket at " ^ agent + ^ ". Under --two-process every edit reaches the program through that \ + socket. " ^ agent_howto) end; let t = @@ -5300,13 +5398,12 @@ let merged_serve () = does not survive: there is one process from the first reply onwards. *) let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () = let t0 = Unix.gettimeofday () in + let dir = session_dir ~file ~sock in + let given = file in let file = try Unix.realpath file with Unix.Unix_error _ -> file in let session, l = Session.create ~debug ~x86 ~file () in - let dir = - Filename.concat (Filename.get_temp_dir_name ()) - (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) - in - (try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); + need_main ~file:given session; + make_session_dir ~file:given dir; let exe = Filename.concat dir "program" in (* The host's IR goes straight to its final home rather than being written into the build's working directory and moved: the merged link is spelled diff --git a/lib/dynload_stubs.c b/lib/dynload_stubs.c index d467aa0a..fa30881c 100644 --- a/lib/dynload_stubs.c +++ b/lib/dynload_stubs.c @@ -219,6 +219,13 @@ CAMLprim value flan_program_wake(value unit) { return Val_int(flan_merged_wake() == 0 ? 0 : 1); } +/* Whether this process has an agent to call at all: the same weak symbol + * [flan_agent_direct] tests, asked without a request. */ +CAMLprim value flan_agent_present(value unit) { + (void)unit; + return Val_bool(flan_agent_request != NULL); +} + CAMLprim value flan_agent_direct(value line) { CAMLparam1(line); CAMLlocal2(s, r); diff --git a/test/programs/dev-noagent-running.flan b/test/programs/dev-noagent-running.flan index 1834441c..f9768554 100644 --- a/test/programs/dev-noagent-running.flan +++ b/test/programs/dev-noagent-running.flan @@ -5,12 +5,13 @@ ;;;; parked program is answered by the parking path. This one keeps running, ;;;; which is the state nothing had pinned: there is no agent in the process to ;;;; hand a module to and no socket to fall back on, so the daemon refuses the -;;;; delivery and says which socket it could not reach. +;;;; delivery. ;;;; -;;;; That is the honest answer for it. A program that *links* the agent has its -;;;; socket bound by the package's constructor before main, so a running -;;;; program with no socket is always this one; see TODO.org, "(agent/start) -;;;; takes no argument, and binds before main". +;;;; That is the honest answer for it: the reply says the program has no agent +;;;; and how to add one. A program that *links* the agent has its socket bound +;;;; by the package's constructor before main, and the one way that bind fails +;;;; — a socket path too long for a unix socket — is refused when flan dev +;;;; starts. ;;;; ;;;; So: no (import agent ...) anywhere, and a loop that outlasts the test. (defn step [] i64 7) diff --git a/test/programs/dev-nomain.flan b/test/programs/dev-nomain.flan new file mode 100644 index 00000000..217a0b02 --- /dev/null +++ b/test/programs/dev-nomain.flan @@ -0,0 +1,2 @@ +;;;; A file with no main: flan dev has nothing to run, and says so before building. +(defn helper [] i64 1) diff --git a/test/test_dev.ml b/test/test_dev.ml index 28c6c6cc..8184c29e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -4748,14 +4748,14 @@ let () = contains_sub (try In_channel.with_open_bin nlog In_channel.input_all with Sys_error _ -> "") - "does it call (agent/start ...)?" + "(import agent \"vendor:agent\")" in ignore (await ~ms:30000 nlog_says); (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()); if not (nlog_says ()) then fail - "a program without (agent/start ...) drew no warning from flan dev:\n%s" + "a program with no agent drew no warning from flan dev:\n%s" (try In_channel.with_open_bin nlog In_channel.input_all with Sys_error _ -> ""); List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) @@ -4767,20 +4767,12 @@ let () = reply an editor gets for a redefinition, and it is here because that reply was never pinned and this lane changed which of two it is. - [install_note] has a sentence for a RUNNING program whose socket is not - bound — queued, installs at its next [(agent/poll)], not at all if there - is never one. It was true of exactly one thing: a merged session whose - program links the agent, so the ring is reachable in-process, but has - not got to its [(agent/start ...)] yet. The constructor closed that - window, so nothing reaches the sentence any more; the late-agent row - below asserts its absence, and TODO.org's entry on the unreachable - agent-start note says the branch can be retired. - - A program that does not link the agent at all never reached it either, - and this row is what says so rather than leaving it to be assumed. There - is no agent in this process to call and no socket to fall back to, so - the delivery is REFUSED — which is the honest answer and not the note: - "queued" would have promised a poll that has nothing to drain. + A program that does not link the agent at all has no agent in this + process to call and no socket to fall back to, so the delivery is + REFUSED, and the reply says the program has no agent and how to give it + one — both for a redefinition and for an expression. "Queued" would + have promised a poll that has nothing to drain, and "connect: No such + file or directory" names a path the reader never chose. It needs the program to be running, which is why it is not folded into the row above: dev-noagent.flan's main returns, so it parks within the @@ -4809,9 +4801,14 @@ let () = \"programs/dev-noagent-running.flan\")" in let msg = Option.value ~default:"" (Wire.string_field r "message") in - (* Refused, and the reason names the socket it could not reach rather - than the compiler: the module built, and what failed is the hand-off - to a program that has no agent in it. *) + (* Refused, and the reason is the program's rather than the compiler's: + the module built, and what is missing is an agent to hand it to. The + fix it names is the import. *) + let names_the_fix m = + contains_sub m "has no agent" + && contains_sub m "(import agent \"vendor:agent\")" + && contains_sub m "(agent/poll)" + in if status r = "ok" then fail "a redefinition for a program with no agent in it was answered \ @@ -4819,9 +4816,20 @@ let () = (match Wire.string_field r "note" with | Some n -> Printf.sprintf " (note: %S)" n | None -> "") - else if not (contains_sub msg "cannot reach the program on ") then + else if not (names_the_fix msg) then fail "a delivery to a running agentless program was refused with: %S" msg; + (* And an expression, which used to be answered with the connect's own + errno. *) + let r = + request gc + "(:op \"eval-expr\" :code \"(step)\" :file \ + \"programs/dev-noagent-running.flan\")" + in + let msg = Option.value ~default:"" (Wire.string_field r "message") in + if status r = "ok" || not (names_the_fix msg) then + fail "an expression for a running agentless program was answered %s: %S" + (status r) msg; (* And the session is still there afterwards, which is the rest of the claim: a refusal is a reply, not the end. *) (match request gc "(:op \"describe\")" with @@ -4843,6 +4851,65 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; glog ]; + (* ── What stops a session from starting, said at the start ───────── + + Three things a session cannot start without, each refused before + anything is built, in both shapes, with the fix named: a TMPDIR that + does not exist (it was an uncaught ENOENT out of mkdir), one so deep + that the agent's socket path does not fit in a unix socket address + (the bind failed where nobody heard it, and every reply after that + said "File name too long" or asked about (agent/start ...)), and a + program with no main (a link error, or a sentence about the merged + build's internals). *) + let refused_at_start what ~tmpdir ~prog ~mode want = + let out = tmp "start-refusal.out" in + let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let env = + Array.append + [| "TMPDIR=" ^ tmpdir |] + (Array.of_list + (List.filter + (fun v -> not (String.starts_with ~prefix:"TMPDIR=" v)) + (Array.to_list (Unix.environment ())))) + in + let argv = + Array.append [| flan; "dev"; prog; "-s"; tmp "start-refusal.sock" |] mode + in + let pid = Unix.create_process_env flan argv env Unix.stdin fd fd in + Unix.close fd; + let _, st = Unix.waitpid [] pid in + let said = In_channel.with_open_bin out In_channel.input_all in + (try Sys.remove out with Sys_error _ -> ()); + let shape = if mode = [||] then "one process" else "--two-process" in + (match st with + | Unix.WEXITED 1 -> () + | _ -> fail "%s (%s): flan dev did not exit 1: %S" what shape said); + List.iter + (fun w -> + if not (contains_sub said w) then + fail "%s (%s): the refusal does not say %S: %S" what shape w said) + want + in + let here = Filename.get_temp_dir_name () in + let deep = + Filename.concat here (String.make (max 1 (110 - String.length here)) 'd') + in + Unix.mkdir deep 0o700; + let missing = Filename.concat here "no-such-directory" in + let nomain = "programs/dev-nomain.flan" in + List.iter + (fun mode -> + refused_at_start "a TMPDIR too deep for a socket path" ~tmpdir:deep + ~prog:"programs/dev-lateagent.flan" ~mode + [ "at most 107 bytes"; "TMPDIR=/tmp flan dev" ]; + refused_at_start "a TMPDIR that does not exist" ~tmpdir:missing + ~prog:"programs/dev-lateagent.flan" ~mode + [ missing ^ " does not exist"; "TMPDIR=/tmp flan dev" ]; + refused_at_start "a program with no main" ~tmpdir:here ~prog:nomain + ~mode [ "has no main"; "(defn main [] i32" ]) + [ [||]; [| "--two-process" |] ]; + (try Unix.rmdir deep with Unix.Unix_error _ -> ()); + (* ── A build that fails is a refusal, not the end of the session ── *) (* Evaluating runs a compiler, and a compiler can fail in ways the @@ -6751,36 +6818,33 @@ let () = fail "the first editor request waited %.1fs on a program whose agent \ starts late; the accept loop is gated on the agent again" ldt; - (* And the delivery, also inside the delay. It is taken, and it carries - no note about [(agent/start ...)]: that sentence is for a program - whose socket is not bound, and the constructor bound this one before - main. [install_note] answering nothing here is therefore the evidence - that the socket is up — the assertion is on the absence because the - absence is the claim. - - It used to be the presence. The program's own start call is still - three seconds away, so this is the same moment it always was; what - changed is that the moment is no longer one in which the program - cannot be reached. lib/dev.ml's branch still says the true thing for - a program that does not link the agent at all (the agentless row - above), and TODO.org's entry on the unreachable agent-start note - records that a dev program which links it can no longer get - there. *) + (* The socket is up inside the delay, three seconds before the program's + own start call: the constructor bound it before main. Checked on the + file itself, at the path the daemon named in FLAN_AGENT_SOCKET — the + merged build execs in place, so its directory carries the daemon's + pid. *) + let agent_sock = + Filename.concat + (Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-dev-%d" lpid)) + "agent.sock" + in + (match (Unix.stat agent_sock).Unix.st_kind with + | Unix.S_SOCK -> () + | _ -> fail "%s is not a socket" agent_sock + | exception Unix.Unix_error (e, _, _) -> + fail + "the agent socket was not bound before main: %s: %s" agent_sock + (Unix.error_message e)); + (* And the delivery, also inside the delay. It is taken. *) let r = request lc "(:op \"eval\" :code \"(defn step [] i64 9)\" :file \ \"programs/dev-lateagent.flan\")" in if status r <> "ok" then - fail "a redefinition sent before (agent/start ...): %s" (said r) - else begin - let note = Option.value ~default:"" (Wire.string_field r "note") in - if contains_sub note "(agent/start ...)" then - fail - "the agent socket was not bound before main, so a delivery was \ - told to wait for a call the program had not made: %S" note - end; - (* The claim the note makes, checked against the program rather than + fail "a redefinition sent before (agent/start ...): %s" (said r); + (* The delivery, checked against the program rather than against the reply: once the sleep is over and the program is polling, the body that was queued is the one that runs. [await] because the moment the agent comes up is the program's to choose, and each