diff --git a/TODO.org b/TODO.org index 081c65c5..61cc6ec3 100644 --- a/TODO.org +++ b/TODO.org @@ -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. diff --git a/lib/classes.ml b/lib/classes.ml index 15b9440a..8a109288 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -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) -> diff --git a/lib/emit.ml b/lib/emit.ml index 13dc14fc..b7eb36a8 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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) diff --git a/lib/session.ml b/lib/session.ml index c682fad7..c5681ead 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -965,7 +965,25 @@ let eval ?(origin = "") ?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 ]); diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index d2849afe..99472218 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -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 diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 8b73adf6..df8020e5 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -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 diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 51639a60..6edc6eb8 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -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(); diff --git a/test/programs/dev-hook.flan b/test/programs/dev-hook.flan new file mode 100644 index 00000000..d553b3fa --- /dev/null +++ b/test/programs/dev-hook.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index 169a2eee..401bdc88 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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" () diff --git a/test/test_session.ml b/test/test_session.ml index 758cb23f..3a44b8e2 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -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 diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 2ca2aadb..4ab2090b 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -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: diff --git a/web/index.html b/web/index.html index 0805ca50..d40a211a 100644 --- a/web/index.html +++ b/web/index.html @@ -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 nil, a dropped one goes, the object is the same object, and class-of 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.

+That is CLHS 4.3.6's protocol. Its user hook is +update-instance-for-redefined-class: 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 migrate-by-name +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.

C-c C-x 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