JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 15:57:40 +07:00
parent d0fc036bba
commit 527da37633
6 changed files with 211 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
TODO.org
View File

@ -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

41
lib/emit.ml
View File

@ -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,

31
lib/x86.ml
View File

@ -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 = []

50
runtime/flan_dev.c
View File

@ -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

91
test/test_dev.ml
View File

@ -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]

34
test/test_session.ml
View File

@ -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);