diff --git a/TODO.org b/TODO.org index c9cd0045..677bc18d 100644 --- a/TODO.org +++ b/TODO.org @@ -564,13 +564,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, @@ -1403,7 +1400,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 @@ -2028,18 +2025,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] +Constructor parameters stay dyn and each store checks at run time; an int widens +into a float slot only if it round-trips, and nil fits only an (Option T) slot. ** DONE println takes up to a second to appear CLOSED: [2026-09-25] @@ -2051,15 +2040,10 @@ are gone. The poll stays for the stop and park edges. Rules out a faster poll and pushes to clients that did not ask for them. See docs/BUILT.md, "Output and the watch table are pushed". -** 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/ast.ml b/lib/ast.ml index 3ecf117f..7aaf7f76 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -203,6 +203,11 @@ and place = | Pfield of expr * string (* (set (.hp e) v) *) | Pindex of expr * expr list (* (set (at grid r c) v) *) | Pderef of expr (* (set (deref p) v) *) + (* (set (get inst :slot) v) — a class instance's declared slot. A map has + no such place: an absent key has no location, and [put] is how one is + written. Which of the two a value is, is known only at run time, so + this is a runtime store that refuses a plain map. *) + | Pslot of expr * expr and arm = { pat : pattern; body : expr list; aloc : Loc.t } @@ -287,8 +292,10 @@ and decl_kind = | Defvar of string * texpr option * init * reinit | Defconst of string * texpr option * expr (* ── The dyn side's classes and generic functions ────────────────── - None of these four reaches [Check]. [Classes.expand] turns the whole set - into ordinary [Defn]s before pass one collects anything, the way [Shim] + None of these four reaches [Check]'s signature pass. [Classes.expand] + turns the generic forms into ordinary [Defn]s before pass one collects + anything, and [Check.pair_decls] turns a [Defclass] into its constructor + once its slot vector can be paired, the way [Shim] already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a constructor, and a generic function is one function whose body is a dispatch over the methods written for it. @@ -298,8 +305,11 @@ and decl_kind = anywhere in the file, or arrive at a reload long after the generic did, and a macro sees one form. *) - (* (defclass point [x y]) — the slot names, in constructor order. *) - | Defclass of string * (string * Loc.t) list + (* (defclass point [x y]) or (defclass state [pause bool step bool]) — the + slot vector, in constructor order, left unpaired for the reason a + [defn]'s is: [[x y]] is two slots or one slot [x] of type [y] depending + on whether [y] names a type. [Check.pair_decls] pairs it. *) + | Defclass of string * pitem list (* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value is the shape tag of the first argument. The parameter vector and the return slot are a [defn]'s, and there is no body. *) @@ -418,6 +428,7 @@ let map_children f (e : expr) : expr = | Pfield (x, n) -> Pfield (ex x, n) | Pindex (x, is) -> Pindex (ex x, List.map ex is) | Pderef x -> Pderef (ex x) + | Pslot (x, k) -> Pslot (ex x, ex k) in let kind = match e.e with diff --git a/lib/check.ml b/lib/check.ml index 49013241..3f29bd6f 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -63,6 +63,22 @@ type binding = { bwhat : string option; } +(* A class slot's type: what a value stored into it is checked against. A + dyn value's tag is all a store can ask of it, so the scalar types a tag + answers for, an instance of a class, and (Option T) of either, which + admits nil as well. *) +type slot_ty = + | Sany (* no type written: any dyn value *) + | Sval of Types.t (* bool, an integer type, f32, f64, string *) + | Sclass of string (* an instance of this class *) + | Sopt of slot_ty (* nil, or a value of the inner type *) + +let rec slot_text = function + | Sany -> "dyn" + | Sval t -> Types.to_string t + | Sclass c -> c + | Sopt s -> "(Option " ^ slot_text s ^ ")" + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -181,6 +197,13 @@ type env = { flag is what lets [resolve_name] say the honest thing in each place instead of a suggestion that cannot be followed. *) mutable in_field : bool; + (* Every [defclass], by name: its slots in constructor order, each with the + type a value stored in it must have — [Types.Dyn] for a slot written + with no type. Filled by [pair_decls], which is where a slot vector is + first readable. The type is a declaration about the values and not a + layout: an instance is a dyn map whatever this says, and what reads it + is [class_spec], which is what the runtime checks a store against. *) + classes : (string, (string * slot_ty) list) Hashtbl.t; (* The bindings a dev build counts at every call: [Shim.resources], read off the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) @@ -214,6 +237,7 @@ let new_env () = { tvpreds = []; chain = []; in_field = false; + classes = Hashtbl.create 8; tracks = Hashtbl.create 16; } @@ -1545,7 +1569,9 @@ let dyn_param_or_typo env n loc = parameters are lowercase" n -let pair_params env (items : Ast.pitem list) : Ast.field list = +let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) + : Ast.field list = + let is_type_name env n = is_type_name env n || also n in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] @@ -1574,10 +1600,122 @@ let pair_params env (items : Ast.pitem list) : Ast.field list = in go items +(* A class slot's type, held to the set a stored dyn value can be checked + against. A class's name is a type here, and only here: it is not a type + anywhere else in the language, since an instance is a dyn value. Every + other type a slot could name — a struct, a Vec, a pointer — does not cross + into dyn at all, so a slot of one could never be written. *) +(* A class named in [cls]'s slot vector: [n] as written, or [n] in [cls]'s own + package, since [Load] leaves a bare name in a slot vector unqualified. *) +let class_named ~classes cls n = + (* The class's own package first: an importer may declare a class of the + same bare name, and a slot the package wrote means the package's. *) + let own = + match String.rindex_opt cls '/' with + | Some i -> + let q = String.sub cls 0 (i + 1) ^ n in + if List.mem q classes then Some q else None + | None -> None + in + match own with + | Some _ -> own + | None -> if List.mem n classes then Some n else None + +let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = + let refuse what = + Loc.failk "check/slot-type" t.Ast.tloc + "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ + which can be checked as bool, an integer type, f32, f64, string, a \ + class, or (Option T) of one of those. Write one of those, or leave the \ + type out and the slot holds any dyn value: [%s]" + fname cls what fname + in + match t.Ast.t with + | Ast.Tname n when class_named ~classes cls n <> None -> + Sclass (Option.get (class_named ~classes cls n)) + | Ast.Tapp ("Option", [ inner ]) -> + (match slot_of env ~classes cls fname inner with + | (Sval _ | Sclass _) as s -> Sopt s + | Sany -> refuse "(Option dyn)" + | Sopt _ as s -> refuse ("(Option " ^ slot_text s ^ ")")) + | _ -> + (match resolve env t with + | Types.Dyn -> Sany + | (Types.Bool | Types.Int _ | Types.Float _ | Types.String) as t -> Sval t + | other -> refuse (Types.to_string other)) + +(* The type's word in the string the runtime reads: the scalar type's name, + [#name] for a class, [?] in front for an Option. See [slot_type_of] in + runtime/flan_dyn.c, which is the reader. *) +let rec slot_word = function + | Sany -> "" + | Sval t -> Types.to_string t + | Sclass c -> "#" ^ c + | Sopt s -> "?" ^ slot_word s + +(* What the runtime is told a class is: one line per slot, in constructor + order, the slot's name and then its type's word after a space — no type + for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the + constructor and to [flan_dyn_class_def] from a reload, so the two cannot + describe one class differently. *) +let class_spec_of (slots : (string * slot_ty) list) = + String.concat "\n" + (List.map + (fun (n, t) -> match t with Sany -> n | t -> n ^ " " ^ slot_word t) + slots) + +let class_slots env n = Hashtbl.find_opt env.classes n + +(* A class's slot vector, paired by [pair_params]'s rule with the program's + class names counted as types — so [[owner point]] is one slot holding a + point. + + A lowercase name after a name that is neither a type nor a class is a + second untyped slot, which is the rule for a [defn]'s parameters and is + not changed here. In a vector that types none of its slots that is the + plain reading — [[x y]] is two slots and says nothing more. In one that + types some of them, two untyped names side by side are as likely a type + nobody has declared, so that is said, at the second name, and the slot + stays what the rule makes it. *) +let pair_slots env ~classes cls (items : Ast.pitem list) : Ast.field list = + let fields = + pair_params ~also:(fun n -> class_named ~classes cls n <> None) env items + in + let untyped (f : Ast.field) = + match f.Ast.fty.Ast.t with Ast.Tname "dyn" -> true | _ -> false + in + let written_dyn = + List.exists (function Ast.Pname ("dyn", _) -> true | _ -> false) items + in + if List.exists (fun f -> not (untyped f)) fields && not written_dyn then begin + let rec scan = function + | (a : Ast.field) :: ((b : Ast.field) :: _ as rest) -> + if untyped a && untyped b then + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " b.Ast.floc + (Printf.sprintf + "%s reads as a slot of %s with no type, because no type or \ + class is named %s. If it was meant as the type of %s, \ + declare it; if it is a slot, write its type or write \ + [%s dyn] to say it holds any value" + b.Ast.fname cls b.Ast.fname a.Ast.fname b.Ast.fname)); + scan rest + | _ -> () + in + scan fields + end; + fields + (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) let pair_decls env (decls : Ast.decl list) : Ast.decl list = + let classes = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) + decls + in let fn (f : Ast.fn) = match f.Ast.praw with | None -> f @@ -1586,6 +1724,18 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = List.map (fun (d : Ast.decl) -> match d.Ast.d with + (* A class's slot vector is paired here and nowhere earlier, for the + reason a [defn]'s is, and its constructor is written from the + pairs — [Classes.expand] left the declaration as it was for exactly + this. *) + | Ast.Defclass (n, items) -> + let slots = pair_slots env ~classes n items in + Hashtbl.replace env.classes n + (List.map + (fun (f : Ast.field) -> + (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) + slots); + Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } @@ -3703,12 +3853,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in + (* A class's constructor stores through [flan_dyn_slot_init], which is + the plain store plus the slot's type check, worded for the + constructor rather than for a [put] nobody wrote. *) let sets = List.map - (fun (k, v) -> - rt loc Types.Unit "flan_dyn_map_set" - [ mval; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + (fun ((k : Ast.expr), v) -> + let args = + [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ] + in + (* The key's location is the slot's, in the defclass: the + constructor has no other place of its own to name. *) + if tag = None then rt loc Types.Unit "flan_dyn_map_set" args + else rt loc Types.Unit "flan_dyn_slot_init" (args @ [ here k.Ast.loc ])) kvs in (* A shape tag, if this is the literal a class's constructor was written @@ -3719,8 +3876,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match tag with | None -> rt loc Types.Dyn "flan_dyn_map_new" [] | Some cls -> + (* The class's slots and their types ride along, so the first + instance built registers the class with the runtime and every + store after it — this literal's own included — is checked. A + class registered already, by an earlier instance or by a reload, + keeps what it has: redefining one is a reload's business. *) + let spec = + match Hashtbl.find_opt ctx.env.classes cls with + | Some slots -> class_spec_of slots + | None -> "" + in rt loc Types.Dyn "flan_dyn_map_new_class" - [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ]; + mk loc Types.String (Tast.Str spec) ] in expect ctx loc ~want (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) @@ -3839,6 +4007,23 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end + (* (set (get inst :slot) x) — a class instance's declared slot. A call and + not a place for [flan_dyn_set_at]'s reason: the runtime has to look at + the value to know it is an instance, which of its slots the key names, + and whether [x] fits the type that slot was declared with, and it traps + on each with a sentence of its own. A typed map has no such place; its + entries are written with [put]. *) + | Ast.Set (Ast.Pslot (target, k), v) -> + let target = check ctx target in + if target.Tast.ty <> Types.Dyn then + fail loc + "(get m k) is a place only on a class instance, and this is %s. A \ + map's entries are written with put" + (Types.to_string target.Tast.ty); + let k = check ctx ~want:Types.Dyn k in + let v = check ctx ~want:Types.Dyn v in + expect ctx loc ~want + (rt loc Types.Unit "flan_dyn_slot_set" [ target; k; v; here loc ]) | Ast.Set (p, v) -> let p, pty = check_place ctx loc p in let v = check ctx ~want:pty v in @@ -6803,6 +6988,13 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = | Types.Ptr t -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) + (* Only [set] writes a class slot, and it has its own arm above. A slot + lives in a map the collector may move entries of, so it has no address + to hand out. *) + | Ast.Pslot _ -> + fail loc + "a class slot (get inst :slot) is written with set and has no address. \ + Read it into a local with let" (* An index or a slice bound that is a literal is known now, so it is an error now rather than a trap later. Only literals: a [defconst] is a global in the @@ -8559,12 +8751,14 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check ctx target in (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no - restart and no region check. An equal key's value is replaced. *) + restart and no region check. An equal key's value is replaced. The + site rides along for the one refusal a put can meet, a class + instance's typed slot. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want - (rt loc Types.Unit "flan_dyn_map_set" + (rt loc Types.Unit "flan_dyn_map_put" [ target; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in let k = check ctx ~want:kt k in @@ -9868,6 +10062,27 @@ and ordinary_call ctx ~want loc name args = in (match Hashtbl.find_opt ctx.env.tracks name with | Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args) + | None when Hashtbl.mem ctx.env.classes name -> + (* A class's constructor, told where it was called from so that a + slot it refuses names this call and not only the defclass. The + arguments go into temps first: one may itself construct, and + the site is set last, immediately before the call, so nothing + between the two can replace it. The constructor takes it as its + first act; one reached through a function value finds none. *) + let temps = + List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args + in + let uses = + List.map + (fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s)) + temps + in + expect ctx loc ~want + (mk loc ret + (Tast.Let + (temps, + [ rt loc Types.Unit "flan_dyn_ctor_site" [ here loc ]; + mk loc ret (Tast.Call (name, uses)) ]))) | None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args)))) | None -> if Hashtbl.mem ctx.env.datas name then @@ -11612,7 +11827,11 @@ let collect env (decls : Ast.decl list) = driver that assembled a declaration list and skipped that pass would otherwise get a missing name from wherever the constructor was called, with nothing pointing here. *) - | Ast.Defclass (n, _) | Ast.Defgeneric { Ast.name = n; _ } + | Ast.Defclass (n, _) -> + fail loc + "internal: the class %s reached the checker unpaired — \ + pair_decls writes its constructor, and did not run" n + | Ast.Defgeneric { Ast.name = n; _ } | Ast.Defmulti { Ast.name = n; _ } -> fail loc "internal: %s reached the checker unexpanded — Classes.expand did \ diff --git a/lib/classes.ml b/lib/classes.ml index a6b7325b..cc006999 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -4,9 +4,11 @@ [(defclass point [x y])] is a constructor. [(defgeneric area [self] dyn)] and [(defmulti describe [x] dyn (get x :kind))] are each one function whose body is a dispatch, and [(defmethod area point [p] ...)] is a branch of - one. Nothing below this pass knows any of the four forms exists: what it - writes is [defn]s, and they are checked, emitted, rooted, redefined and - inspected as any other function is. + one. What it writes is [defn]s, and they are checked, emitted, rooted, + redefined and inspected as any other function is. The one exception is + [defclass], which passes through untouched: its slot vector reads like a + [defn]'s and cannot be paired until every type name is known, so + [Check.pair_decls] pairs it and calls [constructor] below. **Why a pass and not a macro.** A macro sees one form. This needs the whole declaration list, because a method may be written anywhere — above @@ -47,6 +49,46 @@ 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 + at its type's zero value, or nil for an untyped, Option or class slot; + [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 = { @@ -65,23 +107,7 @@ let collect (decls : Ast.decl list) = List.iter (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> - (* Two slots of one name would write one entry and read one value, - and the constructor would take two arguments for it. The duplicate - parameter that falls out of it is refused by the checker anyway; - this says which declaration it came from. *) - let seen = Hashtbl.create 8 in - List.iter - (fun (s, sloc) -> - if Hashtbl.mem seen s then - Loc.failk "check/duplicate-slot" sloc - "%s names the slot %s twice. A slot is a key in the \ - instance's map, so the second would replace the first and \ - the constructor would take an argument that goes nowhere" - n s; - Hashtbl.replace seen s ()) - slots; - Hashtbl.replace classes n d.Ast.dloc + | Ast.Defclass (n, _) -> Hashtbl.replace classes n d.Ast.dloc | Ast.Defgeneric fn -> Hashtbl.replace generics fn.Ast.name { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } @@ -162,14 +188,37 @@ let collect (decls : Ast.decl list) = omitted slot meaning nil — is deferred, and so is refusing an unknown slot at [(get p :z)]. Both are recorded in TODO.org, "Class features deferred, each with its reason". *) -let constructor n slots loc : Ast.decl = +let constructor n (slots : Ast.field list) loc : Ast.decl = + (* Two slots of one name would write one entry and read one value, and the + constructor would take two arguments for it. The duplicate parameter + that falls out of it is refused by the checker anyway; this says which + declaration it came from. *) + let seen = Hashtbl.create 8 in + List.iter + (fun (f : Ast.field) -> + if Hashtbl.mem seen f.Ast.fname then + Loc.failk "check/duplicate-slot" f.Ast.floc + "%s names the slot %s twice. A slot is a key in the instance's \ + map, so the second would replace the first and the constructor \ + would take an argument that goes nowhere" + n f.Ast.fname; + Hashtbl.replace seen f.Ast.fname ()) + slots; + (* Every parameter is dyn whatever its slot's type. The type is checked + where the value is stored — the constructor's own stores included — so + a caller holding a dyn passes it as it is, and a caller holding an i32 + boxes it; neither has to convert to the slot's type first. *) let params = List.map - (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + (fun (f : Ast.field) -> + { Ast.fname = f.Ast.fname; fty = dyn_at f.Ast.floc; floc = f.Ast.floc }) slots in let pairs = - List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + List.map + (fun (f : Ast.field) -> + (ex f.Ast.floc (Ast.Kw f.Ast.fname), ex f.Ast.floc (Ast.Var f.Ast.fname))) + slots in { Ast.d = Ast.Defn @@ -339,11 +388,34 @@ 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) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc) + (* Kept: its slot vector cannot be paired until every type name is + known, so [Check.pair_decls] writes the constructor. *) + | Ast.Defclass _ -> Some d | Ast.Defgeneric fn | Ast.Defmulti fn -> Some (dispatcher (Hashtbl.find generics fn.Ast.name)) (* Gone: its body is inside its generic's dispatch. *) diff --git a/lib/dev.ml b/lib/dev.ml index 05d74af0..98a5f0b3 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1537,17 +1537,29 @@ let defs t = [M-.] on a prelude macro from "the prelude is not a file on disk" into a shrug about the daemon having no location. *) let macro_locs = Hashtbl.create 16 in - (* The classes, off the session's declarations: [Classes.expand] turns a - [defclass] into its constructor [defn] before the checker runs, so the - class is not in [Tast.program] or the checker's environment, and the - declarations are the one place that still has it. Its constructor is - dropped from the [fn] rows for the macro rows' reason: one name, one row, - and [class] is what was written. *) + (* The classes: where each was written, off the session's declarations, + and its slots as the checker paired them, off its environment — the + slot vector is unreadable before pairing. The constructor the checker + wrote is dropped from the [fn] rows for the macro rows' reason: one name, + one row, and [class] is what was written. *) let classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots, d.Ast.dloc) + | Ast.Defclass (n, _) -> + let slots = + Option.value ~default:[] + (Check.class_slots t.session.Session.env n) + in + Some + (n, + List.map + (fun (s, ty) -> + match ty with + | Check.Sany -> s + | ty -> s ^ " " ^ Check.slot_text ty) + slots, + d.Ast.dloc) | _ -> None) t.session.Session.decls in diff --git a/lib/emit.ml b/lib/emit.ml index 0a911b09..6f63ba31 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4780,9 +4780,14 @@ declare i64 @flan_dyn_from_bool(i32) declare i64 @flan_dyn_from_bytes(ptr, i64) declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() -declare i64 @flan_dyn_map_new_class(i64) +declare i64 @flan_dyn_map_new_class(i64, ptr, i64) +declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) +declare void @flan_dyn_slot_init(i64, i64, i64, ptr, i64) +declare void @flan_dyn_ctor_site(ptr, 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/load.ml b/lib/load.ml index 5bf878da..ad55acf0 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -391,6 +391,7 @@ and rename_place owned alias bound (p : Ast.place) : Ast.place = | Ast.Pfield (t, f) -> Ast.Pfield (go t, f) | Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx) | Ast.Pderef t -> Ast.Pderef (go t) + | Ast.Pslot (t, k) -> Ast.Pslot (go t, go k) let rename_field owned alias (f : Ast.field) : Ast.field = { f with Ast.fty = rename_texpr owned alias f.Ast.fty } @@ -502,12 +503,23 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = and the rename is the ordinary one: the declared name, plus whatever inside them is a name of this package. - A class's slots are not renamed. They are keywords in the map the + A class's slot names are not renamed. They are keywords in the map the constructor builds, and a keyword belongs to nobody — the same line the - [MapLit] arm above takes about a map literal's keys. The *class's* name - is qualified, so [pkg/point] is what an instance's shape tag reads and - two packages' [point] classes are two classes. *) - | Ast.Defclass (n, slots) -> Ast.Defclass (qualify alias n, slots) + [MapLit] arm above takes about a map literal's keys. The vector is + unpaired, so a bare symbol in it may be a slot's name, and none is + touched; a type written as a form is renamed as any type is. A bare + class name in a type position is found by [Check.pair_slots] against + the class's own package instead. The *class's* name is qualified, so + [pkg/point] is what an instance's shape tag reads and two packages' + [point] classes are two classes. *) + | Ast.Defclass (n, slots) -> + Ast.Defclass + (qualify alias n, + List.map + (function + | Ast.Pname _ as p -> p + | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t)) + slots) (* A generic's parameters are dyn and were written out by the parser, so there is no unpaired vector here and [bound] is exactly the parameter names. *) @@ -865,6 +877,7 @@ and place_uses acc loc (p : Ast.place) = | Ast.Pfield (t, _) -> expr_uses acc t | Ast.Pindex (t, idx) -> expr_uses acc t; List.iter (expr_uses acc) idx | Ast.Pderef t -> expr_uses acc t + | Ast.Pslot (t, k) -> expr_uses acc t; expr_uses acc k let decl_uses acc (d : Ast.decl) = let field (f : Ast.field) = texpr_uses acc f.Ast.fty in @@ -906,9 +919,14 @@ let decl_uses acc (d : Ast.decl) = | Ast.Zeroed | Ast.Uninit -> ()) | Ast.Defconst (_, t, v) -> Option.iter (texpr_uses acc) t; expr_uses acc v - (* A class's slots are keywords and name nothing. Its constructor's body is - written by [Classes.expand], long after this, out of the slots alone. *) - | Ast.Defclass _ -> () + (* A class's slot names are keywords and name nothing; its slot types are + uses, recorded the way an unpaired [defn] vector's are. *) + | Ast.Defclass (_, slots) -> + List.iter + (function + | Ast.Pname (n, loc) -> acc := (n, loc) :: !acc + | Ast.Ptype t -> texpr_uses acc t) + slots | Ast.Defgeneric f | Ast.Defmulti f -> fn f (* The generic is a use — a method in one package extending another's has to pull that package in — and so is the class in the dispatch slot, for the diff --git a/lib/parse.ml b/lib/parse.ml index b6e15cd1..828b4129 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1207,13 +1207,19 @@ and place (f : Form.t) : Ast.place = either inserts or replaces — so there is no store into a lookup, and an entry that is absent has no location to store into. Refused here rather than parsed into a place form the language does not have. *) + (* A class instance's slot: declared by its defclass, so it always exists + and is a place, where a map's absent key is not. Whether the value is an + instance or a map is a run-time fact, so the store is a run-time call + and a map there is refused by it. *) + | List [ { v = Sym "get"; _ }; target; key ] -> + Ast.Pslot (expr target, expr key) | List ({ v = Sym "get"; _ } :: _) -> fail f "(get m k) is not a place — a map is written with (put m k v)" | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p) | _ -> fail f "%s is not assignable. set takes a name, (.field x), (at a i ...), \ - or (deref p)" + (deref p), or a class slot (get inst :slot)" (Form.to_string f) and arms f (items : Form.t list) : Ast.arm list = @@ -1478,20 +1484,15 @@ let rec decl (f : Form.t) : Ast.decl = only names can be read here. *) | List ({ v = Sym "defclass"; _ } :: args) -> (match args with + (* The slot vector is a [defn]'s parameter vector in every respect — + [[x y]] two dyn slots, [[pause bool step bool]] two typed ones — and + is carried undecided for the same reason. *) | [ n; { v = Vec slots; _ } ] -> - mk (Ast.Defclass - (dname n, - List.map - (fun (s : Form.t) -> - match s.v with - | Sym name -> no_sigil s; (name, s.loc) - | _ -> - fail s - "a class slot is a name — its value is dyn, so there \ - is no type to write. Read one with (get p :%s)" - (Form.to_string s)) - slots)) - | _ -> fail f "defclass is (defclass Name [slot ...])") + List.iter + (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) + slots; + mk (Ast.Defclass (dname n, pitems slots)) + | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> let generic = String.equal which "defgeneric" in diff --git a/lib/session.ml b/lib/session.ml index 5ae2cef3..d03d006c 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -885,7 +885,8 @@ let eval ?(origin = "") ?pause ?(running = true) t src : change = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots) + | Ast.Defclass (n, _) -> + Some (n, Option.value ~default:[] (Check.class_slots env n)) | _ -> None) incoming in @@ -1043,21 +1044,40 @@ let eval ?(origin = "") ?pause ?(running = true) 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 ]); ty = Types.Dyn; loc } in - (* The slot names in one string, newline between: the runtime - splits them. A dyn vector would have been the obvious shape - and is the wrong one — it is a collector object, so the - registry would hold something the marker has to reach, where - a packed string reaches interned keywords that are immortal - already. *) + (* The slots in one string, a line each with the slot's type + after its name: the runtime splits them. A dyn vector would + have been the obvious shape and is the wrong one — it is a + collector object, so the registry would hold something the + marker has to reach, where a packed string reaches interned + keywords that are immortal already. The constructor carries + the same string, from the same function. *) { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_class_def", - [ kw; str (String.concat "\n" slots) ]); + [ kw; str (Check.class_spec_of slots) ]); ty = Types.Unit; loc }) incoming_classes in diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 54cb40f5..e5ef012c 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1470,8 +1470,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.** @@ -1489,14 +1489,17 @@ flan_dyn flan_dyn_map_new(void) { * of dyn vectors would have needed both, and would have needed them to * survive a collection triggered from inside a migration. * - * **What the registry does not do.** It does not constrain [put]. A class + * **What the registry constrains.** A store into a slot the class declares + * — the constructor's, [put]'s, [set]'s — is checked against the slot's + * type. A key the class does not declare is not refused by [put]: a class * instance is an open map — TODO.org, "Class features deferred, each with its - * reason", already defers unknown-slot checking — so a key nobody declared - * can be written to one, and the migration below will *drop* it at the next + * reason", defers unknown-slot checking — so a key nobody declared can be + * written to one, and the migration below will *drop* it at the next * redefinition, because its rule is that an instance's keys are the class's * slots. That is real data loss and it is written down as such in TODO.org, * "A redefined defclass migrates its instances lazily", rather than dressed - * up as enforcement. + * up as enforcement. [set] does refuse an undeclared key, because a slot it + * writes has to exist. * * **Where a migration happens.** [want_map], so every [get], [put] and * [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances @@ -1536,11 +1539,36 @@ flan_dyn flan_dyn_map_new(void) { * runs ahead of its definition declares itself. */ flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n); +/* What a slot may hold. A dyn value's tag is the whole of what can be asked + * of it, so these are the tags — plus a range on top of the int tag for a + * narrower integer type, the significand a float slot holds exactly, a + * class for a slot declared with one, and whether nil is admitted, which is + * what (Option T) says. [word] is a scalar type's name, for the sentence a + * refusal prints. */ +enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT, ST_CLASS }; + +typedef struct slot_type { + uint8_t kind; + uint8_t opt; /* nil admitted: (Option T) */ + uint8_t fbits; /* ST_FLOAT: 53 for f64, 24 for f32 */ + int64_t lo, hi; /* ST_INT only */ + kw_entry *cls; /* ST_CLASS only */ + const char *word; /* static; NULL for ST_ANY and ST_CLASS */ +} slot_type; + typedef struct class_entry { kw_entry *name; kw_entry **slots; /* interned, immortal, in declaration order */ + slot_type *types; /* one per slot, same order */ + /* Per slot, the generation a migration last warned about a value that no + * longer fits the slot's type. One warning per slot per redefinition, + * however many instances carry such a value. */ + uint32_t *warned; int64_t nslots; uint32_t gen; + /* Whether any slot has a type. A class with none pays nothing at a store + * beyond reading this. */ + int typed; } class_entry; static class_entry *classes; @@ -1554,74 +1582,165 @@ static class_entry *class_find(kw_entry *name) { } /* The generation a new instance of [name] is stamped with. Zero for a class - * no definition has been registered for, which is every class in a program - * that was built and never reloaded: nothing has changed shape, so nothing - * needs to migrate, and the registry earns its keep only once an editor has - * sent a new definition. */ + * no definition has been registered for — which, now that the constructor + * registers its class, is only an instance built by something other than a + * constructor: test/dyn_ops.c, calling the runtime directly. */ static uint32_t class_gen(kw_entry *name) { class_entry *e = class_find(name); return e == NULL ? 0u : e->gen; } -/* One class's current slot list, as the compiler's per-reload thunk hands it - * over: the class's name as a keyword, and the slot names packed into one - * string, newline between and no leading colons — the shape a string literal - * already crosses in, rather than a dyn vector this would have to root. - * - * The generation is bumped only when the list actually differs. That is what - * makes C-c C-k idempotent: reloading a file re-runs every one of its class - * definitions, and a bump per reload would migrate every instance in the - * program every time anybody saved, for no change. */ -void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { - kw_entry *k; - kw_entry **list = NULL; - int64_t count = 0, i, start; - class_entry *e; - if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) - /* No location: the caller is the thunk a reload runs, which has no - source position of its own — the class's own [defclass] is where a - reader would look, and it is not on any stack by the time this runs. - Unreachable from written Flan in any case; only the compiler emits - this call, and it emits a keyword. */ - trap1(NULL, 0, TYPE_TRAP, "class definition", - "a class name is a keyword", name); - k = dyn_kw(name); +/* One slot's type, as [Check.class_spec_of] writes it: a scalar type's name, + * [#name] for a class, and a leading [?] for an (Option T). */ +static slot_type slot_type_of(const uint8_t *w, int64_t n) { + static const struct { + const char *w; uint8_t kind, fbits; int64_t lo, hi; + } known[] = { + { "bool", ST_BOOL, 0, 0, 0 }, + { "string", ST_TEXT, 0, 0, 0 }, + { "f32", ST_FLOAT, 24, 0, 0 }, + { "f64", ST_FLOAT, 53, 0, 0 }, + { "i8", ST_INT, 0, INT8_MIN, INT8_MAX }, + { "i16", ST_INT, 0, INT16_MIN, INT16_MAX }, + { "i32", ST_INT, 0, INT32_MIN, INT32_MAX }, + { "i64", ST_INT, 0, INT64_MIN, INT64_MAX }, + { "u8", ST_INT, 0, 0, UINT8_MAX }, + { "u16", ST_INT, 0, 0, UINT16_MAX }, + { "u32", ST_INT, 0, 0, UINT32_MAX }, + { "u64", ST_INT, 0, 0, INT64_MAX }, + }; + slot_type t = { ST_ANY, 0, 0, 0, 0, NULL, NULL }; + size_t i; + if (n > 0 && w[0] == '?') { + t = slot_type_of(w + 1, n - 1); + if (t.kind != ST_ANY) t.opt = 1; + return t; + } + if (n > 1 && w[0] == '#') { + t.kind = ST_CLASS; + t.cls = dyn_kw(flan_dyn_kw(w + 1, n - 1)); + return t; + } + for (i = 0; i < sizeof known / sizeof known[0]; i++) + if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) { + t.kind = known[i].kind; + t.fbits = known[i].fbits; + t.lo = known[i].lo; + t.hi = known[i].hi; + t.word = known[i].w; + return t; + } + /* A word this table does not know is a compiler newer than this runtime. + Holding anything is the answer that loses no data. */ + return t; +} + +static int slot_type_eq(const slot_type *a, const slot_type *b) { + return a->kind == b->kind && a->opt == b->opt && a->fbits == b->fbits + && a->lo == b->lo && a->hi == b->hi && a->cls == b->cls; +} + +/* The type as it was written, for a sentence. */ +static void slot_type_text(const slot_type *t, char *buf, size_t cap) { + char base[96]; + if (t->kind == ST_CLASS) + snprintf(base, sizeof base, "%.*s", (int)t->cls->len, + (const char *)(t->cls + 1)); + else + snprintf(base, sizeof base, "%s", t->word != NULL ? t->word : "dyn"); + if (t->opt) snprintf(buf, cap, "(Option %s)", base); + else snprintf(buf, cap, "%s", base); +} + +/* Whether [v] may be stored in a slot of type [t], and what is stored: [v] + * itself, or — for an int into a float slot — the float it widens to. The + * widening is the typed side's rule read off the value rather than off a + * static type: an integer the float holds exactly is admitted as that float, + * and one it does not is refused, as (f64 x) would be for the + * type that could hold it. A float into an f32 slot has to be one an f32 + * holds, which is the typed side refusing f64 into f32. */ +static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) { + int tag = flan_dyn_tag(v); + *out = v; + if (t->kind == ST_ANY) return 1; + if (tag == FLAN_DYN_TAG_NIL) return t->opt; + switch (t->kind) { + case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL; + case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT; + case ST_CLASS: + return tag == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass == t->cls; + case ST_FLOAT: + if (tag == FLAN_DYN_TAG_FLOAT) { + double d = dyn_num_value(v); + return t->fbits == 53 || d != d || (double)(float)d == d; + } + if (tag == FLAN_DYN_TAG_INT) { + /* Exact is a round trip, not a range: 2^54 is an f64 exactly and + 2^53+1 is not. The range test before the cast back is what keeps + that cast defined, since INT64_MAX rounds up to 2^63. */ + int64_t x = dyn_int_value(v); + double d = t->fbits == 53 ? (double)x : (double)(float)x; + if (!(d >= -9223372036854775808.0 && d < 9223372036854775808.0) + || (int64_t)d != x) + return 0; + *out = flan_dyn_from_f64(d); + return 1; + } + return 0; + case ST_INT: { + int64_t x; + if (tag != FLAN_DYN_TAG_INT) return 0; + x = dyn_int_value(v); + return x >= t->lo && x <= t->hi; + } + default: return 1; + } +} + +static int slot_fits(const slot_type *t, flan_dyn v) { + flan_dyn ignored; + return slot_admit(t, v, &ignored); +} + +/* A class's slots as the compiler hands them over: one line per slot, the + * slot's name and then, after a space, its type's name — nothing for a slot + * written with no type. The same string comes from a constructor and from a + * reload, so it is read in one place. The count is returned; both arrays are + * NULL for a class with no slots, which allocates nothing. */ +static int64_t class_spec(const uint8_t *spec, int64_t n, kw_entry ***names, + slot_type **types) { + int64_t count = 0, i, start; if (n < 0) n = 0; - /* Count first, then fill: one allocation of the right size, and an empty - * class — (defclass marker []) is in the corpus — allocates nothing. */ + *names = NULL; + *types = NULL; for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { + if (i == n ? i > start : spec[i] == '\n') { if (i > start) count++; start = i + 1; } - if (count > 0) { - list = (kw_entry **)malloc((size_t)count * sizeof *list); - if (list == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof *list); - count = 0; - for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { - if (i > start) - list[count++] = dyn_kw(flan_dyn_kw(slots + start, i - start)); - start = i + 1; + if (count == 0) return 0; + *names = (kw_entry **)malloc((size_t)count * sizeof **names); + *types = (slot_type *)malloc((size_t)count * sizeof **types); + if (*names == NULL || *types == NULL) + trap_oom(NULL, 0, count * (int64_t)(sizeof **names + sizeof **types)); + count = 0; + for (i = 0, start = 0; i <= n; i++) + if (i == n ? i > start : spec[i] == '\n') { + if (i > start) { + int64_t sp = start; + while (sp < i && spec[sp] != ' ') sp++; + (*names)[count] = dyn_kw(flan_dyn_kw(spec + start, sp - start)); + (*types)[count] = sp < i ? slot_type_of(spec + sp + 1, i - sp - 1) + : slot_type_of(NULL, 0); + count++; } - } - e = class_find(k); - if (e != NULL) { - int same = e->nslots == count; - if (same) - for (i = 0; i < count; i++) - if (e->slots[i] != list[i]) { same = 0; break; } - if (same) { free(list); return; } - free(e->slots); - e->slots = list; - e->nslots = count; - /* Wrapping is not a correctness question — what matters is that the new - * generation differs from the one the live instances carry — but zero is - * reserved for "no definition registered", so it is stepped over. */ - e->gen = e->gen + 1u; - if (e->gen == 0u) e->gen = 1u; - return; - } + start = i + 1; + } + return count; +} + +static void class_add(kw_entry *k, kw_entry **list, slot_type *types, + int64_t count) { if (classes_n == classes_cap) { int64_t cap = classes_cap ? classes_cap * 2 : 8; class_entry *t = @@ -1632,7 +1751,18 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { } classes[classes_n].name = k; classes[classes_n].slots = list; + classes[classes_n].types = types; + classes[classes_n].warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && classes[classes_n].warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); classes[classes_n].nslots = count; + classes[classes_n].typed = 0; + { + int64_t j; + for (j = 0; j < count; j++) + if (types[j].kind != ST_ANY) classes[classes_n].typed = 1; + } /* One, never zero: an instance built before this registration carries zero * and has to be seen as stale, because the definition it was built from is * exactly the one nobody recorded. */ @@ -1640,11 +1770,201 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { classes_n++; } +/* One class's current definition, as the compiler's per-reload thunk hands + * it over: the class's name as a keyword, and [class_spec]'s string. + * + * The generation is bumped only when the definition actually differs — a + * slot's name or its type. That is what makes C-c C-k idempotent: reloading + * a file re-runs every one of its class definitions, and a bump per reload + * would migrate every instance in the program every time anybody saved, for + * no change. */ +void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { + kw_entry *k; + kw_entry **list; + slot_type *types; + int64_t count, i; + class_entry *e; + if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) + /* No location: the caller is the thunk a reload runs, which has no + source position of its own — the class's own [defclass] is where a + reader would look, and it is not on any stack by the time this runs. + Unreachable from written Flan in any case; only the compiler emits + this call, and it emits a keyword. */ + trap1(NULL, 0, TYPE_TRAP, "class definition", + "a class name is a keyword", name); + k = dyn_kw(name); + count = class_spec(slots, n, &list, &types); + e = class_find(k); + if (e != NULL) { + int same = e->nslots == count; + if (same) + for (i = 0; i < count; i++) + if (e->slots[i] != list[i] || !slot_type_eq(&e->types[i], &types[i])) { + same = 0; + break; + } + if (same) { free(list); free(types); return; } + free(e->slots); + free(e->types); + free(e->warned); + e->slots = list; + e->types = types; + e->warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && e->warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); + e->nslots = count; + e->typed = 0; + for (i = 0; i < count; i++) + if (types[i].kind != ST_ANY) e->typed = 1; + /* Wrapping is not a correctness question — what matters is that the new + * generation differs from the one the live instances carry — but zero is + * reserved for "no definition registered", so it is stepped over. */ + e->gen = e->gen + 1u; + if (e->gen == 0u) e->gen = 1u; + return; + } + 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); + } +} + +/* An entry at the end of a map, with no lookup first: for a map whose keys + * are known to be distinct already. A lookup compares keys with [dyn_equal], + * which migrates any stale instance it meets and runs that instance's hook — + * and a migration building its own hook's arguments must not start another + * one, or the instance it is migrating is migrated again inside itself. */ +static void map_append(flan_obj *m, flan_dyn k, flan_dyn v) { + if (m->len == m->u.v.cap) { + int64_t cap = m->u.v.cap ? m->u.v.cap * 2 : 8; + flan_dyn *items = + (flan_dyn *)realloc(m->u.v.items, (size_t)cap * 2 * sizeof *items); + if (items == NULL) trap_oom(NULL, 0, cap * 2 * (int64_t)sizeof *items); + gc_bytes += (cap - m->u.v.cap) * 2 * (int64_t)sizeof *items; + m->u.v.items = items; + m->u.v.cap = cap; + } + m->u.v.items[m->len * 2] = k; + m->u.v.items[m->len * 2 + 1] = v; + m->len++; +} + +/* Which of [o]'s entries is the slot [s], or -1. The interned identity + * compare, never [dyn_equal]: see [map_append]. [flan_dyn_tag] and not a + * bare [dyn_box]: a float is not boxed at all, so its payload bits can read + * as any box tag, and reading a non-keyword's payload as a [kw_entry *] is a + * wild pointer. A raw [put] can have left a float — or anything else — as a + * key. */ +static int64_t entry_of(flan_obj *o, kw_entry *s) { + int64_t i; + 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) == s) + return i; + } + return -1; +} + /* 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 - * property CLHS 4.3.6 guarantees, matched by name, with the instance's - * identity preserved because none of this allocates a new object. + * has — which is the property CLHS 4.3.6 guarantees, matched by name, with + * the instance's identity preserved because none of this allocates a new + * object. A slot it has just gained holds its type's zero value, Flan's + * zero-is-initialisation — false, 0, 0.0, the empty string — or nil where + * the type admits nil or has no zero: a dyn slot, an (Option T), a class. * * Rebuilt into a fresh block rather than compacted in place, and the order is * the class's rather than the instance's, so that a migrated instance is @@ -1653,61 +1973,183 @@ 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. + * In three steps, and the order is what keeps it sound. * - * 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 - * re-entry through a nested [dyn_equal], including a map used as a key of - * itself, finds [o] already current and returns at the generation compare. - * The key scan here uses the interned identity compare and calls - * [dyn_equal] not at all, so it cannot re-enter from inside. */ -static void class_sync(flan_obj *o) { - class_entry *e; + * First, everything that allocates on the collector's heap: the hook's + * arguments, and an empty string for a gained string slot. A collection may + * run here, while [o] still holds its old entries whole. Nothing in this + * step compares a key with [dyn_equal] — see [map_append] — so nothing in it + * can migrate another instance and run a hook inside this migration. + * + * Second, the name-matching, which allocates nothing on the collector's + * heap, calls nothing that can migrate, and finishes by stamping [o] + * current. [e] is read only up to here: a hook may build an instance of a + * class the registry has not seen, and adding it moves [classes]. + * + * Third, the hook, on an instance that is already current, so a method that + * reads or writes it finds it migrated and does not start a second + * migration. A method may touch anything, including a map something above + * this frame is walking; the migration of [o] itself is finished before it + * runs. */ +/* Kept out of line: inlined into [class_sync], its frame and saved + * registers were paid on every [get] and [put] of every map, current or not + * — measured at about a tenth of an untyped [put]'s instructions. */ +__attribute__((noinline)) +static void class_migrate(flan_obj *o, class_entry *e) { flan_dyn *fresh = NULL; - int64_t i, j; - 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; - 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); + int64_t i, j, n; + /* Rooted by address for as long as they may be needed: each is a + * collector object held nowhere else. */ + flan_dyn inst, added, gone, empty; + int64_t roots_at = roots_n; + int hook, need_empty = 0; + n = e->nslots; + /* 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; + for (j = 0; j < n; j++) + if (e->types[j].kind == ST_TEXT && !e->types[j].opt + && entry_of(o, e->slots[j]) < 0) + need_empty = 1; + inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); + added = gone = empty = dyn_make(BOX_NIL, 0); + if (hook || need_empty) root_add(&inst, NULL); + if (need_empty) { + empty = flan_dyn_from_bytes((const uint8_t *)"", 0); + root_add(&empty, NULL); } - for (j = 0; j < e->nslots; j++) { - flan_dyn v = dyn_make(BOX_NIL, 0); + if (hook) { + added = flan_dyn_vec_new(); + root_add(&added, NULL); + gone = flan_dyn_map_new(); + root_add(&gone, NULL); + for (j = 0; j < n; j++) + if (entry_of(o, e->slots[j]) < 0) + 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. [o]'s + * keys are distinct, so these are, and they are appended as they are. */ for (i = 0; i < o->len; i++) { flan_dyn key = o->u.v.items[i * 2]; - /* [flan_dyn_tag] and not a bare [dyn_box]: a float is not boxed at - all, so its payload bits can read as any box tag, and reading a - non-keyword's payload as a [kw_entry *] is a wild pointer. A raw - [put] can have left a float — or anything else — in here. */ - if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD - && dyn_kw(key) == e->slots[j]) { - v = o->u.v.items[i * 2 + 1]; - break; + int kept = 0; + if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD) + for (j = 0; j < n; j++) + if (dyn_kw(key) == e->slots[j]) { kept = 1; break; } + if (!kept) map_append(dyn_obj(gone), key, o->u.v.items[i * 2 + 1]); + } + } + if (n > 0) { + fresh = (flan_dyn *)malloc((size_t)n * 2 * sizeof *fresh); + if (fresh == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *fresh); + } + for (j = 0; j < n; j++) { + const slot_type *t = &e->types[j]; + flan_dyn v; + i = entry_of(o, e->slots[j]); + if (i >= 0) { + v = o->u.v.items[i * 2 + 1]; + /* A kept value that the slot's new type does not admit is kept + anyway: throwing it away would be the data loss a redefinition + exists to avoid, and there is nothing to convert it to. What it + gets is a warning, once per slot per redefinition, and the next + write to the slot is checked like any other. */ + if (!slot_fits(t, v) && e->warned[j] != e->gen) { + char sv[SAY_MAX], st[128]; + kw_entry *c = o->u.v.klass, *sl = e->slots[j]; + e->warned[j] = e->gen; + say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); + fflush(stdout); + fprintf(stderr, + "warning: %.*s was redefined, and its slot :%.*s is now " + "declared %s. An instance holds %s there, which is %s; it " + "keeps that value, and the next write to :%.*s is checked\n", + (int)c->len, (const char *)(c + 1), + (int)sl->len, (const char *)(sl + 1), st, sv, + tag_of(v), (int)sl->len, (const char *)(sl + 1)); } } + else if (t->opt) v = dyn_make(BOX_NIL, 0); + else + switch (t->kind) { + case ST_BOOL: v = flan_dyn_from_bool(0); break; + case ST_INT: v = flan_dyn_from_i64(0); break; + case ST_FLOAT: v = flan_dyn_from_f64(0.0); break; + case ST_TEXT: v = empty; break; + default: v = dyn_make(BOX_NIL, 0); break; + } fresh[j * 2] = dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]); fresh[j * 2 + 1] = v; } /* Charged the way [map_set]'s growth is, in both directions: a class that * lost slots gives the bytes back, or the trigger drifts up by whatever * every migration in the program ever released. */ - gc_bytes += (e->nslots - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); + gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); free(o->u.v.items); o->u.v.items = fresh; - o->u.v.cap = e->nslots; - o->len = e->nslots; + o->u.v.cap = n; + o->len = n; o->gen = e->gen; + e = NULL; + if (hook) class_hook(o, inst, added, gone, n); + roots_n = roots_at; +} + +/* Every read or write of an instance comes through here first: the class's + * entry, with [o] migrated to it if it was stale, or NULL for a map with no + * class. The common case — current — is a lookup and a compare, and the + * migration is a call of its own so that it stays out of the way. The entry + * is looked up again after one, because a hook may have moved the table. */ +static class_entry *class_sync(flan_obj *o) { + class_entry *e; + if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return NULL; + e = class_find(o->u.v.klass); + if (e == NULL || e->gen == o->gen) return e; + class_migrate(o, e); + return class_find(o->u.v.klass); } /* The same map with a shape tag on it: what a (defclass ...) constructor * calls. [k] is a keyword and anything else traps by name — the compiler - * hands it the class's own name and nothing else can reach this. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k) { + * hands it the class's own name and nothing else can reach this. + * + * [spec] is the class's definition, [class_spec]'s string, and it registers + * the class the first time any instance of it is built. That is what makes + * a slot's type checked in a program that is never reloaded — the registry + * used to be filled only by a reload. A class already registered keeps + * what it has, and has to: a constructor compiled before a redefinition may + * still be on some stack, and letting its definition win would put the + * class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */ +/* A constructor call's site: [pending] from the caller, moved to [building] + * by the constructor's first act, so a call through a function value — which + * sets nothing — finds none rather than an earlier call's. Nothing between + * the caller setting it and the constructor taking it can construct: the + * caller evaluated every argument first. */ +static const uint8_t *site_pending, *site_building; +static int64_t site_pending_len, site_building_len; + +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen) { + site_pending = loc; + site_pending_len = loclen; +} + +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) { flan_obj *o; + site_building = site_pending; + site_building_len = site_pending_len; + site_pending = NULL; + site_pending_len = 0; if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k); + if (class_find(dyn_kw(k)) == NULL) { + kw_entry **list; + slot_type *types; + int64_t count = class_spec(spec, n, &list, &types); + class_add(dyn_kw(k), list, types, count); + } o = gc_alloc(OBJ_MAP, 0); o->len = 0; o->u.v.items = NULL; @@ -2590,8 +3032,160 @@ flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { return flan_dyn_from_bool(map_find(o, k) >= 0); } +/* A class slot's type, checked at the store — SBCL's place for it + * (src/pcl/slots.lisp, [set-slot-value]'s typecheck before the write), + * because the store is where the wrong value is. -1 when [k] is not a slot + * the class declares. */ +static int64_t class_slot(class_entry *e, flan_dyn k) { + int64_t j; + if (e == NULL || flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return -1; + for (j = 0; j < e->nslots; j++) + if (e->slots[j] == dyn_kw(k)) return j; + return -1; +} + +/* The three stores that reach a declared slot, for the sentence a refusal + * prints: the call as it would have been written. */ +enum { BY_PUT, BY_SET, BY_NEW }; + +static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, + int by, flan_obj *o, class_entry *e, + int64_t j, flan_dyn m, flan_dyn v) { + char sm[SAY_MAX], sv[SAY_MAX], st[128]; + const slot_type *t = &e->types[j]; + kw_entry *sl = e->slots[j], *c = o->u.v.klass; + int sn = (int)sl->len, cn = (int)c->len; + const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1); + say(sm, SAY_MAX, m); + say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); + fflush(stdout); + /* A constructor's refusal is placed at the call that was wrong, when the + call said where it was, and names the slot's declaration after it. */ + trap_where(by == BY_NEW && site_building != NULL ? site_building : loc, + by == BY_NEW && site_building != NULL ? site_building_len : loclen); + fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", + by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, + cn, cs, st); + /* A number of the right kind that does not fit is not news about its tag. */ + if ((t->kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) + || (t->kind == ST_FLOAT + && (flan_dyn_tag(v) == FLAN_DYN_TAG_INT + || flan_dyn_tag(v) == FLAN_DYN_TAG_FLOAT))) + fprintf(stderr, "%s is not a value it holds exactly — ", sv); + else if (t->kind == ST_CLASS && flan_dyn_tag(v) == FLAN_DYN_TAG_MAP) + fprintf(stderr, "this is not an instance of it — "); + else + fprintf(stderr, "this is %s — ", tag_of(v)); + if (by == BY_PUT) + fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv); + else if (by == BY_SET) + fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv); + else if (site_building != NULL && loc != NULL) + fprintf(stderr, "(%.*s ...) with :%.*s %s; the slot is declared at %.*s\n", + cn, cs, sn, ss, sv, (int)loclen, (const char *)loc); + else + fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv); + flan_trap((const uint8_t *)"DynType", 7); +} + +/* The value a store into [o] under [k] actually stores: [v], or the float an + * int widens to in a float slot. A class with no typed slot answers at its + * flag, and a map with no class before that. */ +static flan_dyn check_slot(const uint8_t *loc, int64_t loclen, int by, + flan_obj *o, class_entry *e, flan_dyn m, + flan_dyn k, flan_dyn v) { + int64_t j; + flan_dyn out; + if (e == NULL || !e->typed) return v; + j = class_slot(e, k); + if (j < 0) return v; + if (!slot_admit(&e->types[j], v, &out)) + trap_slot_type(loc, loclen, by, o, e, j, m, v); + return out; +} + +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v); + +/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for + * the constructor call it happened inside rather than for a [put] nobody + * wrote, and placed at the slot's declaration. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o = want_map("construct", m, k); + class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass); + map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v)); +} + +/* (set (get inst :slot) v). Three refusals, each its own sentence, because + * they are three different mistakes: the value is not a class instance at + * all (a map's entries are written with [put], which is where inserting a + * key is real); the key is not a slot the class declares; the value does not + * fit the slot's type. The first two are why this is not [put]: a declared + * slot always exists, so writing one is a store and never an insertion. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o; + class_entry *e; + int64_t j; + flan_dyn out; + if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { + char sm[SAY_MAX]; + say(sm, SAY_MAX, m); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, + "dyn set: (get m k) is a place only on a class instance, and " + "this is %s%s — %s. A map's entries are written with put\n", + is_map(m) ? "a map with no class" : "a ", + is_map(m) ? "" : tag_of(m), sm); + flan_trap((const uint8_t *)"DynType", 7); + } + o = dyn_obj(m); + e = class_sync(o); + j = class_slot(e, k); + if (j < 0) { + char sk[SAY_MAX]; + kw_entry *c = o->u.v.klass; + int64_t i; + say(sk, SAY_MAX, k); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn set: %.*s has no slot %s. Its slots are", + (int)c->len, (const char *)(c + 1), sk); + if (e == NULL || e->nslots == 0) fprintf(stderr, " none"); + else + for (i = 0; i < e->nslots; i++) + fprintf(stderr, " :%.*s", (int)e->slots[i]->len, + (const char *)(e->slots[i] + 1)); + fprintf(stderr, "; a key the class does not declare is added with put, " + "not set\n"); + flan_trap((const uint8_t *)"DynType", 7); + } + if (!slot_admit(&e->types[j], v, &out)) + trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); + map_store(o, k, out); +} + +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, + int64_t loclen) { + flan_obj *o; + class_entry *e; + if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, "put", "only a map answers it", m, k); + o = dyn_obj(m); + e = class_sync(o); + /* A map with no class, and a class with no typed slot, stop at the test. */ + if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v); + map_store(o, k, v); +} + +/* The same with no site: a map literal's stores, and test/dyn_ops.c. */ void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { - flan_obj *o = want_map("put", m, k); + flan_dyn_map_put(m, k, v, NULL, 0); +} + +/* The store under all three, with the instance already brought up to date. */ +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { int64_t i = map_find(o, k); if (i >= 0) { o->u.v.items[i * 2 + 1] = v; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 79d90d8d..2ad6dd2b 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -105,15 +105,34 @@ flan_dyn flan_dyn_map_new(void); * * The tag is not traced and does not have to be: an interned keyword entry is * immortal and is not a collector object. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k); +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); + +/* A constructor's store into a slot, checked against the slot's declared + * type — [flan_dyn_map_set] with a refusal worded for the constructor. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); + +/* Where the constructor about to be called was called from. Set by the + * caller immediately before the call and taken by the constructor's + * [flan_dyn_map_new_class], so a refusal in its stores names the call. */ +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen); + +/* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its + * class declares, and [v] must fit the slot's type; each is a trap with its + * own sentence, at [loc]. A declared slot always exists, so this stores and + * never inserts. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); /* The class's name as a keyword, or nil for anything that is not an instance * — an ordinary map included. Never traps. */ flan_dyn flan_dyn_class_of(flan_dyn v); /* A class definition, registered or re-registered: [name] is the class's name - * as a keyword and [slots]/[n] is its slot names packed into one string, - * newline between and no leading colons. The compiler emits one call per + * as a keyword and [slots]/[n] is its slots packed into one string, a line + * each, the slot's name and then — after a space, for a typed slot — its + * type's name: "x i64\ny" is an i64 slot :x and a slot :y of any value. + * [flan_dyn_map_new_class] takes the same string. The compiler emits one call per * (defclass ...) into the thunk a reload runs, so a definition that changed * lands here before anything touches an instance. * @@ -122,9 +141,10 @@ flan_dyn flan_dyn_class_of(flan_dyn v); * migrates nothing. When it does move, every instance built against an * earlier definition migrates lazily at its next [get], [put], [has-key?], * [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 + * matched by name, a slot it has gained holds its type's zero value — nil + * for an untyped, an (Option T) or a class-typed slot — 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 @@ -132,6 +152,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 @@ -203,6 +230,10 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); * key in place, so a key occurs once and insertion order is print order. */ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); +/* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal + * prints. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k); /* Structural, and per type it renders what typed [print] renders. Never diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 5ed878ed..838767fb 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -632,6 +632,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/daemon-x86.out b/test/daemon-x86.out new file mode 100644 index 00000000..63826b3b --- /dev/null +++ b/test/daemon-x86.out @@ -0,0 +1,2 @@ +flan dev: built dev-hook.flan in 444ms +flan dev: /home/joe/Development/flan/.claude/worktrees/agent-a6ffe579d55d1892b/test/programs/dev-hook.flan ready on /tmp/claude-1000/rv-3672919.sock (17ms, one process) diff --git a/test/dyn_ops.c b/test/dyn_ops.c index 5dc1266a..12114fc6 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -1063,7 +1063,8 @@ static void define(const char *name, const char *slots) { * Built through the same entry point a constructor uses, so it is stamped * exactly as compiled code would stamp it. */ static flan_dyn a_point(int64_t x, int64_t y) { - flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny", 3); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(x)); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1178,7 +1179,8 @@ static void classes(void) { define("point", "x\ny\nn"); /* Built by hand rather than through [a_point], because it is the instance the *new* constructor would build: three slots, stamped current. */ - q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny\nn", 5); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(1)); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1238,6 +1240,111 @@ static void classes(void) { printf(failures == 0 ? "classes ok\n" : "classes failed\n"); } +/* ── update-instance-for-redefined-class, re-entered ───────────────── + * + * The hook is Flan in a program; here it is C, installed where the agent + * installs its caller, which is the same call from flan_dyn.c's side. Three + * stale instances, the first holding the other two as keys of raw [put]s, so + * building the first one's discarded map is where a lookup would compare + * them — and migrate them, and run their hooks, inside the first one's + * migration. The hook itself touches the first instance and builds + * instances of classes the registry has not seen, which grows it and moves + * it under any migration still holding an entry. Each instance's hook runs + * once, and the discarded map holds both instance keys. Clean under + * memcheck is the other half of the claim, and is what @valgrind's run of + * this mode says. */ +extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded); +void flan_dyn_class_hook(void *fn); + +static flan_dyn hk_p, hk_q, hk_r; +static int hk_runs_p, hk_runs_q, hk_runs_r, hk_fresh, hk_per_call = 20; +static int64_t hk_gone_len = -1; + +static int hk_call(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded) { + char name[16]; + int i; + (void)fn; + (void)added; + if (instance == hk_p) { + hk_runs_p++; + hk_gone_len = flan_dyn_need_i64(flan_dyn_len(discarded)); + } + if (instance == hk_q) hk_runs_q++; + if (instance == hk_r) hk_runs_r++; + (void)slot(hk_p, "x"); + for (i = 0; i < hk_per_call; i++) { + snprintf(name, sizeof name, "fresh%d", hk_fresh++); + (void)flan_dyn_map_new_class( + flan_dyn_kw((const uint8_t *)name, (int64_t)strlen(name)), + (const uint8_t *)"a", 1); + } + return 0; +} + +static void hook_reentry(void) { + flan_dyn_root_push(&hk_p); + flan_dyn_root_push(&hk_q); + flan_dyn_root_push(&hk_r); + define("pt", "x\ny"); + hk_p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_r = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + flan_dyn_map_set(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(1)); + /* Distinct, or they are one key: instances compare by their slots. */ + flan_dyn_map_set(hk_q, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_r, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(3)); + flan_dyn_map_set(hk_p, hk_q, flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_p, hk_r, flan_dyn_from_i64(3)); + flan_dyn_migrate_hook = hk_call; + flan_dyn_class_hook((void *)hk_call); + define("pt", "x\ny\nz"); + check(flan_dyn_need_i64(slot(hk_p, "x")) == 1, "a kept slot after a re-entered hook"); + check(hk_runs_p == 1, "the first instance's hook ran once"); + check(hk_runs_q == 0 && hk_runs_r == 0, + "building the first instance's arguments migrated no other instance"); + check(hk_gone_len == 2, "the discarded map holds both instance keys"); + (void)slot(hk_q, "x"); + (void)slot(hk_r, "x"); + (void)slot(hk_q, "x"); + check(hk_runs_q == 1 && hk_runs_r == 1, + "each other instance runs its hook once, at its own first touch"); + check(hk_runs_p == 1, "and the first instance's did not run again"); + + /* A migration started by a store rather than a read, with a hook that + grows the registry past its capacity each time: the store goes on to + check the value against the class's entry, and it has to be the entry + the registry holds after the hook, not the one it held before. 200 and + then 300 new classes are each enough to move the table whatever its + capacity was. :x is an f64 slot now, so the int stored must arrive as a + float, which only the entry's types can say. */ + hk_per_call = 200; + define("pt", "x f64\ny\nz\nw"); + flan_dyn_map_put(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(5), NULL, 0); + check(hk_runs_p == 2, "a put migrates and runs the hook"); + check(flan_dyn_tag(slot(hk_p, "x")) == FLAN_DYN_TAG_FLOAT, + "a put after a hook that moved the registry widens by the new entry"); + hk_per_call = 300; + define("pt", "x f64\ny\nz\nw\nv"); + flan_dyn_slot_set(hk_p, flan_dyn_kw((const uint8_t *)"w", 1), + flan_dyn_from_i64(7), NULL, 0); + check(hk_runs_p == 3, "a set migrates and runs the hook"); + check(flan_dyn_need_i64(slot(hk_p, "w")) == 7, + "a set after a hook that moved the registry finds its slot"); + flan_dyn_migrate_hook = NULL; + flan_dyn_class_hook(NULL); + flan_dyn_root_pop(3); + printf(failures == 0 ? "hook ok\n" : "hook failed\n"); +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 2) { @@ -1255,6 +1362,10 @@ int main(int argc, char **argv) { if (strcmp(argv[1], "unrooted") == 0) { unrooted(); return 0; } if (strcmp(argv[1], "park") == 0) { park(); return 0; } if (strcmp(argv[1], "desc") == 0) { desc(); return 0; } + if (strcmp(argv[1], "hook") == 0) { + hook_reentry(); + return failures == 0 ? 0 : 1; + } if (strcmp(argv[1], "classes") == 0) { classes(); return failures == 0 ? 0 : 1; 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/programs/dyn-class-pkg.flan b/test/programs/dyn-class-pkg.flan new file mode 100644 index 00000000..e237cb4e --- /dev/null +++ b/test/programs/dyn-class-pkg.flan @@ -0,0 +1,8 @@ +;;;; A slot type a package wrote names the package's own class, not an +;;;; importer's class of the same bare name. +(import g "pkgs/geo") +(defclass pt [z]) +(defn main [] i32 + (println (g/mk)) + (println (pt 1)) + 0) diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan new file mode 100644 index 00000000..8d3181f1 --- /dev/null +++ b/test/programs/dyn-class-slots.flan @@ -0,0 +1,55 @@ +;;;; Typed class slots, and set on a slot. +;;;; +;;;; A slot vector reads as a defn's parameter vector: [pause bool] is a slot +;;;; of type bool, and a name followed by another name is a slot with no type, +;;;; which holds any dyn value. The type is checked when a value is stored -- +;;;; by the constructor, by put and by set -- and not when one is read: an +;;;; instance is a dyn map whatever its slots say. +;;;; +;;;; set writes a declared slot. A class declares its slots, so one always +;;;; exists and (get s :pause) is a place, where a plain map's absent key is +;;;; not. dyn-slot-trap.flan has the refusals. + +(defclass state [pause bool step i32 speed f64 name string tag]) + +;; A class is a slot type, and (Option T) admits nil beside a T. +(defclass node [owner state next (Option node) weight (Option f32)]) + +(defn twelve [] i64 12) + +(defn main [] i32 + (let [s (state false 3 1.5 "sand" :x)] + (println s) + (set (get s :pause) true) + (println (get s :pause)) + ;; An i32 slot takes any int in i32's range; a dyn caller passes the + ;; value as it is, with nothing converted first. + (set (get s :step) -7) + (println (get s :step)) + (set (get s :tag) [1 2]) + (println (get s :tag)) + ;; put reaches the same check for a declared slot, and still inserts a + ;; key the class does not declare -- an instance is an open map to put. + (put s :speed 2.5) + (put s :scratch 9) + (println (get s :speed)) + (println (get s :scratch)) + (println (length s)) + ;; A typed caller boxes into the dyn parameter as any call does. + (set (get s :step) (twelve)) + (println (get s :step)) + ;; An int into a float slot widens, as it does into a typed f64 + ;; parameter, when the float holds it exactly. + (put s :speed 3) + (println (+ (get s :speed) 0.5)) + ;; Exact is a round trip, not a range: 2^54 is an f64 exactly. + (put s :speed 18014398509481984) + (println (= (get s :speed) 18014398509481984.0)) + (let [n (node s nil nil)] + (set (get n :next) (node s nil 2)) + (println (get (get n :next) :weight)) + (set (get n :weight) nil) + ;; 2^30 is an f32 exactly, though it is past f32's 24-bit significand. + (set (get n :weight) 1073741824) + (println (class-of (get n :owner))))) + 0) diff --git a/test/programs/dyn-slot-trap.flan b/test/programs/dyn-slot-trap.flan new file mode 100644 index 00000000..890489bc --- /dev/null +++ b/test/programs/dyn-slot-trap.flan @@ -0,0 +1,21 @@ +;;;; The refusals of a typed class slot, one per run because each ends the +;;;; process. The argument chooses which. The line numbers are asserted by +;;;; the test, so an edit above them moves them. +(defclass state [pause bool step i32 tag]) +(defclass node [owner state]) + +(defn as-dyn [d dyn] dyn d) + +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0) + s (state false 3 nil)] + (println "before") + (cond + (= which 0) (println (state 1 2 3)) + (= which 1) (put s :pause 1) + (= which 2) (set (get s :step) 5000000000) + (= which 3) (set (get s :paws) true) + (= which 4) (set (get (as-dyn {:pause 1}) :pause) true) + (= which 5) (println (node (node s))) + :else (println (state nil 1 2)))) + 0) diff --git a/test/programs/pkgs/geo/geo.flan b/test/programs/pkgs/geo/geo.flan new file mode 100644 index 00000000..6d3700ef --- /dev/null +++ b/test/programs/pkgs/geo/geo.flan @@ -0,0 +1,5 @@ +;;;; A package whose slot types name its own classes, imported by +;;;; dyn-class-pkg.flan, which declares a class of the same bare name. +(defclass pt [x f64 y f64]) +(defclass seg [a pt b (Option pt) tag]) +(defn mk [] dyn (seg (pt 1 2) nil :t)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 33b659f5..3669a026 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5117,6 +5117,57 @@ level "1" index_site (); index_site ~x86:true (); + (* Typed class slots and set on a slot: the stores that fit, then one + run per refusal. The constructor, put and set each check a declared + slot's type, set refuses a slot the class does not declare and a + value that is not an instance, and put still inserts an undeclared + key. On both backends, because every one of these is a runtime call + whose arguments the two emit separately. *) + let slots_out = + "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n3.5\ntrue\n2\n:state\n" + in + outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; + outputs ~x86:true "dyn: typed class slots, --x86" + "programs/dyn-class-slots.flan" slots_out; + outputs "dyn: a package's slot type names its own class" + "programs/dyn-class-pkg.flan" + "#g/seg{ :a #g/pt{ :x 1 :y 2} :b nil :tag :t}\n#pt{ :z 1}\n"; + let slot_trap ?x86 () = + let exe = compile ?x86 "programs/dyn-slot-trap.flan" in + List.iter + (fun (arg, want) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL dyn: a class slot's refusal%s\n got: %S \ + (exit %d)\n wanted: %S (exit 134)\n" + (match x86 with Some true -> ", --x86" | _ -> "") + text code want + end) + [ ("0", "dyn-slot-trap.flan:14:28: dyn construct: the slot :pause of \ + state is declared bool, and this is int — (state ...) with \ + :pause 1; the slot is declared at programs/dyn-slot-trap.flan:4:18"); + ("1", "dyn-slot-trap.flan:15:19: dyn put: the slot :pause of state \ + is declared bool, and this is int"); + ("2", "dyn-slot-trap.flan:16:19: dyn set: the slot :step of state \ + is declared i32, and 5000000000 is not a value it holds \ + exactly"); + ("3", "dyn-slot-trap.flan:17:19: dyn set: state has no slot :paws. \ + Its slots are :pause :step :tag; a key the class does not \ + declare is added with put, not set"); + ("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \ + on a class instance, and this is a map with no class"); + ("5", "dyn-slot-trap.flan:19:28: dyn construct: the slot :owner of \ + node is declared state, and this is not an instance of it"); + ("6", "dyn-slot-trap.flan:20:22: dyn construct: the slot :pause of \ + state is declared bool, and this is nil") ]; + (try Sys.remove exe with Sys_error _ -> ()) + in + slot_trap (); + slot_trap ~x86:true (); + (* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a dyn box". programs/dyn-cast.flan is one program because the three behaviours are one story told in order: the same-kind casts print, the diff --git a/test/test_dev.ml b/test/test_dev.ml index 14f11ef1..015a62c1 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7942,6 +7942,168 @@ 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 n i32 note string])" + then begin + holds "a value that no longer fits is kept" + "(if (= (get (at instances 0) :x) 3) 1 0)"; + (* A typed slot gained by the redefinition starts at its type's + zero value, as a typed binding does, and not at nil. *) + holds "a gained i32 slot is 0" + "(if (= (get (at instances 0) :n) 0) 1 0)"; + holds "a gained string slot is empty" + "(if (= (get (at instances 0) :note) \"\") 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_dyn.ml b/test/test_dyn.ml index 4969e4d9..96875fce 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -154,6 +154,14 @@ let () = if code <> 0 || out <> "classes ok\n" then fail "redefining a class\n got: %S (exit %d, err %S)" out code err; + (* A migration's hook re-entered from the building of its own + arguments, and a hook that grows the class registry under it — see + dyn_ops.c's [hook_reentry]. *) + let code, out, err = run "hook" in + if code <> 0 || out <> "hook ok\n" then + fail "a re-entered migration hook\n got: %S (exit %d, err %S)" + out code err; + let code, out, _ = run "nested" in if code <> 0 || out <> "chain of 64 intact: yes\n" then fail "a chain of nested vecs\n got: %S (exit %d)" out code; diff --git a/test/test_flan.ml b/test/test_flan.ml index 33c0209f..da520fa8 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2715,14 +2715,38 @@ let () = rejects_check "a constructor takes one argument per slot" "(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))" ~needle:"point"; - (* A slot vector holds names and nothing else. [(defclass point [x i64])] - is therefore two slots, one of them unfortunately named — the parser - cannot tell a type's name from a slot's and does not have to, since a - slot has no type to write. What it can tell is a form that is not a name - at all. *) - rejects_check "a slot is a name, not a type expression" + (* A slot vector is a defn's parameter vector: a name followed by a type + is a typed slot, a name followed by another name is an untyped one. The + type is what a stored dyn value is checked against, so it is one a dyn + value can be checked as, and nothing else. *) + accepts "typed slots, and untyped ones beside them" + "(defclass state [pause bool step bool n i32 tag])\n\ + (defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))"; + accepts "a class and an Option as slot types" + "(defclass point [x f64])\n\ + (defclass node [at point next (Option node) w (Option i32)])\n\ + (defn main [] i32 (let [n (node (point 1) nil nil)] 0))"; + rejects_check "an Option of dyn is not a slot type" + "(defclass point [x (Option dyn)])\n(defn main [] i32 0)" + ~needle:"the slot x of point is declared (Option dyn)"; + rejects_check "a slot's type is one a dyn value can be checked as" "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" - ~needle:"a class slot is a name"; + ~needle:"the slot x of point is declared (Ptr i64)"; + rejects_check "a capitalised name in a slot vector is an unknown type" + "(defclass point [x Widget])\n(defn main [] i32 0)" + ~needle:"unknown type Widget"; + rejects_check "a slot's type is resolved like any other" + "(defclass point [x f65])\n(defn main [] i32 0)" + ~needle:"did you mean f64"; + (* The slot is a place: its class declares it, so it always exists. *) + accepts "set writes a class slot" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (set (get s :pause) true) \ + (if (get s :pause) 0 1)))"; + rejects_check "a class slot has no address" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (addr (get s :pause)) 0))" + ~needle:"addr takes the address of a place"; rejects_check "a class does not name a slot twice" "(defclass point [x x])\n(defn main [] i32 0)" ~needle:"names the slot x twice"; @@ -3814,7 +3838,10 @@ let () = into a lookup and no place form for one. Refused with that reason rather than as a milestone that will never arrive. *) rejects_check "a map entry as a place" - "(defn f [] () (set (get m 1) 2))" + "(defn f [m (Map i64 i64)] () (set (get m 1) 2))" + ~needle:"entries are written with put"; + rejects_check "get with three arguments is not a place" + "(defn f [m dyn] () (set (get m 1 2) 2))" ~needle:"a map is written with (put m k v)"; (* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *) diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index cc0b2626..a4b13462 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -343,7 +343,7 @@ let dyn_sweep () = the old block, or a [len] that outlived the block it described, is a use-after-free here and nothing anywhere else. *) [ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing"; "park"; - "classes" ]; + "classes"; "hook" ]; (try Sys.remove exe with Sys_error _ -> ()) (* A third sweep, over a handful of the same programs built [--dev]. diff --git a/test/test_session.ml b/test/test_session.ml index f2d3f6a0..0d9a7647 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1591,6 +1591,39 @@ 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 + value is stored, at run time. What has to reach the program is the new + definition, and the registration carries it with the type after the + name, which is what makes the runtime see a change and migrate. *) + (let t, _ = Session.create ~file:"programs/dev-class.flan" () in + 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\"") 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); (* ── What a slot is shown as ────────────────────────────────────────── [strip_rebind] takes only a trailing ~N — [~] is the reader's delimiter 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/examples/classes.flan b/web/examples/classes.flan index b79f5b5f..d036b73c 100644 --- a/web/examples/classes.flan +++ b/web/examples/classes.flan @@ -1,5 +1,5 @@ -;; A class is a named dyn map with a shape tag. Its slots are names and -;; carry no types, and its constructor is the class's own name, positional. +;; A class is a named dyn map with a shape tag. A slot with no type holds +;; any value, and its constructor is the class's own name, positional. (defclass point [x y]) (defclass circle [r]) diff --git a/web/index.html b/web/index.html index bee16947..1c311673 100644 --- a/web/index.html +++ b/web/index.html @@ -710,10 +710,17 @@ unit carries nothing for a dyn word to hold, and boxing it is refused — and

Classes and generic functions

A class is a named dyn map with a shape tag. defclass names its -slots, which carry no types; the constructor is the class's own name and is -positional; and class-of answers the tag, or nil for -anything that is not an instance. The slots are map keys, so nothing was added to -read or write one.

+slots, and a slot may be followed by a type, the way a parameter is: +[x y] is two slots that hold any value, and [pause bool] +is one that holds only a bool. The type is checked whenever a value is stored, +and a slot may be bool, an integer type, f32, +f64, string, a class, or (Option T) of one of +those, which also admits nil. The constructor is the class's own name +and is positional, and class-of answers the tag, or nil +for anything that is not an instance. The slots are map keys: get +reads one, and set writes one, as in +(set (get s :pause) true). put writes one too, and is +also how a key the class does not declare is added.

Dispatch comes in the two styles and they are one mechanism. defgeneric dispatches on the class of the first argument, which is @@ -725,8 +732,8 @@ which is last whatever order it was written in. The generic states the return ty once, for every method; a method has no return slot; and every parameter of both is dyn, written or not.

-
;; A class is a named dyn map with a shape tag. Its slots are names and
-;; carry no types, and its constructor is the class's own name, positional.
+
;; A class is a named dyn map with a shape tag. A slot with no type holds
+;; any value, and its constructor is the class's own name, positional.
 (defclass point [x y])
 (defclass circle [r])
 
@@ -2214,9 +2221,18 @@ reason is the whole difference between the two: an instance carries a header nam
 its class and a flat struct does not. Redefining one re-registers the class and
 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
+starts at its type's zero value — false, 0,
+0.0 or "", and nil for a slot with no type,
+an (Option T) or a class — 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