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

A method of update-instance-for-redefined-class runs on each instance as it migrates, and one that signals offers migrate-by-name

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:55:40 +07:00
parent 2682214499
commit e0af3c9b1d
12 changed files with 513 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
TODO.org
View File

@ -549,13 +549,10 @@ dispatch values. With single dispatch on literal values there is no specificity
question, and inheritance or multiple dispatch would create one. Unknown-slot
checking needs class-typed tracking the dyn side deliberately does not have.
** NEXT update-instance-for-redefined-class, the user hook
Decided 2026-09-25: build it after typed class slots land, shaped for the REPL — written and installed from a live session as a one-time "here is how to migrate this", without restarting. It receives the instance with the added and discarded slots and their old values, and runs at each instance's lazy migration. A hook that signals parks in the break buffer with a restart that falls back to name-matching migration.
Left out of v1 because name matching is the half that makes redefinition usable
and the hook is what makes it expressive. The obvious spelling is a generic riding
the dispatch that exists, and the migration already computes both the added and
the discarded lists. Rolling a failed migration back becomes a real question the
day this lands.
** DONE update-instance-for-redefined-class, the user hook
CLOSED: [2026-09-25]
Taking =migrate-by-name= keeps the name-matched instance, not SBCL's obsolete one,
and retries nothing; a transfer from the method to a restart below it traps.
** DONE The module system stays directory-as-package
Several files in one directory are one module; a loose file is a module of one,
@ -1367,7 +1364,7 @@ sibling".
** DONE A redefined defclass migrates its instances lazily
CLOSED: [2026-09-20]
CLHS 4.3.6 minus the user hook. Nothing is enumerated and no heap is walked — the
CLHS 4.3.6. Nothing is enumerated and no heap is walked — the
redefinition is constant time and each instance pays once, at its next touch.
Neither printer migrates, so a stale instance shows its old slots to the editor
until something touches it. The registry is advisory: a key the class never
@ -1976,18 +1973,10 @@ specification's own branch — the flag is the command and the printed shape is
error pattern, so anyone who wants one has the four lines, and the manual carries
them.
** NEXT defclass slots take types, checked on write
Decided 2026-09-25: slots are name/type pairs checked on write; an untyped slot stays legal and holds any =dyn=. A migration keeps a stored value that no longer fits the new type, warns once, and the next write is checked. One lane with the =set= entry below.
=(defclass State [pause bool step bool])= reads as four untyped slots and
reports a duplicate =bool=. Wanted: the slot list is name/type pairs, as CLOS
does it. The type is a declaration about the values and not a layout — an
instance stays a map, so redefinition and lazy migration are unchanged. SBCL
checks it on write (=src/pcl/slots.lisp:160=, the typecheck before the store),
which is where the bad value is, so =put= is the site here.
Open: what migration does with a stored value that no longer fits a changed
slot type, and whether an untyped slot stays legal (it should — =dyn= is a type
and writing nothing should mean it).
** DONE defclass slots take types, checked on write
CLOSED: [2026-09-25]
The constructor's parameters stay dyn and every store checks at run time; no int
converts into a float slot, nil does not fit a typed slot, and a class is no slot type.
** NEXT println takes up to a second to appear
Decided 2026-09-25: the daemon pushes program output on the editor's connection as it is written. Rules out a faster poll.
@ -1997,15 +1986,10 @@ composed, so anything the program prints after that waits for the next tick.
Polling faster costs a request a second for nothing most of the time; the
daemon pushing on its own connection is the other shape. Decide which.
** NEXT set writes a class slot; put is for maps
Decided 2026-09-25: as written; one lane with typed slots.
=put= exists because an absent map key has no location to store into, which is
why =(get m k)= is refused as a place (=lib/parse.ml:1159=). A class instance is
not in that situation: its slots are fixed by the =defclass=, so a declared slot
always exists and =(set (get state :pause) true)= is a field store like
=(set (.velocity g) 0.0)=. Make =set= take it, and leave =put= to maps, where
insertion is real. Writing an undeclared slot through =set= is then a refusal
naming the class.
** DONE set writes a class slot; put is for maps
CLOSED: [2026-09-25]
=put= on an instance still checks a declared slot's type and still inserts an
undeclared key; only =set= refuses one, since a slot it writes has to exist.
** NEXT update: change a place by applying a function to it
Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place.

60
lib/classes.ml
View File

@ -49,6 +49,45 @@ let dispatch_slot = "~dispatch"
the prelude; this is the only place that builds one. *)
let no_method = "NoMethod"
(* CLHS's update-instance-for-redefined-class: what a redefined class does to
each of its instances, run once per instance at the first [get], [put] or
[set] that reaches it after the redefinition. By then the instance already
holds the new slots, each kept one with its old value and each gained one
nil; [added] is a vec of the gained slots' keywords and [discarded] a map
from each lost slot's keyword to the value it held. A method is written for
a class, from a live session, and is how a migration does more than match
slots by name:
(defmethod update-instance-for-redefined-class point [p added discarded]
(set (get p :radius) (get discarded :r))
nil)
A method that signals stops in the break loop with [migrate-by-name] on
offer, which keeps the instance as name-matching left it.
The generic and its :else method, which does nothing, are written here
rather than in the prelude, and only into a program that has a class or a
method of the generic: a program with neither would otherwise carry a dyn
function and pay for the collector it never uses. [Session] registers the
dispatcher's body with the runtime whenever a reload could have changed
it. *)
let migrate_generic = "update-instance-for-redefined-class"
let migrate_decls loc : Ast.decl list =
let p n = { Ast.fname = n; fty = dyn_at loc; floc = loc } in
let fn body =
{ Ast.name = migrate_generic;
params = [ p "instance"; p "added"; p "discarded" ]; praw = None;
ret = Some (dyn_at loc); fwhere = []; fbody = body; nloc = loc;
fprivate = Ast.Exported }
in
[ { Ast.d = Ast.Defgeneric (fn []); dloc = loc };
{ Ast.d =
Ast.Defmethod
{ Ast.mgen = migrate_generic; mkey = Ast.Delse;
mfn = fn [ ex loc (Ast.Var "nil") ]; mkloc = loc };
dloc = loc } ]
(* ── Collecting ────────────────────────────────────────────────────── *)
type generic = {
@ -348,6 +387,27 @@ let expand (decls : Ast.decl list) : Ast.decl list =
in
if not has then decls
else begin
let decls =
let wants =
List.find_opt
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defclass _ -> true
| Ast.Defmethod m -> String.equal m.Ast.mgen migrate_generic
| _ -> false)
decls
and declared =
List.exists
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defgeneric f -> String.equal f.Ast.name migrate_generic
| _ -> false)
decls
in
match wants with
| Some d when not declared -> decls @ migrate_decls d.Ast.dloc
| _ -> decls
in
let _classes, generics = collect decls in
List.filter_map
(fun (d : Ast.decl) ->

1
lib/emit.ml
View File

@ -4376,6 +4376,7 @@ declare void @flan_dyn_slot_init(i64, i64, i64)
declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64)
declare i64 @flan_dyn_class_of(i64)
declare void @flan_dyn_class_def(i64, ptr, i64)
declare void @flan_dyn_class_hook(ptr)
declare i64 @flan_dyn_kw(ptr, i64)
declare i64 @flan_dyn_map_get(i64, i64)
declare void @flan_dyn_map_set(i64, i64, i64)

20
lib/session.ml
View File

@ -965,7 +965,25 @@ let eval ?(origin = "<eval>") ?pause t src : change =
definition the registry has never seen has to arrive somehow. *)
let class_body =
let str s : Tast.expr = { Tast.e = Tast.Str s; ty = Types.String; loc } in
List.map
(* And the hook a migration calls, re-registered by every module that
could have changed what it should be: one carrying a class, since
that is what makes migrations happen, and one carrying a method of
the generic, since that is what changes the body. The address is the
cell's contents at the time the thunk runs — after this module's
bodies are published — so it is the body just installed. *)
let hook =
let n = Classes.migrate_generic in
if incoming_classes <> [] || List.mem n names then
let ty =
Types.CFn ([ Types.Dyn; Types.Dyn; Types.Dyn ], Types.Dyn)
in
[ { Tast.e =
Tast.Prim (Tast.Rt "flan_dyn_class_hook",
[ { Tast.e = Tast.FnAddr (Tast.Fnval n); ty; loc } ]);
ty = Types.Unit; loc } ]
else []
in
hook @ List.map
(fun (n, slots) : Tast.expr ->
let kw : Tast.expr =
{ Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]);

148
runtime/flan_dyn.c
View File

@ -1153,8 +1153,8 @@ flan_dyn flan_dyn_map_new(void) {
*
* The registry a redefined (defclass ...) updates, and the lazy migration
* that makes the instances built against the old definition answer the new
* one. This is CLHS 4.3.6 — [update-instance-for-redefined-class] — with the
* user hook left out; docs/SBCL-REDEFINITION-NOTES.md is where the protocol
* one. This is CLHS 4.3.6, [update-instance-for-redefined-class] included —
* see [class_hook]; docs/SBCL-REDEFINITION-NOTES.md is where the protocol
* was read off and candidate C is this.
*
* **Why a registry at all, when a class instance is already just a map.**
@ -1427,6 +1427,101 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) {
class_add(k, list, types, count);
}
/* update-instance-for-redefined-class's dispatcher, as the last reload that
* installed a class or one of its methods left it; NULL until then. Set by a
* thunk and not found by name, because the name is a Flan symbol this file
* cannot spell and the body behind it moves with every method added. */
static void *migrate_fn;
void flan_dyn_class_hook(void *fn) { migrate_fn = fn; }
extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
uint64_t added, uint64_t discarded);
/* Allocation and the map operations are further down, under their own
* headings; the hook's arguments are built with them. */
flan_dyn flan_dyn_vec_new(void);
flan_dyn flan_dyn_map_new(void);
void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen);
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v);
/* The user hook, run on an instance the name-matching has just brought up to
* date. [inst], [added] and [gone] are rooted by the caller.
*
* Two things are kept for the length of the call, because the call is
* arbitrary Flan and may allocate as much as it likes:
*
* - the name-matched entries, rooted, so that taking the restart puts the
* instance back exactly as name-matching left it, whatever the method did
* to it before it signalled. That is the restart's whole meaning, and it
* is SBCL's choice of what a failed update leaves (std-class.lisp, the
* nlx-protect around the call) moved one step: SBCL restores the obsolete
* instance and retries at the next access, where here the name-matched
* one is kept and nothing is retried.
* - the temporaries ring, saved and put back. A migration starts inside
* [get] or [put], whose caller may be holding an object only the ring
* keeps alive — the result of the call beside it in the same expression.
* A method that allocates more than the ring holds would push it out and
* let the next collection free it, so the ring is rooted for the call and
* restored after it, and the caller sees the ring it left. */
static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added,
flan_dyn gone, int64_t n) {
flan_dyn *snap = NULL;
flan_obj *ring_was[RING];
flan_dyn ring_rooted[RING];
unsigned ring_at_was = ring_at, k;
int64_t j, roots_at = roots_n;
int r;
if (n > 0) {
snap = (flan_dyn *)malloc((size_t)n * 2 * sizeof *snap);
if (snap == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *snap);
memcpy(snap, o->u.v.items, (size_t)n * 2 * sizeof *snap);
for (j = 0; j < n; j++) root_add(&snap[j * 2 + 1], NULL);
}
memcpy(ring_was, ring, sizeof ring);
for (k = 0; k < RING; k++) {
ring_rooted[k] = ring[k] == NULL
? dyn_make(BOX_NIL, 0)
: dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)ring[k]);
root_add(&ring_rooted[k], NULL);
}
r = flan_dyn_migrate_hook(migrate_fn, inst, added, gone);
memcpy(ring, ring_was, sizeof ring);
ring_at = ring_at_was;
/* Nothing below allocates on the collector's heap, so the roots into
[snap] and this frame can go before either does. */
roots_n = roots_at;
if (r == 1) {
/* The restart: the entries name-matching left, in a block of their own,
* whatever the method grew or shrank the instance to. */
flan_dyn *back = NULL;
if (n > 0) {
back = (flan_dyn *)malloc((size_t)n * 2 * sizeof *back);
if (back == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *back);
memcpy(back, snap, (size_t)n * 2 * sizeof *back);
}
gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn);
free(o->u.v.items);
o->u.v.items = back;
o->u.v.cap = n;
o->len = n;
}
free(snap);
if (r == 2) {
kw_entry *c = o->u.v.klass;
fflush(stdout);
fprintf(stderr,
"dyn migrate: update-instance-for-redefined-class, migrating an "
"instance of %.*s, was left for a restart established outside "
"it. A migration runs inside get, put or set, and cannot be "
"left for one of their callers; the instance is kept as its "
"slots matched by name. Take migrate-by-name, or handle the "
"condition inside the method\n",
(int)c->len, (const char *)(c + 1));
flan_trap((const uint8_t *)"DynMigrate", 10);
}
}
/* The migration. [o] is left holding exactly the class's current slots, in
* the class's order, with the values it already had for the ones it still
* has and nil for the ones it has just gained — which is precisely the
@ -1440,8 +1535,10 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) {
* and count in insertion order and would have. One malloc per instance per
* redefinition is the price, and a migration happens once.
*
* Nothing here allocates on the collector's heap, so no collection can run
* part-way through and see an object whose [len] and [items] disagree.
* The name-matching allocates nothing on the collector's heap, so no
* collection can run part-way through it and see an object whose [len] and
* [items] disagree. The hook's arguments are built before it starts, while
* [o] still holds its old entries whole, and the hook runs after it ends.
*
* Nor can it free a block something above it is walking. The block it frees
* is [o]'s, and every caller syncs [o] before it starts walking [o] — so a
@ -1453,9 +1550,48 @@ static void class_sync(flan_obj *o) {
class_entry *e;
flan_dyn *fresh = NULL;
int64_t i, j;
/* The hook's three arguments, rooted by address for as long as the hook
* may run: each is a collector object held nowhere else. */
flan_dyn inst, added, gone;
int64_t roots_at = roots_n;
int hook;
if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return;
e = class_find(o->u.v.klass);
if (e == NULL || e->gen == o->gen) return;
/* CLHS 4.3.6: the method runs on every instance a redefinition reaches,
* whether or not the slot names moved — a changed type is a change a
* method may want to convert for. */
hook = migrate_fn != NULL && flan_dyn_migrate_hook != NULL;
inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
added = gone = dyn_make(BOX_NIL, 0);
if (hook) {
root_add(&inst, NULL);
added = flan_dyn_vec_new();
root_add(&added, NULL);
gone = flan_dyn_map_new();
root_add(&gone, NULL);
for (j = 0; j < e->nslots; j++) {
for (i = 0; i < o->len; i++) {
flan_dyn key = o->u.v.items[i * 2];
if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD
&& dyn_kw(key) == e->slots[j]) break;
}
if (i == o->len)
flan_dyn_push(added,
dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]),
NULL, 0);
}
/* Every key the class no longer declares, a raw [put]'s included:
* CLHS's discarded slots and their property list, as one map. */
for (i = 0; i < o->len; i++) {
flan_dyn key = o->u.v.items[i * 2];
int kept = 0;
if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD)
for (j = 0; j < e->nslots; j++)
if (dyn_kw(key) == e->slots[j]) { kept = 1; break; }
if (!kept) flan_dyn_map_set(gone, key, o->u.v.items[i * 2 + 1]);
}
}
if (e->nslots > 0) {
fresh = (flan_dyn *)malloc((size_t)e->nslots * 2 * sizeof *fresh);
if (fresh == NULL) trap_oom(NULL, 0, e->nslots * 2 * (int64_t)sizeof *fresh);
@ -1506,7 +1642,11 @@ static void class_sync(flan_obj *o) {
o->u.v.items = fresh;
o->u.v.cap = e->nslots;
o->len = e->nslots;
/* Current before the hook runs, so a method that reads or writes the
* instance finds it migrated and does not start a second migration. */
o->gen = e->gen;
if (hook) class_hook(o, inst, added, gone, e->nslots);
roots_n = roots_at;
}
/* The same map with a shape tag on it: what a (defclass ...) constructor

9
runtime/flan_dyn.h
View File

@ -120,7 +120,7 @@ flan_dyn flan_dyn_class_of(flan_dyn v);
* [len] or equality comparison: slots the class still has keep their values
* matched by name, slots it has gained appear as nil, and keys it no longer
* declares are dropped. The instance's identity is preserved throughout;
* this is CLHS 4.3.6 without the user hook.
* this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook.
*
* The drop is unconditional, which is the honest cost of a class instance
* being an open map: a key written by a raw [put] that the class never
@ -128,6 +128,13 @@ flan_dyn flan_dyn_class_of(flan_dyn v);
* class's intention and does not enforce it. */
void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n);
/* The body update-instance-for-redefined-class dispatches through, as a
* reload last saw it. Each migration after this calls it, through
* flan_rt.c's [flan_dyn_migrate_hook], with the instance already matched by
* name. A reload that installs a class or a method of that generic calls
* this again, so the body is never older than the last one installed. */
void flan_dyn_class_hook(void *fn);
/* [sizeof(flan_obj)], for the one test that asserts it. The generation a
* class instance carries was fitted into the padding between [mark] and
* [len] precisely so that this number did not move; a field that pushed it

20
runtime/flan_rt.c
View File

@ -620,6 +620,26 @@ void (*flan_break_hook)(const uint8_t *name, int64_t namelen, void *condition,
* site printed just above carries the detail. */
void (*flan_trap_hook)(const uint8_t *name, int64_t namelen);
/* The call a class migration makes to update-instance-for-redefined-class:
* [fn] is the method dispatcher's current body, and the three words are the
* instance, the vec of slots it gained and the map of the slots it lost to
* the values they held — dyn words, as [uint64_t] here because this file
* does not include flan_dyn.h.
*
* Here and not in flan_dyn.c because it is set by the agent, and the agent
* must link against a program with no collector in it; and not called from
* here because what makes it a hook is the restart it runs under, which is
* the agent's business — the floor a break inside it reads is the agent's.
* NULL, and no hook runs, outside a dev session: a class is redefined only
* by a reload, and a reload only arrives through the agent.
*
* The answer is 0 when the method returned, 1 when the restart the call
* established was taken, and 2 when some other transfer came back through
* it — one aimed at a restart below the call, which a C frame cannot carry
* on. */
int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added,
uint64_t discarded);
static _Noreturn void rt_trap(const uint8_t *name, int64_t namelen) {
if (flan_trap_hook != NULL) flan_trap_hook(name, namelen);
rt_die();

21
test/programs/dev-hook.flan Normal file
View File

@ -0,0 +1,21 @@
;;;; A class redefined under its instances, with update-instance-for-
;;;; redefined-class written from the session to carry a lost slot's value
;;;; into a gained one. dev-classes.flan is the name-matching half; this is
;;;; the half a method adds, and the method that signals.
;;;;
;;;; The instances are pushed by the editor for dev-classes.flan's reason: a
;;;; compiled caller of the constructor would pin its slot count.
(import agent "vendor:agent")
(defclass point [x y])
(defstruct Refused [why i32])
(defonce instances dyn)
(defn main [] i32
(agent/start "/tmp/flan-dev-hook-fallback.sock")
(set instances (vec-new dyn))
(dotimes [i 4000]
(agent/wait 5))
0)

156
test/test_dev.ml
View File

@ -7481,6 +7481,162 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock2; lout2 ];
(* ── update-instance-for-redefined-class, written from the session ──
The method is written and installed while the program runs, then the
class is redefined, and each instance runs the method at its first
touch after that. On both backends, because the method is Flan code
the C runtime calls from inside [get], and that call is the one piece
of this each backend's calling convention has to agree with.
Three claims, in order: a method carries a lost slot's value into a
gained one; a method that signals stops the program with
[migrate-by-name] on offer, and taking it leaves the instance as
name-matching made it, the method's own write included; and a kept
value that no longer fits its slot's new type stays, with a warning.
stdout and stderr go to one file, which is where the warning is read
from. *)
let hook_block ~llvm =
let what = if llvm then "llvm: " else "" in
let hsock = tmp (if llvm then "hook-llvm.sock" else "hook.sock")
and hout = tmp (if llvm then "hook-llvm.out" else "hook.out") in
(try Sys.remove hsock with Sys_error _ -> ());
let hfd =
Unix.openfile hout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let argv =
Array.append
[| flan; "dev"; "programs/dev-hook.flan"; "-s"; hsock |]
(if llvm then [| "--llvm" |] else [||])
in
let hpid = Unix.create_process flan argv Unix.stdin hfd hfd in
Unix.close hfd;
let output () = In_channel.with_open_bin hout In_channel.input_all in
if not (listening ~pid:hpid hsock) then begin
fail "%sthe hook daemon %s (%S)" what !listen_why (output ());
(try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect hsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let file = " :file \"programs/dev-hook.flan\")" in
let ask code =
request c (Printf.sprintf "(:op \"eval-expr\" :code %S%s" code file)
in
let redefine code =
request c (Printf.sprintf "(:op \"eval\" :code %S%s" code file)
in
let holds claim code =
let r = ask code in
if status r <> "ok" then fail "%s%s: %s" what claim (said r)
else if value r <> "1" then
fail "%s%s answered %S (%s)" what claim (value r) code
in
let defined claim code =
let r = redefine code in
if status r <> "ok" then (fail "%s%s: %s" what claim (said r); false)
else true
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let started () =
status (ask "(do (push instances (point 3 4)) 1)") = "ok"
in
if not (await started) then
fail "%sthe hook daemon never reached a frame boundary" what
else begin
holds "a second instance" "(do (push instances (point 5 6)) 1)";
(* ── A method that carries a value across ── *)
if defined "a method of the migration generic, from the session"
"(defmethod update-instance-for-redefined-class point \
[p added discarded] \
(set (get p :radius) (get discarded :y)) nil)"
&& defined "a class redefined under a method"
"(defclass point [x radius])"
then begin
holds "the method moved the lost slot's value into the new one"
"(if (= (get (at instances 0) :radius) 4) 1 0)";
holds "a kept slot is untouched by the method"
"(if (= (get (at instances 0) :x) 3) 1 0)";
holds "the lost slot is gone"
"(if (= (length (at instances 0)) 2) 1 0)";
holds "each instance runs the method at its own first touch"
"(if (= (get (at instances 1) :radius) 6) 1 0)"
end;
(* ── A method that signals ── *)
if defined "a method that signals"
"(defmethod update-instance-for-redefined-class point \
[p added discarded] \
(set (get p :x) 99) (error (Refused {.why 1})) nil)"
&& defined "a class redefined under a method that signals"
"(defclass point [x radius z])"
then begin
let r = ask "(get (at instances 0) :x)" in
if status r <> "error" then
fail "%sa migration whose method signals answered %s" what
(status r);
let r = request c "(:op \"break\")" in
let names =
match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str x -> Some x | _ -> None)
l
| _ -> []
in
(match names with
| "migrate-by-name" :: _ -> ()
| _ ->
fail "%sthe restarts at a signalling method: %s" what
(String.concat ", " names));
let r = request c "(:op \"restart\" :name \"migrate-by-name\")" in
if status r <> "ok" then
fail "%smigrate-by-name was refused: %s" what (said r);
if not
(await (fun () -> not (stopped (request c "(:op \"describe\")"))))
then fail "%sthe program did not run again after migrate-by-name" what
else begin
holds "migrate-by-name undoes the method's write"
"(if (= (get (at instances 0) :x) 3) 1 0)";
holds "and keeps what name-matching kept"
"(if (= (get (at instances 0) :radius) 4) 1 0)";
holds "and has the new definition's slots"
"(if (= (length (at instances 0)) 3) 1 0)"
end
end;
(* ── A type that no longer fits ── *)
if defined "a method that does nothing"
"(defmethod update-instance-for-redefined-class point \
[p added discarded] nil)"
&& defined "a slot's type changed to one its value does not fit"
"(defclass point [x string radius z])"
then begin
holds "a value that no longer fits is kept"
"(if (= (get (at instances 0) :x) 3) 1 0)";
let warned () =
contains_sub (output ())
"warning: point was redefined, and its slot :x is now \
declared string"
in
if not (await warned) then
fail "%sno warning for a kept value that does not fit: %S" what
(output ())
end
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] hpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ hsock; hout ]
in
hook_block ~llvm:false;
hook_block ~llvm:true;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
Test_support.report ~label:"dev" ()

19
test/test_session.ml
View File

@ -1384,6 +1384,25 @@ let () =
(String.concat " " c.Session.fns)
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a class and its caller evaluated together: %s" m);
(* A method of update-instance-for-redefined-class, from the session. The
generic is written by [Classes.expand], not by the program, so this is
the case where the declaration being extended is nowhere in the
session's own list — and the method still has to install the generic's
dispatch, and the module has to hand the runtime the body it just
installed, or migrations go on calling the old one. *)
(let t, _ = Session.create ~file:"programs/dev-class.flan" () in
match
Session.eval t
"(defmethod update-instance-for-redefined-class point \
[p added discarded] nil)"
with
| c ->
if not (List.mem Classes.migrate_generic c.Session.fns) then
fail "a migration method installed %s" (String.concat " " c.Session.fns);
if not (has c.Session.ir "call void @flan_dyn_class_hook") then
fail "a migration method did not re-register the hook"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a migration method was refused: %s" m);
(* A slot's type changed and nothing else. Every constructor parameter is
dyn whatever the slot says, so the signature is the one it was and a
compiled caller is no reason to refuse — the type is checked where a

44
vendor/agent/flan_agent.c vendored
View File

@ -336,6 +336,8 @@ extern int64_t flan_break_site_len;
* shadow-stack frame's shape does: the struct is declared in one file. */
extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen);
extern void flan_restart_pop_c(void *frame);
extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
uint64_t added, uint64_t discarded);
/* -- How far down a transfer can actually land ----------------------- */
@ -402,6 +404,44 @@ static int32_t frame_floor = -1;
static void *eval_boundary;
static const uint8_t abandon_name[] = "abandon-evaluation";
/* -- update-instance-for-redefined-class ------------------------------ */
/* A class migration calls the method from inside [get], [put] or [set] —
* a C frame with no transfer channel of its own — so the call is made the
* way a thunk's is: behind a floor, with a channel of its own and a restart
* of its own above the floor. A break inside the method then offers
* [migrate-by-name] and nothing below the call, which it could not reach.
* Taking it leaves the instance as name-matching made it; flan_dyn.c's
* [class_hook] puts that back.
*
* [eval_boundary] is cleared for the call: an evaluation in progress
* underneath is below this floor, and offering to abandon it would be a
* choice nothing can carry out. Everything saved is restored, so a
* migration inside a thunk inside a break nests like the rest. */
static const uint8_t migrate_name[] = "migrate-by-name";
typedef uint64_t (*migrate_fn_t)(uint64_t, uint64_t, uint64_t, void *);
static int migrate_call(void *fn, uint64_t instance, uint64_t added,
uint64_t discarded) {
int32_t outer = restart_floor;
int32_t oframe = frame_floor;
void *obound = eval_boundary;
void *xfer = NULL;
void *mine;
restart_floor = flan_restart_count();
frame_floor = flan_dev_frame_count();
eval_boundary = NULL;
mine = flan_restart_push_c(migrate_name, sizeof migrate_name - 1);
((migrate_fn_t)fn)(instance, added, discarded, &xfer);
flan_restart_pop_c(mine);
eval_boundary = obound;
restart_floor = outer;
frame_floor = oframe;
if (xfer == NULL) return 0;
return (mine != NULL && xfer == mine) ? 1 : 2;
}
/* The three of them, dropped between two runs of [main]. The counterpart of
* flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's
* [flan_dev_frames_reset], called from the same one place and for the same
@ -864,6 +904,9 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
!s->resumable ? " (cannot be taken from this trap)"
: i == s->boundary
? " (stop running the expression; the program carries on)"
: strcmp(s->names + s->off[i], (const char *)migrate_name) == 0
&& s->reachable[i]
? " (keep the instance as its slots matched by name)"
: s->reachable[i] ? ""
: " (below this break; cannot be taken)");
if (s->total > s->n)
@ -2114,6 +2157,7 @@ static int32_t start_on(const char *path) {
* to do, and stopping forever is worse than the abort it replaces. */
flan_break_hook = break_loop;
flan_trap_hook = trap_stop;
flan_dyn_migrate_hook = migrate_call;
return 0;
failed:

9
web/index.html
View File

@ -2220,7 +2220,14 @@ bumps a generation counter, which is O(1) and walks no heap; every live instance
migrates at its next touch. Slots matched by name keep their values, a gained slot
appears as <code>nil</code>, a dropped one goes, the object is the same object, and
<code>class-of</code> still answers the same tag, so every method still reaches it.
That is CLHS 4.3.6's protocol without the user hook, which is not built.</p>
That is CLHS 4.3.6's protocol. Its user hook is
<code>update-instance-for-redefined-class</code>: a method of it written for a
class, from the running session, runs on each instance as it migrates, with a
vec of the slots it gained and a map from each slot it lost to the value that slot
held. A method that signals stops the program with <code>migrate-by-name</code>
on offer, which keeps the instance as matching by name left it. A kept value that
no longer fits its slot's new type is kept, with a warning, and the next write to
the slot is checked.</p>
<p><kbd>C-c C-x</kbd> rebuilds, relaunches and reconnects, and is the way out while the
above is true. It costs the program's state, which is why it is a key you press rather than