diff --git a/FIX.org b/FIX.org index 61d3eea..58df760 100644 --- a/FIX.org +++ b/FIX.org @@ -185,8 +185,9 @@ against 985ms on LLVM. * Landed on dev-loop Items 1, 2, 3 and 5 are merged and green (dune test --force, 232 elisp checks, -0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 is -held. +0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 — +classes and generic functions — is no longer held: it landed, and the M2 queue +above records it under item 6 with its commits. ** Re-run is merged, and does not work under --x86 Park and re-run live in the merged entry point's main(), and --x86 refuses the @@ -519,7 +520,10 @@ rename. typed-flan branch freezes the static language pre-dyn. 5. Typed = and != grow strings: bytewise, length + same-pointer fast paths, both backends, one survey program. Ordering stays refused. — LANDED, daed039 6. defclass = named dyn map + shape tag; CLOS class dispatch AND - Clojure-style arbitrary dispatch functions. After 1. + Clojure-style arbitrary dispatch functions. After 1. — LANDED, 8d2bf2a + (the feature), 5af990e (the daemon proof and an x86 descriptor fix it + turned up) and 6c6024e. Written up below, "Classes and generic + functions, 2026-09-20". 7. dyn if: truthiness (nil/false are false, all else true). Typed stays strict bool. — LANDED, 264765a @@ -1359,3 +1363,238 @@ test/programs/defvar-dyn.flan is both readings in one program, pinned in acceptance at the default, -O0 and --x86; and dev-rerun.flan grew a [(defvar tally 0)] whose line is 4 after three re-runs, which is the claim that the new spelling goes through the old guard. +* Classes and generic functions, 2026-09-20 — M2 queue item 6 +The recorded decision was "defclass = named dyn map + shape tag; CLOS class +dispatch AND Clojure-style arbitrary dispatch functions", and it is built as +written. The two dispatch styles are one mechanism and not two: a class +dispatcher is the shape tag of the first argument used as the dispatch +function, so a method written for the class ~point~ and one written for the +value ~:point~ are the same branch — which is also why the two spellings are +refused as duplicates of each other. + +** The surface, as landed +#+begin_src lisp +(defclass point [x y]) ; a class: named slots, no types +(point 3 4) ; the constructor — the class's own name +(class-of p) ; :point, and nil for anything else +(get p :x) (put p :x 10) ; the slots are map keys; nothing new + +(defgeneric area [self] dyn) ; CLOS: dispatch on the class +(defmethod area point [p] (* (get p :x) (get p :y))) + +(defmulti describe [x] dyn (get x :kind)) ; Clojure: the body is the dispatch +(defmethod describe :square [s] (get s :side)) +(defmethod describe :else [s] "something else") +#+end_src + +- *A slot is a key.* An instance is a dyn map, so ~get~, ~put~, ~has-key?~ + and ~len~ are how one is read and written, and no operation was added for + any of it. ~(len p)~ is the slot count. +- *The constructor is positional*, one argument per slot in the order they + were written, and it is an ordinary ~defn~ — so its arity refusal, its cell + in a dev build and its behaviour under redefinition are the ones every + function already has. The named-slot spelling is deferred; see below. +- *A method has no return slot.* The generic states the return type once, for + every method written for it, which is also what makes the parse + unambiguous: the vector is always the third form. +- *Every parameter of a generic and of a method is dyn*, written or not, and + a slot that is not a bare name is refused. That keeps these forms off the + undecided-pairing path a ~defn~'s vector is on: a vector that may hold only + names can be read by the parser, where a ~defn~'s cannot be read until + every type name is known. +- *A dispatch value is a literal* — a class's name, a keyword, a string, an + integer, ~true~, ~false~, or ~:else~ for the arm everything falls through + to. ~:else~ and not Clojure's ~:default~, because ~match~ already spells + "none of the above" that way and two words for it would be one too many. + ~:else~ is the last arm whatever order it was written in. +- *A miss signals.* ~(defstruct NoMethod [generic string value dyn])~ in the + prelude, signalled with ~error~, carrying the name written at the generic + and the value the dispatch actually produced. A condition and not a trap, + because a miss is something a program can be written to answer; + ~handler-case~ around the call is the shape, and a ~:else~ method is the + other answer. No restart is established at the miss, which is + BoundsError's decision taken for BoundsError's reason. ~value~ is the first + ~dyn~ field in any condition here; the per-type descriptor an item-2 struct + carries is what the collector reaches it by. + +** The shape tag: a header field, not a reserved key +This queue item's own note said "named dyn map + shape tag", and the obvious +reading was a reserved entry in the map. It is a field in the object's header +instead — an interned ~kw_entry *~ in the map arm of ~flan_obj~'s union — and +the departure is deliberate. + +An entry would be counted by ~len~, walked by both renderers, and compared by +~dyn_equal~'s key loop. Every instance would answer a length one larger than +its slot count, print a key nobody wrote, and be one ~put~ away from having +its own class changed. A header field cannot be reached by ~get~ or ~put~ at +all, so the question of a user key colliding with it does not arise rather +than being answered by picking an unlikely spelling. + +It cost nothing. The view arm of that union is 24 bytes, so the map arm +growing from 16 to 24 does not grow the union, and ~sizeof(flan_obj)~ is 48 +before and after — checked, not assumed. It needs no marking either: an +interned keyword entry is immortal by construction and is not a collector +object, which ~mark_value~ states by following ~BOX_OBJ~ and nothing else. + +The tag is read in exactly four places in flan_dyn.c: ~class-of~ answers it; +~dyn_equal~ compares it, so two instances of one class compare by their slots +and an instance is never equal to a plain map with the same entries +(Clojure's answer for a record beside a map); and *both* renderers write it — +~render~, which is what ~print~ goes through, and ~say_render~, the 96-byte +sentence a trap prints, so a dyn trap naming an instance says which class it +was. The spelling is ~#point{ :x 1 :y 2}~, Clojure's own for a record. + +The tag is built from the class's *qualified* name, and the qualifier is the +**importer's alias** rather than anything the defining package chose — the +same class imported as ~a~ and as ~zz~ tags its instances ~:a/point~ and +~:zz/point~. That falls straight out of [Load]'s rename, and it is right for +the dispatch, which resolves the class name through the same rename and +therefore agrees with it. What it is *not* safe for is a hand-written +dispatch value: ~(defmethod g :a/point ...)~ is a keyword and nobody +qualifies it, so it is coupled to one import's alias and silently answers for +nothing under another. Write the class's name, ~(defmethod g point ...)~, +which is renamed with everything else. Two packages' own ~point~ classes are +two classes either way, which was the property wanted. + +** How it is built: a pass, not a macro +None of the four forms reaches the checker. ~lib/classes.ml~ rewrites the +whole declaration list at the top of ~Check.build_program~, exactly where +~Shim.expand~ rewrites a ~declare-c~: a class becomes its constructor, a +generic becomes one function whose body binds the dispatch value and compares +it down a chain, and a method becomes a branch of that chain. + +A macro sees one form and this needs the whole list, because a method may be +written above its generic, below it, or arrive at a reload an hour later. +Running over the flat list is also what makes the dev loop work: a reload +rebuilds every dispatch from the session's whole set of declarations. + +*The method bodies are inlined rather than lifted into functions of their +own*, and that is the load-bearing choice. A generic is then exactly one +top-level name, so adding a method to a running program is the ordinary +redefinition of one function, through the cell the call site already goes +through. ~session.ml~ names the generic alongside the method's own +declaration name for that reason — without it a ~C-c C-c~ on a ~defmethod~ +would install something no call site reads. A method still declares a name of +its own, ~area@:circle~, which is what makes re-evaluating one a replacement +and evaluating a new one an append; no function is emitted under it. Proved +end to end against a real daemon (~test_dev.ml~, "a method added to a running +program"), not only at the session's report. + +A method's own parameter names are bound from the generic's *in parallel*, +through temporaries in the unspellable ~[~]~ namespace. A [let] binds in +sequence, so the pairwise spelling reads a name it has just bound: a method +[[b a]] under a generic [[a b]] would be handed its first argument twice and +the second would be unreachable. Both the swap and the one-step shift are +pinned in the survey program, where the values are what is wrong rather than +the types. + +The cost, recorded rather than hidden: *a method is not separately callable +and is not a frame of its own*. A break loop under a method shows the +generic. And the generic's own parameter names stay in scope inside a method +that renamed them, so a body reaching for ~self~ where it declared ~p~ +silently resolves instead of being refused — small, and closing it would mean +giving the dispatcher unspellable parameter names, which is what the +inspector reads. + +** Deferred, each with the reason +- *Inheritance.* plan.org's own rule is that method specificity and ambiguity + rules are required before inheritance or multiple dispatch is enabled, and + with single dispatch on literal values there is no specificity question at + all: two methods either answer for the same value, which is refused, or for + different ones. A hierarchy would create the question, and the author never + asked for one. +- *Multi-argument dispatch.* plan.org names it as the later extension, for + ~(collide Player Enemy)~. It wants the specificity rules above. +- *~:before~, ~:after~, ~:around~ and ~call-next-method~.* They only mean + something once methods can be ordered by anything but equality, which is + the same gate inheritance is behind. +- *Named-slot construction*, ~(point {:x 1})~ with an omitted slot meaning + nil — the dyn twin of ~(Cursor {.src s})~ with its omitted-is-zeroed rule. + Positional is what a generated ~defn~ gives for free, arity included; the + named form is a checker special case and was not worth one at v1. +- *Unknown-slot checking at ~(get p :z)~.* The one compile-time win a + declared slot set makes possible (docs/SPIKE-DUPLICITY.md §8 names it), and + it needs the checker to know the class of an expression — class-typed + tracking on the dyn side, which dyn deliberately does not have. A class + adds a tag and a dispatch, not a static slot discipline. +- *Computed dispatch values.* Clojure registers a method under any value + because registration there is a run-time call; here it is compile-time, and + the method's declaration name is built from the value. +- *~nil~ and floats as dispatch values.* ~:else~ covers the nil case, which + is the common one (~class-of~ answers nil for anything that is not an + instance); a float compared for equality is a trap waiting to be sprung. +- *Class redefinition and migration* — plan.org's ~redefine-class~ / + ~migrate-instances~. A heterogeneous map has no layout to be stale, so + nothing breaks today when a class gains a slot: old instances simply lack + it. Enumerating live instances is the part that is missing, and it is the + pool's question rather than this lane's. +- *The JS backend.* It refuses dyn wholesale, so none of this compiles there. + Same parking as the string-equality hole above. + +** Two things found on the way, neither about classes +- *The x86 backend's redefinition module never emitted the per-type dyn + descriptors.* ~Emit.redefinition~ has always emitted them, by going through + ~finish~; the x86 twin ended at the rodata section and stopped. Nothing had + reached it, because a redefined body had to construct a struct holding a + dyn to need one, and until ~NoMethod~ there was no such struct a + compiler-written body could build. It is not a bad read at run time — a + descriptor label is local, so ~ld~ refuses the module with an undefined + symbol. Fixed with one line beside the same call in the executable path. + + Emitting them turned up the second half: ~descriptors_asm~ wrote them into + ~.rodata~, and a descriptor holds the address of its own offset table. A + relocation in a read-only section is a ~DT_TEXTREL~ — ld warns about it in + a PIE and refuses it in a shared object — so the section is now + ~.data.rel.ro~, which exists for exactly this and is what both the + executable and the reload module use. Verified with ~readelf -d~ on a + reload module from each backend: no ~TEXTREL~, descriptors in + ~.data.rel.ro~. + + *Still unexercised, and for the next sweep rather than this lane:* marking + THROUGH a descriptor that an x86 reload module emitted. What is proved is + that the module links and runs; what is not is a collection happening while + a live instance of a dyn-holding struct sits in a frame of a body that + module delivered. The LLVM path has been exercised since item 2; this one + has existed for a day. +- *A dyn value answered by ~eval-expr~ never reaches the reply's ~:value~.* + It renders to the program's own stdout, which arrives on a *later* reply's + ~:output~ — the dyn-global rows already read one that way and say so, and + ~(+ 2 3)~ answering "5" beside ~(area (point 3 4))~ answering "" is the + whole of the difference. Left standing: where a dyn expression's value + should surface is a question about the editor protocol, not about this + lane. The dev test works around it by comparing inside the expression, so + what crosses the wire is a typed 1. + +** What was run +~dune test --root .~ green (exit 0, no FAIL lines) after each commit, and +again on the rebase onto the defvar-dyn lane — whose ~load.ml~ arms are the +~defvar~ one and whose ~ast.ml~ arm is the ~Ambiguous~ initialiser, disjoint +from the four class arms beside them; both sets were read against each other +by hand rather than trusted to the auto-merge. Three acceptance rows for +~test/programs/dyn-class.flan~ — default, ~-O0~ and ~--x86~ — and a three-way +diff of the program's real output across the same three, captured by hand +before the rows were written and again after the rebase. It is in +~test_sanitize.ml~'s list; per the sweep policy the sweep itself was not run. + +** Found while running it: ~dune test~ exits 1 at random, and has since before + this lane +~test_dev.ml~'s ~trap_park~ rows are racy, and when they lose the race the +whole test binary dies with ~Fatal error: exception Flan.Wire.Closed~ — exit +1 with no FAIL line anywhere, which is the worst shape a failure can have +given that the sweep policy says a lane is judged on the exit status. + +The mechanism: ~trap_park~ polls with ~ask~, which is a bare ~Wire.send~ / +~Wire.recv~ pair with nothing around it, and the program it is polling has +just aborted at the break loop. If the daemon exits between the send and the +recv, ~Wire.recv~ raises ~Closed~, nothing catches it, and every row after it +— in this lane's case the new class daemon among them — never runs. Both +observed failures landed at the same row, ~dev-trap-null-alloc~. + +*It is not this lane's.* Measured on a detached worktree at dev-loop's tip +(c4e0725) with nothing of this lane in it: 2 of 5 runs exit 1 with the same +exception at the same row, against 2 of 5 on this branch. The rates match +because the code is the same. + +Not fixed here, deliberately: the fix is to catch ~Closed~ in that poll and +read it as the program having ended, which is a claim about what those rows +mean and belongs to whoever owns them. Flagged rather than patched. diff --git a/bin/main.ml b/bin/main.ml index 639253f..f950233 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -92,6 +92,15 @@ let summarise (d : Flan.Ast.decl) = Printf.sprintf "declare-c %s (%d params) = %s" fn.name (List.length fn.params) csym | Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms) + | Defclass (n, slots) -> + Printf.sprintf "defclass %s (%d slots)" n (List.length slots) + | Defgeneric fn -> + Printf.sprintf "defgeneric %s (%d params)" fn.name (List.length fn.params) + | Defmulti fn -> + Printf.sprintf "defmulti %s (%d params)" fn.name (List.length fn.params) + | Defmethod m -> + Printf.sprintf "defmethod %s %s (%d body forms)" m.mgen + (dispatch_text m.mkey) (List.length m.mfn.fbody) | Defn fn -> Printf.sprintf "defn %s (%d params, %s return, %d body forms)" fn.name (List.length fn.params) diff --git a/lib/ast.ml b/lib/ast.ml index a6c3fae..222fb24 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -69,7 +69,13 @@ and expr_kind = (* {:a 1 :b s} — a dyn map literal. Braces whose first form is not a [.field] symbol are this; the struct spelling keeps the dot. Keys are ordinary expressions, keywords being the common case. *) - | MapLit of (expr * expr) list + (* The [string option] is a shape tag, and the parser never writes one: a + tagged map is what a (defclass ...) constructor builds, and + [Classes.expand] is the only thing that writes that constructor. The tag + is the class's name; the instance carries it in its object header, not as + an entry, so a tagged literal and an untagged one with the same pairs + differ in exactly one word and in nothing a [get] can see. *) + | MapLit of string option * (expr * expr) list | Arr of expr list (* [0xE6B800FF ...] — a fixed array value *) (* (array 4 rl/Vector2) — a zeroed fixed array, given its count and its element type. [n T] is the ordinary *type* syntax and already works @@ -208,6 +214,52 @@ and decl_kind = (* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *) | Defvar of string * texpr option * init | 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] + 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. + + They are declarations here rather than a macro because the expansion + needs the *whole* declaration list in hand — a method may be written + 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 + (* (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. *) + | Defgeneric of fn + (* (defmulti describe [x] dyn (get x :kind)) — Clojure's: the body IS the + dispatch function, computing the value the methods are keyed by. Exactly + a [defn]'s shape, which is what it is. *) + | Defmulti of fn + (* (defmethod area point [p] body ...) — one method of a generic. [mgen] is + the generic's name, [mkey] the dispatch value it answers for, and [mfn] + carries the parameter vector and the body. There is no return slot: the + generic states the return type once, for all of its methods. *) + | Defmethod of methd + +(* A dispatch value, written at a [defmethod]. Only literals: the value is + compared at run time and the *name* the method is declared under is built + from it at compile time, so it has to be something both passes can read. *) +and dispatch = + (* [point] — a class's name, standing for the keyword its instances carry. + Refused unless a [defclass] of that name is in scope, which is the one + compile-time check a shape tag makes possible. *) + | Dclass of string + | Dkw of string (* :circle *) + | Dstr of string (* "circle" *) + | Dint of int64 + | Dbool of bool + (* [:else] — the method that answers when no other does. The spelling is + [match]'s, not Clojure's [:default], because this language already has + one word for "none of the above" and two would be one too many. *) + | Delse + +and methd = { mgen : string; mkey : dispatch; mfn : fn; mkloc : Loc.t } and variant = { vname : string; vfields : field list; vloc : Loc.t } @@ -225,11 +277,37 @@ and init = Zeroed | Uninit | Init of expr | Ambiguous of expr one top-level namespace, so this is both the set [Load] renames on an import and the set [Check] refuses to see twice — one definition, so the two cannot drift apart. *) +(* How a dispatch value reads back, in a message and in the name below. The + keyword keeps its colon and the string its quotes, so that a method written + for :circle and one written for "circle" — two different values — do not + read as the same thing in a duplicate-method refusal. *) +let dispatch_text = function + | Dclass n -> n + | Dkw k -> ":" ^ k + | Dstr s -> "\"" ^ s ^ "\"" + | Dint i -> Int64.to_string i + | Dbool b -> if b then "true" else "false" + | Delse -> ":else" + +(* The top-level name a [defmethod] declares. No function is ever emitted + under it — a method's body is inlined into its generic's dispatch, so the + only function the pass writes is the generic itself — but a declaration + still needs a name of its own, for the reason every declaration does: a + session replaces a declaration it has already seen by name, and appends one + it has not. Redefining a method has to replace, and adding one has to + append, and the pair (generic, dispatch value) is what tells those two + apart. The [@] is what keeps the name out of a program's reach: no symbol a + reader accepts contains one. *) +let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey + let declared_name (d : decl) = match d.d with | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _) - | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n - | Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name + | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) + | Defclass (n, _) -> Some n + | Declare (fn, _) | DeclareC (fn, _) | Defn fn + | Defgeneric fn | Defmulti fn -> Some fn.name + | Defmethod m -> Some (method_name m) | Package _ | Import _ -> None (* ── Instrumenting a form with (pause) ─────────────────────────────── *) @@ -279,7 +357,7 @@ let map_children f (e : expr) : expr = | Call (fn, args) -> Call (ex fn, List.map ex args) | Match (s, arms) -> Match (ex s, List.map arm arms) | Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs) - | MapLit kvs -> MapLit (List.map (fun (k, v) -> (ex k, ex v)) kvs) + | MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs) | Arr es -> Arr (List.map ex es) | Fn (ps, es) -> Fn (ps, List.map ex es) | Dotimes (l, n, c, es) -> Dotimes (l, n, ex c, List.map ex es) @@ -331,6 +409,14 @@ let mark_pause ~line ~col (ds : decl list) : decl list option = hit := true; { d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } } | Defn f -> { d with d = Defn { f with fbody = body f.fbody } } + (* A method's body and a defmulti's dispatch body are code someone wrote + and can stop inside, so both are walked. Marking the whole declaration + — the [at d.dloc] case above — is deliberately not offered for either: + a method is not a function of its own by the time it runs, so there is + no entry to stop at, only the forms inside it. *) + | Defmethod m -> + { d with d = Defmethod { m with mfn = { m.mfn with fbody = body m.mfn.fbody } } } + | Defmulti f -> { d with d = Defmulti { f with fbody = body f.fbody } } | Defvar (n, t, Init e) -> { d with d = Defvar (n, t, Init (walk e)) } (* The value reading of an undecided [defvar] is walked too: if it is the one that wins it is an initialiser like any other, and if the type diff --git a/lib/check.ml b/lib/check.ml index f238763..179bb35 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2417,7 +2417,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = like any other dyn value would. The literal lowers to a fresh slot — a rooted one, because a slot of type dyn is what [dyn_roots] counts — so the map stays reachable across the allocations its own entries make. *) - | Ast.MapLit kvs -> + | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in let sets = @@ -2428,10 +2428,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = check ctx ~want:Types.Dyn v ]) kvs in + (* A shape tag, if this is the literal a class's constructor was written + from. It is the class's name interned as a keyword, and it goes into + the object's header rather than into the entries — so everything below + this line, the rooting included, is the untagged case unchanged. *) + let empty = + match tag with + | None -> rt loc Types.Dyn "flan_dyn_map_new" [] + | Some cls -> + rt loc Types.Dyn "flan_dyn_map_new_class" + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + in expect ctx loc ~want - (mk loc Types.Dyn - (Tast.Let ([ (m, rt loc Types.Dyn "flan_dyn_map_new" []) ], - sets @ [ mval ]))) + (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 | Ast.Var name -> var ctx loc ~want name @@ -5439,6 +5448,25 @@ and named_call ctx ~want loc name args = (Types.to_string other)) | _ -> assert false) + (* (class-of v) -> the class's name as a keyword, or nil. It is the dyn + side's one question about shape, and the dispatch a (defgeneric ...) + compiles to is this call and a comparison — so what a class dispatcher + is, exactly, is the shape tag of the first argument as the dispatch + function, which is what makes the CLOS half and the Clojure half one + mechanism rather than two. + + Anything that is not an instance answers nil rather than trapping: an + ordinary map, a number, nil itself. Asking is not a claim, and the + question is askable of every value — the same line [get] takes about an + absent key. *) + | "class-of" -> + arity loc name 1 args; + (match args with + | [ v ] -> + expect ctx loc ~want + (rt loc Types.Dyn "flan_dyn_class_of" [ check ctx ~want:Types.Dyn v ]) + | _ -> assert false) + (* (map-remove m k) -> (Option V): the value that was there, or None when the key was not. The same answer [get] gives, for the same reason — a key that is not in the map is an answer and not a failure — and the value @@ -6779,6 +6807,12 @@ let builtins : (string * string * string) list = wants, where get would hand back an Option to match on. Over a dyn map \ it is the question that stays askable when nil might also be stored \ under the key."); + ("class-of", "class-of [dyn] dyn", + "The class's name as a keyword for a value built by a defclass \ + constructor, and nil for everything else — an ordinary map included. \ + It is what a defgeneric dispatches on, so a class dispatcher is this \ + call over the first argument and a defmulti whose body is (class-of x) \ + is the same generic function written the other way."); ("keyword", "keyword [string|[u8]] dyn", "The interned dyn keyword named by the bytes, for a name that only \ exists at run time — a reader building :texture-path out of a token's \ @@ -7229,7 +7263,21 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.globals n (ty, false) | Ast.Defconst (n, Some t, _) -> Hashtbl.replace env.globals n (resolve env t, true) - | Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped) + | Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped + (* [Classes.expand] ran at the top of [build_program] and left none of + these behind, the way [Shim.expand] leaves no [declare-c] behind. A + 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.Defmulti { Ast.name = n; _ } -> + fail loc + "internal: %s reached the checker unexpanded — Classes.expand did \ + not run over this declaration list" n + | Ast.Defmethod m -> + fail loc + "internal: a method of %s reached the checker unexpanded — \ + Classes.expand did not run over this declaration list" m.Ast.mgen) decls; (* Also to a fixpoint, and for the same reason: one untyped constant may be defined in terms of another declared after it. A constant that still does @@ -8421,6 +8469,11 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env = flattening comes back to be compiled into the build. Nothing below this line knows the form exists. *) let decls, cshim = Shim.expand decls in + (* And on the same line: every class and generic function becomes the + [defn]s it stands for. It runs over the whole list because a method may + be written anywhere in it, which is also what makes a reload rebuild + every dispatch from the session's declarations — see lib/classes.ml. *) + let decls = Classes.expand decls in (* Pass one, and it stops at the first thing it refuses. That is not laziness: every name, type and signature in the file comes from here, so a declaration this pass could not make sense of leaves a hole that pass two @@ -8791,6 +8844,9 @@ let memory_class (sym : string) (args : Tast.expr list) = gc "allocates: a dyn vector is an object on the collector's heap" | "flan_dyn_map_new" -> gc "allocates: a dyn map is an object on the collector's heap" + | "flan_dyn_map_new_class" -> + gc "allocates: a class instance is a dyn map on the collector's heap, \ + with the class's name in its header" | "flan_dyn_view_vec" | "flan_dyn_view_flat" -> gc "allocates: a typed container crossing into dyn takes a view record \ on the collector's heap — the elements are not copied, the record is" diff --git a/lib/classes.ml b/lib/classes.ml new file mode 100644 index 0000000..7afe0c6 --- /dev/null +++ b/lib/classes.ml @@ -0,0 +1,351 @@ +(** The dyn side's classes and generic functions, turned into ordinary + declarations. + + [(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. + + **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 + its generic, below it, or at a reload an hour later — and the generic's + body is not decidable until every method is in hand. The pass runs at the + top of [Check.build_program], over the flat list an import has already + been folded into, so a reload rebuilds every dispatch from the session's + whole set of declarations and a method added to a running program is the + ordinary redefinition of the one function that dispatches. [Shim.expand] + is the precedent, form for form. + + **Why the method bodies are inlined rather than lifted into functions of + their own.** A generic is then exactly one top-level name, which is what + makes adding a method at a reload work: the session installs the bodies + the evaluated form declared, one name each, and a new method has to reach + a call site that was compiled before it existed. One function means one + cell to replace. The cost is that a method is not separately callable and + does not appear as a frame of its own, which is recorded in FIX.org. + + **What it does not do.** There is no inheritance, no multi-argument + dispatch, and no :before/:after/:around — see FIX.org, 2026-09-20, for + which of those were deferred and why. A method's dispatch value is a + literal, so the specificity question CLOS answers with a class precedence + list does not arise here: two methods either answer for the same value, + which is refused, or for different ones. *) + +let dyn_at loc : Ast.texpr = { Ast.t = Ast.Tname "dyn"; tloc = loc } + +let ex loc (e : Ast.expr_kind) : Ast.expr = { Ast.e; loc } + +(* The name the dispatch value is bound to inside a generic's body. [~] is a + delimiter in the reader, so no symbol anyone can write is this one and no + method body can shadow it or be shadowed by it. *) +let dispatch_slot = "~dispatch" + +(* The condition a generic signals when no method answers. Its struct is in + the prelude; this is the only place that builds one. *) +let no_method = "NoMethod" + +(* ── Collecting ────────────────────────────────────────────────────── *) + +type generic = { + gkind : [ `Class | `Multi ]; + gfn : Ast.fn; + gloc : Loc.t; + (* In source order, which is dispatch order: the first method whose value + matches answers, and since duplicates are refused the order is not + observable except for [:else], which is moved to the end regardless. *) + mutable gms : Ast.methd list; +} + +let collect (decls : Ast.decl list) = + let classes : (string, Loc.t) Hashtbl.t = Hashtbl.create 8 in + let generics : (string, generic) Hashtbl.t = Hashtbl.create 8 in + 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.Defgeneric fn -> + Hashtbl.replace generics fn.Ast.name + { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } + | Ast.Defmulti fn -> + Hashtbl.replace generics fn.Ast.name + { gkind = `Multi; gfn = fn; gloc = d.Ast.dloc; gms = [] } + | _ -> ()) + decls; + (* Methods second, so a method may be written above the generic it extends + — which it has to be able to be, since a reload appends. *) + List.iter + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defmethod m -> + let g = + match Hashtbl.find_opt generics m.Ast.mgen with + | Some g -> g + | None -> + Loc.failk "check/unknown-generic" d.Ast.dloc + "no defgeneric or defmulti names %s, so there is nothing for \ + this method to be a method of. A generic function is \ + declared once, with its parameters and its return type, and \ + the methods are written against it" + m.Ast.mgen + in + (match m.Ast.mkey with + | Ast.Dclass c when not (Hashtbl.mem classes c) -> + Loc.failk "check/unknown-class" m.Ast.mkloc + "no defclass names %s. A bare name in a method's dispatch slot \ + is a class, and stands for the shape tag its instances carry; \ + a dispatch value that is not a class is written as itself — a \ + keyword, a string, an integer" + c + | _ -> ()); + let n = List.length m.Ast.mfn.Ast.params + and want = List.length g.gfn.Ast.params in + if n <> want then + Loc.failk "check/method-arity" d.Ast.dloc + "%s takes %d argument%s and this method of it takes %d. Every \ + method of a generic function has the generic's own parameter \ + list: one call site reaches all of them, and it can only pass \ + one number of arguments" + m.Ast.mgen want (if want = 1 then "" else "s") n; + (* A class's name and its keyword are one dispatch value — a class + stands for the keyword its instances carry, which is the whole of + how the two dispatch styles share a mechanism — so [point] and + [:point] have to be compared as one or the second method is + accepted and is dead code. *) + let norm = function Ast.Dclass c -> Ast.Dkw c | k -> k in + List.iter + (fun (prev : Ast.methd) -> + if norm prev.Ast.mkey = norm m.Ast.mkey then + Loc.failk "check/duplicate-method" d.Ast.dloc + "%s already has a method for %s. Two methods for one \ + dispatch value is an ambiguity nothing resolves — there \ + is no specificity rule here, because a dispatch value is \ + a value and not a type" + m.Ast.mgen (Ast.dispatch_text m.Ast.mkey)) + g.gms; + g.gms <- g.gms @ [ m ] + | _ -> ()) + decls; + (classes, generics) + +(* ── Writing the declarations ──────────────────────────────────────── *) + +(* [(defclass point [x y])] becomes + + (defn point [x dyn y dyn] dyn #point{:x x :y y}) + + — the constructor, positional, one argument per slot in the order the + slots were written. The slots are keys in an ordinary dyn map, so [get], + [put] and [has-key?] are how one is read and written and no new operation + is needed for any of it. What the class adds is the tag on the map, which + is what [class-of] answers and what a generic dispatches on. + + Named-slot construction — the dyn twin of [(Cursor {.src s})], with an + omitted slot meaning nil — is deferred, and so is refusing an unknown slot + at [(get p :z)]. Both are recorded in FIX.org. *) +let constructor n slots loc : Ast.decl = + let params = + List.map + (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + slots + in + let pairs = + List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + in + { Ast.d = + Ast.Defn + { Ast.name = n; params; praw = None; ret = Some (dyn_at loc); + fwhere = []; fbody = [ ex loc (Ast.MapLit (Some n, pairs)) ]; + nloc = loc }; + dloc = loc } + +(* The dispatch value a method answers for, as an expression to compare + against. A class's name stands for the keyword its instances carry, which + is the whole of how the CLOS half and the Clojure half share one + mechanism: [(defgeneric area [self] dyn)] is [(defmulti area [self] dyn + (class-of self))], and a method written for the class [point] is a method + written for the value [:point]. *) +let key_expr loc (k : Ast.dispatch) : Ast.expr = + match k with + | Ast.Dclass c -> ex loc (Ast.Kw c) + | Ast.Dkw k -> ex loc (Ast.Kw k) + | Ast.Dstr s -> ex loc (Ast.Str s) + | Ast.Dint i -> ex loc (Ast.Int i) + | Ast.Dbool b -> ex loc (Ast.Var (if b then "true" else "false")) + | Ast.Delse -> assert false (* never compared: it is the else arm *) + +(* A method's body, with the method's own parameter names bound to the + generic's. The names are the method's to choose — [(defmethod area point [p] + ...)] under [(defgeneric area [self] dyn)] — and a method whose names + already agree with the generic's binds nothing, so the common case adds no + [let] at all. + + **The rebinding is parallel, and it has to be.** A [let] here binds in + sequence: each binding is in scope for the next one's value. So the + pairwise spelling — [(let [b a a b] ...)] for a generic [[a b]] and a + method [[b a]] — reads the [b] it has just bound and hands the method its + first argument twice, with the second unreachable. That is a swap, and a + swap is exactly what a method renaming its parameters is most likely to be + doing; the non-swap case [[b c]] is the same bug one step shorter, since + [b] reads the binding above it rather than the parameter. Both are what + [rotatef] and Clojure's destructuring do in parallel, and neither language + would read a name it was in the middle of rebinding. + + So every argument is copied into a temp first and every method name is + bound from a temp, never from a parameter. [~] is a delimiter in the + reader, so the temps cannot collide with a method's names whatever they + are, and one uniform shape is written rather than only the pairs that + actually collide — a rule that fires only on the tangled case is a rule + nobody exercises. *) +let method_body (g : generic) (m : Ast.methd) : Ast.expr = + let loc = m.Ast.mfn.Ast.nloc in + let pairs = List.combine m.Ast.mfn.Ast.params g.gfn.Ast.params in + if + List.for_all + (fun ((mp : Ast.field), (gp : Ast.field)) -> + String.equal mp.Ast.fname gp.Ast.fname) + pairs + then ex loc (Ast.Do m.Ast.mfn.Ast.fbody) + else begin + let tmp i = Printf.sprintf "~arg%d" i in + let hold = + List.mapi + (fun i ((_ : Ast.field), (gp : Ast.field)) -> + { Ast.bname = tmp i; bty = None; + bval = ex gp.Ast.floc (Ast.Var gp.Ast.fname); + bloc = gp.Ast.floc }) + pairs + in + let rename = + List.mapi + (fun i ((mp : Ast.field), (_ : Ast.field)) -> + { Ast.bname = mp.Ast.fname; bty = None; + bval = ex mp.Ast.floc (Ast.Var (tmp i)); + bloc = mp.Ast.floc }) + pairs + in + ex loc (Ast.Let (hold @ rename, m.Ast.mfn.Ast.fbody)) + end + +(* What a generic answers when no method does. Common Lisp signals here and + so does this: it is a condition with a handler-case around it, not a trap, + because a dispatch that missed is a thing a program can be written to + answer — a default, a log line, a fallback object — and a trap would take + that away. [error] rather than [signal] because there is no value to carry + on with if nothing handles it. + + No restart is established at the miss. That is BoundsError's and + ArithError's decision, taken here for their reason: a restart frame is + allocated by the form that offers it, and the ones that matter — a frame + loop's [continue] — are already on the stack and reachable from a handler + without this form pushing anything. *) +let miss loc gname : Ast.expr = + ex loc + (Ast.Signal + (Ast.Serror, + ex loc + (Ast.Struct + (no_method, + [ ("generic", ex loc (Ast.Str gname)); + ("value", ex loc (Ast.Var dispatch_slot)) ])))) + +let dispatcher (g : generic) : Ast.decl = + let loc = g.gloc in + let gname = g.gfn.Ast.name in + (* The value the methods are keyed by. A defgeneric computes it — the shape + tag of the first argument — and a defmulti's own body is it. *) + let value = + match g.gkind with + | `Multi -> ex loc (Ast.Do g.gfn.Ast.fbody) + | `Class -> + (match g.gfn.Ast.params with + | p :: _ -> + ex loc + (Ast.Call (ex loc (Ast.Var "class-of"), + [ ex p.Ast.floc (Ast.Var p.Ast.fname) ])) + | [] -> + Loc.failk "check/method-arity" loc + "%s takes no arguments, and a defgeneric dispatches on the class \ + of its first one. Write a defmulti, whose body says what to \ + dispatch on" + gname) + in + (* [:else] last whatever order it was written in, because it is the arm + everything else falls through to and not a value to compare against. *) + let fallback, cases = + List.partition (fun (m : Ast.methd) -> m.Ast.mkey = Ast.Delse) g.gms + in + let last = + match fallback with + | m :: _ -> method_body g m + | [] -> miss loc gname + in + let chain = + List.fold_right + (fun (m : Ast.methd) rest -> + let kloc = m.Ast.mkloc in + ex kloc + (Ast.If + (ex kloc + (Ast.Call (ex kloc (Ast.Var "="), + [ ex kloc (Ast.Var dispatch_slot); + key_expr kloc m.Ast.mkey ])), + method_body g m, Some rest))) + cases last + in + { Ast.d = + Ast.Defn + { g.gfn with + Ast.fbody = + [ ex loc + (Ast.Let ([ { Ast.bname = dispatch_slot; bty = None; + bval = value; bloc = loc } ], + [ chain ])) ] }; + dloc = loc } + +(** Every [defclass], [defgeneric], [defmulti] and [defmethod] in the list, + replaced by the [defn]s they stand for. Everything else is untouched and + keeps its position: a constructor is written where its class was and a + dispatch where its generic was, so declaration order — which is emission + order for globals — does not move. *) +let expand (decls : Ast.decl list) : Ast.decl list = + let has = + List.exists + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defclass _ | Ast.Defgeneric _ | Ast.Defmulti _ + | Ast.Defmethod _ -> true + | _ -> false) + decls + in + if not has then decls + else begin + 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) + | Ast.Defgeneric fn | Ast.Defmulti fn -> + Some (dispatcher (Hashtbl.find generics fn.Ast.name)) + (* Gone: its body is inside its generic's dispatch. *) + | Ast.Defmethod _ -> None + | _ -> Some d) + decls + end diff --git a/lib/emit.ml b/lib/emit.ml index 3ba2f40..ca4d8a5 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3619,6 +3619,8 @@ 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_class_of(i64) declare i64 @flan_dyn_kw(ptr, i64) declare i64 @flan_dyn_map_get(i64, i64) declare void @flan_dyn_map_set(i64, i64, i64) @@ -4034,7 +4036,15 @@ let descriptors_asm m = "\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\ # size of one instance, how many dyn words it holds, and where they are.\n\ # Read by the collector through flan_dyn_root_push_desc and by nothing\n\ - # else; no value points at one.\n\t.section\t.rodata\n"; + # else; no value points at one.\n\ + #\n\ + # .data.rel.ro and not .rodata, because a descriptor holds the address\n\ + # of its own offset table. That is a relocation, and a relocation in a\n\ + # read-only section is one the dynamic linker can only apply by making\n\ + # the section writable — a DT_TEXTREL, which ld warns about in a PIE\n\ + # and refuses outright in a shared object. .data.rel.ro is the section\n\ + # for exactly this: relocated at load and read-only from then on.\n\ + \t.section\t.data.rel.ro,\"aw\",@progbits\n"; List.iter (fun (_, (sym, offs, size)) -> Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym); diff --git a/lib/load.ml b/lib/load.ml index 3c8c7c8..9308fba 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -267,8 +267,11 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs) (* A dyn map literal has no name of its own to qualify; its keys and values are ordinary expressions and are walked like anything else. *) - | Ast.MapLit kvs -> - Ast.MapLit (List.map (fun (k, v) -> (go k, go v)) kvs) + | Ast.MapLit (tag, kvs) -> + (* The tag is a class's name and is already qualified: the only thing + that writes one is [Classes.expand], which runs over the flat list + after every import has been folded into it. *) + Ast.MapLit (tag, List.map (fun (k, v) -> (go k, go v)) kvs) | Ast.Arr items -> Ast.Arr (gos items) | Ast.ArrayOf t -> Ast.ArrayOf (rename_texpr owned alias t) | Ast.Fn (ps, body) -> @@ -358,6 +361,18 @@ let rename_pitem owned alias (p : Ast.pitem) : Ast.pitem = | Ast.Pname _ -> p | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t) +(* A generic function's or a method's signature and body. Its parameters are + all [dyn] and were written out by the parser, so unlike a [defn]'s there is + no undecided vector to qualify and the names the body may shadow are simply + the parameter names. The declared name is qualified by the caller, which + for a method is not [fn.name] at all. *) +let qualify_dyn_fn owned alias (fn : Ast.fn) : Ast.fn = + let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in + { fn with + Ast.name = qualify alias fn.Ast.name; + ret = Option.map (rename_texpr owned alias) fn.Ast.ret; + fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody } + let qualify_decl owned alias (d : Ast.decl) : Ast.decl = let loc = d.Ast.dloc in let k = @@ -432,6 +447,41 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = params; praw; ret = Option.map (rename_texpr owned alias) fn.Ast.ret; fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody } + (* ── The class forms ────────────────────────────────────────────── + [Classes.expand] has not run — it runs over the whole flat list, after + every import has been folded into it — so these arrive here as written + 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 + 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) + (* 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. *) + | Ast.Defgeneric fn -> Ast.Defgeneric (qualify_dyn_fn owned alias fn) + | Ast.Defmulti fn -> Ast.Defmulti (qualify_dyn_fn owned alias fn) + (* Both halves of the head are names this package owns or does not: the + generic being extended, and — when the dispatch value is a class — the + class being dispatched on. A method written in one package for another + package's generic therefore keeps working, because [owned] answers no + for that name and the alias-qualified spelling the source wrote is left + alone by [rename_expr]'s rule. *) + | Ast.Defmethod m -> + let mkey = + match m.Ast.mkey with + | Ast.Dclass c when List.mem c owned -> Ast.Dclass (qualify alias c) + | k -> k + in + let mgen = if List.mem m.Ast.mgen owned then qualify alias m.Ast.mgen + else m.Ast.mgen in + let mfn = qualify_dyn_fn owned alias m.Ast.mfn in + Ast.Defmethod + { m with Ast.mgen; mkey; + mfn = { mfn with Ast.name = mgen ^ "@" ^ Ast.dispatch_text mkey } } | Ast.Package _ -> Ast.Package alias (* A package's own imports were resolved before this ran and are not in the list it is given, so one arriving here is a bug in [import] rather @@ -681,7 +731,7 @@ let rec expr_uses acc (e : Ast.expr) = | Ast.Struct (n, kvs) -> acc := (n, e.Ast.loc) :: !acc; List.iter (fun (_, v) -> go v) kvs - | Ast.MapLit kvs -> List.iter (fun (k, v) -> go k; go v) kvs + | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs | Ast.Arr items -> gos items | Ast.ArrayOf t -> texpr_uses acc t | Ast.Fn (_, body) -> gos body @@ -755,6 +805,19 @@ 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 _ -> () + | 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 + same reason a type in a signature is. *) + | Ast.Defmethod m -> + acc := (m.Ast.mgen, d.Ast.dloc) :: !acc; + (match m.Ast.mkey with + | Ast.Dclass c -> acc := (c, m.Ast.mkloc) :: !acc + | _ -> ()); + fn m.Ast.mfn let uses (ds : Ast.decl list) = let acc = ref [] in diff --git a/lib/parse.ml b/lib/parse.ml index 3210cf6..6a5ac37 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -140,6 +140,52 @@ and pitems (items : Form.t list) : Ast.pitem list = | _ -> Ast.Ptype (texpr it)) items +(* A generic's or a method's parameter vector. Every slot is a bare name and + every parameter is [dyn], so the types are written out here rather than + left for [Check.pair_params] to decide: the pairing exists because a + [defn]'s vector is ambiguous until every type name is known, and this one + never is. A parameter named after a type is therefore fine here, where in a + [defn] it would be refused. *) +and dyn_params which (items : Form.t list) : Ast.field list = + List.map + (fun (it : Form.t) -> + match it.v with + | Sym s -> + { Ast.fname = s; + fty = { Ast.t = Ast.Tname "dyn"; tloc = it.loc }; + floc = it.loc } + | _ -> + fail it + "a %s's parameter is a bare name, and found %s. Every parameter of \ + a generic function is dyn — there is no type to write, and a \ + method that wanted one could not be reached by a dispatch that \ + does not know types either" + which (Form.to_string it)) + items + +(* A [defmethod]'s dispatch value. Literals only: the value is compared + against what the dispatch answered at run time, and the method is declared + under a name built from it at compile time, so it has to be something both + passes can read off the source. A computed one — Clojure allows any value a + method is registered under, because registration there is a run-time call — + is not available and the message says so. *) +and dispatch (f : Form.t) : Ast.dispatch = + match f.v with + | Kw "else" -> Ast.Delse + | Sym "true" -> Ast.Dbool true + | Sym "false" -> Ast.Dbool false + | Sym s -> Ast.Dclass s + | Kw k -> Ast.Dkw k + | Str s -> Ast.Dstr s + | Int i -> Ast.Dint i + | _ -> + fail f + "a method's dispatch value is a class's name, a keyword, a string, an \ + integer, true, false, or :else for the one that answers when no other \ + does — and found %s. It is matched at compile time as well as at run \ + time, so it is written out rather than computed" + (Form.to_string f) + (* ── The constraint map at the head of a defn body ────────────────────── [(defn sort [s [$t]] () {:where (ordered? $t)} body ...)]. Clojure's [{:pre [...] :post [...]}] is the precedent and the reason it is a map @@ -274,7 +320,7 @@ let rec expr (f : Form.t) : Ast.expr = | Map ({ v = Sym s; _ } :: _) when String.length s > 1 && s.[0] = '.' -> fail f "a bare map is not an expression; write (Type {.field v})" - | Map items -> mk (Ast.MapLit (map_pairs f items)) + | Map items -> mk (Ast.MapLit (None, map_pairs f items)) | List [] -> fail f "() is not an expression" | List (head :: args) -> form f mk head args @@ -567,7 +613,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = output rather than a dependency. Building a declaration as a value is what a macro is for. *) | Sym ("defmacro" | "defn" | "defvar" | "defconst" | "defstruct" | "defdata" - | "defunion" + | "defunion" | "defclass" | "defgeneric" | "defmulti" | "defmethod" | "defenum" | "defalias" | "import" as name) -> fail f "%s is a top-level declaration, not an expression. A quasiquoted one is \ @@ -1215,6 +1261,77 @@ let rec decl (f : Form.t) : Ast.decl = "defn is (defn name [param Type ...] ReturnType body ...). The return \ type is not optional; a function that returns nothing writes ()") + (* ── The dyn side's classes and generic functions ────────────────── + Four forms, all of them shorthand: nothing below [Classes.expand] knows + they exist, and what it writes in their place is ordinary [defn]s. The + parsing here is only the shape check — which slots are present, and what + kind of thing is in each — because everything that needs the other + declarations to answer (is that a class? is there a generic by that + name? has this dispatch value a method already?) is the expansion's. + + Every parameter of a generic and of a method is [dyn], written or not, + so a parameter vector here takes bare names and nothing else. That is + what keeps these off [defn]'s undecided-pairing path: a [defn]'s vector + cannot be read until every type name is known, and one that may hold + only names can be read here. *) + | List ({ v = Sym "defclass"; _ } :: args) -> + (match args with + | [ n; { v = Vec slots; _ } ] -> + mk (Ast.Defclass + (sym n, + List.map + (fun (s : Form.t) -> + match s.v with + | Sym name -> (name, s.loc) + | _ -> + fail s + "a class slot is a name. Its value is dyn and there is \ + no type to write: an instance is a dyn map with a \ + shape tag on it, and (get p :%s) is how a slot is read" + (Form.to_string s)) + slots)) + | _ -> fail f "defclass is (defclass Name [slot ...])") + + | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> + let generic = String.equal which "defgeneric" in + let usage = + if generic then + "defgeneric is (defgeneric name [param ...] ReturnType). It has no \ + body: its dispatch value is the class of its first argument, which \ + is what makes it the class-dispatching half of the pair. Write \ + defmulti for a dispatch value of your own" + else + "defmulti is (defmulti name [param ...] ReturnType body ...), and the \ + body is the dispatch: it answers the value the methods are keyed by" + in + (match args with + | n :: { v = Vec ps; _ } :: ret :: body + when if generic then body = [] else body <> [] -> + mk ((if generic then (fun fn -> Ast.Defgeneric fn) + else fun fn -> Ast.Defmulti fn) + { Ast.name = sym n; params = dyn_params which ps; praw = None; + ret = Some (texpr ret); fwhere = []; fbody = body_of body; + nloc = n.loc }) + | _ -> fail f "%s" usage) + + | List ({ v = Sym "defmethod"; _ } :: args) -> + (match args with + | n :: key :: { v = Vec ps; _ } :: body when body <> [] -> + let gen = sym n and k = dispatch key in + mk (Ast.Defmethod + { Ast.mgen = gen; mkey = k; mkloc = key.loc; + (* The name is the declaration's, not a symbol anything emits: + no function is ever written under it. *) + mfn = { Ast.name = gen ^ "@" ^ Ast.dispatch_text k; + params = dyn_params "defmethod" ps; praw = None; + ret = None; fwhere = []; fbody = body_of body; + nloc = n.loc } }) + | _ -> + fail f + "defmethod is (defmethod generic dispatch [param ...] body ...). \ + There is no return type: the generic states it once, for every \ + method written for it") + | List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) -> (* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is last and is always written: a foreign name is not derivable from a Flan diff --git a/lib/prelude.ml b/lib/prelude.ml index 847109c..b015fd9 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -148,6 +148,28 @@ let source = {flan| ;; pushed here. (defstruct ArithError [op i32 lhs i64 rhs i64]) +;; What a generic function signals when no method answers. `generic` is the +;; name written at the defgeneric or defmulti, and `value` is what the +;; dispatch actually produced -- the class of the first argument for a +;; defgeneric, whatever the body answered for a defmulti. A miss is nil for +;; the common case of a value that is not an instance at all. +;; +;; A condition and not a trap, and that is the decision rather than the +;; obvious default: Common Lisp signals here, and a dispatch that missed is +;; something a program can be written to answer -- a default object, a log +;; line, a fallback -- which a trap would take away. `handler-case` around +;; the call is the shape, and a method written for `:else` is the other +;; answer, in the generic rather than at the call. +;; +;; `value` is dyn, which is the one field type no other condition here has. +;; It is the honest one: a dispatch value is whatever the dispatch answered +;; and there is no narrower type it has. The collector reaches it through the +;; per-type descriptor a struct with a dyn field carries. +;; +;; No restart is established at the miss, which is BoundsError's decision +;; taken for BoundsError's reason -- see the note above it. +(defstruct NoMethod [generic string value dyn]) + ;; A breakpoint. (pause) stops the program where it stands and hands it to the ;; break loop, with the whole stack under it readable — C-c C-b lists the ;; frames, TAB opens one, and taking `continue` resumes at the call. diff --git a/lib/session.ml b/lib/session.ml index a724f25..49daeb5 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -586,7 +586,21 @@ let eval ?(origin = "") ?pause t src : change = fail loc "nothing to pause at line %d, column %d of the form sent" line col) in - let names = List.filter_map Ast.declared_name incoming in + (* A method declares a name of its own — that is what makes evaluating one + twice a replacement and evaluating a new one an append, through the same + kept/added logic every other declaration goes through. But no function is + emitted under that name: a method's body is inlined into its generic's + dispatch by [Classes.expand], so the body that has to be installed is the + *generic's*. Naming it here is what makes [C-c C-c] on a defmethod reach + a call site compiled before the method existed, which is the whole of why + this feature is usable in the loop the project exists for. *) + let names = + List.filter_map Ast.declared_name incoming + @ List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None) + incoming + in let replacement n = List.find_opt (fun (d : Ast.decl) -> Ast.declared_name d = Some n) diff --git a/lib/x86.ml b/lib/x86.ml index c585400..096382f 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4922,6 +4922,17 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) \t.size\tflan_reload_transient, 1\n\ flan_reload_transient:\n\t.byte\t1\n" | _ -> ()); + (* The per-type dyn descriptors this module's own bodies asked for, exactly + as [program] emits them. They were missing here, and the hole only became + reachable when a redefined body first constructed a struct holding a dyn: + [desc_of] mints a local label and the body references it, so a module + that never wrote the label out is one [ld] refuses with an undefined + symbol rather than one that loads and reads garbage. The labels are local + in both backends — [desc_of] says so, and this is the other half of that + sentence — so emitting the same type's descriptor here and in the host is + not a duplicate symbol. [Emit.redefinition] has always emitted them, by + going through [finish]. *) + Buffer.add_string out (Emit.descriptors_asm md); Buffer.add_string out "\n\t.section\t.rodata\n"; Buffer.add_buffer out rodata; Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 34afd76..8169146 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -220,6 +220,11 @@ typedef struct flan_dyn_alloc_hdr { uint64_t epoch; } flan_dyn_alloc_hdr; +/* A keyword's interned entry, declared here because a map's shape tag is one. + * The definition, the table and the argument for interning are further down, + * under "Keywords". */ +struct kw_entry; + typedef struct flan_obj { struct flan_obj *next; /* every object ever allocated, newest first */ uint8_t kind; @@ -228,7 +233,26 @@ typedef struct flan_obj { of a map */ union { int64_t i; /* OBJ_INT */ - struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC and OBJ_MAP — + struct { flan_dyn *items; int64_t cap; + /* OBJ_MAP only, and NULL for every map that is not a defclass + instance: the shape tag. It is the interned entry of the + class's name — :point for (defclass point [x y]) — so the + identity compare that makes keyword equality cheap is also + what makes a class check cheap, and the tag needs no marking + because an interned entry is immortal and is not a GC object + (see [mark_value], which follows BOX_OBJ and nothing else). + + It lives in the header rather than in a reserved entry of the + map itself, which is the one place this departs from the + queue's note: an entry would be counted by [len], walked by + [render], and compared by [dyn_equal]'s key loop, so every + instance would answer a length one larger than its slot count + and print a key nobody wrote. A field cannot be reached by + [get] or [put] at all, so no user key can collide with it. + + A vec leaves it NULL. The arm is shared, so the field exists + for both kinds; nothing reads it for an OBJ_VEC. */ + struct kw_entry *klass; } v; /* OBJ_VEC and OBJ_MAP — a map shares the vec's arm on purpose: its entries are the same malloc block of dyn words, interleaved key then value, with [len] counting entries and [cap] counting entries too. Sharing the arm is what lets the @@ -555,6 +579,13 @@ static void render(flan_dyn v, int depth, int nested) { case FLAN_DYN_TAG_MAP: { flan_obj *o = dyn_obj(v); int64_t i; + /* A class instance prints its shape tag in front, Clojure's own spelling + * for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is + * written here or it is not written at all. */ + if (o->u.v.klass != NULL) { + emit("#"); + emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len); + } emit("{"); for (i = 0; i < o->len; i++) { emit(" "); @@ -651,6 +682,19 @@ static void say_render(sayer *s, flan_dyn v, int depth) { flan_obj *o = dyn_obj(v); int64_t i; if (depth >= 2) { say_puts(s, "{...}"); return; } + /* The same tag [render] writes, so a trap sentence naming an instance + * says which class it was. Truncated with the rest when the buffer is + * short: [say] is a 96-byte sentence, not a printer. */ + if (o->u.v.klass != NULL && s->n < s->cap - 8) { + int64_t j; + say_puts(s, "#"); + for (j = 0; j < o->u.v.klass->len && s->n < s->cap - 8; j++) { + char c[2]; + c[0] = (char)kw_bytes(o->u.v.klass)[j]; + c[1] = '\0'; + say_puts(s, c); + } + } say_puts(s, "{"); for (i = 0; i < o->len && s->n < s->cap - 8; i++) { say_puts(s, " "); @@ -1015,6 +1059,9 @@ flan_dyn flan_dyn_vec_new(void) { o->len = 0; o->u.v.items = NULL; o->u.v.cap = 0; + /* Shared arm, and nothing reads this for a vec; written anyway so that the + field's value is never whatever [gc_alloc] happened to leave. */ + o->u.v.klass = NULL; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } @@ -1023,9 +1070,37 @@ flan_dyn flan_dyn_map_new(void) { o->len = 0; o->u.v.items = NULL; o->u.v.cap = 0; + o->u.v.klass = NULL; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } +/* 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) { + flan_obj *o; + if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) + trap1(TYPE_TRAP, "class instance", "a class tag is a keyword", k); + o = gc_alloc(OBJ_MAP, 0); + o->len = 0; + o->u.v.items = NULL; + o->u.v.cap = 0; + o->u.v.klass = dyn_kw(k); + return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); +} + +/* The shape tag, as a value: the class's name as a keyword, or nil. Never + * traps. Absence is an answer here for the reason it is one in [map_get] — + * asking what class a value is, is a question every value can be asked, and + * an ordinary map, a number and nil all truthfully answer "none". */ +flan_dyn flan_dyn_class_of(flan_dyn v) { + flan_obj *o; + if (flan_dyn_tag(v) != FLAN_DYN_TAG_MAP) return flan_dyn_nil(); + o = dyn_obj(v); + if (o->u.v.klass == NULL) return flan_dyn_nil(); + return dyn_make(BOX_KW, (uint64_t)(uintptr_t)o->u.v.klass); +} + /* ── Keywords ────────────────────────────────────────────────────────── * * One global table, append-only, never freed: a keyword is a *name*, the set @@ -1483,6 +1558,12 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { int64_t i, j; if (x == y) return 1; if (depth >= EQ_DEPTH) return 0; + /* The shape tag is part of the value. Two instances of one class compare + * by their entries as any two maps do; an instance and a plain map with + * the same entries do not, which is Clojure's answer for a record beside + * a map and is the only answer a tag can have if it means anything. An + * identity compare, because both sides are interned entries. */ + if (x->u.v.klass != y->u.v.klass) return 0; if (x->len != y->len) return 0; for (i = 0; i < x->len; i++) { flan_dyn k = x->u.v.items[i * 2]; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 2f95b6b..928e1e9 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -76,6 +76,24 @@ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n); flan_dyn flan_dyn_vec_new(void); flan_dyn flan_dyn_map_new(void); +/* A map carrying a shape tag: what a (defclass point [x y]) constructor + * builds. [k] is the class's name as a keyword and anything else traps. + * + * The tag lives in the object's header and not in an entry of the map, so it + * is invisible to [get], [set], [contains] and [len] — an instance's length + * is its slot count and no key a program can write collides with it. What can + * see it is [flan_dyn_class_of], [flan_dyn_eq] (two values of different + * classes are unequal, and an instance is never equal to a plain map) and + * [flan_dyn_print] (an instance renders as #point{ :x 1 :y 2}). + * + * 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); + +/* 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 keyword: :foo as a run-time value. Interned — the runtime keeps one entry * per distinct name forever, so two keywords with the same bytes are the same * word and equality is an identity compare, never a memcmp. The entries are diff --git a/test/programs/dev-class.flan b/test/programs/dev-class.flan new file mode 100644 index 0000000..d64371a --- /dev/null +++ b/test/programs/dev-class.flan @@ -0,0 +1,26 @@ +;;;; A class and a generic function, for the dev loop rather than for output. +;;;; +;;;; What a session does with this is the question the feature is judged on: +;;;; adding a method to a running program has to reach the call sites that +;;;; were compiled before the method existed. It does, and the reason is that +;;;; a generic is one function — the methods are branches of its body, not +;;;; functions of their own — so a new method is the ordinary redefinition of +;;;; one name, through the cell the call already goes through. +;;;; +;;;; It keeps running rather than returning, for dev-repl.flan's reason: an +;;;; expression typed at the editor is a thunk the agent runs at a frame +;;;; boundary, and a parked program has none. +(import agent "vendor:agent") + +(defclass point [x y]) +(defclass circle [r]) + +(defgeneric area [self] dyn) + +(defmethod area point [p] (* (get p :x) (get p :y))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-class-fallback.sock") + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/programs/dyn-class.flan b/test/programs/dyn-class.flan new file mode 100644 index 0000000..5bc6ed4 --- /dev/null +++ b/test/programs/dyn-class.flan @@ -0,0 +1,137 @@ +;;;; Classes and generic functions, the dyn side's two dispatch styles. +;;;; +;;;; A defclass is a named dyn map with a shape tag. The constructor is the +;;;; class's own name, positional over the slots; the slots are ordinary map +;;;; keys, so get and put are how one is read and written and nothing new was +;;;; needed for either. What the class adds is the tag, which lives in the +;;;; object's header and not in the entries: (len p) is the slot count, no key +;;;; a program can write collides with it, and it shows up in exactly three +;;;; places -- class-of, equality, and the printed form #point{ :x 1 :y 2}. +;;;; +;;;; The two dispatch styles are one mechanism. A defgeneric dispatches on the +;;;; class of its first argument, which is Common Lisp's; a defmulti's body IS +;;;; the dispatch, which is Clojure's. A class dispatcher is the shape tag of +;;;; the first argument as the dispatch function, so the second spells the +;;;; first, and a method is a branch either way. + +(defclass point [x y]) +(defclass circle [r]) + +;; CLOS's half: dispatch on the class of the first argument. The generic +;; declares the parameters and the return type once; a method states neither. +(defgeneric area [self] dyn) + +(defmethod area point [p] (* (get p :x) (get p :y))) +;; A method may name its parameter whatever it likes -- the generic's name is +;; bound to it on the way in. +(defmethod area circle [c] (* 3 (* (get c :r) (get c :r)))) + +;; Clojure's half: the dispatch is a body, over the same parameter list every +;; method has, answering the value the methods are keyed by. +(defmulti describe [thing] dyn (get thing :kind)) + +(defmethod describe :square [s] (get s :side)) +(defmethod describe "round" [s] "a round thing, keyed by a string") +(defmethod describe 7 [s] "the one keyed by a number") +;; The method that answers when no other does. It is :else, which is the word +;; match already uses, and it is the last arm whatever order it is written in. +(defmethod describe :else [s] "something else") + +;; A generic with no :else: a miss signals, and the program answers it. +(defgeneric name-of [self] dyn) +(defmethod name-of point [p] "a point") + +;; A method's parameter names are its own, and the rebinding that gives it +;; them is parallel. [reorder] names them in the generic's order reversed, which +;; a sequential binding would get wrong in the worst possible way -- it would +;; read the name it had just bound and hand the method its first argument +;; twice. [shift] is the same bug one step shorter: [b] there is the +;; generic's second parameter and must not become the first. +(defmulti reorder [a b] dyn (class-of a)) +(defmethod reorder point [b a] [b a]) +(defmulti shift [a b] dyn (class-of a)) +(defmethod shift point [b c] [b c]) + +(defn main [] i32 + (let [p (point 3 4) + c (circle 2)] + ;; The instance is a map, and prints as one with its tag in front. + (println p) + (println (len p)) + (println (get p :x)) + (put p :x 10) + (println (get p :x)) + (println (has-key? p :x)) + (println (has-key? p :nothing)) + (println (get p :nothing)) + + ;; The shape tag, as a value. Every value can be asked; only an instance + ;; answers with a name. + (println (class-of p)) + (println (class-of c)) + (println (class-of {:x 3 :y 4})) + (println (class-of 1)) + (println (class-of nil)) + + ;; Equality takes the tag into account: two instances of one class compare + ;; by their slots, an instance and a plain map with the same entries do + ;; not, and two classes with the same slots are two classes. + (println (= (point 1 2) (point 1 2))) + (println (= (point 1 2) (point 1 3))) + (println (= (point 1 2) {:x 1 :y 2})) + (println (= (circle 2) (circle 2))) + + ;; Class dispatch. Same call site, two classes, two methods. + (println (area p)) + (println (area c)) + + ;; Arbitrary dispatch, over three kinds of dispatch value and the + ;; fallback. The dispatch runs on every call, so the value is whatever + ;; the map holds at the time. + (println (describe {:kind :square :side 5})) + (println (describe {:kind "round"})) + (println (describe {:kind 7})) + (println (describe {:kind :hexagon})) + ;; An empty map on its own is the zero-field struct literal, so it is + ;; bound first -- the dispatch answers nil for a map with no :kind, and + ;; nil finds no method either. + (let [empty {:no :kind}] + (println (describe empty))) + + ;; An instance is an ordinary dyn value: it goes in a vec, keys a map, + ;; and is collected like anything else. + (let [v [p c]] + (println (len v)) + (println (class-of (at v 1)))) + + ;; The renamed parameters, in the generic's own order: the first element + ;; of each answer is the first argument. A sequential rebinding would + ;; print the point twice in the first and lose the 99 in the second. + (println (reorder p 99)) + (println (shift p 99)) + + ;; The miss. No method and no :else, so the generic signals NoMethod, and + ;; handler-case answers the whole form with a value -- the condition + ;; carries the generic's name and the dispatch value that found nothing. + (println (name-of p)) + (println + (handler-case (name-of c) + [(NoMethod [e] (.generic e))])) + ;; The condition carries the dispatch value that found nothing, which for + ;; a defgeneric over a value that is no instance at all is nil. + (println + (handler-case (name-of 42) + [(NoMethod [e] (.value e))]))) + + ;; Instances under the collector: enough of them to pass the 1 MiB floor + ;; many times over, with one live instance in a rooted global. A marker that + ;; lost an instance's slots would free something live and the sum would come + ;; out wrong -- the tag itself is an interned keyword and immortal, which is + ;; why it needs no tracing. + (let [total (point 0 0)] + (dotimes [i 50000] + (let [q (point i "forty-seven bytes of text to fatten each row")] + (put total :x (+ (get total :x) (len q))))) + (println (get total :x)) + (println (class-of total))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index fecf848..bcc7366 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3575,6 +3575,41 @@ level "1" "programs/dyn-map.flan" dyn_map_out; outputs ~x86:true "dyn: maps and keywords, --x86" "programs/dyn-map.flan" dyn_map_out; + (* ── Classes and generic functions, M2 item 6 ──────────────────── + The dyn side's two dispatch styles over one mechanism, at all three + rows because dispatch is a chain of dyn comparisons and the shape tag + is a word in an object header — two things the backends could differ + about and do not. Captured from the running program. The first line + pins the tagged rendering (#point in front of the map the renderer + already wrote, with its space-per-element convention unchanged) and + the 2 after it pins the other half of the decision: the tag is not an + entry, so an instance's length is its slot count. The three nils in + the middle are class-of over a plain map, a number and nil — asking + is not a claim. The 40 and the 12 are class dispatch over two + classes at one call site; the four lines under them are arbitrary + dispatch over a keyword, a string, a number and the :else fallback. + The two bracketed lines are a method whose parameter names are the + generic's reversed and one whose names are shifted along: both answer + first-argument-first, which is what says the rebinding is parallel — + a sequential one prints the point twice in the first and loses the 99 + in the second. + name-of, then nil, are a dispatch miss answered by handler-case: the + generic's name out of the condition, then the dispatch value that + found nothing. The 100000 at the end is 50000 instances allocated + against one live instance, well past the collector's 1 MiB floor. *) + let dyn_class_out = + "#point{ :x 3 :y 4}\n2\n3\n10\ntrue\nfalse\nnil\n:point\n\ + :circle\nnil\nnil\nnil\ntrue\nfalse\nfalse\ntrue\n40\n12\n5\n\ + a round thing, keyed by a string\nthe one keyed by a number\n\ + something else\nsomething else\n2\n:circle\n\ + [ #point{ :x 10 :y 4} 99]\n[ #point{ :x 10 :y 4} 99]\n\ + a point\nname-of\nnil\n100000\n:point\n" + in + outputs "dyn: classes and dispatch" "programs/dyn-class.flan" dyn_class_out; + outputs ~opt:"-O0" "dyn: classes and dispatch, -O0" + "programs/dyn-class.flan" dyn_class_out; + outputs ~x86:true "dyn: classes and dispatch, --x86" + "programs/dyn-class.flan" dyn_class_out; (* ── Per-type descriptors, M2 item 2 ───────────────────────────── The first program anywhere with a dyn field in a struct, which was a refusal until the descriptors landed. It matters at all three rows diff --git a/test/test_dev.ml b/test/test_dev.ml index 0a14909..e8cfbb2 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -4899,6 +4899,91 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]; + (* ── A method added to a running program ─────────────────────── + The one claim classes rest on, made end to end rather than at the + session's report: a generic function compiled with one method gets a + second one delivered into the live process, and the call that goes + through its cell answers with the new method's body. The session test + pins which name is installed; this pins that installing it works. + + Its own daemon over [programs/dev-class.flan], which keeps running so + that an expression has a frame boundary to be run at. *) + let csock = tmp "class.sock" and cout = tmp "class.out" in + (try Sys.remove csock with Sys_error _ -> ()); + let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let cpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-class.flan"; "-s"; csock |] + Unix.stdin cfd Unix.stderr + in + Unix.close cfd; + if not (listening ~pid:cpid csock) then begin + fail "the class daemon %s (%S)" !listen_why + (In_channel.with_open_bin cout In_channel.input_all); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect csock 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 ask code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")" + code) + in + (* Every answer is compared inside the expression rather than read out + of it. A generic answers a dyn, and a dyn value is rendered to the + program's own stdout rather than into the reply's :value — it does + reach a later reply's :output, which is how the dyn-global rows + below read one, but the flush is the next reply's and not this one's. + Asking the running program whether the answer is 12 puts a typed + value in :value and takes the timing out of the test. + + The first ask is retried: the agent's thread is let go only after the + socket is bound, so an early ask is a race with the startup and not a + result. *) + let answered = ref "" in + let asked () = + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + status r = "ok" && (answered := value r; true) + in + if not (await asked) then + fail "the class daemon never reached a frame boundary" + else begin + if !answered <> "1" then + fail "the method the program was built with answered %S" !answered; + (* A circle has no method yet, so the dispatch misses and the generic + signals NoMethod — the answer a program handles, spelled here as + the thing that makes the next step's success mean something. *) + let r = + request c + "(:op \"eval\" :code \"(defmethod area circle [q] (* 3 (* (get q \ + :r) (get q :r))))\" :file \"programs/dev-class.flan\")" + in + if status r <> "ok" then fail "delivering a new method: %s" (said r) + else begin + (* The call site in the generic's own cell now reaches a branch that + did not exist when the process started. *) + let r = ask "(if (= (area (circle 2)) 12) 1 0)" in + if status r <> "ok" then + fail "calling a generic after a method was added: %s" (said r) + else if value r <> "1" then + fail "the added method did not answer 12 (%S)" (value r); + (* And the method that was already there still answers, which is + what says the generic was extended rather than replaced. *) + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + if value r <> "1" then + fail "the original method stopped answering (%S)" (value r) + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ csock; cout ]; + 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_flan.ml b/test/test_flan.ml index 477e57a..753bc77 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1732,6 +1732,144 @@ let () = main_at "a wrong main parameter points at main" "(defn main [n i32] ())"; main_at "a wrong main return type points at main" "(defn main [] bool true)"; + (* ── Classes and generic functions — M2 item 6 ─────────────────── *) + (* A class is a constructor and a shape tag. The constructor is the class's + own name, positional over the slots, and everything that reads or writes + an instance is the dyn map operation that was already there. *) + accepts "a class and its constructor" + "(defclass point [x y])\n\ + (defn main [] i32 (let [p (point 1 2)] (if (= (get p :x) 1) 0 1)))"; + accepts "a class with no slots" + "(defclass marker [])\n(defn main [] i32 (let [m (marker)] 0))"; + accepts "class-of answers nil for anything that is not an instance" + "(defn main [] i32 (if (= (class-of 1) nil) 0 1))"; + (* The constructor is an ordinary function, so its arity is the ordinary + arity check and a wrong one names the class. *) + 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" + "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" + ~needle:"a class slot is a name"; + 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"; + + (* Both halves of the dispatch, and the fact that they are one mechanism: + a defgeneric is a defmulti whose dispatch is (class-of first-argument), + so a method written for a class is a method written for its keyword. *) + accepts "class dispatch" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] (* (get p :x) (get p :y)))\n\ + (defn main [] i32 (if (= (area (point 2 3)) 6) 0 1))"; + accepts "arbitrary dispatch, with a fallback" + "(defmulti describe [x] dyn (get x :kind))\n\ + (defmethod describe :square [s] 1)\n\ + (defmethod describe :else [s] 2)\n\ + (defn main [] i32 (if (= (describe {:kind :round}) 2) 0 1))"; + accepts "a method may name its parameters whatever it likes" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [whatever] (get whatever :x))\n\ + (defn main [] i32 0)"; + (* The rebinding that gives a method its own parameter names is parallel. + A [let] binds in sequence, so the pairwise spelling reads a name it has + just bound: these two type-check either way and the values are what is + wrong, which is why dyn-class.flan is where they are really pinned. What + is pinned here is that both shapes are legal at all. *) + accepts "a method may reverse its generic's parameter names" + "(defmulti g [a b] () (class-of a))\n\ + (defmethod g :else [b a] (println b) (println a))\n\ + (defn main [] i32 0)"; + accepts "a method may shift its generic's parameter names along" + "(defmulti g [a b] () (class-of a))\n\ + (defmethod g :else [b c] (println b) (println c))\n\ + (defn main [] i32 0)"; + accepts "a method may be written above its generic" + "(defclass point [x y])\n\ + (defmethod area point [p] (get p :x))\n\ + (defgeneric area [self] dyn)\n\ + (defn main [] i32 0)"; + (* A generic with no methods at all is legal and always misses; that is a + run-time answer (the NoMethod condition), not a compile-time refusal. *) + accepts "a generic with no methods" + "(defgeneric area [self] dyn)\n(defn main [] i32 0)"; + + rejects_check "a method needs a generic" + "(defclass point [x y])\n(defmethod area point [p] 1)\n\ + (defn main [] i32 0)" + ~needle:"no defgeneric or defmulti names area"; + rejects_check "a method dispatching on an unknown class" + "(defgeneric area [self] dyn)\n(defmethod area square [p] 1)\n\ + (defn main [] i32 0)" + ~needle:"no defclass names square"; + rejects_check "two methods for one dispatch value" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] 1)\n\ + (defmethod area point [p] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for point"; + (* A class's name and its keyword are one value: a class stands for the + keyword its instances carry, so these two methods are the same method + written twice and the second would be dead code. *) + rejects_check "a class and its keyword are one dispatch value" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] 1)\n\ + (defmethod area :point [p] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for :point"; + rejects_check "two :else methods for one generic" + "(defmulti d [x] dyn x)\n\ + (defmethod d :else [x] 1)\n\ + (defmethod d :else [x] 2)\n\ + (defn main [] i32 0)" + ~needle:"already has a method for :else"; + rejects_check "a method's arity is its generic's" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p q] 1)\n\ + (defn main [] i32 0)" + ~needle:"and this method of it takes 2"; + rejects_check "a generic's parameter is a bare name" + "(defgeneric area [self (Ptr i64)] dyn)\n(defn main [] i32 0)" + ~needle:"parameter is a bare name"; + rejects_check "a defgeneric has no body" + "(defgeneric area [self] dyn (class-of self))\n(defn main [] i32 0)" + ~needle:"It has no body"; + rejects_check "a defmulti has one" + "(defmulti describe [x] dyn)\n(defn main [] i32 0)" + ~needle:"the body is the dispatch"; + rejects_check "a defgeneric needs something to dispatch on" + "(defgeneric area [] dyn)\n(defn main [] i32 0)" + ~needle:"dispatches on the class of its first"; + rejects_check "a dispatch value is written out, not computed" + "(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\ + (defn main [] i32 0)" + ~needle:"is written out rather than computed"; + (* A method has no return slot: the generic states the type once, for all + of them. What that means for anyone writing the defn spelling by habit + is that the slot they would have written is read as the first form of + the body, and a lone type name there is an unknown name. *) + rejects_check "a method has no return slot" + "(defclass point [x y])\n\ + (defgeneric area [self] dyn)\n\ + (defmethod area point [p] dyn (get p :x))\n\ + (defn main [] i32 0)" + ~needle:"dyn"; + (* A class and a function are one namespace, as a defn and a defvar are: + the constructor is a defn, so the collision is the ordinary one. *) + rejects_check "a class collides with a function of the same name" + "(defclass point [x y])\n(defn point [] i32 0)\n(defn main [] i32 0)" + ~needle:"point"; + (* ── Unconstrained operators, and everything past milestone 2 ──── *) (* M2 queue item 5: typed = and != grow strings, bytewise. Ordering does not — there is no collation the language has picked, so < stays diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index 04bb183..ad37a9d 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -195,6 +195,14 @@ let corpus = amount of reading the offsets can. *) "programs/dyn-struct.flan", []; "programs/dyn-map.flan", []; + (* Classes, M2 queue item 6. A class instance is a map with one more word + in its header, so what this adds over [dyn-map] is that word: it is + written by a constructor, read by class-of, compared by equality and + printed by both renderers, and it is the one field in an object that + the marker deliberately does not trace — an interned keyword entry is + immortal and is not a collector object. If that reasoning is wrong, + 50000 instances past the one-megabyte floor is where ASan says so. *) + "programs/dyn-class.flan", []; (* nil <-> None at (Option T), M2 queue item 4: an Option's tag is read with a raw [Field] the surface language never writes (check.ml's [box_option]/[unbox_option], the same access Render's structural diff --git a/test/test_session.ml b/test/test_session.ml index 7351a61..6dff651 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -303,6 +303,53 @@ let () = | _ -> () | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m); + (* ── A method added to a running program ──────────────────────── + The dev loop is what classes were built for, so this is the case that + decides whether the feature is usable at all. A generic function is one + top-level name whose body dispatches, and a method is a branch of it — + so adding a method has to install the *generic's* body, not a function + of the method's own, and it has to do it through the cell the call site + already goes through. If it reported only the method's own declaration + name, [report]'s compiled call to [area] would go on running the body it + was built with and the new method would be invisible. *) + let t, _ = Session.create ~file:"programs/dev-class.flan" () in + let c = Session.eval t "(defmethod area circle [c] (* 3 (* (get c :r) (get c :r))))" in + if not c.Session.installs then + fail "adding a method had nothing to install"; + if not (List.mem "area" c.Session.fns) then + fail "adding a method installed %s, not the generic's body" + (String.concat " " c.Session.fns); + (* Redefining one is the same path, and the declaration is replaced rather + than appended: a second (defmethod area circle ...) is not a duplicate + method, it is this one again. *) + let c = Session.eval t "(defmethod area circle [c] 0)" in + if not (List.mem "area" c.Session.fns) then + fail "redefining a method installed %s" (String.concat " " c.Session.fns); + (* And it stays in the session: the class the method dispatches on, the + generic it extends, and the method itself are all still there for the + next form to check against. *) + (match Session.eval t "(defmethod area point [p] (+ (get p :x) (get p :y)))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a method added earlier left the session broken: %s" m); + (* A method for a class that is not there is refused, and refusing leaves + the session exactly as it was — the same rule every other refusal here + follows. *) + (match Session.eval t "(defmethod area square [s] 1)" with + | _ -> fail "a method dispatching on an unknown class was accepted" + | exception Loc.Error _ -> ()); + (* A whole new class and a method for it, in one form — the shape of + actually growing a program in the loop. The constructor is a name the + process was never built with, so it goes through the registry the way + any added function does, and the generic is redefined around it. *) + let c = + Session.eval t + "(do (defclass square [s]) (defmethod area square [q] (* (get q :s) (get q :s))))" + in + if not (List.mem "square" c.Session.fns && List.mem "area" c.Session.fns) then + fail "adding a class and a method installed %s" + (String.concat " " c.Session.fns); + (* A file with imports, re-evaluated whole — the C-c C-k case. The session keeps the *expanded* declarations, so the package's names are replaced in place rather than appended a second time and rejected as duplicates. *)