From 527da3763373ae67b254b90b4b8f36d179139def Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:57:40 +0700 Subject: [PATCH] An evaluated expression's module is unloaded when its only strings are literals or registry names, because a literal is a copy the process keeps --- TODO.org | 15 +++----- lib/emit.ml | 41 +++++++++++++++----- lib/x86.ml | 31 ++++++++++----- runtime/flan_dev.c | 50 ++++++++++++++++++++++++ test/test_dev.ml | 91 ++++++++++++++++++++++++++++++++++++++------ test/test_session.ml | 34 ++++++++++------- 6 files changed, 211 insertions(+), 51 deletions(-) diff --git a/TODO.org b/TODO.org index e58e50d2..ef81b3c1 100644 --- a/TODO.org +++ b/TODO.org @@ -1498,10 +1498,6 @@ out the first element typing the rest. * Dev loop -** TODO Every evaluated expression leaves its module mapped -Each C-x C-e loads its own =.so= and never unloads it, so a session's mapping count -grows by about four per evaluation; the kernel's limit (65530) ends a long session. - ** TODO A prelude function shadowed live is reached by the prelude's own calls A defn of a prelude function's name sent to a running =flan dev= installs into the host's cell for that name, so the prelude's calls compiled into the host follow it; @@ -1822,11 +1818,12 @@ line and every later row unrun. gone. The dev daemon now removes its own on a clean end; the one-shot commands do not. -** TODO An x86 dev session's dyn global sometimes reads wrong after an allocating thunk -test_dev's =--x86: after a thunk that allocates (cycle 1) the parked program's dyn -global reads "kept"= failed once in a full =dune test= on 2026-09-25 and passed three -direct reruns. Intermittent and GC-shaped: a dyn global read after a collection a -C-x C-e thunk triggered. Needs reproducing under load and fixing. +** WAIT An x86 dev session's read after an allocating thunk once answered without the value +WAIT on a recurrence; the test now prints the failing read's own reply. +The one failure's message came from a second read, which said "kept", so the global +was intact and the first read's reply lacked the value: not the collector. Not +reproduced in 350 churn-and-read cycles under 8-way load, three concurrent test_dev +runs, or a valgrind run of the cycle, which was clean. * Editor diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..390aae7e 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -536,6 +536,12 @@ type m = { [annot]. *) ann : bool; mutable nstr : int; + (* Set while an expression thunk's module is emitted: a string literal's + value is then a copy [flan_dev_literal] keeps for the life of the + process, so storing it anywhere leaves nothing pointing into the module, + and the literal is not counted in [nstr]. Without it every C-x C-e that + wrote a string or a keyword kept its mapping. *) + mutable pool : bool; (* The frame descriptors a dev build's shadow stack points at, counted apart from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide whether an expression thunk's module may be unloaded — a string literal in @@ -2562,6 +2568,16 @@ and value_at f (e : Tast.expr) : string = | Tast.Int (n, _) -> Int64.to_string n | Tast.Float (x, k) -> float_const k x | Tast.Bool b -> if b then "true" else "false" + | Tast.Str s when f.md.pool -> + (* See [pool]: the bytes are still this module's, but only the copy + leaves it, so they are [fi_bytes]' kind of constant and not + [string_bytes']. The copy carries the NUL. *) + let id, n = fi_bytes f.md s in + let p = fresh f in + ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n; + let v = fresh f in + ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p; + v | Tast.Str s -> string_const f.md s | Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer" | Tast.Uninit _ -> "poison" @@ -4957,6 +4973,8 @@ declare void @flan_dev_watch_emit_i64(i64) declare void @flan_dev_watch_emit_u64(i64) declare void @flan_dev_watch_emit_f64(double) declare void @flan_dev_watch_end() +; An expression thunk's string literals, copied to storage the process keeps. +declare ptr @flan_dev_literal(ptr, i64) declare i64 @flan_dyn_need_i64(i64) declare double @flan_dyn_need_f64(i64) declare i32 @flan_dyn_need_bool(i64) @@ -5273,7 +5291,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) globals = Hashtbl.create 16; externs = Hashtbl.create 32; checks; dev; gcfn = dev || makes_closures p; - known; nstr = 0; nfi = 0; sanitize; ann = annotate; + known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate; descs = Hashtbl.create 8; dbg = (if debug then Some (new_dbg p) else None); fsigs = fsigs_of p; @@ -5749,6 +5767,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns in let m = new_module ~checks ~dev ~known ~debug ~annotate p in + m.pool <- call <> None && retains; (* A thunk the module runs itself is excluded from all of this: it is called directly by [flan_reload_call], so it needs no cell, must not be published into one, and must not take a registry slot — there are 4096 of those and @@ -5868,7 +5887,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) let t = fresh () in Buffer.add_string b (Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n" - t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name))) + t (fi_cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name))) new_fns; List.iter (fun (g : Tast.global) -> @@ -5887,8 +5906,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) match initial_image p g with | None -> "null" | Some v -> - let init = Printf.sprintf "@\".init.%d\"" m.nstr in - m.nstr <- m.nstr + 1; + (* Copied by the runtime and not kept, so not counted in + [nstr]; a string inside it is, through [const]. *) + let init = Printf.sprintf "@\".init.%d\"" m.nfi in + m.nfi <- m.nfi + 1; Buffer.add_string m.strs (Printf.sprintf "%s = private constant %s %s\n" init (ll g.Tast.gty) (const m v)); @@ -5898,7 +5919,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) (Printf.sprintf " %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \ store ptr %s, ptr %s\n" - t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t + t (fi_cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t (globalptr g.Tast.gname))) new_globals; (* A constant whose value the checker never consumed is just bytes in the @@ -5967,10 +5988,12 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) expression may store one anywhere it likes — [(set msg "tuned")] on a string global leaves that global pointing into the mapping the agent is about to drop. The next thunk can be mapped at the same address, so - the result is silent garbage rather than a fault. A module with no - string constants has nothing in its image anyone could still be - pointing at; one with any keeps its mapping, which costs a page and is - the same bargain every redefinition already makes. *) + the result is silent garbage rather than a fault. So a thunk's + literal is a copy the process keeps (see [pool]) and is not counted; + what [nstr] still counts is a constant something may go on pointing + at, such as a condition's name, and a module with one keeps its + mapping. The registry names above are not counted: flan_dev.c copies + a name it keeps, and an initial image is copied on allocation. *) (* [retains = false] is a caller saying it knows where every literal in this module goes. The [m.nstr] test below is a conservative stand-in for that — an expression may store a string literal anywhere it likes, diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..b48d64d6 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -491,7 +491,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m = globals; externs = Hashtbl.create 1; checks; dev; gcfn = dev || Emit.makes_closures p; known = (fun _ -> true); dbg = None; sanitize = false; ann = false; - nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p } + nstr = 0; pool = false; nfi = 0; descs = Hashtbl.create 8; + fsigs = Emit.fsigs_of p } let sizeof md t = fst (Emit.lay md t) @@ -1812,6 +1813,16 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit = let l = float_const f x ~f64 in fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 + | Tast.Str s when f.md.Emit.pool -> + (* [Emit]'s [pool]: an expression thunk's literal is a copy the process + keeps, so nothing is left pointing into the module. *) + let l, n = fi_bytes f s in + lea f.b ~dst:rdi ~mm:(Sym (l, 0)); + imm_into f ~reg:rsi (Int64.of_int n); + call_sym f.b "flan_dev_literal"; + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; + imm_into f ~reg:rax (Int64.of_int n); + store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 | Tast.Str s -> (* A string and a [u8] slice are the same two words, which is why [Bytes] below is a non-instruction. *) @@ -5315,6 +5326,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) p.Tast.globals in let md = layout_ctx ~checks ~dev p in + md.Emit.pool <- call <> None && retains; let externs = Hashtbl.create 16 in List.iter (fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym) @@ -5419,7 +5431,10 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) the same and [test_reload.ml] checks it there by grepping the IR text; there is no text to grep on this side, so the guarantee is this loop order and this comment. *) - let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in + (* Not counted in [nstr]: flan_dev.c's registry copies a name it keeps, so + nothing is left pointing at these once the lookup returns. Counted, every + module after the session's first new name would keep its mapping. *) + let cstr sym = let l = fi_cstring f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in List.iter (fun (fn : Tast.fn) -> cstr (Mangle.sym fn.Tast.name); @@ -5598,13 +5613,11 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) store one anywhere it likes -- [(set msg "tuned")] on a string global leaves that global pointing into the mapping the agent is about to drop. The next thunk can be mapped at the same address, so the result is silent - garbage rather than a fault. A module with no string constants has nothing - in its image anyone could still be pointing at; one with any keeps its - mapping, which costs a page and is the same bargain every redefinition - already makes. [string_const] is where the count is kept, and the install - function's own registry names go through it too -- which is right rather - than incidental, since a module that interned a name left something - behind. *) + garbage rather than a fault. So a thunk's literal is a copy the process + keeps ([Emit]'s [pool]) and is not counted; what [string_const] still + counts is a constant something may go on pointing at, such as a + condition's name, and a module with one keeps its mapping. The install + function's registry names are not counted: the registry copies them. *) (match call with | Some fn when fns = [ fn ] && consts = [] diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..6663f368 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -436,6 +436,56 @@ void flan_dev_result_end(void) { * when it was sizing something to send through a socket. */ uint64_t flan_dev_result_cap(void) { return RESULT_MAX; } +/* ── An expression thunk's string literals ──────────────────────────── */ + +/* A literal in an evaluated expression is a copy made here and kept for the + * life of the process, one per distinct text, NUL after the bytes as the + * module's own constants have. The expression may store it anywhere, so + * pointing it into the thunk's module would keep that module mapped for ever + * (Emit's [pool]); pointing it here lets the agent unload the module once the + * thunk returns. Game thread only: thunks run there. */ +typedef struct lit { struct lit *next; int64_t len; uint8_t bytes[]; } lit; + +static lit **lits; +static size_t lits_cap, lits_n; + +static uint64_t lit_hash(const uint8_t *p, int64_t n) { + uint64_t h = 1469598103934665603ULL; /* FNV-1a */ + for (int64_t i = 0; i < n; i++) { h ^= p[i]; h *= 1099511628211ULL; } + return h; +} + +const uint8_t *flan_dev_literal(const uint8_t *p, int64_t n) { + if (n < 0) n = 0; + if (lits_n >= lits_cap / 2) { + size_t cap = lits_cap ? lits_cap * 2 : 64; + lit **t = calloc(cap, sizeof *t); + if (t == NULL) die("out of memory", "a string literal"); + for (size_t i = 0; i < lits_cap; i++) + for (lit *e = lits[i], *nx; e != NULL; e = nx) { + nx = e->next; + size_t b = lit_hash(e->bytes, e->len) & (cap - 1); + e->next = t[b]; + t[b] = e; + } + free(lits); + lits = t; + lits_cap = cap; + } + size_t b = lit_hash(p, n) & (lits_cap - 1); + for (lit *e = lits[b]; e != NULL; e = e->next) + if (e->len == n && memcmp(e->bytes, p, (size_t)n) == 0) return e->bytes; + lit *e = malloc(sizeof *e + (size_t)n + 1); + if (e == NULL) die("out of memory", "a string literal"); + e->len = n; + if (n > 0) memcpy(e->bytes, p, (size_t)n); + e->bytes[n] = 0; + e->next = lits[b]; + lits[b] = e; + lits_n++; + return e->bytes; +} + /* Called between the copy and the second read of the counter, when set. It * exists for test/dev_limits.c and nothing else sets it: the losing side of * the race is a write landing inside that window, and a second thread cannot diff --git a/test/test_dev.ml b/test/test_dev.ml index c1f02dc8..e487f855 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6604,12 +6604,12 @@ let () = let answer r = Option.value ~default:"" (Wire.string_field r "value") in - let read () = - answer - (request c - "(:op \"eval-expr\" :code \"(get config :s)\" \ - :file \"programs/dev-dyn-global.flan\")") + let read_reply () = + request c + "(:op \"eval-expr\" :code \"(get config :s)\" \ + :file \"programs/dev-dyn-global.flan\")" in + let read () = answer (read_reply ()) in (* A hundred thousand small maps: flan_dyn.c collects at a one-megabyte floor, so this is several collections and not a heap that merely grew. *) @@ -6629,11 +6629,17 @@ let () = if status r <> "ok" then fail "--%s: the churning thunk (cycle %d): %s" backend cycle (said r) - else if not (contains_sub (read ()) "kept") then - fail - "--%s: after a thunk that allocates (cycle %d) the parked \ - program's dyn global reads %S" - backend cycle (read ()); + else begin + (* The failing reply itself, and not a second read: the one + recorded failure here re-read and got "kept", so what the + first read answered is the whole of the evidence. *) + let r = read_reply () in + if not (contains_sub (answer r) "kept") then + fail + "--%s: after a thunk that allocates (cycle %d) the \ + parked program's dyn global read %S (%s: %s)" + backend cycle (answer r) (status r) (said r) + end; (* And round main again, which re-enters the very code that pushed those roots. *) let r = request c "(:op \"rerun\")" in @@ -6642,7 +6648,48 @@ let () = if not (await ~ms:20000 parked) then fail "--%s: the program did not park again (cycle %d)" backend cycle - done + done; + (* An expression's module is unloaded once it returns, string + literals and all: a literal is a copy the process keeps, so a + global left holding one still reads it after the module that + wrote it is gone and later ones have been mapped where it + was. The mapping count is what the kernel limits. *) + let ev code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %s \ + :file \"programs/dev-dyn-global.flan\")" (Wire.quote code)) + in + let r = + request c + "(:op \"eval\" :code \"(defonce msg string)\" \ + :file \"programs/dev-dyn-global.flan\")" + in + if status r <> "ok" then fail "--%s: defonce msg: %s" backend (said r) + else begin + ignore (ev "(do (set msg \"tuned\") 0)"); + let maps () = + List.length + (String.split_on_char '\n' + (In_channel.with_open_bin + (Printf.sprintf "/proc/%d/maps" dpid) + In_channel.input_all)) + in + let m0 = maps () in + for i = 1 to 20 do + ignore (ev (Printf.sprintf "(do (println \"other %d\") %d)" i i)) + done; + let m1 = maps () in + if m1 - m0 >= 20 then + fail "--%s: twenty expressions with a string literal left %d \ + more mappings" backend (m1 - m0); + let r = ev "msg" in + if Wire.string_field r "value" <> Some "\"tuned\"" then + fail "--%s: a literal stored by an unloaded module reads %S \ + (%s)" backend + (Option.value ~default:"" (Wire.string_field r "value")) + (said r) + end end; ignore (request c "(:op \"close\")"); (try Unix.close c with Unix.Unix_error _ -> ()); @@ -8761,6 +8808,28 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── --sanitize on the backend it cannot instrument ───────────── *) + + (* Refused before anything is built, by name and with the way out. The + session itself is driven under the sanitizers by @sanitize. *) + let zerr = tmp "x86san.err" in + let zfd = Unix.openfile zerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let zpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-loop.flan"; "-s"; tmp "x86san.sock"; + "--x86"; "--sanitize" |] + Unix.stdin zfd zfd + in + Unix.close zfd; + (match Unix.waitpid [] zpid with + | _, Unix.WEXITED 1 -> + let said = In_channel.with_open_bin zerr In_channel.input_all in + if not (contains_sub said "--x86 --sanitize" + && contains_sub said "Drop --x86") then + fail "flan dev --x86 --sanitize was refused as: %S" said + | _ -> fail "flan dev --x86 --sanitize was not refused"); + (try Sys.remove zerr with Sys_error _ -> ()); + (* ── Whose break it is ─────────────────────────────────────────── *) (* The program stops on its own while an evaluation is in flight: [go] diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..5e50af53 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1315,17 +1315,25 @@ let () = if has c.Session.ir "@flan_reload_transient" then fail "a module that publishes a body claimed to be unloadable"; - (* And a third condition, about data rather than text. A string literal lives - in the evaluating module's own image, and an expression may store one - anywhere: [(set msg "x")] on a string global would leave that global - pointing into a mapping the agent then drops — and since the next thunk can - be mapped at the same address, the result is silent garbage rather than a - fault. A module carrying any string constant keeps its mapping. *) + (* And a third condition, about data rather than text. An expression may + store a string literal anywhere — [(set msg "x")] on a string global — so + a literal's value is a copy [flan_dev_literal] keeps for the process, and + nothing is left pointing into the module. A string constant the module + does hand out still keeps its mapping: a condition's name, which a handler + may carry away. *) let str = Session.eval_expr t "(println \"tuned\")" in - if not (has str.Session.ir ".str.0") then - fail "the fixture stopped carrying a string constant, so it proves nothing"; - if has str.Session.ir "@flan_reload_transient" then - fail "an expression holding a string claimed to be unloadable"; + if not (has str.Session.ir "@flan_dev_literal(ptr") then + fail "an expression's string literal is not a kept copy"; + if has str.Session.ir ".str." then + fail "an expression's string literal is still a constant of its module"; + if not (has str.Session.ir "@flan_reload_transient") then + fail "an expression whose only string is a literal kept its mapping"; + let held = + Session.eval_expr t + "(restart-case (+ 1 2) (use-zero [] :report \"Answer 0\" 0))" + in + if has held.Session.ir "@flan_reload_transient" then + fail "an expression establishing a restart claimed to be unloadable"; (* ── Generics in the dev loop ───────────────────────────────────────── A generic [defn] produces no [Tast.fn] of its own — only its copies do — @@ -1523,7 +1531,7 @@ let () = (* And the slot names, in the packed form the runtime splits — which is what says the call carries *this* class's new list and not some other module's leftovers. *) - if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") then + if not (has c.Session.ir "c\"x\\0Ay\\0Az\"") then fail "the registration did not carry the new slot list" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "adding a slot to a class was refused: %s" m); @@ -1556,7 +1564,7 @@ let () = | c -> if not (has c.Session.ir "call void @flan_dyn_class_def") then fail "an unchanged class definition registered nothing"; - if not (has c.Session.ir "c\"x\\0Ay\\00\"") then + if not (has c.Session.ir "c\"x\\0Ay\"") then fail "an unchanged class registered some other slot list" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "re-evaluating an unchanged class was refused: %s" m); @@ -1620,7 +1628,7 @@ let () = ignore (Session.eval t "(defn origin [] dyn (point 0 0))"); match Session.eval t "(defclass point [x i64 y])" with | c -> - if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then + if not (has c.Session.ir "c\"x i64\\0Ay\"") then fail "a slot's new type did not reach the registration" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a slot's type changed under a compiled caller was refused: %s" m);