diff --git a/TODO.org b/TODO.org index cbacacb1..01a819fc 100644 --- a/TODO.org +++ b/TODO.org @@ -147,14 +147,7 @@ CLOSED: [2026-09-25] =f64-inf=, =f64-nan=, =f32-inf= and =f32-nan= are names the checker supplies (=Check.special_float=), reached only after every local, global and function has missed, so a program's own binding of one wins. Negative infinity is -=(- 0.0 f64-inf)=: the decision wrote =(- f64-inf)=, and there is no unary minus. -Rules out Clojure's =##Inf= reader literal. - -** TODO (!= x x) is false for a NaN -=!== on floats is LLVM's ordered =one= on both backends (=lib/emit.ml= =fcmp_op=, -=lib/x86.ml= =float_cc=), so =(!= f64-nan f64-nan)= is =false= where C, Odin and -IEEE 754 say =true=; =(not (= x x))= is the only NaN test that works. Changing it -to =une= is a decision about what =!== means. +=(- f64-inf)=. Rules out Clojure's =##Inf= reader literal. ** DONE A u64 constant above 2^63 cannot be written in decimal CLOSED: [2026-09-25] @@ -162,8 +155,8 @@ An integer written at or above 2^63 — a decimal up to 2^64 - 1, or hex with th top bit set — reads as =Form.UInt=, its pattern and its spelling. It is accepted where the type is =u64=, a =(u64 ...)= cast included, and refused everywhere else in the spelling it was written in. Hex with the top bit set was accepted as a -negative at any integer type before this; it is refused now too. A negative -decimal is still a =u64= bit pattern. A cast's integer literal that does not fit +negative at any integer type before this; it is refused now too. A cast's +integer literal that does not fit =i32= is checked at the cast's type; one that fits keeps the =i32= default, so =(u32 -1)= still means what it did. A wide literal passed to a macro as an argument comes back wide: it crosses as an =Int= with a token in the unused @@ -571,13 +564,10 @@ dispatch values. With single dispatch on literal values there is no specificity question, and inheritance or multiple dispatch would create one. Unknown-slot checking needs class-typed tracking the dyn side deliberately does not have. -** NEXT update-instance-for-redefined-class, the user hook -Decided 2026-09-25: build it after typed class slots land, shaped for the REPL — written and installed from a live session as a one-time "here is how to migrate this", without restarting. It receives the instance with the added and discarded slots and their old values, and runs at each instance's lazy migration. A hook that signals parks in the break buffer with a restart that falls back to name-matching migration. -Left out of v1 because name matching is the half that makes redefinition usable -and the hook is what makes it expressive. The obvious spelling is a generic riding -the dispatch that exists, and the migration already computes both the added and -the discarded lists. Rolling a failed migration back becomes a real question the -day this lands. +** DONE update-instance-for-redefined-class, the user hook +CLOSED: [2026-09-25] +Taking =migrate-by-name= keeps the name-matched instance, not SBCL's obsolete one, +and retries nothing; a transfer from the method to a restart below it traps. ** DONE The module system stays directory-as-package Several files in one directory are one module; a loose file is a module of one, @@ -957,19 +947,13 @@ type an expression cannot hold, such as =(Fn [i32] ())=, is parsed as ** DONE An array literal cannot say it is [f32] CLOSED: [2026-09-25] -With nothing outside an array literal naming its element type, the first -element's type is the want for the rest, so =[(f32 1.0) 2.5]= is a =[2 f32]=. A -refusal of a later element carries a note at the first saying it set the type. -Rules out a =1.0f= suffix for now. +=(the [f32] [1 2.5])= names the element type; with nothing naming one, a literal +element takes the other elements' type. Rules out a =1.0f= suffix for now. -** NEXT A let binding takes no type annotation -Decided 2026-09-25: =(the T expr)=, Common Lisp's special operator, gives any expression its want; checked at compile time like any other want, and it compiles to nothing. =let= is unchanged. On a =dyn= operand it is refused, naming the cast. The refusals that say "annotate the binding" — =None=, an empty =[]=, and =(zeroed)=/=(filled)=/=(dead-beef)= with no want — suggest it instead, because today their suggestion cannot compile. -Everything under the surface is there — the binding carries a type slot and the -checker consumes it as the want — and only the way it is written is open, because -=let= is a flat list of pairs and cannot disambiguate by count. No longer the -blocker it was, since =(array 4 T)= answers the case that raised it. plan.org's -rule is "annotate function signatures, infer locals", so a general annotation is a -deliberate absence. +** DONE A let binding takes no type annotation +CLOSED: [2026-09-25] +=(the T expr)= gives any expression its want and =let= stays a flat list of +pairs. Rules out a type slot in =let=. ** NEXT A read-only slice type Decided 2026-09-25: =[const u8]=, Zig's spelling in Flan's brackets. =bytes-view= answers one and a =set= through it is a compile error; a =[T]= converts to =[const T]= and not back, and the prelude's read-only functions take it. =const= is reserved as a name, since =[n T]= accepts a constant's name for =n=. @@ -1025,10 +1009,9 @@ died in the backend as a redefinition of a symbol, a message with no source location. ** DONE A u64 literal is its 64-bit pattern -The cost of accepting the pattern is that a negative decimal literal is accepted -as a =u64=, because the reader records the value and not how it was written. -Narrower unsigned types keep the strict check, which is where a typo like =300= -for a =u8= shows up. +A negative literal fits no unsigned type, u64 included; =(u64 -1)= is how the +pattern is written, and a constant folds it. Rules out a negative decimal as a +u64's bit pattern. ** DONE A folded constant does not skip the range check The folding pass makes its own call to the range test, because a global's @@ -1090,11 +1073,6 @@ An unknown call whose near miss is a value — =(context-allocator)= against =context/allocator=, or a global — says the name is a value written without parentheses, and names no call at all when the call had arguments. -** NEXT (max-value T) and (min-value T) -Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's -max(T), valid at any numeric type or a numeric?-bounded variable. For a float, -min-of is the most negative finite value. - ** NEXT (Ptr const T), the pointer beside [const T] Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which nothing writes through; (Ptr T) widens to it and never back; a C parameter @@ -1422,7 +1400,7 @@ sibling". ** DONE A redefined defclass migrates its instances lazily CLOSED: [2026-09-20] -CLHS 4.3.6 minus the user hook. Nothing is enumerated and no heap is walked — the +CLHS 4.3.6. Nothing is enumerated and no heap is walked — the redefinition is constant time and each instance pays once, at its next touch. Neither printer migrates, so a stale instance shows its old slots to the editor until something touches it. The registry is advisory: a key the class never @@ -1575,14 +1553,19 @@ incarnation it was made for; every use compares the incarnation, so a destroyed arena traps whether or not a later arena-new reused its record. Rules out static tracking of destroy, which is move semantics. -** NEXT A mixed array literal with no want is a dyn vector -Decided 2026-09-25: with nothing expected of it, an array literal whose elements -agree (numbers widening together) is typed; one whose elements mix — [10 "Hi"], -[nil 1] — is a dyn vector. (the [T] ...) forces a typed one, and a want from -context still wins. Replaces the first-element carry-over. +** DONE A mixed array literal with no want is a dyn vector +CLOSED: [2026-09-25] +Elements that agree, numbers meeting at the wider, are typed; elements that mix +are a dyn vector, except numbers with no common type, which are refused. Rules +out the first element typing the rest. * Dev loop +** TODO A prelude function shadowed live is reached by the prelude's own calls +A defn of a prelude function's name sent to a running =flan dev= installs into the +host's cell for that name, so the prelude's calls compiled into the host follow it; +a rebuild gives them the prelude's again, as =Check.shadow_prelude= intends. + ** DONE The dev loop, step 1: the reload primitive A list of top-level forms is recompiled and installed into a running process, and call sites compiled before those forms existed follow them through an indirection @@ -2041,18 +2024,10 @@ specification's own branch — the flag is the command and the printed shape is error pattern, so anyone who wants one has the four lines, and the manual carries them. -** NEXT defclass slots take types, checked on write -Decided 2026-09-25: slots are name/type pairs checked on write; an untyped slot stays legal and holds any =dyn=. A migration keeps a stored value that no longer fits the new type, warns once, and the next write is checked. One lane with the =set= entry below. -=(defclass State [pause bool step bool])= reads as four untyped slots and -reports a duplicate =bool=. Wanted: the slot list is name/type pairs, as CLOS -does it. The type is a declaration about the values and not a layout — an -instance stays a map, so redefinition and lazy migration are unchanged. SBCL -checks it on write (=src/pcl/slots.lisp:160=, the typecheck before the store), -which is where the bad value is, so =put= is the site here. - -Open: what migration does with a stored value that no longer fits a changed -slot type, and whether an untyped slot stays legal (it should — =dyn= is a type -and writing nothing should mean it). +** DONE defclass slots take types, checked on write +CLOSED: [2026-09-25] +Constructor parameters stay dyn and each store checks at run time; an int widens +into a float slot only if it round-trips, and nil fits only an (Option T) slot. ** DONE println takes up to a second to appear CLOSED: [2026-09-25] @@ -2064,15 +2039,10 @@ are gone. The poll stays for the stop and park edges. Rules out a faster poll and pushes to clients that did not ask for them. See docs/BUILT.md, "Output and the watch table are pushed". -** NEXT set writes a class slot; put is for maps -Decided 2026-09-25: as written; one lane with typed slots. -=put= exists because an absent map key has no location to store into, which is -why =(get m k)= is refused as a place (=lib/parse.ml:1159=). A class instance is -not in that situation: its slots are fixed by the =defclass=, so a declared slot -always exists and =(set (get state :pause) true)= is a field store like -=(set (.velocity g) 0.0)=. Make =set= take it, and leave =put= to maps, where -insertion is real. Writing an undeclared slot through =set= is then a refusal -naming the class. +** DONE set writes a class slot; put is for maps +CLOSED: [2026-09-25] +=put= on an instance still checks a declared slot's type and still inserts an +undeclared key; only =set= refuses one, since a slot it writes has to exist. ** NEXT update: change a place by applying a function to it Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place. diff --git a/bin/main.ml b/bin/main.ml index f4564016..0f1db3e2 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -362,6 +362,7 @@ let () = p.globals; List.iter (fun (f : Flan.Tast.fn) -> + if not (Flan.Check.internal_name f.name) then Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name (String.concat " " (List.map Flan.Types.to_string f.params)) @@ -736,6 +737,8 @@ let () = if List.mem warn_memory_flag rest then print_memory_warnings ~file:path p) in + Flan.Build.need_main ~file:path ~doing:"flan build has nothing to link" + f.program; ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; dev; debug; sanitize; target; x86; @@ -915,6 +918,8 @@ let () = (Printf.sprintf "flan-run-%d" (Unix.getpid ())) in let f = Flan.Front.linked ~all:true path in + Flan.Build.need_main ~file:path ~doing:"flan run has nothing to run" + f.program; ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; debug; sanitize; x86; diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 05b2747c..e297b3a7 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -129,7 +129,7 @@ (defconst flan--special '("quote" "do" "let" "if" "when" "cond" "and" "or" "while" "until" "break" "continue" "return" "set" - "array" "array-fill" "array-gen" "match" "fn" "dotimes" "loop" "recur" + "array" "array-fill" "array-gen" "the" "match" "fn" "dotimes" "loop" "recur" "defer" "some" "try" "signal" "error" "handler-bind" "handler-case" "restart-case" "invoke-restart") "The heads `Parse.form' dispatches on — the forms with a meaning of their own. diff --git a/lib/ast.ml b/lib/ast.ml index 67902059..7aaf7f76 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -126,6 +126,10 @@ and expr_kind = dimension; [ArrayFill]'s is the element value itself, evaluated once. *) | ArrayFill of len list * expr | ArrayGen of len list * expr + (* (the T e) — [e] checked with [T] as its expectation, Common Lisp's + special operator. A binding has no type slot, and this is what gives any + expression one; it compiles to [e]. *) + | The of texpr * expr (* These bind names or alter control flow, so none of them can be a call. *) | Fn of string list * expr list (* (fn [x y] ...) *) (* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and @@ -199,6 +203,11 @@ and place = | Pfield of expr * string (* (set (.hp e) v) *) | Pindex of expr * expr list (* (set (at grid r c) v) *) | Pderef of expr (* (set (deref p) v) *) + (* (set (get inst :slot) v) — a class instance's declared slot. A map has + no such place: an absent key has no location, and [put] is how one is + written. Which of the two a value is, is known only at run time, so + this is a runtime store that refuses a plain map. *) + | Pslot of expr * expr and arm = { pat : pattern; body : expr list; aloc : Loc.t } @@ -283,8 +292,10 @@ and decl_kind = | Defvar of string * texpr option * init * reinit | Defconst of string * texpr option * expr (* ── The dyn side's classes and generic functions ────────────────── - None of these four reaches [Check]. [Classes.expand] turns the whole set - into ordinary [Defn]s before pass one collects anything, the way [Shim] + None of these four reaches [Check]'s signature pass. [Classes.expand] + turns the generic forms into ordinary [Defn]s before pass one collects + anything, and [Check.pair_decls] turns a [Defclass] into its constructor + once its slot vector can be paired, the way [Shim] already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a constructor, and a generic function is one function whose body is a dispatch over the methods written for it. @@ -294,8 +305,11 @@ and decl_kind = anywhere in the file, or arrive at a reload long after the generic did, and a macro sees one form. *) - (* (defclass point [x y]) — the slot names, in constructor order. *) - | Defclass of string * (string * Loc.t) list + (* (defclass point [x y]) or (defclass state [pause bool step bool]) — the + slot vector, in constructor order, left unpaired for the reason a + [defn]'s is: [[x y]] is two slots or one slot [x] of type [y] depending + on whether [y] names a type. [Check.pair_decls] pairs it. *) + | Defclass of string * pitem list (* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value is the shape tag of the first argument. The parameter vector and the return slot are a [defn]'s, and there is no body. *) @@ -414,6 +428,7 @@ let map_children f (e : expr) : expr = | Pfield (x, n) -> Pfield (ex x, n) | Pindex (x, is) -> Pindex (ex x, List.map ex is) | Pderef x -> Pderef (ex x) + | Pslot (x, k) -> Pslot (ex x, ex k) in let kind = match e.e with @@ -438,6 +453,7 @@ let map_children f (e : expr) : expr = subexpressions. The dimensions are [len]s and hold none. *) | ArrayFill (ds, v) -> ArrayFill (ds, ex v) | ArrayGen (ds, f) -> ArrayGen (ds, ex f) + | The (t, x) -> The (t, ex x) | Fn (ps, es) -> Fn (ps, List.map ex es) | Dotimes (l, n, b, es) -> Dotimes (l, n, diff --git a/lib/build.ml b/lib/build.ml index 899310d2..70e94449 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -744,6 +744,22 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () = end; obj +(* A program with no [main] builds every function and then fails at the link, + as an undefined reference from the C startup code — a message about crt1.o + for a mistake in the .flan file. Asked here, by the commands that make an + executable, rather than inside [executable], whose callers include hosts + and tests that supply their own [main]. *) +let need_main ~file ~doing (p : Tast.program) = + if not (List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns) + then + failwith + (Printf.sprintf + "%s has no main, so %s. A program starts at a function named main, \ + for example:\n\n\ + \ (defn main [] i32\n\ + \ 0)" + file doing) + (* [csrcs] and [lflags] come from the imported packages (see [Load]): the C shim a package binds through, and the arguments needed to link the library it binds to. diff --git a/lib/check.ml b/lib/check.ml index 80b92b58..3f29bd6f 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -63,6 +63,22 @@ type binding = { bwhat : string option; } +(* A class slot's type: what a value stored into it is checked against. A + dyn value's tag is all a store can ask of it, so the scalar types a tag + answers for, an instance of a class, and (Option T) of either, which + admits nil as well. *) +type slot_ty = + | Sany (* no type written: any dyn value *) + | Sval of Types.t (* bool, an integer type, f32, f64, string *) + | Sclass of string (* an instance of this class *) + | Sopt of slot_ty (* nil, or a value of the inner type *) + +let rec slot_text = function + | Sany -> "dyn" + | Sval t -> Types.to_string t + | Sclass c -> c + | Sopt s -> "(Option " ^ slot_text s ^ ")" + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -181,6 +197,13 @@ type env = { flag is what lets [resolve_name] say the honest thing in each place instead of a suggestion that cannot be followed. *) mutable in_field : bool; + (* Every [defclass], by name: its slots in constructor order, each with the + type a value stored in it must have — [Types.Dyn] for a slot written + with no type. Filled by [pair_decls], which is where a slot vector is + first readable. The type is a declaration about the values and not a + layout: an instance is a dyn map whatever this says, and what reads it + is [class_spec], which is what the runtime checks a store against. *) + classes : (string, (string * slot_ty) list) Hashtbl.t; (* The bindings a dev build counts at every call: [Shim.resources], read off the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) @@ -214,6 +237,7 @@ let new_env () = { tvpreds = []; chain = []; in_field = false; + classes = Hashtbl.create 8; tracks = Hashtbl.create 16; } @@ -1545,7 +1569,9 @@ let dyn_param_or_typo env n loc = parameters are lowercase" n -let pair_params env (items : Ast.pitem list) : Ast.field list = +let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) + : Ast.field list = + let is_type_name env n = is_type_name env n || also n in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] @@ -1574,10 +1600,122 @@ let pair_params env (items : Ast.pitem list) : Ast.field list = in go items +(* A class slot's type, held to the set a stored dyn value can be checked + against. A class's name is a type here, and only here: it is not a type + anywhere else in the language, since an instance is a dyn value. Every + other type a slot could name — a struct, a Vec, a pointer — does not cross + into dyn at all, so a slot of one could never be written. *) +(* A class named in [cls]'s slot vector: [n] as written, or [n] in [cls]'s own + package, since [Load] leaves a bare name in a slot vector unqualified. *) +let class_named ~classes cls n = + (* The class's own package first: an importer may declare a class of the + same bare name, and a slot the package wrote means the package's. *) + let own = + match String.rindex_opt cls '/' with + | Some i -> + let q = String.sub cls 0 (i + 1) ^ n in + if List.mem q classes then Some q else None + | None -> None + in + match own with + | Some _ -> own + | None -> if List.mem n classes then Some n else None + +let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = + let refuse what = + Loc.failk "check/slot-type" t.Ast.tloc + "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ + which can be checked as bool, an integer type, f32, f64, string, a \ + class, or (Option T) of one of those. Write one of those, or leave the \ + type out and the slot holds any dyn value: [%s]" + fname cls what fname + in + match t.Ast.t with + | Ast.Tname n when class_named ~classes cls n <> None -> + Sclass (Option.get (class_named ~classes cls n)) + | Ast.Tapp ("Option", [ inner ]) -> + (match slot_of env ~classes cls fname inner with + | (Sval _ | Sclass _) as s -> Sopt s + | Sany -> refuse "(Option dyn)" + | Sopt _ as s -> refuse ("(Option " ^ slot_text s ^ ")")) + | _ -> + (match resolve env t with + | Types.Dyn -> Sany + | (Types.Bool | Types.Int _ | Types.Float _ | Types.String) as t -> Sval t + | other -> refuse (Types.to_string other)) + +(* The type's word in the string the runtime reads: the scalar type's name, + [#name] for a class, [?] in front for an Option. See [slot_type_of] in + runtime/flan_dyn.c, which is the reader. *) +let rec slot_word = function + | Sany -> "" + | Sval t -> Types.to_string t + | Sclass c -> "#" ^ c + | Sopt s -> "?" ^ slot_word s + +(* What the runtime is told a class is: one line per slot, in constructor + order, the slot's name and then its type's word after a space — no type + for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the + constructor and to [flan_dyn_class_def] from a reload, so the two cannot + describe one class differently. *) +let class_spec_of (slots : (string * slot_ty) list) = + String.concat "\n" + (List.map + (fun (n, t) -> match t with Sany -> n | t -> n ^ " " ^ slot_word t) + slots) + +let class_slots env n = Hashtbl.find_opt env.classes n + +(* A class's slot vector, paired by [pair_params]'s rule with the program's + class names counted as types — so [[owner point]] is one slot holding a + point. + + A lowercase name after a name that is neither a type nor a class is a + second untyped slot, which is the rule for a [defn]'s parameters and is + not changed here. In a vector that types none of its slots that is the + plain reading — [[x y]] is two slots and says nothing more. In one that + types some of them, two untyped names side by side are as likely a type + nobody has declared, so that is said, at the second name, and the slot + stays what the rule makes it. *) +let pair_slots env ~classes cls (items : Ast.pitem list) : Ast.field list = + let fields = + pair_params ~also:(fun n -> class_named ~classes cls n <> None) env items + in + let untyped (f : Ast.field) = + match f.Ast.fty.Ast.t with Ast.Tname "dyn" -> true | _ -> false + in + let written_dyn = + List.exists (function Ast.Pname ("dyn", _) -> true | _ -> false) items + in + if List.exists (fun f -> not (untyped f)) fields && not written_dyn then begin + let rec scan = function + | (a : Ast.field) :: ((b : Ast.field) :: _ as rest) -> + if untyped a && untyped b then + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " b.Ast.floc + (Printf.sprintf + "%s reads as a slot of %s with no type, because no type or \ + class is named %s. If it was meant as the type of %s, \ + declare it; if it is a slot, write its type or write \ + [%s dyn] to say it holds any value" + b.Ast.fname cls b.Ast.fname a.Ast.fname b.Ast.fname)); + scan rest + | _ -> () + in + scan fields + end; + fields + (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) let pair_decls env (decls : Ast.decl list) : Ast.decl list = + let classes = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) + decls + in let fn (f : Ast.fn) = match f.Ast.praw with | None -> f @@ -1586,6 +1724,18 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = List.map (fun (d : Ast.decl) -> match d.Ast.d with + (* A class's slot vector is paired here and nowhere earlier, for the + reason a [defn]'s is, and its constructor is written from the + pairs — [Classes.expand] left the declaration as it was for exactly + this. *) + | Ast.Defclass (n, items) -> + let slots = pair_slots env ~classes n items in + Hashtbl.replace env.classes n + (List.map + (fun (f : Ast.field) -> + (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) + slots); + Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } @@ -2074,12 +2224,20 @@ let mk loc ty e : Tast.expr = { Tast.e; ty; loc } let unit_at loc = mk loc Types.Unit Tast.Unit +(* The compiler temp an [and] leaves in its else arm; see [check_if]. *) +let and_sentinel (x : Ast.expr) = + match x.Ast.e with + | Ast.Var n -> String.length n > 4 && String.sub n 0 4 = "and~" + | _ -> false + (* Integer arithmetic over literals alone, folded. Unlike [const_int] no name is read: a defconst has a type of its own, and only an untyped constant may stand at a type variable. *) let rec literal_arith (e : Ast.expr) : int64 option = match e.Ast.e with | Ast.Int n -> Some n + | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> + Option.map Int64.neg (literal_arith x) | Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) -> let step a b = match op with @@ -2098,6 +2256,10 @@ let rec literal_arith (e : Ast.expr) : int64 option = (literal_arith x) (y :: rest) | _ -> None +(* A value with no type until one is asked of it: a literal, or arithmetic + over literals alone. *) +let lone_literal (e : Ast.expr) = is_literal e || literal_arith e <> None + (* The environment for a lifted body, built once its own body has been checked and [caught] is therefore final. spec-memory.md's case 2, and the whole of @@ -3571,6 +3733,28 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let tail = ctx.tail in ctx.tail <- false; match e.Ast.e with + (* A negative literal in a generic body, at an instantiation that made it + unsigned. The cast the ordinary refusal names would be wrong at every + other type the function is called at, so the fix is one that needs no + negative number at all, and the refusal says which call asked. *) + | Ast.Int n + when Int64.compare n 0L < 0 && ctx.env.chain <> [] + && (match want with + | Some (Types.Int k) -> not (Types.signed k) + | _ -> false) -> + let t = Option.get want in + let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in + let var = + match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with + | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) + | None -> Types.to_string t + in + Loc.failk literal_at_want loc + ~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ] + "%Ld does not fit in %s, which holds no negative number, and %s is called \ + at %s — the body has to work at every type it is called at, so write \ + it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" + n (Types.to_string t) gname var (Int64.neg n) n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.UInt (n, s) -> wide_literal loc ~want n s | Ast.Byte b -> @@ -3669,12 +3853,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in + (* A class's constructor stores through [flan_dyn_slot_init], which is + the plain store plus the slot's type check, worded for the + constructor rather than for a [put] nobody wrote. *) let sets = List.map - (fun (k, v) -> - rt loc Types.Unit "flan_dyn_map_set" - [ mval; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + (fun ((k : Ast.expr), v) -> + let args = + [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ] + in + (* The key's location is the slot's, in the defclass: the + constructor has no other place of its own to name. *) + if tag = None then rt loc Types.Unit "flan_dyn_map_set" args + else rt loc Types.Unit "flan_dyn_slot_init" (args @ [ here k.Ast.loc ])) kvs in (* A shape tag, if this is the literal a class's constructor was written @@ -3685,8 +3876,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match tag with | None -> rt loc Types.Dyn "flan_dyn_map_new" [] | Some cls -> + (* The class's slots and their types ride along, so the first + instance built registers the class with the runtime and every + store after it — this literal's own included — is checked. A + class registered already, by an earlier instance or by a reload, + keeps what it has: redefining one is a reload's business. *) + let spec = + match Hashtbl.find_opt ctx.env.classes cls with + | Some slots -> class_spec_of slots + | None -> "" + in rt loc Types.Dyn "flan_dyn_map_new_class" - [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ] + [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ]; + mk loc Types.String (Tast.Str spec) ] in expect ctx loc ~want (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) @@ -3805,6 +4007,23 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end + (* (set (get inst :slot) x) — a class instance's declared slot. A call and + not a place for [flan_dyn_set_at]'s reason: the runtime has to look at + the value to know it is an instance, which of its slots the key names, + and whether [x] fits the type that slot was declared with, and it traps + on each with a sentence of its own. A typed map has no such place; its + entries are written with [put]. *) + | Ast.Set (Ast.Pslot (target, k), v) -> + let target = check ctx target in + if target.Tast.ty <> Types.Dyn then + fail loc + "(get m k) is a place only on a class instance, and this is %s. A \ + map's entries are written with put" + (Types.to_string target.Tast.ty); + let k = check ctx ~want:Types.Dyn k in + let v = check ctx ~want:Types.Dyn v in + expect ctx loc ~want + (rt loc Types.Unit "flan_dyn_slot_set" [ target; k; v; here loc ]) | Ast.Set (p, v) -> let p, pty = check_place ctx loc p in let v = check ctx ~want:pty v in @@ -3826,18 +4045,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = {:xs [1 2]} mean what it reads as. Everywhere else brackets stay the fixed-array literal they always were. *) | Ast.Arr items when want = Some Types.Dyn -> - let v = fresh_slot ctx Types.Dyn in - let vval = mk loc Types.Dyn (Tast.Local v) in - let pushes = - List.map - (fun x -> - rt loc Types.Unit "flan_dyn_push" - [ vval; check ctx ~want:Types.Dyn x; here loc ]) - items - in - mk loc Types.Dyn - (Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ], - pushes @ [ vval ])) + dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items) | Ast.Arr items -> check_arr ctx ~want loc items (* (array 4 rl/Vector2). Parse already assembled the whole array type, so there is nothing to infer: resolve it and hand back its all-bytes-zero @@ -3852,6 +4060,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = fail loc "this is a type, and a value is wanted here" | Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v | Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f + | Ast.The (t, v) -> check_the ctx ~want loc t v | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms (* Constant integer arithmetic where a type variable is wanted is folded to the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever @@ -4069,24 +4278,34 @@ and wide_literal loc ~want n s = (* Arithmetic wraps, but a literal that does not fit its type is a typo, not a wrap — 300 is never what someone meant by a u8. *) -and in_range loc k n = +and in_range ?(pattern = false) loc k n = let bits = Types.bits k in let ok = if Types.signed k then bits = 64 || (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0 && Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0) - else if bits = 64 then - (* A literal at or above 2^63 is a [UInt] and never reaches here; see - [wide_literal]. A negative decimal is accepted as a u64's bit pattern, - which is a settled rule. Narrower unsigned types keep the strict - check, which is where a typo like 300 for a u8 actually shows up. *) - true + (* A literal at or above 2^63 is a [UInt] and never reaches here as a + literal; see [wide_literal]. [pattern] is the folded-constant path, + which holds a u64 as its 64-bit pattern and cannot tell 2^64 - 1 from + -1, so there every pattern is a u64. *) + else if bits = 64 then pattern || Int64.compare n 0L >= 0 else Int64.compare n 0L >= 0 && Int64.compare n (Int64.shift_left 1L bits) < 0 in if ok then n + else if Int64.compare n 0L < 0 && not (Types.signed k) then + (* A negative number at an unsigned type is never the value it reads as. + The cast is how to ask for the bit pattern, and names what it is. *) + let mask = + if bits = 64 then -1L else Int64.sub (Int64.shift_left 1L bits) 1L + in + let tn = Types.ikind_name k in + Loc.failk literal_at_want loc + "%Ld does not fit in %s, which holds no negative number — write (%s %Ld) \ + for the %s with the same bits, %Lu" + n tn tn n tn (Int64.logand n mask) else Loc.failk literal_at_want loc "%Ld does not fit in %s" n (Types.ikind_name k) @@ -4129,8 +4348,8 @@ and var ctx ?(qualified = false) loc ~want name = fail loc "expected %s, found None" (Types.to_string other) | _ -> fail loc - "nothing here says what None is an Option of — annotate the \ - function's return type or the binding") + "nothing here says what None is an Option of — use it where an \ + Option is expected, or name one, as in (the (Option i32) None)") (* spec-memory.md puts the allocator in the calling convention as [context/allocator] and [context/temp]. They read as names rather than calls because that is how the spec writes them, and they are dynamic @@ -5321,6 +5540,27 @@ and check_if ctx ?(tail = false) ?want loc c t e = no value on the missing side. `when` desugars to this. *) let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) + (* Two literal arms meet at the wider of their own types, as two literal + elements of an array do: [(if c 1 2.5)] is an f64. *) + | Some e + when want = None && lone_literal t && lone_literal e + && (match literal_join ctx t e with + | Some j -> not (Types.equal j (Types.Int Types.I32)) + | None -> false) -> + let want = literal_join ctx t e in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in + let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want e)) in + mk loc t.Tast.ty (Tast.If (c, t, e)) + | Some e when want = None && lone_literal t && not (lone_literal e) + && not (and_sentinel e) -> + (* A literal has no type of its own until something asks, so with no + expectation the other arm decides: [(if c 4000000 n)] over an i64 [n] + is an i64, as [(+ 4000000 n)] is. *) + let e = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in + let twant = if e.Tast.ty = Types.Never then None else Some e.Tast.ty in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:twant t)) in + let ty = if e.Tast.ty = Types.Never then t.Tast.ty else e.Tast.ty in + mk loc ty (Tast.If (c, t, e)) | Some e -> let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in (* With no expectation the then-branch supplies one for the else-branch, @@ -5344,12 +5584,6 @@ and check_if ctx ?(tail = false) ?want loc c t e = sentinel in the then arm, so every operand is already blamed at its own location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) - let and_sentinel (x : Ast.expr) = - match x.Ast.e with - | Ast.Var n -> - String.length n > 4 && String.sub n 0 4 = "and~" - | _ -> false - in let e = match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with | v -> v @@ -5371,6 +5605,18 @@ and check_if ctx ?(tail = false) ?want loc c t e = in mk loc ty (Tast.If (c, t, e)) +(* The type two literals meet at, each at its own type — a wide integer at + u64, which is the only type that holds one. *) +and literal_join ctx (a : Ast.expr) (b : Ast.expr) = + let own (x : Ast.expr) = + match x.Ast.e with + | Ast.UInt _ -> Some (Types.Int Types.U64) + | _ -> probe ctx x.Ast.loc (fun () -> (check ctx x).Tast.ty) + in + match own a, own b with + | Some x, Some y -> Types.join x y + | _ -> None + (* Whether a name would reach a callee if it were called — a global function, a generic, or a local holding a function value. The three sources [named_call] itself consults, in its own order; builtins are deliberately not among them, @@ -5696,63 +5942,31 @@ and check_arr ctx ~want loc items = | Some (Types.Slice t) -> Some t | _ -> None in - (* With nothing outside saying what the elements are, the first one says: - [[(f32 1.0) 2.5]] is an [[2 f32]], its [2.5] checked at [f32] the way it - would be at an [f32] parameter. *) - let items = - match elem_want, items with - | Some _, _ | None, [] -> map_lr (fun i -> check ctx ?want:elem_want i) items - | None, first :: rest -> - let first_ast = first in - let first = check ctx first in - let want = - match first.Tast.ty with Types.Never -> None | t -> Some t - in - (* A refusal of the element itself says where its type came from. *) - let one (i : Ast.expr) = - (match i.Ast.e, want with - | Ast.UInt (_, text), Some (Types.Int k) when k <> Types.U64 -> - let first_src = - match first_ast.Ast.e with - | Ast.Int _ | Ast.Byte _ -> Some (spell_arg "" first_ast) - | _ -> None - in - Loc.failk literal_at_want i.Ast.loc - ~notes: - [ Loc.note first.Tast.loc - (Printf.sprintf - "this array's first element is %s, so every element is" - (Types.ikind_name k)) ] - "%s does not fit in %s, and only a u64 holds it%s" text - (Types.ikind_name k) - (match first_src with - | Some f -> - Printf.sprintf " — write the first element as (u64 %s) for an \ - array of u64" f - | None -> " — make the first element a u64 for an array of u64") - | _ -> ()); - try check ctx ?want i with - | Loc.Error d when d.Loc.dloc = i.Ast.loc && want <> None -> - raise - (Loc.Error - { d with - Loc.notes = - d.Loc.notes - @ [ Loc.note first.Tast.loc - (Printf.sprintf - "this array's first element is %s, so every \ - element is" - (Types.to_string first.Tast.ty)) ] }) - in - first :: map_lr one rest - in + match elem_want, items with + | None, _ :: _ -> + (match arr_elem_type ctx items with + | Some t -> + let n = Int64.of_int (List.length items) in + expect ctx loc ~want + (check_arr ctx ~want:(Some (Types.Array (n, t))) loc items) + | None -> + (match + trial ctx (fun () -> + dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items)) + with + | Ok v -> expect ctx loc ~want v + | Error d -> mixed_refusal ctx items d)) + | _ -> + let items = map_lr (fun i -> check ctx ?want:elem_want i) items in let n = Int64.of_int (List.length items) in let elem = match elem_want, items with | Some t, _ -> t | None, first :: _ -> first.Tast.ty | None, [] -> - fail loc "an empty array literal needs a type — annotate the binding" + fail loc + "an empty array literal needs a type — use it where one is expected, \ + or name it, as in (the [0 i32] [])" in List.iter (fun (i : Tast.expr) -> @@ -5768,6 +5982,206 @@ and check_arr ctx ~want loc items = an array literal does not satisfy a slice expectation. *) expect ctx loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items)) +(* The element type of an array literal nothing outside it names, or [None] + for a dyn vector. Every element is looked at on its own terms first, by + [probe], so nothing here is checked for real — [check_arr] does that once, + at the answer. + + Elements that agree are a typed array: one type, or numbers that meet at + the wider of them the way two operands of [+] do. A literal takes the + others' type if it fits it, so [[(f32 1.0) 2.5]] is an [[2 f32]] and + [[(u8 1) 300]] an [[2 i32]]. An element that cannot be checked without + being told what it is — [None], a bare struct — takes the same type. + Elements that do not agree — [[10 "Hi"]], a dyn beside anything that is + not one — are a dyn vector, which is what the same brackets are where a + dyn is expected. Numbers that do not agree are refused instead; see + [numbers_disagree]. *) +and arr_elem_type ctx (items : Ast.expr list) : Types.t option = + let natural (i : Ast.expr) = + match i.Ast.e with + (* Refused with no want, and only a u64 holds one. *) + | Ast.UInt _ -> Some (Types.Int Types.U64) + | _ -> probe ctx i.Ast.loc (fun () -> (check ctx i).Tast.ty) + in + let fits t (i : Ast.expr) = + probe ctx i.Ast.loc (fun () -> ignore (check ctx ~want:t i)) <> None + in + let lits, rest = List.partition lone_literal items in + let typed, needs = + List.partition_map + (fun i -> + match natural i with Some t -> Left (i, t) | None -> Right i) + rest + in + let tys = + List.filter (fun t -> t <> Types.Never) (List.map snd typed) + in + let lit_tys = List.filter_map natural lits in + let join_all = function + | [] -> None + | t :: ts -> + List.fold_left + (fun acc t -> Option.bind acc (fun a -> Types.join a t)) (Some t) ts + in + let mixed_dyn = + List.mem Types.Dyn tys + && (List.exists (fun t -> t <> Types.Dyn) tys || lits <> []) + in + let all_fit t = List.for_all (fits t) lits && List.for_all (fits t) needs in + (* A candidate the literals do not all fit is widened by the ones that do + not, once: [[x 2.5]] over an i32 [x] meets at f64. *) + let settle = function + | None -> None + | Some t when all_fit t -> Some t + | Some t -> + let t' = + List.fold_left + (fun acc i -> + if fits t i then acc + else Option.bind acc (fun a -> Option.bind (natural i) (Types.join a))) + (Some t) lits + in + (match t' with + | Some t' when not (Types.equal t' t) && all_fit t' -> Some t' + | _ -> None) + in + let candidates = + if tys <> [] then [ join_all tys ] + else join_all lit_tys :: List.map Option.some lit_tys + in + if mixed_dyn then None + else if tys = [] && lits = [] then + (match typed, needs with + | _ :: _, [] -> Some Types.Never + (* Nothing here says what any of them is. The first one's own refusal is + the one worth reading. *) + | _, first :: _ -> ignore (check ctx first); None + | [], [] -> None) + else + match + List.fold_left + (fun found c -> match found with Some _ -> found | None -> settle c) + None candidates + with + | Some t -> Some t + | None -> + let numeric t = match t with Types.Int _ | Types.Float _ -> true | _ -> false in + if needs = [] && List.for_all numeric (tys @ lit_tys) then + numbers_disagree ctx + (List.filter_map + (fun i -> Option.map (fun t -> (i, t)) (natural i)) items) + else None + +(* Numbers with no type they all meet at — an i32 beside an f32, an i64 beside + a u64 — are refused rather than boxed into a dyn vector: the elements are + all numbers, and which one should move is the program's to say. The fix + named converts the second of the first disagreeing pair, into the float + when one of the two is a float and into the first's type otherwise. *) +and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = + fun ctx elems -> + match elems with + | [] -> fail Loc.unknown "internal: an array of numbers with no elements" + | _ :: _ -> + (* A literal is not one of the disagreeing types when it fits the others: + each is checked at the type the rest meet at — or, with every element a + literal, at the u64 a wide one needs — and the first that does not fit + is the refusal, its own. *) + let lit (e, _) = lone_literal e in + let others = List.filter (fun p -> not (lit p)) elems in + let meet = + match others with + | [] -> + if List.exists (fun (e, _) -> match e.Ast.e with Ast.UInt _ -> true | _ -> false) elems + then Some (Types.Int Types.U64) else None + | (_, t) :: ts -> + List.fold_left (fun acc (_, u) -> Option.bind acc (fun a -> Types.join a u)) + (Some t) ts + in + (match meet with + | Some (Types.Int _ as m) -> + List.iter + (fun (e, t) -> + if lone_literal e && (match t with Types.Int _ -> true | _ -> false) + then ignore (check ctx ~want:m e)) + elems + | _ -> ()); + let pool = if others = [] then elems else others in + let first, t1 = List.hd pool in + let second, t2 = + match List.find_opt (fun (_, t) -> Types.join t1 t = None) (List.tl pool) with + | Some p -> p + | None -> + (match List.find_opt (fun (_, t) -> Types.join t1 t = None) elems with + | Some p -> p + | None -> List.nth elems (List.length elems - 1)) + in + let target, moved, moved_ty, other = + match t1, t2 with + | Types.Int _, Types.Float _ -> t2, first, t1, second + | _ -> t1, second, t2, first + in + ignore ctx; + let tn = Types.to_string target in + Loc.failk "check/array-numbers-disagree" moved.Ast.loc + ~notes:[ Loc.note other.Ast.loc (Printf.sprintf "this element is %s" tn) ] + "this array's elements are %s and %s, and neither holds every value of \ + the other — %s" + (Types.to_string moved_ty) tn + (match spell_arg "" moved with + | "" -> + Printf.sprintf "convert the %s element with the %s cast" (Types.to_string moved_ty) tn + | x -> Printf.sprintf "convert one, as in (%s %s)" tn x) + +(* Elements that do not agree and cannot all become a dyn either: a struct + beside a number, a type variable beside a literal. The dyn vector's refusal + would be about dyn, which the program never mentioned, so the elements are + refused against each other instead — the first one's type is what the rest + are checked at, and the refusal points back at it. [d] is the answer if + that finds nothing. *) +and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = + fun ctx items d -> + match items with + | [] -> raise (Loc.Error d) + | first :: rest -> + let first = check ctx first in + let want = match first.Tast.ty with Types.Never -> None | t -> Some t in + List.iter + (fun (i : Ast.expr) -> + match check ctx ?want i with + | v -> + (match want with + | Some t when not (Types.fits ~expected:t ~actual:v.Tast.ty) -> + fail i.Ast.loc "this array's elements are %s, but this one is %s" + (Types.to_string t) (Types.to_string v.Tast.ty) + | _ -> ()) + | exception Loc.Error e when e.Loc.dloc = i.Ast.loc && want <> None -> + raise + (Loc.Error + { e with + Loc.notes = + e.Loc.notes + @ [ Loc.note first.Tast.loc + (Printf.sprintf + "this array's first element is %s, so every \ + element is" + (match first.Tast.ty with + | Types.Var v -> "$" ^ v + | t -> Types.to_string t)) ] })) + rest; + raise (Loc.Error d) + +(* A dyn vector built where it stands from elements already checked at dyn: + the runtime's own vec, pushed to in order. *) +and dyn_vec ctx loc (items : Tast.expr list) = + let v = fresh_slot ctx Types.Dyn in + let vval = mk loc Types.Dyn (Tast.Local v) in + let pushes = + List.map (fun x -> rt loc Types.Unit "flan_dyn_push" [ vval; x; here loc ]) + items + in + mk loc Types.Dyn + (Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ], pushes @ [ vval ])) + (* ── (array-fill [r c] v) and (array-gen [r c] f) ────────────────────── TODO.org, "A value-producing array constructor". [(array 4 T)] is @@ -5886,6 +6300,78 @@ and array_build ctx loc ns elem ~pre ~element = (Tast.Let (pre @ [ (arr, mk loc aty (Tast.Zero aty)) ], [ nest ns islots; arrv ])) +(* (the T e): [e] with [T] as its expectation, which is every conversion an + annotation would make — a literal built at T, a narrower number widened — + and nothing more. A dyn operand is the exception: an expectation would + unbox it and trap at run time on a mismatch, and [the] is a statement about + the type rather than a conversion, so it is refused and the cast named. + + [(the [T] [...])] asks for the literal's element type and answers the + [n T] the literal is, since an array literal is never a slice. *) +and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = + let ty = resolve ctx.env t in + let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in + if ty <> Types.Dyn && not is_nil + && probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn + then begin + let tn = Types.to_string ty in + let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in + if numeric then + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is a dyn \ + — %s" + tn + (match spell_arg "" v with + | "" -> Printf.sprintf "convert it with the %s cast instead" tn + | s -> Printf.sprintf "write (%s %s) to convert it" tn s) + else + (* What a dyn does at this type is the boundary's own answer, asked of + it rather than restated: some types take one where a value is passed, + returned or stored, and the rest do not take one at all. *) + let crosses = + probe ctx loc (fun () -> + ignore (expect ctx v.Ast.loc ~want:(Some ty) (check ctx v))) + in + match crosses with + | Some () -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is a \ + dyn — a dyn becomes a %s where a %s is passed, returned or stored" + tn tn tn + | None -> + (match check ctx ~want:ty v with + | _ -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is \ + a dyn" tn + | exception Loc.Error d -> + fail v.Ast.loc + "the checks a value as %s and does not convert one, and this is \ + a dyn — %s" tn d.Loc.dmsg) + end; + let r = + match ty, v.Ast.e with + | Types.Slice elem, Ast.Arr items -> + check_arr ctx + ~want:(Some (Types.Array (Int64.of_int (List.length items), elem))) + v.Ast.loc items + | _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v) + in + expect ctx loc ~want r + +(* [f] run for its answer alone: whatever it wrote into the context is put + back whether it succeeded or not, so a form can be checked once to see what + it is and then checked again for real. [None] if it was refused. *) +and probe : 'a. ctx -> Loc.t -> (unit -> 'a) -> 'a option = fun ctx loc f -> + let answer = ref None in + (match + trial ctx (fun () -> + answer := Some (f ()); + raise (Loc.Error (Loc.diag loc "probe"))) + with + | _ -> ()); + !answer + and check_array_fill ctx ~want loc dims v = let ns = array_dims ctx loc dims in let elem_want = array_elem_want (List.length ns) want in @@ -6080,7 +6566,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = let want = ref want in let seen = Hashtbl.create 8 in let saw_wild = ref false in - let arms = + let resolved = map_lr (fun (a : Ast.arm) -> let ctor, binds = resolve_pat a in @@ -6091,6 +6577,48 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = fail a.Ast.aloc "this match has two %s arms" (match subject with `Enum _ -> ":" ^ c | _ -> c); Hashtbl.add seen c ()); + (a, ctor, binds)) + arms + in + (* With nothing expected of the match, the first arm's type is every arm's — + unless that arm is a bare literal, which has no type until asked. So the + arms whose value is a literal are checked last, and take their type from + the others, as an [if]'s literal arm does. The order is only the order + they are checked in; they are put back in source order below. *) + let literal_arm ((a : Ast.arm), _, _) = + match List.rev a.Ast.body with last :: _ -> lone_literal last | [] -> false + in + (* Every arm a literal: they meet at the wider of their own types, as an + [if]'s two do. *) + (if !want = None && resolved <> [] && List.for_all literal_arm resolved then + let lasts = + List.map (fun ((a : Ast.arm), _, _) -> List.hd (List.rev a.Ast.body)) + resolved + in + match lasts with + | first :: rest -> + let j = + List.fold_left + (fun acc x -> + Option.bind acc (fun a -> + Option.bind (literal_join ctx first x) (Types.join a))) + (literal_join ctx first first) rest + in + (match j with + | Some t when not (Types.equal t (Types.Int Types.I32)) -> want := Some t + | _ -> ()) + | [] -> ()); + let order = + let idx = List.mapi (fun i r -> (i, r)) resolved in + if !want <> None then idx + else + List.filter (fun (_, r) -> not (literal_arm r)) idx + @ List.filter (fun (_, r) -> literal_arm r) idx + in + let checked = + map_lr + (fun (i, ((a : Ast.arm), ctor, binds)) -> + i, branch ctx (fun () -> (* What each name in this arm is, in words, for the one refusal that needs it: a case pattern binds fields positionally, so the @@ -6126,7 +6654,10 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = if !want = None && body.Tast.ty <> Types.Never then want := Some body.Tast.ty; { Tast.acase = ctor; binds; abody = [ body ] })) - arms + order + in + let arms = + List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked) in (* Exhaustiveness is refused, not defaulted. A match that silently fell through would have to produce a value of the match's type out of nothing, @@ -6457,6 +6988,13 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = | Types.Ptr t -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) + (* Only [set] writes a class slot, and it has its own arm above. A slot + lives in a map the collector may move entries of, so it has no address + to hand out. *) + | Ast.Pslot _ -> + fail loc + "a class slot (get inst :slot) is written with set and has no address. \ + Read it into a local with let" (* An index or a slice bound that is a literal is known now, so it is an error now rather than a trap later. Only literals: a [defconst] is a global in the @@ -6609,12 +7147,9 @@ and arity _ctx loc name n args = Two is the floor, and the two missing cases are refused rather than invented. Zero operands would have to mean an identity element, 0 for + and 1 for *, and a sum with no terms in it is a typo far more often than it is - an intent. One operand would have to mean negation for [-] and reciprocal - for [/], and this language has no unary minus anywhere: the prelude writes - every negation as [(- 0 n)] or [(- 0.0 x)], and [(- x)] meaning something - else than the [-] two lines above it is a rule a reader has to carry rather - than see. Integer division makes the reciprocal worse still: [(/ 3)] would - be 0. + an intent. One operand is refused for every operator but [-], whose one + operand form is negation and is [named_call]'s. For [/] it would be the + reciprocal, and integer division makes that a trap: [(/ 3)] would be 0. A one-operand comparison would have to be [true] — there is no pair to disagree, and nothing for a lone value to be distinct from — and a test @@ -6623,10 +7158,6 @@ and arity _ctx loc name n args = and fold_arity loc name args = match args with | _ :: _ :: _ -> () - | [ _ ] when String.equal name "-" -> - fail loc - "- takes two arguments or more, given 1 — there is no unary minus; \ - write (- 0 x) to negate" | [ _ ] when String.equal name "/" -> fail loc "/ takes two arguments or more, given 1 — there is no reciprocal; \ @@ -7013,6 +7544,16 @@ and file_guard ctx loc ~path_slot ~op mk_steps = missing annotation for a program that had written one. One list, read by both callers, so the next kind of type added cannot be added to one of them. *) +(* An argument written as a type: a type expression, or a bare name that is a + type and not a local or a global of the same spelling. *) +and type_arg ctx (a : Ast.expr) = + type_of_expr a <> None + || (match a.Ast.e with + | Ast.Var n -> + lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) + && type_named ctx n + | _ -> false) + and type_named ctx n = (* A type variable names a type here too, which is what lets [(vec-new t)] and [(vec-new $t)] be written in a generic body: inside an instantiation @@ -7283,6 +7824,33 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ when (not qualified) && shadows_builtin ctx loc name -> ordinary_call ctx ~want loc name args (* ── arithmetic and comparison ─────────────────────────────────── *) + (* (- x) negates, Clojure's rule. A literal operand is the negative literal, + so it takes its type from the site as any literal does. A float is + subtracted from -0.0, which is exact negation — 0.0 - 0.0 would answer + +0.0 — and an integer from 0, which wraps as (- 0 x) does. *) + | "-" when List.length args = 1 -> + let x = List.hd args in + (match x.Ast.e, literal_arith x with + (* Integer arithmetic over literals alone negates to a literal, so + [(- (- 1))] is the literal 1 and fits a u8. *) + | _, Some n when n <> Int64.min_int -> + check ctx ?want { Ast.e = Ast.Int (Int64.neg n); loc } + | Ast.Float v, _ -> check ctx ?want { Ast.e = Ast.Float (-.v); loc } + | _ -> + let v = check ctx ?want:(numeric_want want) x in + if v.Tast.ty = Types.Dyn then + expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_neg" [ v; here loc ]) + else begin + unconstrained ctx.env loc name ~needs:"numeric?" v.Tast.ty; + if not (Types.is_numeric v.Tast.ty || generic_ty v.Tast.ty) then + not_numeric name "numbers" v; + let zero = + match v.Tast.ty with + | Types.Float k -> mk loc v.Tast.ty (Tast.Float (-0.0, k)) + | ty -> int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L + in + expect ctx loc ~want (mk loc v.Tast.ty (Tast.Prim (Tast.Sub, [ zero; v ]))) + end) | "+" | "-" | "*" | "/" -> let p = match name with | "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul @@ -7508,6 +8076,67 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg)) (pick a b) rest) + (* A type handed to the prelude's slice reductions: the reach for the + type-limit constants under the name of the reduction beside them. *) + | ("max-of" | "min-of") + when (not (shadows_builtin ctx loc name)) + && (match args with [ a ] -> type_arg ctx a | _ -> false) -> + let which = if String.equal name "max-of" then "max-value" else "min-value" in + fail loc + "%s reduces a slice to its %s element, and this is a type — the %s value \ + of a type is (%s %s)" + name (if which = "max-value" then "largest" else "least") + (if which = "max-value" then "largest" else "least") which + (spell_arg "i32" (List.hd args)) + (* (max-value T) and (min-value T): the type-limit constants, by type, so a + generic body can name its own type's. Odin's max(T) and min(T), and the + same answer for a float: the largest finite value and its negation, not + the smallest positive one. *) + | "max-value" | "min-value" -> + arity ctx loc name 1 args; + if not (type_arg ctx (List.hd args)) then + fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name; + let a = List.hd args in + let ty = + match type_of_expr a, a.Ast.e with + | Some t, _ -> resolve ctx.env t + | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n + | _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name + in + let max = String.equal name "max-value" in + let v = + match ty with + | Types.Int k -> + let b = Types.bits k in + let n = + if Types.signed k then + let top = Int64.shift_left 1L (b - 1) in + if max then Int64.sub top 1L else Int64.neg top + else if not max then 0L + else if b = 64 then -1L + else Int64.sub (Int64.shift_left 1L b) 1L + in + mk loc ty (Tast.Int (n, k)) + | Types.Float k -> + let m = + match k with + | Types.F32 -> Int32.float_of_bits 0x7f7fffffl + | Types.F64 -> Float.max_float + in + mk loc ty (Tast.Float ((if max then m else -.m), k)) + | Types.Var v -> + if not (declares ctx.env.tvpreds v "numeric?") then + Loc.failk "check/unconstrained-type-variable" a.Ast.loc + "%s is a limit of a numeric type, and nothing declares $%s \ + numeric — write {:where (numeric? $%s)} at the head of the body" + name v v; + int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L + | _ -> + fail a.Ast.loc + "%s takes a numeric? type, and %s is not one — as in (%s i32)" name + (Types.to_string ty) name + in + expect ctx loc ~want v (* (zeroed) is the all-bytes-zero value of whatever it is being stored into, so it only means anything where a type is expected of it. *) | "zeroed" -> @@ -7519,7 +8148,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> fail loc "zeroed needs to know the type it is zeroing — use it where one is \ - expected, as in (set grid (zeroed))") + expected, or name it, as in (the [4 i32] (zeroed))") (* [zeroed]'s two siblings, and the same shape exactly: a value of whatever type is expected of it, so [(set grid (filled 0xFF))] is how a place is @@ -7616,7 +8245,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> fail loc "%s needs to know the type it is filling — use it where one is \ - expected, as in (set grid (%s))" + expected, or name it, as in (the [4 u32] (%s))" name (if is_byte then "filled 0xFF" else name)) (* The one half of a destructuring [let] that [Parse] cannot do on its own. @@ -8122,12 +8751,14 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check ctx target in (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no - restart and no region check. An equal key's value is replaced. *) + restart and no region check. An equal key's value is replaced. The + site rides along for the one refusal a put can meet, a class + instance's typed slot. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want - (rt loc Types.Unit "flan_dyn_map_set" + (rt loc Types.Unit "flan_dyn_map_put" [ target; check ctx ~want:Types.Dyn k; - check ctx ~want:Types.Dyn v ]) + check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in let k = check ctx ~want:kt k in @@ -9431,6 +10062,27 @@ and ordinary_call ctx ~want loc name args = in (match Hashtbl.find_opt ctx.env.tracks name with | Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args) + | None when Hashtbl.mem ctx.env.classes name -> + (* A class's constructor, told where it was called from so that a + slot it refuses names this call and not only the defclass. The + arguments go into temps first: one may itself construct, and + the site is set last, immediately before the call, so nothing + between the two can replace it. The constructor takes it as its + first act; one reached through a function value finds none. *) + let temps = + List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args + in + let uses = + List.map + (fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s)) + temps + in + expect ctx loc ~want + (mk loc ret + (Tast.Let + (temps, + [ rt loc Types.Unit "flan_dyn_ctor_site" [ here loc ]; + mk loc ret (Tast.Call (name, uses)) ]))) | None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args)))) | None -> if Hashtbl.mem ctx.env.datas name then @@ -10352,7 +11004,8 @@ let builtins : (string * string * string) list = numeric types meet at the wider one when that cannot lose — i32 and i64 \ add at i64 — and i32 with u32 has no such type and is refused."); ("-", "- [numeric? ...] numeric?", - "Difference, folded left: (- a b c) is ((a - b) - c)."); + "Difference, folded left: (- a b c) is ((a - b) - c). With one operand, \ + its negation: (- x)."); ("*", "* [numeric? ...] numeric?", "Product, folded left over two or more operands of one numeric type."); ("/", "/ [numeric? ...] numeric?", @@ -10368,7 +11021,8 @@ let builtins : (string * string * string) list = ordered."); ("!=", "!= [equal? ...] bool", "All different: (!= a b c) is true when every operand differs from every \ - other, so (!= 1 2 1) is false. Over everything = accepts."); + other, so (!= 1 2 1) is false. Over everything = accepts. A float NaN \ + is != to everything, itself included."); ("<", "< [ordered? ...] bool", "Less than, chained: (< a b c) is a < b and b < c, and every operand is \ evaluated once. Machine numbers and enums only — ordering a handle \ @@ -10399,6 +11053,13 @@ let builtins : (string * string * string) list = i16-y) is an i16."); ("max", "max [ordered? ...] ordered?", "The largest of two or more operands, each evaluated exactly once."); + ("max-value", "max-value [type] T", + "The largest value of a numeric type: (max-value u8) is 255, and at a \ + float the largest finite value. Takes a type variable under \ + {:where (numeric? $t)}."); + ("min-value", "min-value [type] T", + "The least value of a numeric type: (min-value i8) is -128, 0 at an \ + unsigned type, and at a float the negation of the largest finite value."); ("zeroed", "zeroed [] T", "The all-bytes-zero value of whatever it is being stored into, so it \ only means anything where a type is expected of it."); @@ -10643,9 +11304,9 @@ let builtins : (string * string * string) list = not hold. It becomes None where an (Option T) is wanted, and stays dyn \ everywhere else."); ("None", "None (Option T)", - "The absent Option. It takes its type from its context — a return type \ - or an annotated binding — because nothing about the word says what it \ - is an Option of."); + "The absent Option. It takes its type from its context — a return type, \ + a parameter, or (the (Option i32) None) — because nothing about the \ + word says what it is an Option of."); ("context/allocator", "context/allocator Allocator", "The allocator in effect here: what with-allocator rebinds, and what an \ allocating operation uses when none is named at the site."); @@ -10711,6 +11372,22 @@ let rec const_int env (e : Ast.expr) : int64 option = | Ast.Int n -> Some n | Ast.Byte b -> Some (Int64.of_int b) | Ast.Var n -> Hashtbl.find_opt env.consts n + | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> + Option.map Int64.neg (const_int env x) + (* A conversion to an integer type, which is how a negative number is + written as an unsigned constant's bit pattern: [(u64 -1)]. Truncated to + the type's width and extended by its sign, as the cast does at run time. *) + | Ast.Call ({ Ast.e = Ast.Var k; _ }, [ x ]) + when Types.ikind_of_name k <> None -> + let k = Option.get (Types.ikind_of_name k) in + let bits = Types.bits k in + Option.map + (fun n -> + if bits = 64 then n + else if Types.signed k then + Int64.shift_right (Int64.shift_left n (64 - bits)) (64 - bits) + else Int64.logand n (Int64.sub (Int64.shift_left 1L bits) 1L)) + (const_int env x) (* Left to right over any number of operands, because that is how the checker reads the same form: an array length that type-checks as a product of three literals and is then not a constant would be a @@ -11150,7 +11827,11 @@ let collect env (decls : Ast.decl list) = driver that assembled a declaration list and skipped that pass would otherwise get a missing name from wherever the constructor was called, with nothing pointing here. *) - | Ast.Defclass (n, _) | Ast.Defgeneric { Ast.name = n; _ } + | Ast.Defclass (n, _) -> + fail loc + "internal: the class %s reached the checker unpaired — \ + pair_decls writes its constructor, and did not run" n + | Ast.Defgeneric { Ast.name = n; _ } | Ast.Defmulti { Ast.name = n; _ } -> fail loc "internal: %s reached the checker unexpanded — Classes.expand did \ @@ -11758,12 +12439,26 @@ let check_global env (d : Ast.decl) : Tast.global option = than the expression it came from: a global's initialiser has to be a compile-time constant, and [(/ screen-height cell-size)] is one — the folding pass is the only thing that knows it. *) + (* A folded conversion is still a value of the type it converts to. *) + (match v.Ast.e, ty with + | Ast.Call ({ Ast.e = Ast.Var c; _ }, [ _ ]), Types.Int kind + when (match Types.ikind_of_name c with + | Some k -> + k <> kind + && not (Types.widens_to ~from:(Types.Int k) ~into:(Types.Int kind)) + | None -> false) -> + fail v.Ast.loc "expected %s, found %s" (Types.ikind_name kind) c + | _ -> ()); let ginit = match Hashtbl.find_opt env.consts n, ty with | Some k, Types.Int kind -> (* Still range-checked: this path skips [check], and [in_range] is the only thing that rejects 300 as a u8. *) - { Tast.e = Tast.Int (in_range d.Ast.dloc kind k, kind); ty; + { Tast.e = + Tast.Int + (in_range + ~pattern:(match v.Ast.e with Ast.Int _ -> false | _ -> true) + v.Ast.loc kind k, kind); ty; loc = d.Ast.dloc } | _ -> check (ctx ()) ~want:ty v in @@ -12427,6 +13122,68 @@ let is_env_struct = Closures.is_env_struct let heap_env = Closures.heap_env let place_closures fns = Closures.place ~dev:false fns +(* A program's function named as a prelude function takes the name over, the + way a definition of a builtin's name does: every call written in the file + that defines it reaches the program's, and every call anywhere else — the + prelude's own among them, which were written against the prelude's + signature — keeps reaching the prelude's. The prelude's is renamed out of + the way, under a qualifier no source can spell, rather than dropped. + Functions only: a type or a global of the prelude's name is still defined + twice. *) +let prelude_alias = "prelude~" + +(* Off for a check whose warnings were already printed for the same source: + the dev program re-creating the session its launcher built and warned for. *) +let print_warnings = ref true + +(* A name the renaming above made, which nobody wrote: left out of every + listing a person reads, and shown as whose it is where a frame has to be. *) +let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n + +let shown_name n = + if internal_name n then + let p = String.length prelude_alias + 1 in + "the prelude's " ^ String.sub n p (String.length n - p) + else n + +let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = + let fn_name (d : Ast.decl) = + match d.Ast.d with + | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name + | _ -> None + in + let theirs = List.filter_map fn_name prelude in + let taken = + List.filter_map + (fun (d : Ast.decl) -> + match fn_name d with + | Some n when List.mem n theirs -> Some (n, d.Ast.dloc) + | _ -> None) + decls + in + let warnings = + List.map + (fun (n, at) -> + Loc.diag ~kind:"check/shadows-prelude" at + (Printf.sprintf + "%s shadows the prelude's %s — every call in this file now \ + reaches your definition" + n n)) + taken + in + let prelude, decls = + List.fold_left + (fun (prelude, decls) (n, (at : Loc.t)) -> + ( List.map (Load.rename_refs [ n ] prelude_alias) prelude, + List.map + (fun (d : Ast.decl) -> + if String.equal d.Ast.dloc.Loc.file at.Loc.file then d + else Load.rename_refs [ n ] prelude_alias d) + decls )) + (prelude, decls) taken + in + (prelude @ decls, warnings) + let build_program ~keep_going ?tolerate (decls : Ast.decl list) : Tast.program * env * string list = let env = new_env () in @@ -12482,7 +13239,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : end else raise e) in - let decls = Parse.program (Prelude.forms ()) @ decls in + let decls, prelude_warnings = + shadow_prelude (Parse.program (Prelude.forms ())) decls + in (* Before anything is collected: every (declare-c ...) becomes an ordinary flattened [declare] with a Flan [defn] over it, and the C that does the flattening comes back to be compiled into the build. Nothing below this @@ -12502,11 +13261,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : reload, which is where a defn is most likely to be written. Printed in the shape [Loc] gives an error, so a checker in an editor parses it the same way. *) + if !print_warnings then List.iter (fun (d : Loc.diag) -> prerr_endline (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) - (shadowed_builtins decls); + (shadowed_builtins decls @ prelude_warnings); (* 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 diff --git a/lib/classes.ml b/lib/classes.ml index a6b7325b..cc006999 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -4,9 +4,11 @@ [(defclass point [x y])] is a constructor. [(defgeneric area [self] dyn)] and [(defmulti describe [x] dyn (get x :kind))] are each one function whose body is a dispatch, and [(defmethod area point [p] ...)] is a branch of - one. Nothing below this pass knows any of the four forms exists: what it - writes is [defn]s, and they are checked, emitted, rooted, redefined and - inspected as any other function is. + one. What it writes is [defn]s, and they are checked, emitted, rooted, + redefined and inspected as any other function is. The one exception is + [defclass], which passes through untouched: its slot vector reads like a + [defn]'s and cannot be paired until every type name is known, so + [Check.pair_decls] pairs it and calls [constructor] below. **Why a pass and not a macro.** A macro sees one form. This needs the whole declaration list, because a method may be written anywhere — above @@ -47,6 +49,46 @@ let dispatch_slot = "~dispatch" the prelude; this is the only place that builds one. *) let no_method = "NoMethod" +(* CLHS's update-instance-for-redefined-class: what a redefined class does to + each of its instances, run once per instance at the first [get], [put] or + [set] that reaches it after the redefinition. By then the instance already + holds the new slots, each kept one with its old value and each gained one + at its type's zero value, or nil for an untyped, Option or class slot; + [added] is a vec of the gained slots' keywords and [discarded] a map + from each lost slot's keyword to the value it held. A method is written for + a class, from a live session, and is how a migration does more than match + slots by name: + + (defmethod update-instance-for-redefined-class point [p added discarded] + (set (get p :radius) (get discarded :r)) + nil) + + A method that signals stops in the break loop with [migrate-by-name] on + offer, which keeps the instance as name-matching left it. + + The generic and its :else method, which does nothing, are written here + rather than in the prelude, and only into a program that has a class or a + method of the generic: a program with neither would otherwise carry a dyn + function and pay for the collector it never uses. [Session] registers the + dispatcher's body with the runtime whenever a reload could have changed + it. *) +let migrate_generic = "update-instance-for-redefined-class" + +let migrate_decls loc : Ast.decl list = + let p n = { Ast.fname = n; fty = dyn_at loc; floc = loc } in + let fn body = + { Ast.name = migrate_generic; + params = [ p "instance"; p "added"; p "discarded" ]; praw = None; + ret = Some (dyn_at loc); fwhere = []; fbody = body; nloc = loc; + fprivate = Ast.Exported } + in + [ { Ast.d = Ast.Defgeneric (fn []); dloc = loc }; + { Ast.d = + Ast.Defmethod + { Ast.mgen = migrate_generic; mkey = Ast.Delse; + mfn = fn [ ex loc (Ast.Var "nil") ]; mkloc = loc }; + dloc = loc } ] + (* ── Collecting ────────────────────────────────────────────────────── *) type generic = { @@ -65,23 +107,7 @@ let collect (decls : Ast.decl list) = List.iter (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> - (* Two slots of one name would write one entry and read one value, - and the constructor would take two arguments for it. The duplicate - parameter that falls out of it is refused by the checker anyway; - this says which declaration it came from. *) - let seen = Hashtbl.create 8 in - List.iter - (fun (s, sloc) -> - if Hashtbl.mem seen s then - Loc.failk "check/duplicate-slot" sloc - "%s names the slot %s twice. A slot is a key in the \ - instance's map, so the second would replace the first and \ - the constructor would take an argument that goes nowhere" - n s; - Hashtbl.replace seen s ()) - slots; - Hashtbl.replace classes n d.Ast.dloc + | Ast.Defclass (n, _) -> Hashtbl.replace classes n d.Ast.dloc | Ast.Defgeneric fn -> Hashtbl.replace generics fn.Ast.name { gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] } @@ -162,14 +188,37 @@ let collect (decls : Ast.decl list) = omitted slot meaning nil — is deferred, and so is refusing an unknown slot at [(get p :z)]. Both are recorded in TODO.org, "Class features deferred, each with its reason". *) -let constructor n slots loc : Ast.decl = +let constructor n (slots : Ast.field list) loc : Ast.decl = + (* Two slots of one name would write one entry and read one value, and the + constructor would take two arguments for it. The duplicate parameter + that falls out of it is refused by the checker anyway; this says which + declaration it came from. *) + let seen = Hashtbl.create 8 in + List.iter + (fun (f : Ast.field) -> + if Hashtbl.mem seen f.Ast.fname then + Loc.failk "check/duplicate-slot" f.Ast.floc + "%s names the slot %s twice. A slot is a key in the instance's \ + map, so the second would replace the first and the constructor \ + would take an argument that goes nowhere" + n f.Ast.fname; + Hashtbl.replace seen f.Ast.fname ()) + slots; + (* Every parameter is dyn whatever its slot's type. The type is checked + where the value is stored — the constructor's own stores included — so + a caller holding a dyn passes it as it is, and a caller holding an i32 + boxes it; neither has to convert to the slot's type first. *) let params = List.map - (fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc }) + (fun (f : Ast.field) -> + { Ast.fname = f.Ast.fname; fty = dyn_at f.Ast.floc; floc = f.Ast.floc }) slots in let pairs = - List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots + List.map + (fun (f : Ast.field) -> + (ex f.Ast.floc (Ast.Kw f.Ast.fname), ex f.Ast.floc (Ast.Var f.Ast.fname))) + slots in { Ast.d = Ast.Defn @@ -339,11 +388,34 @@ let expand (decls : Ast.decl list) : Ast.decl list = in if not has then decls else begin + let decls = + let wants = + List.find_opt + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defclass _ -> true + | Ast.Defmethod m -> String.equal m.Ast.mgen migrate_generic + | _ -> false) + decls + and declared = + List.exists + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defgeneric f -> String.equal f.Ast.name migrate_generic + | _ -> false) + decls + in + match wants with + | Some d when not declared -> decls @ migrate_decls d.Ast.dloc + | _ -> decls + in let _classes, generics = collect decls in List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc) + (* Kept: its slot vector cannot be paired until every type name is + known, so [Check.pair_decls] writes the constructor. *) + | Ast.Defclass _ -> Some d | Ast.Defgeneric fn | Ast.Defmulti fn -> Some (dispatcher (Hashtbl.find generics fn.Ast.name)) (* Gone: its body is inside its generic's dispatch. *) diff --git a/lib/dev.ml b/lib/dev.ml index 2346f35d..1fb4ff7c 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1532,7 +1532,10 @@ let describe t = ok [ ":fns " ^ Wire.strings - (List.map (fun (f : Tast.fn) -> f.Tast.name) + (List.filter_map + (fun (f : Tast.fn) -> + if Check.internal_name f.Tast.name then None + else Some f.Tast.name) t.session.Session.program.Tast.fns); ":globals " ^ Wire.strings @@ -1618,17 +1621,29 @@ let defs t = [M-.] on a prelude macro from "the prelude is not a file on disk" into a shrug about the daemon having no location. *) let macro_locs = Hashtbl.create 16 in - (* The classes, off the session's declarations: [Classes.expand] turns a - [defclass] into its constructor [defn] before the checker runs, so the - class is not in [Tast.program] or the checker's environment, and the - declarations are the one place that still has it. Its constructor is - dropped from the [fn] rows for the macro rows' reason: one name, one row, - and [class] is what was written. *) + (* The classes: where each was written, off the session's declarations, + and its slots as the checker paired them, off its environment — the + slot vector is unreadable before pairing. The constructor the checker + wrote is dropped from the [fn] rows for the macro rows' reason: one name, + one row, and [class] is what was written. *) let classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots, d.Ast.dloc) + | Ast.Defclass (n, _) -> + let slots = + Option.value ~default:[] + (Check.class_slots t.session.Session.env n) + in + Some + (n, + List.map + (fun (s, ty) -> + match ty with + | Check.Sany -> s + | ty -> s ^ " " ^ Check.slot_text ty) + slots, + d.Ast.dloc) | _ -> None) t.session.Session.decls in @@ -1644,6 +1659,7 @@ let defs t = Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc); None | None when List.mem f.Tast.name class_names -> None + | None when Check.internal_name f.Tast.name -> None | None -> Some (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) @@ -2091,7 +2107,7 @@ let backtrace_op t = (List.map (fun (name, loc, mine, nslots, _sig, _rsig) -> Wire.list - [ Wire.quote name; Wire.quote loc; + [ Wire.quote (Check.shown_name name); Wire.quote loc; Wire.quote (if mine then "program" else "eval"); string_of_int nslots ]) frames); @@ -5998,7 +6014,10 @@ let merged_setup () = marshalling a [Session.t] through a file, which buys nothing: the source cannot have changed between the two, because the build that produced this binary is the one that exec'd it. *) + (* Its warnings were printed by the launcher over the same source. *) + Check.print_warnings := false; let session, _, _ = Session.create_dev ~debug ~x86 ~file () in + Check.print_warnings := true; (* The program's output has to reach an editor exactly as it did when the daemon held the other end of a pipe. Same pipe, one process: fd 1 is replaced before the program starts, and the accept loop drains it — diff --git a/lib/emit.ml b/lib/emit.ml index 0e27575b..6f63ba31 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -2277,8 +2277,11 @@ let icmp_op signed = function | Tast.Ge -> if signed then "sge" else "uge" | _ -> assert false +(* [!=] is unordered and the rest are ordered, so a NaN is unequal to + everything, itself included, and neither less, greater nor equal: IEEE 754's + answers, and C's and Odin's. *) let fcmp_op = function - | Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt" + | Tast.Eq -> "oeq" | Tast.Ne -> "une" | Tast.Lt -> "olt" | Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge" | _ -> assert false @@ -4777,9 +4780,14 @@ declare i64 @flan_dyn_from_bool(i32) declare i64 @flan_dyn_from_bytes(ptr, i64) declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() -declare i64 @flan_dyn_map_new_class(i64) +declare i64 @flan_dyn_map_new_class(i64, ptr, i64) +declare void @flan_dyn_slot_set(i64, i64, i64, ptr, i64) +declare void @flan_dyn_slot_init(i64, i64, i64, ptr, i64) +declare void @flan_dyn_ctor_site(ptr, i64) +declare void @flan_dyn_map_put(i64, i64, i64, ptr, i64) declare i64 @flan_dyn_class_of(i64) declare void @flan_dyn_class_def(i64, ptr, i64) +declare void @flan_dyn_class_hook(ptr) declare i64 @flan_dyn_kw(ptr, i64) declare i64 @flan_dyn_map_get(i64, i64) declare void @flan_dyn_map_set(i64, i64, i64) @@ -4793,6 +4801,7 @@ declare i64 @flan_dyn_sub(i64, i64, ptr, i64) declare i64 @flan_dyn_mul(i64, i64, ptr, i64) declare i64 @flan_dyn_div(i64, i64, ptr, i64) declare i64 @flan_dyn_rem(i64, i64, ptr, i64) +declare i64 @flan_dyn_neg(i64, ptr, i64) declare i64 @flan_dyn_lt(i64, i64, ptr, i64) declare i64 @flan_dyn_le(i64, i64, ptr, i64) declare i64 @flan_dyn_gt(i64, i64, ptr, i64) diff --git a/lib/load.ml b/lib/load.ml index 17d9b0c8..ad55acf0 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -315,6 +315,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = other reference to it. *) | Ast.ArrayFill (ds, v) -> Ast.ArrayFill (List.map (rename_len owned alias) ds, go v) | Ast.ArrayGen (ds, v) -> Ast.ArrayGen (List.map (rename_len owned alias) ds, go v) + | Ast.The (t, v) -> Ast.The (rename_texpr owned alias t, go v) | Ast.Fn (ps, body) -> Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body) | Ast.Dotimes (l, i, b, body) -> @@ -390,6 +391,7 @@ and rename_place owned alias bound (p : Ast.place) : Ast.place = | Ast.Pfield (t, f) -> Ast.Pfield (go t, f) | Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx) | Ast.Pderef t -> Ast.Pderef (go t) + | Ast.Pslot (t, k) -> Ast.Pslot (go t, go k) let rename_field owned alias (f : Ast.field) : Ast.field = { f with Ast.fty = rename_texpr owned alias f.Ast.fty } @@ -501,12 +503,23 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = and the rename is the ordinary one: the declared name, plus whatever inside them is a name of this package. - A class's slots are not renamed. They are keywords in the map the + A class's slot names are not renamed. They are keywords in the map the constructor builds, and a keyword belongs to nobody — the same line the - [MapLit] arm above takes about a map literal's keys. The *class's* name - is qualified, so [pkg/point] is what an instance's shape tag reads and - two packages' [point] classes are two classes. *) - | Ast.Defclass (n, slots) -> Ast.Defclass (qualify alias n, slots) + [MapLit] arm above takes about a map literal's keys. The vector is + unpaired, so a bare symbol in it may be a slot's name, and none is + touched; a type written as a form is renamed as any type is. A bare + class name in a type position is found by [Check.pair_slots] against + the class's own package instead. The *class's* name is qualified, so + [pkg/point] is what an instance's shape tag reads and two packages' + [point] classes are two classes. *) + | Ast.Defclass (n, slots) -> + Ast.Defclass + (qualify alias n, + List.map + (function + | Ast.Pname _ as p -> p + | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t)) + slots) (* A generic's parameters are dyn and were written out by the parser, so there is no unpaired vector here and [bound] is exactly the parameter names. *) @@ -554,6 +567,37 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = in { d with Ast.d = k } +(* [qualify_decl]'s rename of every use of an [owned] name, without the rename + of the declaration's own name unless that name is one of them. How a + program's definition of a name the prelude also defines takes the name + over: the prelude's declaration and its uses outside the program's file + move to the qualified name, and the program's file keeps the bare one. *) +let rename_refs owned alias (d : Ast.decl) : Ast.decl = + match Ast.declared_name d, d.Ast.d with + | _, (Ast.Package _ | Ast.Import _) -> d + | Some n, _ when List.mem n owned -> qualify_decl owned alias d + | _ -> + let q = qualify_decl owned alias d in + let named (fn : Ast.fn) (o : Ast.fn) = { fn with Ast.name = o.Ast.name } in + let k = + match q.Ast.d, d.Ast.d with + | Ast.Declare (fn, c), Ast.Declare (o, _) -> Ast.Declare (named fn o, c) + | Ast.DeclareC (fn, c), Ast.DeclareC (o, _) -> Ast.DeclareC (named fn o, c) + | Ast.Defn fn, Ast.Defn o -> Ast.Defn (named fn o) + | Ast.Defgeneric fn, Ast.Defgeneric o -> Ast.Defgeneric (named fn o) + | Ast.Defmulti fn, Ast.Defmulti o -> Ast.Defmulti (named fn o) + | Ast.Defenum (_, ms), Ast.Defenum (n, _) -> Ast.Defenum (n, ms) + | Ast.Defalias (_, t), Ast.Defalias (n, _) -> Ast.Defalias (n, t) + | Ast.Defconst (_, t, v), Ast.Defconst (n, _, _) -> Ast.Defconst (n, t, v) + | Ast.Defstruct (_, fs), Ast.Defstruct (n, _) -> Ast.Defstruct (n, fs) + | Ast.Defunion (_, fs), Ast.Defunion (n, _) -> Ast.Defunion (n, fs) + | Ast.Defdata (_, vs), Ast.Defdata (n, _) -> Ast.Defdata (n, vs) + | Ast.Defvar (_, t, i, r), Ast.Defvar (n, _, _, _) -> Ast.Defvar (n, t, i, r) + | Ast.Defclass (_, ss), Ast.Defclass (n, _) -> Ast.Defclass (n, ss) + | k, _ -> k + in + { q with Ast.d = k } + (* ── Qualifying a package's macros ────────────────────────────────── The rename above works over the Ast and a macro cannot go that way. By the time [Parse] is finished with a [defmacro] its quasiquote has been desugared @@ -790,6 +834,7 @@ let rec expr_uses acc (e : Ast.expr) = | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs | Ast.Arr items -> gos items | Ast.ArrayOf t | Ast.TypeArg t -> texpr_uses acc t + | Ast.The (t, v) -> texpr_uses acc t; go v (* A dimension written as a name is a use of that constant, exactly as it is inside [Tarray]. *) | Ast.ArrayFill (ds, v) | Ast.ArrayGen (ds, v) -> @@ -832,6 +877,7 @@ and place_uses acc loc (p : Ast.place) = | Ast.Pfield (t, _) -> expr_uses acc t | Ast.Pindex (t, idx) -> expr_uses acc t; List.iter (expr_uses acc) idx | Ast.Pderef t -> expr_uses acc t + | Ast.Pslot (t, k) -> expr_uses acc t; expr_uses acc k let decl_uses acc (d : Ast.decl) = let field (f : Ast.field) = texpr_uses acc f.Ast.fty in @@ -873,9 +919,14 @@ let decl_uses acc (d : Ast.decl) = | Ast.Zeroed | Ast.Uninit -> ()) | Ast.Defconst (_, t, v) -> Option.iter (texpr_uses acc) t; expr_uses acc v - (* A class's slots are keywords and name nothing. Its constructor's body is - written by [Classes.expand], long after this, out of the slots alone. *) - | Ast.Defclass _ -> () + (* A class's slot names are keywords and name nothing; its slot types are + uses, recorded the way an unpaired [defn] vector's are. *) + | Ast.Defclass (_, slots) -> + List.iter + (function + | Ast.Pname (n, loc) -> acc := (n, loc) :: !acc + | Ast.Ptype t -> texpr_uses acc t) + slots | Ast.Defgeneric f | Ast.Defmulti f -> fn f (* The generic is a use — a method in one package extending another's has to pull that package in — and so is the class in the dispatch slot, for the diff --git a/lib/parse.ml b/lib/parse.ml index 519103b1..828b4129 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -489,6 +489,15 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = array of integers — the wrong reading, and a silent one. Read here, the brackets are [len]s: the same integer-or-constant's-name the [n T] type spelling takes, refused by [len] when they are anything else. *) + (* ── (the T e) ──────────────────────────────────────────────────── *) + | Sym "the" -> + (match args with + | [ t; v ] -> mk (Ast.The (texpr t, expr v)) + | _ -> + fail f + "the is (the TYPE value), as in (the u8 0) — the value, checked as \ + a TYPE") + | Sym (("array-fill" | "array-gen") as which) -> let usage () = fail f @@ -1198,13 +1207,19 @@ and place (f : Form.t) : Ast.place = either inserts or replaces — so there is no store into a lookup, and an entry that is absent has no location to store into. Refused here rather than parsed into a place form the language does not have. *) + (* A class instance's slot: declared by its defclass, so it always exists + and is a place, where a map's absent key is not. Whether the value is an + instance or a map is a run-time fact, so the store is a run-time call + and a map there is refused by it. *) + | List [ { v = Sym "get"; _ }; target; key ] -> + Ast.Pslot (expr target, expr key) | List ({ v = Sym "get"; _ } :: _) -> fail f "(get m k) is not a place — a map is written with (put m k v)" | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p) | _ -> fail f "%s is not assignable. set takes a name, (.field x), (at a i ...), \ - or (deref p)" + (deref p), or a class slot (get inst :slot)" (Form.to_string f) and arms f (items : Form.t list) : Ast.arm list = @@ -1469,20 +1484,15 @@ let rec decl (f : Form.t) : Ast.decl = only names can be read here. *) | List ({ v = Sym "defclass"; _ } :: args) -> (match args with + (* The slot vector is a [defn]'s parameter vector in every respect — + [[x y]] two dyn slots, [[pause bool step bool]] two typed ones — and + is carried undecided for the same reason. *) | [ n; { v = Vec slots; _ } ] -> - mk (Ast.Defclass - (dname n, - List.map - (fun (s : Form.t) -> - match s.v with - | Sym name -> no_sigil s; (name, s.loc) - | _ -> - fail s - "a class slot is a name — its value is dyn, so there \ - is no type to write. Read one with (get p :%s)" - (Form.to_string s)) - slots)) - | _ -> fail f "defclass is (defclass Name [slot ...])") + List.iter + (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) + slots; + mk (Ast.Defclass (dname n, pitems slots)) + | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> let generic = String.equal which "defgeneric" in diff --git a/lib/prelude.ml b/lib/prelude.ml index 880a720a..9eb5ce04 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -427,6 +427,7 @@ let source = {flan| ;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+] ;; either. These reduce a slice, which is a different operation with a ;; different arity, so the different name is honest rather than a workaround. +;; A type's own limits are (min-value T) and (max-value T). (defn min-of [s [$t]] (Option $t) {:where (ordered? $t)} (if (= (length s) 0) @@ -716,7 +717,7 @@ let source = {flan| ;; The floats are three questions and not two, which is why there is no ;; f32-min here to sit beside f32-max. ;; -;; A float's least value is just the negation of its greatest — (- 0.0 f32-max) +;; A float's least value is just the negation of its greatest — (- f32-max) ;; — so a constant for it would say nothing the language cannot. What a caller ;; actually reaches for under the name "min" is the smallest positive one, and ;; that is a different number entirely. Naming it f32-min would make the two diff --git a/lib/session.ml b/lib/session.ml index 96766b23..d2cba1f1 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -186,6 +186,10 @@ let stale_sites ?(live = SM.empty) ?(running = false) built (p : Tast.program) : m acc in from ~kept:true live (from ~kept:false built []) + (* A caller or callee the prelude-shadowing rename made is not the + program's, and there is nothing in the program to recompile for it. *) + |> List.filter (fun s -> + not (Check.internal_name s.caller || Check.internal_name s.target)) |> List.sort (fun a b -> match String.compare a.at.Loc.file b.at.Loc.file with | 0 -> Loc.before a.at b.at @@ -995,7 +999,8 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with - | Ast.Defclass (n, slots) -> Some (n, List.map fst slots) + | Ast.Defclass (n, _) -> + Some (n, Option.value ~default:[] (Check.class_slots env n)) | _ -> None) incoming in @@ -1153,21 +1158,40 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan definition the registry has never seen has to arrive somehow. *) let class_body = let str s : Tast.expr = { Tast.e = Tast.Str s; ty = Types.String; loc } in - List.map + (* And the hook a migration calls, re-registered by every module that + could have changed what it should be: one carrying a class, since + that is what makes migrations happen, and one carrying a method of + the generic, since that is what changes the body. The address is the + cell's contents at the time the thunk runs — after this module's + bodies are published — so it is the body just installed. *) + let hook = + let n = Classes.migrate_generic in + if incoming_classes <> [] || List.mem n names then + let ty = + Types.CFn ([ Types.Dyn; Types.Dyn; Types.Dyn ], Types.Dyn) + in + [ { Tast.e = + Tast.Prim (Tast.Rt "flan_dyn_class_hook", + [ { Tast.e = Tast.FnAddr (Tast.Fnval n); ty; loc } ]); + ty = Types.Unit; loc } ] + else [] + in + hook @ List.map (fun (n, slots) : Tast.expr -> let kw : Tast.expr = { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]); ty = Types.Dyn; loc } in - (* The slot names in one string, newline between: the runtime - splits them. A dyn vector would have been the obvious shape - and is the wrong one — it is a collector object, so the - registry would hold something the marker has to reach, where - a packed string reaches interned keywords that are immortal - already. *) + (* The slots in one string, a line each with the slot's type + after its name: the runtime splits them. A dyn vector would + have been the obvious shape and is the wrong one — it is a + collector object, so the registry would hold something the + marker has to reach, where a packed string reaches interned + keywords that are immortal already. The constructor carries + the same string, from the same function. *) { Tast.e = Tast.Prim (Tast.Rt "flan_dyn_class_def", - [ kw; str (String.concat "\n" slots) ]); + [ kw; str (Check.class_spec_of slots) ]); ty = Types.Unit; loc }) incoming_classes in diff --git a/lib/x86.ml b/lib/x86.ml index de4665cf..7b7f03b7 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1318,18 +1318,20 @@ let int_cc ~signed (p : Tast.prim) = (* Parity, which on [ucomis] means "unordered": one of the operands was a NaN. Nothing else in this file reads it. *) -let cc_np = 11 +let cc_p = 10 and cc_np = 11 (* [ucomis] sets the flags the *unsigned* codes read, whichever way the operands are signed, so a float comparison never uses l/g — and it sets CF, ZF and PF all at once when either operand is a NaN. That last part is why this is not simply the unsigned table. Every - comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq, - one, olt, ...), which answers false for a NaN, and [setb] after an - unordered compare answers true. So [<] and [<=] swap their operands and ask - for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be - spelled by one code at all and take a second [setnp] beside them. + comparison Flan has but one is LLVM's *ordered* one ([emit.ml]'s + [fcmp_op]: oeq, olt, ...), which answers false for a NaN, and [setb] after + an unordered compare answers true. So [<] and [<=] swap their operands and + ask for a/ae, which are the two codes a NaN makes false; [=] cannot be + spelled by one code at all and takes a second [setnp] beside it. The one is + [!=], which is [une] — true for a NaN, as IEEE 754 and C have it — and is + [setne] or'd with [setp]. [(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as @@ -1345,7 +1347,7 @@ let float_cc (p : Tast.prim) = | _ -> unsupported "not a comparison" let float_ordered (p : Tast.prim) = - match p with Tast.Eq | Tast.Ne -> true | _ -> false + match p with Tast.Eq -> true | _ -> false let is_cmp (p : Tast.prim) = match p with @@ -3274,6 +3276,12 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst = movzx8 f.b ~dst:rcx ~src:rcx; and_rr f.b ~dst:rax ~src:rcx end + else if p = Tast.Ne then begin + movzx8 f.b ~dst:rax ~src:rax; + setcc f.b ~cc:cc_p ~dst:rcx; + movzx8 f.b ~dst:rcx ~src:rcx; + or_rr f.b ~dst:rax ~src:rcx + end end else begin load_loc f ~reg:rax la a.Tast.ty; load_loc f ~reg:rcx lb b.Tast.ty; diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 0743bfc8..780f299e 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1475,8 +1475,8 @@ flan_dyn flan_dyn_map_new(void) { * * The registry a redefined (defclass ...) updates, and the lazy migration * that makes the instances built against the old definition answer the new - * one. This is CLHS 4.3.6 — [update-instance-for-redefined-class] — with the - * user hook left out; docs/SBCL-REDEFINITION-NOTES.md is where the protocol + * one. This is CLHS 4.3.6, [update-instance-for-redefined-class] included — + * see [class_hook]; docs/SBCL-REDEFINITION-NOTES.md is where the protocol * was read off and candidate C is this. * * **Why a registry at all, when a class instance is already just a map.** @@ -1494,14 +1494,17 @@ flan_dyn flan_dyn_map_new(void) { * of dyn vectors would have needed both, and would have needed them to * survive a collection triggered from inside a migration. * - * **What the registry does not do.** It does not constrain [put]. A class + * **What the registry constrains.** A store into a slot the class declares + * — the constructor's, [put]'s, [set]'s — is checked against the slot's + * type. A key the class does not declare is not refused by [put]: a class * instance is an open map — TODO.org, "Class features deferred, each with its - * reason", already defers unknown-slot checking — so a key nobody declared - * can be written to one, and the migration below will *drop* it at the next + * reason", defers unknown-slot checking — so a key nobody declared can be + * written to one, and the migration below will *drop* it at the next * redefinition, because its rule is that an instance's keys are the class's * slots. That is real data loss and it is written down as such in TODO.org, * "A redefined defclass migrates its instances lazily", rather than dressed - * up as enforcement. + * up as enforcement. [set] does refuse an undeclared key, because a slot it + * writes has to exist. * * **Where a migration happens.** [want_map], so every [get], [put] and * [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances @@ -1541,11 +1544,36 @@ flan_dyn flan_dyn_map_new(void) { * runs ahead of its definition declares itself. */ flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n); +/* What a slot may hold. A dyn value's tag is the whole of what can be asked + * of it, so these are the tags — plus a range on top of the int tag for a + * narrower integer type, the significand a float slot holds exactly, a + * class for a slot declared with one, and whether nil is admitted, which is + * what (Option T) says. [word] is a scalar type's name, for the sentence a + * refusal prints. */ +enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT, ST_CLASS }; + +typedef struct slot_type { + uint8_t kind; + uint8_t opt; /* nil admitted: (Option T) */ + uint8_t fbits; /* ST_FLOAT: 53 for f64, 24 for f32 */ + int64_t lo, hi; /* ST_INT only */ + kw_entry *cls; /* ST_CLASS only */ + const char *word; /* static; NULL for ST_ANY and ST_CLASS */ +} slot_type; + typedef struct class_entry { kw_entry *name; kw_entry **slots; /* interned, immortal, in declaration order */ + slot_type *types; /* one per slot, same order */ + /* Per slot, the generation a migration last warned about a value that no + * longer fits the slot's type. One warning per slot per redefinition, + * however many instances carry such a value. */ + uint32_t *warned; int64_t nslots; uint32_t gen; + /* Whether any slot has a type. A class with none pays nothing at a store + * beyond reading this. */ + int typed; } class_entry; static class_entry *classes; @@ -1559,74 +1587,165 @@ static class_entry *class_find(kw_entry *name) { } /* The generation a new instance of [name] is stamped with. Zero for a class - * no definition has been registered for, which is every class in a program - * that was built and never reloaded: nothing has changed shape, so nothing - * needs to migrate, and the registry earns its keep only once an editor has - * sent a new definition. */ + * no definition has been registered for — which, now that the constructor + * registers its class, is only an instance built by something other than a + * constructor: test/dyn_ops.c, calling the runtime directly. */ static uint32_t class_gen(kw_entry *name) { class_entry *e = class_find(name); return e == NULL ? 0u : e->gen; } -/* One class's current slot list, as the compiler's per-reload thunk hands it - * over: the class's name as a keyword, and the slot names packed into one - * string, newline between and no leading colons — the shape a string literal - * already crosses in, rather than a dyn vector this would have to root. - * - * The generation is bumped only when the list actually differs. That is what - * makes C-c C-k idempotent: reloading a file re-runs every one of its class - * definitions, and a bump per reload would migrate every instance in the - * program every time anybody saved, for no change. */ -void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { - kw_entry *k; - kw_entry **list = NULL; - int64_t count = 0, i, start; - class_entry *e; - if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) - /* No location: the caller is the thunk a reload runs, which has no - source position of its own — the class's own [defclass] is where a - reader would look, and it is not on any stack by the time this runs. - Unreachable from written Flan in any case; only the compiler emits - this call, and it emits a keyword. */ - trap1(NULL, 0, TYPE_TRAP, "class definition", - "a class name is a keyword", name); - k = dyn_kw(name); +/* One slot's type, as [Check.class_spec_of] writes it: a scalar type's name, + * [#name] for a class, and a leading [?] for an (Option T). */ +static slot_type slot_type_of(const uint8_t *w, int64_t n) { + static const struct { + const char *w; uint8_t kind, fbits; int64_t lo, hi; + } known[] = { + { "bool", ST_BOOL, 0, 0, 0 }, + { "string", ST_TEXT, 0, 0, 0 }, + { "f32", ST_FLOAT, 24, 0, 0 }, + { "f64", ST_FLOAT, 53, 0, 0 }, + { "i8", ST_INT, 0, INT8_MIN, INT8_MAX }, + { "i16", ST_INT, 0, INT16_MIN, INT16_MAX }, + { "i32", ST_INT, 0, INT32_MIN, INT32_MAX }, + { "i64", ST_INT, 0, INT64_MIN, INT64_MAX }, + { "u8", ST_INT, 0, 0, UINT8_MAX }, + { "u16", ST_INT, 0, 0, UINT16_MAX }, + { "u32", ST_INT, 0, 0, UINT32_MAX }, + { "u64", ST_INT, 0, 0, INT64_MAX }, + }; + slot_type t = { ST_ANY, 0, 0, 0, 0, NULL, NULL }; + size_t i; + if (n > 0 && w[0] == '?') { + t = slot_type_of(w + 1, n - 1); + if (t.kind != ST_ANY) t.opt = 1; + return t; + } + if (n > 1 && w[0] == '#') { + t.kind = ST_CLASS; + t.cls = dyn_kw(flan_dyn_kw(w + 1, n - 1)); + return t; + } + for (i = 0; i < sizeof known / sizeof known[0]; i++) + if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) { + t.kind = known[i].kind; + t.fbits = known[i].fbits; + t.lo = known[i].lo; + t.hi = known[i].hi; + t.word = known[i].w; + return t; + } + /* A word this table does not know is a compiler newer than this runtime. + Holding anything is the answer that loses no data. */ + return t; +} + +static int slot_type_eq(const slot_type *a, const slot_type *b) { + return a->kind == b->kind && a->opt == b->opt && a->fbits == b->fbits + && a->lo == b->lo && a->hi == b->hi && a->cls == b->cls; +} + +/* The type as it was written, for a sentence. */ +static void slot_type_text(const slot_type *t, char *buf, size_t cap) { + char base[96]; + if (t->kind == ST_CLASS) + snprintf(base, sizeof base, "%.*s", (int)t->cls->len, + (const char *)(t->cls + 1)); + else + snprintf(base, sizeof base, "%s", t->word != NULL ? t->word : "dyn"); + if (t->opt) snprintf(buf, cap, "(Option %s)", base); + else snprintf(buf, cap, "%s", base); +} + +/* Whether [v] may be stored in a slot of type [t], and what is stored: [v] + * itself, or — for an int into a float slot — the float it widens to. The + * widening is the typed side's rule read off the value rather than off a + * static type: an integer the float holds exactly is admitted as that float, + * and one it does not is refused, as (f64 x) would be for the + * type that could hold it. A float into an f32 slot has to be one an f32 + * holds, which is the typed side refusing f64 into f32. */ +static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) { + int tag = flan_dyn_tag(v); + *out = v; + if (t->kind == ST_ANY) return 1; + if (tag == FLAN_DYN_TAG_NIL) return t->opt; + switch (t->kind) { + case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL; + case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT; + case ST_CLASS: + return tag == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass == t->cls; + case ST_FLOAT: + if (tag == FLAN_DYN_TAG_FLOAT) { + double d = dyn_num_value(v); + return t->fbits == 53 || d != d || (double)(float)d == d; + } + if (tag == FLAN_DYN_TAG_INT) { + /* Exact is a round trip, not a range: 2^54 is an f64 exactly and + 2^53+1 is not. The range test before the cast back is what keeps + that cast defined, since INT64_MAX rounds up to 2^63. */ + int64_t x = dyn_int_value(v); + double d = t->fbits == 53 ? (double)x : (double)(float)x; + if (!(d >= -9223372036854775808.0 && d < 9223372036854775808.0) + || (int64_t)d != x) + return 0; + *out = flan_dyn_from_f64(d); + return 1; + } + return 0; + case ST_INT: { + int64_t x; + if (tag != FLAN_DYN_TAG_INT) return 0; + x = dyn_int_value(v); + return x >= t->lo && x <= t->hi; + } + default: return 1; + } +} + +static int slot_fits(const slot_type *t, flan_dyn v) { + flan_dyn ignored; + return slot_admit(t, v, &ignored); +} + +/* A class's slots as the compiler hands them over: one line per slot, the + * slot's name and then, after a space, its type's name — nothing for a slot + * written with no type. The same string comes from a constructor and from a + * reload, so it is read in one place. The count is returned; both arrays are + * NULL for a class with no slots, which allocates nothing. */ +static int64_t class_spec(const uint8_t *spec, int64_t n, kw_entry ***names, + slot_type **types) { + int64_t count = 0, i, start; if (n < 0) n = 0; - /* Count first, then fill: one allocation of the right size, and an empty - * class — (defclass marker []) is in the corpus — allocates nothing. */ + *names = NULL; + *types = NULL; for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { + if (i == n ? i > start : spec[i] == '\n') { if (i > start) count++; start = i + 1; } - if (count > 0) { - list = (kw_entry **)malloc((size_t)count * sizeof *list); - if (list == NULL) trap_oom(NULL, 0, count * (int64_t)sizeof *list); - count = 0; - for (i = 0, start = 0; i <= n; i++) - if (i == n ? i > start : slots[i] == '\n') { - if (i > start) - list[count++] = dyn_kw(flan_dyn_kw(slots + start, i - start)); - start = i + 1; + if (count == 0) return 0; + *names = (kw_entry **)malloc((size_t)count * sizeof **names); + *types = (slot_type *)malloc((size_t)count * sizeof **types); + if (*names == NULL || *types == NULL) + trap_oom(NULL, 0, count * (int64_t)(sizeof **names + sizeof **types)); + count = 0; + for (i = 0, start = 0; i <= n; i++) + if (i == n ? i > start : spec[i] == '\n') { + if (i > start) { + int64_t sp = start; + while (sp < i && spec[sp] != ' ') sp++; + (*names)[count] = dyn_kw(flan_dyn_kw(spec + start, sp - start)); + (*types)[count] = sp < i ? slot_type_of(spec + sp + 1, i - sp - 1) + : slot_type_of(NULL, 0); + count++; } - } - e = class_find(k); - if (e != NULL) { - int same = e->nslots == count; - if (same) - for (i = 0; i < count; i++) - if (e->slots[i] != list[i]) { same = 0; break; } - if (same) { free(list); return; } - free(e->slots); - e->slots = list; - e->nslots = count; - /* Wrapping is not a correctness question — what matters is that the new - * generation differs from the one the live instances carry — but zero is - * reserved for "no definition registered", so it is stepped over. */ - e->gen = e->gen + 1u; - if (e->gen == 0u) e->gen = 1u; - return; - } + start = i + 1; + } + return count; +} + +static void class_add(kw_entry *k, kw_entry **list, slot_type *types, + int64_t count) { if (classes_n == classes_cap) { int64_t cap = classes_cap ? classes_cap * 2 : 8; class_entry *t = @@ -1637,7 +1756,18 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { } classes[classes_n].name = k; classes[classes_n].slots = list; + classes[classes_n].types = types; + classes[classes_n].warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && classes[classes_n].warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); classes[classes_n].nslots = count; + classes[classes_n].typed = 0; + { + int64_t j; + for (j = 0; j < count; j++) + if (types[j].kind != ST_ANY) classes[classes_n].typed = 1; + } /* One, never zero: an instance built before this registration carries zero * and has to be seen as stale, because the definition it was built from is * exactly the one nobody recorded. */ @@ -1645,11 +1775,201 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { classes_n++; } +/* One class's current definition, as the compiler's per-reload thunk hands + * it over: the class's name as a keyword, and [class_spec]'s string. + * + * The generation is bumped only when the definition actually differs — a + * slot's name or its type. That is what makes C-c C-k idempotent: reloading + * a file re-runs every one of its class definitions, and a bump per reload + * would migrate every instance in the program every time anybody saved, for + * no change. */ +void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { + kw_entry *k; + kw_entry **list; + slot_type *types; + int64_t count, i; + class_entry *e; + if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD) + /* No location: the caller is the thunk a reload runs, which has no + source position of its own — the class's own [defclass] is where a + reader would look, and it is not on any stack by the time this runs. + Unreachable from written Flan in any case; only the compiler emits + this call, and it emits a keyword. */ + trap1(NULL, 0, TYPE_TRAP, "class definition", + "a class name is a keyword", name); + k = dyn_kw(name); + count = class_spec(slots, n, &list, &types); + e = class_find(k); + if (e != NULL) { + int same = e->nslots == count; + if (same) + for (i = 0; i < count; i++) + if (e->slots[i] != list[i] || !slot_type_eq(&e->types[i], &types[i])) { + same = 0; + break; + } + if (same) { free(list); free(types); return; } + free(e->slots); + free(e->types); + free(e->warned); + e->slots = list; + e->types = types; + e->warned = + count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL; + if (count > 0 && e->warned == NULL) + trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t)); + e->nslots = count; + e->typed = 0; + for (i = 0; i < count; i++) + if (types[i].kind != ST_ANY) e->typed = 1; + /* Wrapping is not a correctness question — what matters is that the new + * generation differs from the one the live instances carry — but zero is + * reserved for "no definition registered", so it is stepped over. */ + e->gen = e->gen + 1u; + if (e->gen == 0u) e->gen = 1u; + return; + } + class_add(k, list, types, count); +} + +/* update-instance-for-redefined-class's dispatcher, as the last reload that + * installed a class or one of its methods left it; NULL until then. Set by a + * thunk and not found by name, because the name is a Flan symbol this file + * cannot spell and the body behind it moves with every method added. */ +static void *migrate_fn; + +void flan_dyn_class_hook(void *fn) { migrate_fn = fn; } + +extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, + uint64_t added, uint64_t discarded); + +/* Allocation and the map operations are further down, under their own + * headings; the hook's arguments are built with them. */ +flan_dyn flan_dyn_vec_new(void); +flan_dyn flan_dyn_map_new(void); +void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); +void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); + +/* The user hook, run on an instance the name-matching has just brought up to + * date. [inst], [added] and [gone] are rooted by the caller. + * + * Two things are kept for the length of the call, because the call is + * arbitrary Flan and may allocate as much as it likes: + * + * - the name-matched entries, rooted, so that taking the restart puts the + * instance back exactly as name-matching left it, whatever the method did + * to it before it signalled. That is the restart's whole meaning, and it + * is SBCL's choice of what a failed update leaves (std-class.lisp, the + * nlx-protect around the call) moved one step: SBCL restores the obsolete + * instance and retries at the next access, where here the name-matched + * one is kept and nothing is retried. + * - the temporaries ring, saved and put back. A migration starts inside + * [get] or [put], whose caller may be holding an object only the ring + * keeps alive — the result of the call beside it in the same expression. + * A method that allocates more than the ring holds would push it out and + * let the next collection free it, so the ring is rooted for the call and + * restored after it, and the caller sees the ring it left. */ +static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added, + flan_dyn gone, int64_t n) { + flan_dyn *snap = NULL; + flan_obj *ring_was[RING]; + flan_dyn ring_rooted[RING]; + unsigned ring_at_was = ring_at, k; + int64_t j, roots_at = roots_n; + int r; + if (n > 0) { + snap = (flan_dyn *)malloc((size_t)n * 2 * sizeof *snap); + if (snap == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *snap); + memcpy(snap, o->u.v.items, (size_t)n * 2 * sizeof *snap); + for (j = 0; j < n; j++) root_add(&snap[j * 2 + 1], NULL); + } + memcpy(ring_was, ring, sizeof ring); + for (k = 0; k < RING; k++) { + ring_rooted[k] = ring[k] == NULL + ? dyn_make(BOX_NIL, 0) + : dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)ring[k]); + root_add(&ring_rooted[k], NULL); + } + r = flan_dyn_migrate_hook(migrate_fn, inst, added, gone); + memcpy(ring, ring_was, sizeof ring); + ring_at = ring_at_was; + /* Nothing below allocates on the collector's heap, so the roots into + [snap] and this frame can go before either does. */ + roots_n = roots_at; + if (r == 1) { + /* The restart: the entries name-matching left, in a block of their own, + * whatever the method grew or shrank the instance to. */ + flan_dyn *back = NULL; + if (n > 0) { + back = (flan_dyn *)malloc((size_t)n * 2 * sizeof *back); + if (back == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *back); + memcpy(back, snap, (size_t)n * 2 * sizeof *back); + } + gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); + free(o->u.v.items); + o->u.v.items = back; + o->u.v.cap = n; + o->len = n; + } + free(snap); + if (r == 2) { + kw_entry *c = o->u.v.klass; + fflush(stdout); + fprintf(stderr, + "dyn migrate: update-instance-for-redefined-class, migrating an " + "instance of %.*s, was left for a restart established outside " + "it. A migration runs inside get, put or set, and cannot be " + "left for one of their callers; the instance is kept as its " + "slots matched by name. Take migrate-by-name, or handle the " + "condition inside the method\n", + (int)c->len, (const char *)(c + 1)); + flan_trap((const uint8_t *)"DynMigrate", 10); + } +} + +/* An entry at the end of a map, with no lookup first: for a map whose keys + * are known to be distinct already. A lookup compares keys with [dyn_equal], + * which migrates any stale instance it meets and runs that instance's hook — + * and a migration building its own hook's arguments must not start another + * one, or the instance it is migrating is migrated again inside itself. */ +static void map_append(flan_obj *m, flan_dyn k, flan_dyn v) { + if (m->len == m->u.v.cap) { + int64_t cap = m->u.v.cap ? m->u.v.cap * 2 : 8; + flan_dyn *items = + (flan_dyn *)realloc(m->u.v.items, (size_t)cap * 2 * sizeof *items); + if (items == NULL) trap_oom(NULL, 0, cap * 2 * (int64_t)sizeof *items); + gc_bytes += (cap - m->u.v.cap) * 2 * (int64_t)sizeof *items; + m->u.v.items = items; + m->u.v.cap = cap; + } + m->u.v.items[m->len * 2] = k; + m->u.v.items[m->len * 2 + 1] = v; + m->len++; +} + +/* Which of [o]'s entries is the slot [s], or -1. The interned identity + * compare, never [dyn_equal]: see [map_append]. [flan_dyn_tag] and not a + * bare [dyn_box]: a float is not boxed at all, so its payload bits can read + * as any box tag, and reading a non-keyword's payload as a [kw_entry *] is a + * wild pointer. A raw [put] can have left a float — or anything else — as a + * key. */ +static int64_t entry_of(flan_obj *o, kw_entry *s) { + int64_t i; + for (i = 0; i < o->len; i++) { + flan_dyn key = o->u.v.items[i * 2]; + if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD && dyn_kw(key) == s) + return i; + } + return -1; +} + /* The migration. [o] is left holding exactly the class's current slots, in * the class's order, with the values it already had for the ones it still - * has and nil for the ones it has just gained — which is precisely the - * property CLHS 4.3.6 guarantees, matched by name, with the instance's - * identity preserved because none of this allocates a new object. + * has — which is the property CLHS 4.3.6 guarantees, matched by name, with + * the instance's identity preserved because none of this allocates a new + * object. A slot it has just gained holds its type's zero value, Flan's + * zero-is-initialisation — false, 0, 0.0, the empty string — or nil where + * the type admits nil or has no zero: a dyn slot, an (Option T), a class. * * Rebuilt into a fresh block rather than compacted in place, and the order is * the class's rather than the instance's, so that a migrated instance is @@ -1658,61 +1978,183 @@ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) { * and count in insertion order and would have. One malloc per instance per * redefinition is the price, and a migration happens once. * - * Nothing here allocates on the collector's heap, so no collection can run - * part-way through and see an object whose [len] and [items] disagree. + * In three steps, and the order is what keeps it sound. * - * Nor can it free a block something above it is walking. The block it frees - * is [o]'s, and every caller syncs [o] before it starts walking [o] — so a - * re-entry through a nested [dyn_equal], including a map used as a key of - * itself, finds [o] already current and returns at the generation compare. - * The key scan here uses the interned identity compare and calls - * [dyn_equal] not at all, so it cannot re-enter from inside. */ -static void class_sync(flan_obj *o) { - class_entry *e; + * First, everything that allocates on the collector's heap: the hook's + * arguments, and an empty string for a gained string slot. A collection may + * run here, while [o] still holds its old entries whole. Nothing in this + * step compares a key with [dyn_equal] — see [map_append] — so nothing in it + * can migrate another instance and run a hook inside this migration. + * + * Second, the name-matching, which allocates nothing on the collector's + * heap, calls nothing that can migrate, and finishes by stamping [o] + * current. [e] is read only up to here: a hook may build an instance of a + * class the registry has not seen, and adding it moves [classes]. + * + * Third, the hook, on an instance that is already current, so a method that + * reads or writes it finds it migrated and does not start a second + * migration. A method may touch anything, including a map something above + * this frame is walking; the migration of [o] itself is finished before it + * runs. */ +/* Kept out of line: inlined into [class_sync], its frame and saved + * registers were paid on every [get] and [put] of every map, current or not + * — measured at about a tenth of an untyped [put]'s instructions. */ +__attribute__((noinline)) +static void class_migrate(flan_obj *o, class_entry *e) { flan_dyn *fresh = NULL; - int64_t i, j; - if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return; - e = class_find(o->u.v.klass); - if (e == NULL || e->gen == o->gen) return; - if (e->nslots > 0) { - fresh = (flan_dyn *)malloc((size_t)e->nslots * 2 * sizeof *fresh); - if (fresh == NULL) trap_oom(NULL, 0, e->nslots * 2 * (int64_t)sizeof *fresh); + int64_t i, j, n; + /* Rooted by address for as long as they may be needed: each is a + * collector object held nowhere else. */ + flan_dyn inst, added, gone, empty; + int64_t roots_at = roots_n; + int hook, need_empty = 0; + n = e->nslots; + /* CLHS 4.3.6: the method runs on every instance a redefinition reaches, + * whether or not the slot names moved — a changed type is a change a + * method may want to convert for. */ + hook = migrate_fn != NULL && flan_dyn_migrate_hook != NULL; + for (j = 0; j < n; j++) + if (e->types[j].kind == ST_TEXT && !e->types[j].opt + && entry_of(o, e->slots[j]) < 0) + need_empty = 1; + inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); + added = gone = empty = dyn_make(BOX_NIL, 0); + if (hook || need_empty) root_add(&inst, NULL); + if (need_empty) { + empty = flan_dyn_from_bytes((const uint8_t *)"", 0); + root_add(&empty, NULL); } - for (j = 0; j < e->nslots; j++) { - flan_dyn v = dyn_make(BOX_NIL, 0); + if (hook) { + added = flan_dyn_vec_new(); + root_add(&added, NULL); + gone = flan_dyn_map_new(); + root_add(&gone, NULL); + for (j = 0; j < n; j++) + if (entry_of(o, e->slots[j]) < 0) + flan_dyn_push(added, + dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]), + NULL, 0); + /* Every key the class no longer declares, a raw [put]'s included: + * CLHS's discarded slots and their property list, as one map. [o]'s + * keys are distinct, so these are, and they are appended as they are. */ for (i = 0; i < o->len; i++) { flan_dyn key = o->u.v.items[i * 2]; - /* [flan_dyn_tag] and not a bare [dyn_box]: a float is not boxed at - all, so its payload bits can read as any box tag, and reading a - non-keyword's payload as a [kw_entry *] is a wild pointer. A raw - [put] can have left a float — or anything else — in here. */ - if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD - && dyn_kw(key) == e->slots[j]) { - v = o->u.v.items[i * 2 + 1]; - break; + int kept = 0; + if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD) + for (j = 0; j < n; j++) + if (dyn_kw(key) == e->slots[j]) { kept = 1; break; } + if (!kept) map_append(dyn_obj(gone), key, o->u.v.items[i * 2 + 1]); + } + } + if (n > 0) { + fresh = (flan_dyn *)malloc((size_t)n * 2 * sizeof *fresh); + if (fresh == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *fresh); + } + for (j = 0; j < n; j++) { + const slot_type *t = &e->types[j]; + flan_dyn v; + i = entry_of(o, e->slots[j]); + if (i >= 0) { + v = o->u.v.items[i * 2 + 1]; + /* A kept value that the slot's new type does not admit is kept + anyway: throwing it away would be the data loss a redefinition + exists to avoid, and there is nothing to convert it to. What it + gets is a warning, once per slot per redefinition, and the next + write to the slot is checked like any other. */ + if (!slot_fits(t, v) && e->warned[j] != e->gen) { + char sv[SAY_MAX], st[128]; + kw_entry *c = o->u.v.klass, *sl = e->slots[j]; + e->warned[j] = e->gen; + say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); + fflush(stdout); + fprintf(stderr, + "warning: %.*s was redefined, and its slot :%.*s is now " + "declared %s. An instance holds %s there, which is %s; it " + "keeps that value, and the next write to :%.*s is checked\n", + (int)c->len, (const char *)(c + 1), + (int)sl->len, (const char *)(sl + 1), st, sv, + tag_of(v), (int)sl->len, (const char *)(sl + 1)); } } + else if (t->opt) v = dyn_make(BOX_NIL, 0); + else + switch (t->kind) { + case ST_BOOL: v = flan_dyn_from_bool(0); break; + case ST_INT: v = flan_dyn_from_i64(0); break; + case ST_FLOAT: v = flan_dyn_from_f64(0.0); break; + case ST_TEXT: v = empty; break; + default: v = dyn_make(BOX_NIL, 0); break; + } fresh[j * 2] = dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]); fresh[j * 2 + 1] = v; } /* Charged the way [map_set]'s growth is, in both directions: a class that * lost slots gives the bytes back, or the trigger drifts up by whatever * every migration in the program ever released. */ - gc_bytes += (e->nslots - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); + gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn); free(o->u.v.items); o->u.v.items = fresh; - o->u.v.cap = e->nslots; - o->len = e->nslots; + o->u.v.cap = n; + o->len = n; o->gen = e->gen; + e = NULL; + if (hook) class_hook(o, inst, added, gone, n); + roots_n = roots_at; +} + +/* Every read or write of an instance comes through here first: the class's + * entry, with [o] migrated to it if it was stale, or NULL for a map with no + * class. The common case — current — is a lookup and a compare, and the + * migration is a call of its own so that it stays out of the way. The entry + * is looked up again after one, because a hook may have moved the table. */ +static class_entry *class_sync(flan_obj *o) { + class_entry *e; + if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return NULL; + e = class_find(o->u.v.klass); + if (e == NULL || e->gen == o->gen) return e; + class_migrate(o, e); + return class_find(o->u.v.klass); } /* The same map with a shape tag on it: what a (defclass ...) constructor * calls. [k] is a keyword and anything else traps by name — the compiler - * hands it the class's own name and nothing else can reach this. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k) { + * hands it the class's own name and nothing else can reach this. + * + * [spec] is the class's definition, [class_spec]'s string, and it registers + * the class the first time any instance of it is built. That is what makes + * a slot's type checked in a program that is never reloaded — the registry + * used to be filled only by a reload. A class already registered keeps + * what it has, and has to: a constructor compiled before a redefinition may + * still be on some stack, and letting its definition win would put the + * class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */ +/* A constructor call's site: [pending] from the caller, moved to [building] + * by the constructor's first act, so a call through a function value — which + * sets nothing — finds none rather than an earlier call's. Nothing between + * the caller setting it and the constructor taking it can construct: the + * caller evaluated every argument first. */ +static const uint8_t *site_pending, *site_building; +static int64_t site_pending_len, site_building_len; + +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen) { + site_pending = loc; + site_pending_len = loclen; +} + +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) { flan_obj *o; + site_building = site_pending; + site_building_len = site_pending_len; + site_pending = NULL; + site_pending_len = 0; if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k); + if (class_find(dyn_kw(k)) == NULL) { + kw_entry **list; + slot_type *types; + int64_t count = class_spec(spec, n, &list, &types); + class_add(dyn_kw(k), list, types, count); + } o = gc_alloc(OBJ_MAP, 0); o->len = 0; o->u.v.items = NULL; @@ -2081,6 +2523,14 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen) { return arith(loc, loclen, "-", a, b); } +/* (- x): an int wraps, as (- 0 x) does, and a float flips its sign, so the + * negation of 0.0 is -0.0 and not the 0.0 a subtraction from zero gives. */ +flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen) { + if (!is_num(a)) trap1(loc, loclen, TYPE_TRAP, "-", "it takes a number", a); + if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT) + return flan_dyn_from_i64((int64_t)(0 - (uint64_t)dyn_int_value(a))); + return flan_dyn_from_f64(-dyn_num_value(a)); +} flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen) { return arith(loc, loclen, "*", a, b); @@ -2587,8 +3037,160 @@ flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { return flan_dyn_from_bool(map_find(o, k) >= 0); } +/* A class slot's type, checked at the store — SBCL's place for it + * (src/pcl/slots.lisp, [set-slot-value]'s typecheck before the write), + * because the store is where the wrong value is. -1 when [k] is not a slot + * the class declares. */ +static int64_t class_slot(class_entry *e, flan_dyn k) { + int64_t j; + if (e == NULL || flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return -1; + for (j = 0; j < e->nslots; j++) + if (e->slots[j] == dyn_kw(k)) return j; + return -1; +} + +/* The three stores that reach a declared slot, for the sentence a refusal + * prints: the call as it would have been written. */ +enum { BY_PUT, BY_SET, BY_NEW }; + +static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen, + int by, flan_obj *o, class_entry *e, + int64_t j, flan_dyn m, flan_dyn v) { + char sm[SAY_MAX], sv[SAY_MAX], st[128]; + const slot_type *t = &e->types[j]; + kw_entry *sl = e->slots[j], *c = o->u.v.klass; + int sn = (int)sl->len, cn = (int)c->len; + const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1); + say(sm, SAY_MAX, m); + say(sv, SAY_MAX, v); + slot_type_text(t, st, sizeof st); + fflush(stdout); + /* A constructor's refusal is placed at the call that was wrong, when the + call said where it was, and names the slot's declaration after it. */ + trap_where(by == BY_NEW && site_building != NULL ? site_building : loc, + by == BY_NEW && site_building != NULL ? site_building_len : loclen); + fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ", + by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss, + cn, cs, st); + /* A number of the right kind that does not fit is not news about its tag. */ + if ((t->kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT) + || (t->kind == ST_FLOAT + && (flan_dyn_tag(v) == FLAN_DYN_TAG_INT + || flan_dyn_tag(v) == FLAN_DYN_TAG_FLOAT))) + fprintf(stderr, "%s is not a value it holds exactly — ", sv); + else if (t->kind == ST_CLASS && flan_dyn_tag(v) == FLAN_DYN_TAG_MAP) + fprintf(stderr, "this is not an instance of it — "); + else + fprintf(stderr, "this is %s — ", tag_of(v)); + if (by == BY_PUT) + fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv); + else if (by == BY_SET) + fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv); + else if (site_building != NULL && loc != NULL) + fprintf(stderr, "(%.*s ...) with :%.*s %s; the slot is declared at %.*s\n", + cn, cs, sn, ss, sv, (int)loclen, (const char *)loc); + else + fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv); + flan_trap((const uint8_t *)"DynType", 7); +} + +/* The value a store into [o] under [k] actually stores: [v], or the float an + * int widens to in a float slot. A class with no typed slot answers at its + * flag, and a map with no class before that. */ +static flan_dyn check_slot(const uint8_t *loc, int64_t loclen, int by, + flan_obj *o, class_entry *e, flan_dyn m, + flan_dyn k, flan_dyn v) { + int64_t j; + flan_dyn out; + if (e == NULL || !e->typed) return v; + j = class_slot(e, k); + if (j < 0) return v; + if (!slot_admit(&e->types[j], v, &out)) + trap_slot_type(loc, loclen, by, o, e, j, m, v); + return out; +} + +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v); + +/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for + * the constructor call it happened inside rather than for a [put] nobody + * wrote, and placed at the slot's declaration. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o = want_map("construct", m, k); + class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass); + map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v)); +} + +/* (set (get inst :slot) v). Three refusals, each its own sentence, because + * they are three different mistakes: the value is not a class instance at + * all (a map's entries are written with [put], which is where inserting a + * key is real); the key is not a slot the class declares; the value does not + * fit the slot's type. The first two are why this is not [put]: a declared + * slot always exists, so writing one is a store and never an insertion. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen) { + flan_obj *o; + class_entry *e; + int64_t j; + flan_dyn out; + if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) { + char sm[SAY_MAX]; + say(sm, SAY_MAX, m); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, + "dyn set: (get m k) is a place only on a class instance, and " + "this is %s%s — %s. A map's entries are written with put\n", + is_map(m) ? "a map with no class" : "a ", + is_map(m) ? "" : tag_of(m), sm); + flan_trap((const uint8_t *)"DynType", 7); + } + o = dyn_obj(m); + e = class_sync(o); + j = class_slot(e, k); + if (j < 0) { + char sk[SAY_MAX]; + kw_entry *c = o->u.v.klass; + int64_t i; + say(sk, SAY_MAX, k); + fflush(stdout); + trap_where(loc, loclen); + fprintf(stderr, "dyn set: %.*s has no slot %s. Its slots are", + (int)c->len, (const char *)(c + 1), sk); + if (e == NULL || e->nslots == 0) fprintf(stderr, " none"); + else + for (i = 0; i < e->nslots; i++) + fprintf(stderr, " :%.*s", (int)e->slots[i]->len, + (const char *)(e->slots[i] + 1)); + fprintf(stderr, "; a key the class does not declare is added with put, " + "not set\n"); + flan_trap((const uint8_t *)"DynType", 7); + } + if (!slot_admit(&e->types[j], v, &out)) + trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); + map_store(o, k, out); +} + +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, + int64_t loclen) { + flan_obj *o; + class_entry *e; + if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, "put", "only a map answers it", m, k); + o = dyn_obj(m); + e = class_sync(o); + /* A map with no class, and a class with no typed slot, stop at the test. */ + if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v); + map_store(o, k, v); +} + +/* The same with no site: a map literal's stores, and test/dyn_ops.c. */ void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { - flan_obj *o = want_map("put", m, k); + flan_dyn_map_put(m, k, v, NULL, 0); +} + +/* The store under all three, with the instance already brought up to date. */ +static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v) { int64_t i = map_find(o, k); if (i >= 0) { o->u.v.items[i * 2 + 1] = v; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index de2a3ae7..abe83d2a 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -105,15 +105,34 @@ flan_dyn flan_dyn_map_new(void); * * The tag is not traced and does not have to be: an interned keyword entry is * immortal and is not a collector object. */ -flan_dyn flan_dyn_map_new_class(flan_dyn k); +flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n); + +/* A constructor's store into a slot, checked against the slot's declared + * type — [flan_dyn_map_set] with a refusal worded for the constructor. */ +void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); + +/* Where the constructor about to be called was called from. Set by the + * caller immediately before the call and taken by the constructor's + * [flan_dyn_map_new_class], so a refusal in its stores names the call. */ +void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen); + +/* (set (get inst :slot) v): [m] must be a class instance and [k] a slot its + * class declares, and [v] must fit the slot's type; each is a trap with its + * own sentence, at [loc]. A declared slot always exists, so this stores and + * never inserts. */ +void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); /* The class's name as a keyword, or nil for anything that is not an instance * — an ordinary map included. Never traps. */ flan_dyn flan_dyn_class_of(flan_dyn v); /* A class definition, registered or re-registered: [name] is the class's name - * as a keyword and [slots]/[n] is its slot names packed into one string, - * newline between and no leading colons. The compiler emits one call per + * as a keyword and [slots]/[n] is its slots packed into one string, a line + * each, the slot's name and then — after a space, for a typed slot — its + * type's name: "x i64\ny" is an i64 slot :x and a slot :y of any value. + * [flan_dyn_map_new_class] takes the same string. The compiler emits one call per * (defclass ...) into the thunk a reload runs, so a definition that changed * lands here before anything touches an instance. * @@ -122,9 +141,10 @@ flan_dyn flan_dyn_class_of(flan_dyn v); * migrates nothing. When it does move, every instance built against an * earlier definition migrates lazily at its next [get], [put], [has-key?], * [len] or equality comparison: slots the class still has keep their values - * matched by name, slots it has gained appear as nil, and keys it no longer + * matched by name, a slot it has gained holds its type's zero value — nil + * for an untyped, an (Option T) or a class-typed slot — and keys it no longer * declares are dropped. The instance's identity is preserved throughout; - * this is CLHS 4.3.6 without the user hook. + * this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook. * * The drop is unconditional, which is the honest cost of a class instance * being an open map: a key written by a raw [put] that the class never @@ -132,6 +152,13 @@ flan_dyn flan_dyn_class_of(flan_dyn v); * class's intention and does not enforce it. */ void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n); +/* The body update-instance-for-redefined-class dispatches through, as a + * reload last saw it. Each migration after this calls it, through + * flan_rt.c's [flan_dyn_migrate_hook], with the instance already matched by + * name. A reload that installs a class or a method of that generic calls + * this again, so the body is never older than the last one installed. */ +void flan_dyn_class_hook(void *fn); + /* [sizeof(flan_obj)], for the one test that asserts it. The generation a * class instance carries was fitted into the padding between [mark] and * [len] precisely so that this number did not move; a field that pushed it @@ -168,6 +195,7 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); +flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen); /* Answer a bool dyn. Numbers compare as numbers and text compares bytewise; * a mixture of the two, or anything else, traps. */ @@ -202,6 +230,10 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); * key in place, so a key occurs once and insertion order is print order. */ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); +/* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal + * prints. */ +void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, + const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k); /* Structural, and per type it renders what typed [print] renders. Never diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 7746b3ad..40495be1 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -647,6 +647,26 @@ void (*flan_break_hook)(const uint8_t *name, int64_t namelen, void *condition, * site printed just above carries the detail. */ void (*flan_trap_hook)(const uint8_t *name, int64_t namelen); +/* The call a class migration makes to update-instance-for-redefined-class: + * [fn] is the method dispatcher's current body, and the three words are the + * instance, the vec of slots it gained and the map of the slots it lost to + * the values they held — dyn words, as [uint64_t] here because this file + * does not include flan_dyn.h. + * + * Here and not in flan_dyn.c because it is set by the agent, and the agent + * must link against a program with no collector in it; and not called from + * here because what makes it a hook is the restart it runs under, which is + * the agent's business — the floor a break inside it reads is the agent's. + * NULL, and no hook runs, outside a dev session: a class is redefined only + * by a reload, and a reload only arrives through the agent. + * + * The answer is 0 when the method returned, 1 when the restart the call + * established was taken, and 2 when some other transfer came back through + * it — one aimed at a restart below the call, which a C frame cannot carry + * on. */ +int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded); + static _Noreturn void rt_trap(const uint8_t *name, int64_t namelen) { if (flan_trap_hook != NULL) flan_trap_hook(name, namelen); rt_die(); diff --git a/test/daemon-x86.out b/test/daemon-x86.out new file mode 100644 index 00000000..63826b3b --- /dev/null +++ b/test/daemon-x86.out @@ -0,0 +1,2 @@ +flan dev: built dev-hook.flan in 444ms +flan dev: /home/joe/Development/flan/.claude/worktrees/agent-a6ffe579d55d1892b/test/programs/dev-hook.flan ready on /tmp/claude-1000/rv-3672919.sock (17ms, one process) diff --git a/test/dyn_ops.c b/test/dyn_ops.c index d57d4424..12114fc6 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -985,6 +985,8 @@ static void refuse(const char *what) { if (strcmp(what, "add") == 0) (void)FDYN_add(flan_dyn_from_i64(3), t); else if (strcmp(what, "sub") == 0) (void)FDYN_sub(flan_dyn_nil(), flan_dyn_from_i64(1)); + else if (strcmp(what, "neg") == 0) + (void)flan_dyn_neg(t, NULL, 0); else if (strcmp(what, "mul") == 0) (void)FDYN_mul(flan_dyn_from_bool(1), flan_dyn_from_i64(2)); else if (strcmp(what, "div") == 0) @@ -1061,7 +1063,8 @@ static void define(const char *name, const char *slots) { * Built through the same entry point a constructor uses, so it is stamped * exactly as compiled code would stamp it. */ static flan_dyn a_point(int64_t x, int64_t y) { - flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + flan_dyn p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny", 3); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(x)); flan_dyn_map_set(p, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1176,7 +1179,8 @@ static void classes(void) { define("point", "x\ny\nn"); /* Built by hand rather than through [a_point], because it is the instance the *new* constructor would build: three slots, stamped current. */ - q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5)); + q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"point", 5), + (const uint8_t *)"x\ny\nn", 5); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"x", 1), flan_dyn_from_i64(1)); flan_dyn_map_set(q, flan_dyn_kw((const uint8_t *)"y", 1), @@ -1236,6 +1240,111 @@ static void classes(void) { printf(failures == 0 ? "classes ok\n" : "classes failed\n"); } +/* ── update-instance-for-redefined-class, re-entered ───────────────── + * + * The hook is Flan in a program; here it is C, installed where the agent + * installs its caller, which is the same call from flan_dyn.c's side. Three + * stale instances, the first holding the other two as keys of raw [put]s, so + * building the first one's discarded map is where a lookup would compare + * them — and migrate them, and run their hooks, inside the first one's + * migration. The hook itself touches the first instance and builds + * instances of classes the registry has not seen, which grows it and moves + * it under any migration still holding an entry. Each instance's hook runs + * once, and the discarded map holds both instance keys. Clean under + * memcheck is the other half of the claim, and is what @valgrind's run of + * this mode says. */ +extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded); +void flan_dyn_class_hook(void *fn); + +static flan_dyn hk_p, hk_q, hk_r; +static int hk_runs_p, hk_runs_q, hk_runs_r, hk_fresh, hk_per_call = 20; +static int64_t hk_gone_len = -1; + +static int hk_call(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded) { + char name[16]; + int i; + (void)fn; + (void)added; + if (instance == hk_p) { + hk_runs_p++; + hk_gone_len = flan_dyn_need_i64(flan_dyn_len(discarded)); + } + if (instance == hk_q) hk_runs_q++; + if (instance == hk_r) hk_runs_r++; + (void)slot(hk_p, "x"); + for (i = 0; i < hk_per_call; i++) { + snprintf(name, sizeof name, "fresh%d", hk_fresh++); + (void)flan_dyn_map_new_class( + flan_dyn_kw((const uint8_t *)name, (int64_t)strlen(name)), + (const uint8_t *)"a", 1); + } + return 0; +} + +static void hook_reentry(void) { + flan_dyn_root_push(&hk_p); + flan_dyn_root_push(&hk_q); + flan_dyn_root_push(&hk_r); + define("pt", "x\ny"); + hk_p = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_q = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + hk_r = flan_dyn_map_new_class(flan_dyn_kw((const uint8_t *)"pt", 2), + (const uint8_t *)"x\ny", 3); + flan_dyn_map_set(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(1)); + /* Distinct, or they are one key: instances compare by their slots. */ + flan_dyn_map_set(hk_q, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_r, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(3)); + flan_dyn_map_set(hk_p, hk_q, flan_dyn_from_i64(2)); + flan_dyn_map_set(hk_p, hk_r, flan_dyn_from_i64(3)); + flan_dyn_migrate_hook = hk_call; + flan_dyn_class_hook((void *)hk_call); + define("pt", "x\ny\nz"); + check(flan_dyn_need_i64(slot(hk_p, "x")) == 1, "a kept slot after a re-entered hook"); + check(hk_runs_p == 1, "the first instance's hook ran once"); + check(hk_runs_q == 0 && hk_runs_r == 0, + "building the first instance's arguments migrated no other instance"); + check(hk_gone_len == 2, "the discarded map holds both instance keys"); + (void)slot(hk_q, "x"); + (void)slot(hk_r, "x"); + (void)slot(hk_q, "x"); + check(hk_runs_q == 1 && hk_runs_r == 1, + "each other instance runs its hook once, at its own first touch"); + check(hk_runs_p == 1, "and the first instance's did not run again"); + + /* A migration started by a store rather than a read, with a hook that + grows the registry past its capacity each time: the store goes on to + check the value against the class's entry, and it has to be the entry + the registry holds after the hook, not the one it held before. 200 and + then 300 new classes are each enough to move the table whatever its + capacity was. :x is an f64 slot now, so the int stored must arrive as a + float, which only the entry's types can say. */ + hk_per_call = 200; + define("pt", "x f64\ny\nz\nw"); + flan_dyn_map_put(hk_p, flan_dyn_kw((const uint8_t *)"x", 1), + flan_dyn_from_i64(5), NULL, 0); + check(hk_runs_p == 2, "a put migrates and runs the hook"); + check(flan_dyn_tag(slot(hk_p, "x")) == FLAN_DYN_TAG_FLOAT, + "a put after a hook that moved the registry widens by the new entry"); + hk_per_call = 300; + define("pt", "x f64\ny\nz\nw\nv"); + flan_dyn_slot_set(hk_p, flan_dyn_kw((const uint8_t *)"w", 1), + flan_dyn_from_i64(7), NULL, 0); + check(hk_runs_p == 3, "a set migrates and runs the hook"); + check(flan_dyn_need_i64(slot(hk_p, "w")) == 7, + "a set after a hook that moved the registry finds its slot"); + flan_dyn_migrate_hook = NULL; + flan_dyn_class_hook(NULL); + flan_dyn_root_pop(3); + printf(failures == 0 ? "hook ok\n" : "hook failed\n"); +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 2) { @@ -1253,6 +1362,10 @@ int main(int argc, char **argv) { if (strcmp(argv[1], "unrooted") == 0) { unrooted(); return 0; } if (strcmp(argv[1], "park") == 0) { park(); return 0; } if (strcmp(argv[1], "desc") == 0) { desc(); return 0; } + if (strcmp(argv[1], "hook") == 0) { + hook_reentry(); + return failures == 0 ? 0 : 1; + } if (strcmp(argv[1], "classes") == 0) { classes(); return failures == 0 ? 0 : 1; diff --git a/test/programs/array-first-element.flan b/test/programs/array-first-element.flan index a667a60a..e50876e8 100644 --- a/test/programs/array-first-element.flan +++ b/test/programs/array-first-element.flan @@ -1,6 +1,6 @@ ;;;; An array literal with nothing outside it saying what its elements are -;;;; takes that from its first element: [(f32 1.0) 2.5] is a [2 f32], and the -;;;; 2.5 is an f32 literal rather than an f64 refused for not being one. +;;;; takes that from the elements that are not literals: [(f32 1.0) 2.5] is a +;;;; [2 f32], and the 2.5 is an f32 literal rather than an f64. (defn sum3 [a [3 f32]] f32 (+ (at a 0) (at a 1) (at a 2))) (defn main [] i32 diff --git a/test/programs/array-mixed.flan b/test/programs/array-mixed.flan new file mode 100644 index 00000000..f4238c73 --- /dev/null +++ b/test/programs/array-mixed.flan @@ -0,0 +1,59 @@ +;;;; An array literal with nothing outside it naming a type: elements that agree +;;;; are a typed array, numbers meeting at the wider and a literal taking the +;;;; others' type, and elements that do not are a dyn vector. +(defstruct P [x i32 y i32]) +(defn mixed [] i32 + (let [x (i32 4) + a [(f32 1.0) 2.5 3.25] + b [(i64 1) 2 3] + c [(u8 1) 300] + d [x 2.5] + e [1 18446744073709551615] + f [10 "Hi"] + g [nil 1] + h [None (Some 3)] + i [(P 1 2) {.x 3 .y 4}] + j [[1 2] [3 4]] + k [1 2.5] + m [x (i64 5)] + dd [:a "b" 3]] + (println (length a)) + (println (+ (at c 1) (i32 (at c 0)))) + (println (at d 1)) + (println (at e 1)) + (println f) + (println g) + (println (length f)) + (println (match (at h 1) None 0 (Some v) v)) + (println (.y (at i 1))) + (println (at (at j 1) 0)) + (println (at k 0)) + (println (+ (at m 0) (i64 9000000000))) + (println dd)) + 0) + +;; (the T e) gives any expression its type. +(defn the-forms [] i32 + (let [a (the u8 200) + b (the i64 5000000000) + c (the f32 2.5) + d (the [3 f32] [1 2 3.5]) + e (the [f32] [1 2.5]) + f (the (Option i32) None) + g (the (Option i32) nil) + h (the dyn 3) + n (the i64 (+ (the i32 1) 2)) + v (the (Vec i32) (vec-new))] + (println (+ a (u8 55))) + (println b) + (println (* c (f32 2.0))) + (println (+ (at d 0) (at d 2))) + (println (length e)) + (println (match f None 0 (Some x) x)) + (println (match g None 7 (Some x) x)) + (println h) + (println n) + (println (length v))) + 0) + +(defn main [] i32 (mixed) (the-forms)) diff --git a/test/programs/dev-hook.flan b/test/programs/dev-hook.flan new file mode 100644 index 00000000..d553b3fa --- /dev/null +++ b/test/programs/dev-hook.flan @@ -0,0 +1,21 @@ +;;;; A class redefined under its instances, with update-instance-for- +;;;; redefined-class written from the session to carry a lost slot's value +;;;; into a gained one. dev-classes.flan is the name-matching half; this is +;;;; the half a method adds, and the method that signals. +;;;; +;;;; The instances are pushed by the editor for dev-classes.flan's reason: a +;;;; compiled caller of the constructor would pin its slot count. +(import agent "vendor:agent") + +(defclass point [x y]) + +(defstruct Refused [why i32]) + +(defonce instances dyn) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-hook-fallback.sock") + (set instances (vec-new dyn)) + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/programs/dyn-class-pkg.flan b/test/programs/dyn-class-pkg.flan new file mode 100644 index 00000000..e237cb4e --- /dev/null +++ b/test/programs/dyn-class-pkg.flan @@ -0,0 +1,8 @@ +;;;; A slot type a package wrote names the package's own class, not an +;;;; importer's class of the same bare name. +(import g "pkgs/geo") +(defclass pt [z]) +(defn main [] i32 + (println (g/mk)) + (println (pt 1)) + 0) diff --git a/test/programs/dyn-class-slots.flan b/test/programs/dyn-class-slots.flan new file mode 100644 index 00000000..8d3181f1 --- /dev/null +++ b/test/programs/dyn-class-slots.flan @@ -0,0 +1,55 @@ +;;;; Typed class slots, and set on a slot. +;;;; +;;;; A slot vector reads as a defn's parameter vector: [pause bool] is a slot +;;;; of type bool, and a name followed by another name is a slot with no type, +;;;; which holds any dyn value. The type is checked when a value is stored -- +;;;; by the constructor, by put and by set -- and not when one is read: an +;;;; instance is a dyn map whatever its slots say. +;;;; +;;;; set writes a declared slot. A class declares its slots, so one always +;;;; exists and (get s :pause) is a place, where a plain map's absent key is +;;;; not. dyn-slot-trap.flan has the refusals. + +(defclass state [pause bool step i32 speed f64 name string tag]) + +;; A class is a slot type, and (Option T) admits nil beside a T. +(defclass node [owner state next (Option node) weight (Option f32)]) + +(defn twelve [] i64 12) + +(defn main [] i32 + (let [s (state false 3 1.5 "sand" :x)] + (println s) + (set (get s :pause) true) + (println (get s :pause)) + ;; An i32 slot takes any int in i32's range; a dyn caller passes the + ;; value as it is, with nothing converted first. + (set (get s :step) -7) + (println (get s :step)) + (set (get s :tag) [1 2]) + (println (get s :tag)) + ;; put reaches the same check for a declared slot, and still inserts a + ;; key the class does not declare -- an instance is an open map to put. + (put s :speed 2.5) + (put s :scratch 9) + (println (get s :speed)) + (println (get s :scratch)) + (println (length s)) + ;; A typed caller boxes into the dyn parameter as any call does. + (set (get s :step) (twelve)) + (println (get s :step)) + ;; An int into a float slot widens, as it does into a typed f64 + ;; parameter, when the float holds it exactly. + (put s :speed 3) + (println (+ (get s :speed) 0.5)) + ;; Exact is a round trip, not a range: 2^54 is an f64 exactly. + (put s :speed 18014398509481984) + (println (= (get s :speed) 18014398509481984.0)) + (let [n (node s nil nil)] + (set (get n :next) (node s nil 2)) + (println (get (get n :next) :weight)) + (set (get n :weight) nil) + ;; 2^30 is an f32 exactly, though it is past f32's 24-bit significand. + (set (get n :weight) 1073741824) + (println (class-of (get n :owner))))) + 0) diff --git a/test/programs/dyn-slot-trap.flan b/test/programs/dyn-slot-trap.flan new file mode 100644 index 00000000..890489bc --- /dev/null +++ b/test/programs/dyn-slot-trap.flan @@ -0,0 +1,21 @@ +;;;; The refusals of a typed class slot, one per run because each ends the +;;;; process. The argument chooses which. The line numbers are asserted by +;;;; the test, so an edit above them moves them. +(defclass state [pause bool step i32 tag]) +(defclass node [owner state]) + +(defn as-dyn [d dyn] dyn d) + +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0) + s (state false 3 nil)] + (println "before") + (cond + (= which 0) (println (state 1 2 3)) + (= which 1) (put s :pause 1) + (= which 2) (set (get s :step) 5000000000) + (= which 3) (set (get s :paws) true) + (= which 4) (set (get (as-dyn {:pause 1}) :pause) true) + (= which 5) (println (node (node s))) + :else (println (state nil 1 2)))) + 0) diff --git a/test/programs/limits.flan b/test/programs/limits.flan index bd284465..954cc082 100644 --- a/test/programs/limits.flan +++ b/test/programs/limits.flan @@ -60,6 +60,10 @@ (print " ") (println (if ok "ok" "WRONG"))) +(defn ne-f64 [a f64 b f64] bool (!= a b)) +(defn ne-f32 [a f32 b f32] bool (!= a b)) +(defn ne-dyn [a dyn b dyn] bool (!= a b)) + (defn main [] i32 ;; The integers, each printed as the exact decimal the expected output pins. (println i8-max) @@ -115,17 +119,26 @@ ;; the absence is recorded rather than merely unmentioned: a float's least ;; value is the negation of its greatest, and there is nothing to derive. (say "f32's least value negates its greatest" - (< (- (f32 0.0) f32-max) (- (f32 0.0) f32-min-positive))) + (< (- f32-max) (- f32-min-positive))) (say "f64's least value negates its greatest" - (< (- 0.0 f64-max) (- 0.0 f64-min-positive))) + (< (- f64-max) (- f64-min-positive))) ;; The infinities and NaNs, which no literal writes. Each infinity is the ;; overflow of its type's greatest value, negated it is below the least ;; finite one, and a NaN is the one value not equal to itself. (say "f64-inf" (= f64-inf (* f64-max 2.0))) (say "f32-inf" (= f32-inf (* f32-max (f32 2.0)))) - (say "f64-inf negated" (< (- 0.0 f64-inf) (- 0.0 f64-max))) - (say "f32-inf negated" (< (- (f32 0.0) f32-inf) (- (f32 0.0) f32-max))) + (say "f64-inf negated" (< (- f64-inf) (- f64-max))) + (say "f32-inf negated" (< (- f32-inf) (- f32-max))) (say "f64-nan" (not (= f64-nan f64-nan))) (say "f32-nan" (not (= f32-nan f32-nan))) + ;; != is the one unordered comparison: a NaN is unequal to everything, + ;; itself included, and the dyn side agrees. The operands arrive as + ;; parameters so that no constant folder answers in the backend's place. + (say "f64-nan != itself" (ne-f64 f64-nan f64-nan)) + (say "f32-nan != itself" (ne-f32 f32-nan f32-nan)) + (say "!= over ordinary floats" + (and (ne-f64 1.0 2.0) (not (ne-f64 1.5 1.5)) + (ne-f32 (f32 1.0) (f32 2.0)) (not (ne-f32 (f32 1.5) (f32 1.5))))) + (say "a dyn NaN != itself" (ne-dyn f64-nan f64-nan)) 0) diff --git a/test/programs/literal-arm.flan b/test/programs/literal-arm.flan new file mode 100644 index 00000000..5459e906 --- /dev/null +++ b/test/programs/literal-arm.flan @@ -0,0 +1,18 @@ +;;;; A literal arm takes its type from the arm that is not a literal, in an +;;;; if, a cond and a match alike, as a literal operand of + does. +(defn g [c bool n i64] i64 (let [x (if c 4000000 n)] x)) +(defn h [k i32 n i64] i64 + (let [x (cond (= k 0) 5000000000 (= k 1) 7 :else n)] x)) +(defn m [o (Option i64)] i64 + (let [x (match o None 3 (Some v) v)] x)) +(defn f32s [c bool y f32] f32 (let [x (if c 2.5 y)] x)) +(defn main [] i32 + (println (g true (i64 3))) + (println (g false (i64 9000000000))) + (println (h 0 (i64 1))) + (println (h 1 (i64 1))) + (println (h 2 (i64 9000000000))) + (println (m None)) + (println (m (Some (i64 9000000000)))) + (println (f32s true (f32 1.0))) + 0) diff --git a/test/programs/max-value.flan b/test/programs/max-value.flan new file mode 100644 index 00000000..70015390 --- /dev/null +++ b/test/programs/max-value.flan @@ -0,0 +1,54 @@ +;;;; (max-value T) and (min-value T): a numeric type's limits, named by the type, at +;;;; a concrete type and inside a generic whose bound admits numbers. + +;; A selection sort, descending, whose running best starts at the least value +;; of the element type, so any element beats it. +(defn sort-desc [s [$t]] () + {:where (numeric? $t)} + (dotimes [i (length s)] + (let [best (min-value $t) + at-best i] + (dotimes [j (- (length s) i)] + (let [k (+ i j)] + (when (> (at s k) best) + (set best (at s k)) + (set at-best k)))) + (swap s i at-best)))) + +(defn largest [s [$t]] $t + {:where (numeric? $t)} + (let [best (min-value t)] + (dotimes [i (length s)] + (when (> (at s i) best) (set best (at s i)))) + best)) + +(defn show-i32 [s [i32]] () + (dotimes [i (length s)] (print (at s i)) (print " ")) + (println "")) + +(defn show-f64 [s [f64]] () + (dotimes [i (length s)] (print (at s i)) (print " ")) + (println "")) + +(defn main [] i32 + (println (max-value u8)) + (println (min-value u8)) + (println (max-value i8)) + (println (min-value i8)) + (println (max-value i32)) + (println (min-value i64)) + (println (max-value u64)) + (println (= (max-value f32) f32-max)) + (println (= (min-value f64) (- f64-max))) + (println (= (max-value i16) i16-max)) + (let [a [(i32 3) -7 12 0 -2147483648 5] + b [2.5 -1.0 1e300 -1e308] + c [(u8 4) 0 200 9]] + (sort-desc (slice a)) + (show-i32 (slice a)) + (sort-desc (slice b)) + (show-f64 (slice b)) + (println (largest (slice c))) + (println (let [d [(i64 -5) -9]] (largest (slice d)))) + (println (let [e [(f32 -1.0) -3.0]] (= (largest (slice e)) (f32 -1.0))))) + 0) diff --git a/test/programs/negate.flan b/test/programs/negate.flan new file mode 100644 index 00000000..51821e23 --- /dev/null +++ b/test/programs/negate.flan @@ -0,0 +1,25 @@ +;;;; (- x) negates: an integer wraps, a float flips its sign — the negation of +;;;; 0.0 is -0.0, which 1/x tells apart — and a dyn does either by its tag. +(defn negi [x i32] i32 (- x)) +(defn negf [x f64] f64 (- x)) +(defn negf32 [x f32] f32 (- x)) +(defn negu [x u8] u8 (- x)) +(defn negd [x dyn] dyn (- x)) +(defn negg [x $t] $t {:where (numeric? $t)} (- x)) +(defn main [] i32 + (println (negi 3)) + (println (negi -7)) + (println (negf 2.5)) + (println (/ 1.0 (negf 0.0))) + (println (negf32 (f32 1.5))) + (println (negu (u8 1))) + (println (negd 4)) + (println (negd 2.5)) + (println (/ 1.0 (negd 0.0))) + (println (negg (i64 9000000000))) + (println (negg 0.5)) + (let [a (- 5) b (i64 (- 3))] + (println (+ a (i32 b)))) + (println (- f64-inf)) + (println (< (- f64-inf) (- f64-max))) + 0) diff --git a/test/programs/pkgs/geo/geo.flan b/test/programs/pkgs/geo/geo.flan new file mode 100644 index 00000000..6d3700ef --- /dev/null +++ b/test/programs/pkgs/geo/geo.flan @@ -0,0 +1,5 @@ +;;;; A package whose slot types name its own classes, imported by +;;;; dyn-class-pkg.flan, which declares a class of the same bare name. +(defclass pt [x f64 y f64]) +(defclass seg [a pt b (Option pt) tag]) +(defn mk [] dyn (seg (pt 1 2) nil :t)) diff --git a/test/programs/shadow-prelude.flan b/test/programs/shadow-prelude.flan new file mode 100644 index 00000000..a9d628ae --- /dev/null +++ b/test/programs/shadow-prelude.flan @@ -0,0 +1,13 @@ +;;;; A program's function named as a prelude function takes the name over for +;;;; the calls in its own file, and the prelude's own calls keep the prelude's: +;;;; ceil-f32 is written over the prelude's floor-f32, and still answers 3. +(defn abs-f32 [v f32] f32 (if (< v 0.0) (- v) (+ v (f32 100.0)))) +(defn floor-f32 [x f32] f32 (f32 999.0)) +(defn abs [x i32] i32 (* x 10)) +(defn main [] i32 + (println (abs-f32 (f32 -2.5))) + (println (abs-f32 (f32 2.5))) + (println (floor-f32 (f32 2.3))) + (println (ceil-f32 (f32 2.3))) + (println (abs -3)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 19deffc0..3669a026 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -563,13 +563,50 @@ let () = fpu_out; outputs ~x86:true "a pointer and a union filled, x86" "programs/fill-ptr-union.flan" fpu_out; - (* An array literal takes its element type from its first element when - nothing outside it names one. *) + (* A literal element takes its type from the other elements when nothing + outside the array names one. *) let first_out = "3\n6.75\n9000000002\n255\n" in outputs "an array literal's first element types the rest" "programs/array-first-element.flan" first_out; outputs ~x86:true "an array literal's first element types the rest, x86" "programs/array-first-element.flan" first_out; + (* An array literal whose elements agree is typed and one whose elements + mix is a dyn vector; (the T e) gives any expression its type. *) + let mixed_out = + "3\n301\n2.5\n18446744073709551615\n[ 10 \"Hi\"]\n[ nil 1]\n2\n3\n4\n\ + 3\n1\n9000000004\n[ :a \"b\" 3]\n\ + 255\n5000000000\n5\n4.5\n2\n0\n7\n3\n3\n0\n" in + outputs "mixed array literals and the" "programs/array-mixed.flan" mixed_out; + outputs ~x86:true "mixed array literals and the, x86" + "programs/array-mixed.flan" mixed_out; + (* A program's function named as a prelude function takes the name over + for its own file; the prelude's own calls keep the prelude's. *) + let sp_out = "2.5\n102.5\n999\n3\n-30\n" in + outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out; + outputs ~x86:true "a prelude function shadowed, x86" + "programs/shadow-prelude.flan" sp_out; + (* (max-value T) and (min-value T), concrete and inside a generic. *) + let maxof_out = + "255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\ + 18446744073709551615\ntrue\ntrue\ntrue\n\ + 12 5 3 0 -7 -2147483648 \n1e+300 2.5 -1 -1e+308 \n200\n-5\ntrue\n" in + outputs "max-value and min-value" "programs/max-value.flan" maxof_out; + outputs ~opt:"-O0" "max-value and min-value, -O0" "programs/max-value.flan" maxof_out; + outputs ~x86:true "max-value and min-value, x86" "programs/max-value.flan" maxof_out; + (* (- x) negates, on every numeric type, a type variable and a dyn. *) + let neg_out = + "-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\ + -0.5\n-8\n-inf\ntrue\n" in + outputs "unary minus" "programs/negate.flan" neg_out; + outputs ~opt:"-O0" "unary minus, -O0" "programs/negate.flan" neg_out; + outputs ~x86:true "unary minus, x86" "programs/negate.flan" neg_out; + (* A literal arm takes the other arm's type. *) + let arm_out = + "4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in + outputs "a literal arm takes the other arm's type" + "programs/literal-arm.flan" arm_out; + outputs ~x86:true "a literal arm takes the other arm's type, x86" + "programs/literal-arm.flan" arm_out; (* into. The count of pulls is the assertion a unit test cannot make: one pass, one call per element per stage it reaches, and no intermediate collection anywhere. The two show lines either side of it are the same @@ -5080,6 +5117,57 @@ level "1" index_site (); index_site ~x86:true (); + (* Typed class slots and set on a slot: the stores that fit, then one + run per refusal. The constructor, put and set each check a declared + slot's type, set refuses a slot the class does not declare and a + value that is not an instance, and put still inserts an undeclared + key. On both backends, because every one of these is a runtime call + whose arguments the two emit separately. *) + let slots_out = + "#state{ :pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ + true\n-7\n[ 1 2]\n2.5\n9\n6\n12\n3.5\ntrue\n2\n:state\n" + in + outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; + outputs ~x86:true "dyn: typed class slots, --x86" + "programs/dyn-class-slots.flan" slots_out; + outputs "dyn: a package's slot type names its own class" + "programs/dyn-class-pkg.flan" + "#g/seg{ :a #g/pt{ :x 1 :y 2} :b nil :tag :t}\n#pt{ :z 1}\n"; + let slot_trap ?x86 () = + let exe = compile ?x86 "programs/dyn-slot-trap.flan" in + List.iter + (fun (arg, want) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL dyn: a class slot's refusal%s\n got: %S \ + (exit %d)\n wanted: %S (exit 134)\n" + (match x86 with Some true -> ", --x86" | _ -> "") + text code want + end) + [ ("0", "dyn-slot-trap.flan:14:28: dyn construct: the slot :pause of \ + state is declared bool, and this is int — (state ...) with \ + :pause 1; the slot is declared at programs/dyn-slot-trap.flan:4:18"); + ("1", "dyn-slot-trap.flan:15:19: dyn put: the slot :pause of state \ + is declared bool, and this is int"); + ("2", "dyn-slot-trap.flan:16:19: dyn set: the slot :step of state \ + is declared i32, and 5000000000 is not a value it holds \ + exactly"); + ("3", "dyn-slot-trap.flan:17:19: dyn set: state has no slot :paws. \ + Its slots are :pause :step :tag; a key the class does not \ + declare is added with put, not set"); + ("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \ + on a class instance, and this is a map with no class"); + ("5", "dyn-slot-trap.flan:19:28: dyn construct: the slot :owner of \ + node is declared state, and this is not an instance of it"); + ("6", "dyn-slot-trap.flan:20:22: dyn construct: the slot :pause of \ + state is declared bool, and this is nil") ]; + (try Sys.remove exe with Sys_error _ -> ()) + in + slot_trap (); + slot_trap ~x86:true (); + (* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a dyn box". programs/dyn-cast.flan is one program because the three behaviours are one story told in order: the same-kind casts print, the @@ -5684,7 +5772,9 @@ level "1" f32's least value negates its greatest ok\n\ f64's least value negates its greatest ok\n\ f64-inf ok\nf32-inf ok\nf64-inf negated ok\nf32-inf negated ok\n\ - f64-nan ok\nf32-nan ok\n" + f64-nan ok\nf32-nan ok\n\ + f64-nan != itself ok\nf32-nan != itself ok\n\ + != over ordinary floats ok\na dyn NaN != itself ok\n" in outputs "type limits" "programs/limits.flan" limits_out; outputs ~opt:"-O0" "type limits, -O0" "programs/limits.flan" limits_out; @@ -6716,6 +6806,28 @@ level "1" cli_case "--debug and an explicit -O are refused together" "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 ~says:[ "--debug"; "-O2"; "Drop one of the two" ]; + (* The name a shadowed prelude function is moved to is nobody's to read. *) + (let code, text = cli "check programs/shadow-prelude.flan" in + if code <> 0 || contains text "prelude~" + || not (contains text "defn floor-f32") + then begin + incr failures; + Printf.printf + "FAIL check's listing leaves out the renamed prelude function\n\ + \ got: %S (exit %d)\n" text code + end); + (* A file with no main is refused by name before the link, which would + otherwise report an undefined reference from crt1.o. *) + let nomain = Filename.concat scratch "no-main.flan" in + Out_channel.with_open_bin nomain (fun oc -> + output_string oc "(defn f [] i32 0)\n"); + cli_case "build of a file with no main names main" + (Printf.sprintf "build %s -o /dev/null" (Filename.quote nomain)) ~code:1 + ~says:[ "has no main"; "(defn main [] i32" ]; + cli_case "run of a file with no main names main" + (Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1 + ~says:[ "has no main"; "(defn main [] i32" ]; + Sys.remove nomain; (* Every row above that went through the pool has been forked; nothing after this point may look at [failures] until every one of them has diff --git a/test/test_dev.ml b/test/test_dev.ml index cc7c1d9e..8eba3fdc 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8073,6 +8073,168 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ lsock2; lout2 ]; + (* ── update-instance-for-redefined-class, written from the session ── + The method is written and installed while the program runs, then the + class is redefined, and each instance runs the method at its first + touch after that. On both backends, because the method is Flan code + the C runtime calls from inside [get], and that call is the one piece + of this each backend's calling convention has to agree with. + + Three claims, in order: a method carries a lost slot's value into a + gained one; a method that signals stops the program with + [migrate-by-name] on offer, and taking it leaves the instance as + name-matching made it, the method's own write included; and a kept + value that no longer fits its slot's new type stays, with a warning. + stdout and stderr go to one file, which is where the warning is read + from. *) + let hook_block ~llvm = + let what = if llvm then "llvm: " else "" in + let hsock = tmp (if llvm then "hook-llvm.sock" else "hook.sock") + and hout = tmp (if llvm then "hook-llvm.out" else "hook.out") in + (try Sys.remove hsock with Sys_error _ -> ()); + let hfd = + Unix.openfile hout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let argv = + Array.append + [| flan; "dev"; "programs/dev-hook.flan"; "-s"; hsock |] + (if llvm then [| "--llvm" |] else [||]) + in + let hpid = Unix.create_process flan argv Unix.stdin hfd hfd in + Unix.close hfd; + let output () = In_channel.with_open_bin hout In_channel.input_all in + if not (listening ~pid:hpid hsock) then begin + fail "%sthe hook daemon %s (%S)" what !listen_why (output ()); + (try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect hsock in + let said r = Option.value ~default:"" (Wire.string_field r "message") in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + let file = " :file \"programs/dev-hook.flan\")" in + let ask code = + request c (Printf.sprintf "(:op \"eval-expr\" :code %S%s" code file) + in + let redefine code = + request c (Printf.sprintf "(:op \"eval\" :code %S%s" code file) + in + let holds claim code = + let r = ask code in + if status r <> "ok" then fail "%s%s: %s" what claim (said r) + else if value r <> "1" then + fail "%s%s answered %S (%s)" what claim (value r) code + in + let defined claim code = + let r = redefine code in + if status r <> "ok" then (fail "%s%s: %s" what claim (said r); false) + else true + in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let started () = + status (ask "(do (push instances (point 3 4)) 1)") = "ok" + in + if not (await started) then + fail "%sthe hook daemon never reached a frame boundary" what + else begin + holds "a second instance" "(do (push instances (point 5 6)) 1)"; + (* ── A method that carries a value across ── *) + if defined "a method of the migration generic, from the session" + "(defmethod update-instance-for-redefined-class point \ + [p added discarded] \ + (set (get p :radius) (get discarded :y)) nil)" + && defined "a class redefined under a method" + "(defclass point [x radius])" + then begin + holds "the method moved the lost slot's value into the new one" + "(if (= (get (at instances 0) :radius) 4) 1 0)"; + holds "a kept slot is untouched by the method" + "(if (= (get (at instances 0) :x) 3) 1 0)"; + holds "the lost slot is gone" + "(if (= (length (at instances 0)) 2) 1 0)"; + holds "each instance runs the method at its own first touch" + "(if (= (get (at instances 1) :radius) 6) 1 0)" + end; + (* ── A method that signals ── *) + if defined "a method that signals" + "(defmethod update-instance-for-redefined-class point \ + [p added discarded] \ + (set (get p :x) 99) (error (Refused {.why 1})) nil)" + && defined "a class redefined under a method that signals" + "(defclass point [x radius z])" + then begin + let r = ask "(get (at instances 0) :x)" in + if status r <> "error" then + fail "%sa migration whose method signals answered %s" what + (status r); + let r = request c "(:op \"break\")" in + let names = + match Wire.field r "restarts" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (n : Form.t) -> + match n.Form.v with Form.Str x -> Some x | _ -> None) + l + | _ -> [] + in + (match names with + | "migrate-by-name" :: _ -> () + | _ -> + fail "%sthe restarts at a signalling method: %s" what + (String.concat ", " names)); + let r = request c "(:op \"restart\" :name \"migrate-by-name\")" in + if status r <> "ok" then + fail "%smigrate-by-name was refused: %s" what (said r); + if not + (await (fun () -> not (stopped (request c "(:op \"describe\")")))) + then fail "%sthe program did not run again after migrate-by-name" what + else begin + holds "migrate-by-name undoes the method's write" + "(if (= (get (at instances 0) :x) 3) 1 0)"; + holds "and keeps what name-matching kept" + "(if (= (get (at instances 0) :radius) 4) 1 0)"; + holds "and has the new definition's slots" + "(if (= (length (at instances 0)) 3) 1 0)" + end + end; + (* ── A type that no longer fits ── *) + if defined "a method that does nothing" + "(defmethod update-instance-for-redefined-class point \ + [p added discarded] nil)" + && defined "a slot's type changed to one its value does not fit" + "(defclass point [x string radius z n i32 note string])" + then begin + holds "a value that no longer fits is kept" + "(if (= (get (at instances 0) :x) 3) 1 0)"; + (* A typed slot gained by the redefinition starts at its type's + zero value, as a typed binding does, and not at nil. *) + holds "a gained i32 slot is 0" + "(if (= (get (at instances 0) :n) 0) 1 0)"; + holds "a gained string slot is empty" + "(if (= (get (at instances 0) :note) \"\") 1 0)"; + let warned () = + contains_sub (output ()) + "warning: point was redefined, and its slot :x is now \ + declared string" + in + if not (await warned) then + fail "%sno warning for a kept value that does not fit: %S" what + (output ()) + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill hpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] hpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ hsock; hout ] + in + hook_block ~llvm:false; + hook_block ~llvm:true; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () diff --git a/test/test_dyn.ml b/test/test_dyn.ml index 8152b9cf..96875fce 100644 --- a/test/test_dyn.ml +++ b/test/test_dyn.ml @@ -154,6 +154,14 @@ let () = if code <> 0 || out <> "classes ok\n" then fail "redefining a class\n got: %S (exit %d, err %S)" out code err; + (* A migration's hook re-entered from the building of its own + arguments, and a hook that grows the class registry under it — see + dyn_ops.c's [hook_reentry]. *) + let code, out, err = run "hook" in + if code <> 0 || out <> "hook ok\n" then + fail "a re-entered migration hook\n got: %S (exit %d, err %S)" + out code err; + let code, out, _ = run "nested" in if code <> 0 || out <> "chain of 64 intact: yes\n" then fail "a chain of nested vecs\n got: %S (exit %d)" out code; @@ -205,6 +213,7 @@ let () = let refusals = [ ("add", "dyn +: int and text"); ("sub", "dyn -: nil and int"); + ("neg", "dyn -: text, and it takes a number"); ("mul", "dyn *: bool and int"); ("div", "dyn /: vec and int"); ("rem", "dyn %: int and nil"); diff --git a/test/test_flan.ml b/test/test_flan.ml index 2e265ce7..da520fa8 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1245,7 +1245,7 @@ let () = accepts "return type types the literal" "(defn f [] u8 0)"; accepts "return type types None" "(defn f [] (Option f64) None)"; rejects_check "bare None has no type" "(defconst x None)" - ~needle:"what None is an Option of"; + ~needle:"(the (Option i32) None)"; accepts "param types the literal" "(defn g [x u8] ()) (defn f [] () (g 3))"; rejects_check "wrong argument type" @@ -1337,14 +1337,18 @@ let () = infers "min at four" "(min 4 1 3 2)" "i32"; infers "max at four" "(max 4 1 3 2)" "i32"; (* And the two counts below the floor. Zero would have to mean an identity - element and one a unary operator this language does not have; both are a - typo far more often than an intent, so both are refused by name. *) + element, and one is refused for every operator but -, whose one-operand + form negates. *) rejects_check "a sum with no terms" "(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0"; rejects_check "a product with no factors" "(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0"; - rejects_check "there is no unary minus" - "(defn f [] i32 (- 1))" ~needle:"there is no unary minus"; + infers "a negated literal" "(- 1)" "i32"; + infers "a negated literal takes its type from the site" "(i64 (- 1))" "i64"; + rejects_check "unary minus over a string names the operand" + "(defn f [s string] () (println (- s)))" ~needle:"- takes numbers"; + rejects_check "unary minus at an unsigned literal is out of range" + "(defn f [] u8 (- 1))" ~needle:"does not fit in u8"; rejects_check "there is no reciprocal" "(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal"; rejects_check "one operand is not a bitwise and" @@ -2711,14 +2715,38 @@ let () = rejects_check "a constructor takes one argument per slot" "(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))" ~needle:"point"; - (* A slot vector holds names and nothing else. [(defclass point [x i64])] - is therefore two slots, one of them unfortunately named — the parser - cannot tell a type's name from a slot's and does not have to, since a - slot has no type to write. What it can tell is a form that is not a name - at all. *) - rejects_check "a slot is a name, not a type expression" + (* A slot vector is a defn's parameter vector: a name followed by a type + is a typed slot, a name followed by another name is an untyped one. The + type is what a stored dyn value is checked against, so it is one a dyn + value can be checked as, and nothing else. *) + accepts "typed slots, and untyped ones beside them" + "(defclass state [pause bool step bool n i32 tag])\n\ + (defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))"; + accepts "a class and an Option as slot types" + "(defclass point [x f64])\n\ + (defclass node [at point next (Option node) w (Option i32)])\n\ + (defn main [] i32 (let [n (node (point 1) nil nil)] 0))"; + rejects_check "an Option of dyn is not a slot type" + "(defclass point [x (Option dyn)])\n(defn main [] i32 0)" + ~needle:"the slot x of point is declared (Option dyn)"; + rejects_check "a slot's type is one a dyn value can be checked as" "(defclass point [x (Ptr i64)])\n(defn main [] i32 0)" - ~needle:"a class slot is a name"; + ~needle:"the slot x of point is declared (Ptr i64)"; + rejects_check "a capitalised name in a slot vector is an unknown type" + "(defclass point [x Widget])\n(defn main [] i32 0)" + ~needle:"unknown type Widget"; + rejects_check "a slot's type is resolved like any other" + "(defclass point [x f65])\n(defn main [] i32 0)" + ~needle:"did you mean f64"; + (* The slot is a place: its class declares it, so it always exists. *) + accepts "set writes a class slot" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (set (get s :pause) true) \ + (if (get s :pause) 0 1)))"; + rejects_check "a class slot has no address" + "(defclass state [pause bool])\n\ + (defn main [] i32 (let [s (state false)] (addr (get s :pause)) 0))" + ~needle:"addr takes the address of a place"; rejects_check "a class does not name a slot twice" "(defclass point [x x])\n(defn main [] i32 0)" ~needle:"names the slot x twice"; @@ -3001,7 +3029,7 @@ let () = ~needle:"needs to know the type it is filling"; rejects_check "a dead-beef in a position with no expected type" "(defn f [] () (print (dead-beef)))" - ~needle:"needs to know the type it is filling"; + ~needle:"(the [4 u32] (dead-beef))"; (* The byte is a u8 and the ordinary literal rule applies to it — there is no range check of this builtin's own, and there does not need to be. *) rejects_check "a fill byte out of range" @@ -3810,7 +3838,10 @@ let () = into a lookup and no place form for one. Refused with that reason rather than as a milestone that will never arrive. *) rejects_check "a map entry as a place" - "(defn f [] () (set (get m 1) 2))" + "(defn f [m (Map i64 i64)] () (set (get m 1) 2))" + ~needle:"entries are written with put"; + rejects_check "get with three arguments is not a place" + "(defn f [m dyn] () (set (get m 1 2) 2))" ~needle:"a map is written with (put m k v)"; (* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *) @@ -5406,6 +5437,24 @@ let () = | exception Loc.Error _ -> false); check "a program that shadows nothing is warned at not at all" (Check.shadowed_builtins (program "(defn f [] i32 1)") = []); + (* A prelude function's name is taken over the same way, for the calls in + the defining file. *) + let prelude_src = "(defn abs-f32 [v f32] f32 v)" in + (match + snd (Check.shadow_prelude (Parse.program (Prelude.forms ())) + (program prelude_src)) + with + | [ d ] -> + check "a defn of a prelude function's name warns once" + (d.Loc.kind = "check/shadows-prelude" + && d.Loc.dmsg + = "abs-f32 shadows the prelude's abs-f32 — every call in this file \ + now reaches your definition") + | _ -> check "a defn of a prelude function's name warns exactly once" false); + accepts "a defn of a prelude function's name is not defined twice" + prelude_src; + rejects_check "a struct of a prelude type's name is still defined twice" + "(defstruct Form [x i32])" ~needle:"Form is defined twice"; (* An operator is a builtin like any other and shadows like any other. Pinned in both halves because it is the case most likely to be thought of as special and quietly excepted later: the warning is the same @@ -6205,8 +6254,61 @@ let () = "(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \ (defn f [x u64] u64 (+ x 9223372036854775808)) \ (defn g [] f64 (f64 (u64 12345678901234567890)))"; - accepts "a negative decimal is still a u64 bit pattern" - "(defconst a u64 -1)"; + (* A negative literal fits no unsigned type, wherever the type comes from; + the cast the refusal names is how to write the bit pattern. *) + List.iter + (fun (what, src, needle) -> rejects_check what src ~needle) + [ ("a negative literal at a u64 constant", "(defconst a u64 -1)", + "-1 does not fit in u64, which holds no negative number — write \ + (u64 -1) for the u64 with the same bits, 18446744073709551615"); + ("a negative literal at a u32 global", "(defonce g u32 -5)", + "write (u32 -5) for the u32 with the same bits, 4294967291"); + ("a negative literal as a u64 return", "(defn f [] u64 -1)", + "-1 does not fit in u64"); + ("a negative literal as a u32 argument", + "(defn t [x u32] u32 x) (defn f [] u32 (t -2))", "-2 does not fit in u32"); + ("a negative literal in a u8 field", + "(defstruct S [a u8]) (defn f [] S (S -3))", "write (u8 -3)"); + ("a negative literal given a u64 by the", + "(defn f [] i32 (let [a (the u64 -1)] 0))", "-1 does not fit in u64"); + ("a negative literal beside a u64-only literal", + "(defn f [] i32 (let [a [-1 18446744073709551615]] 0))", + "write (u64 -1) for the u64"); + ("a negative literal beside a u64 element", + "(defn f [x u64] i32 (let [a [x -1]] 0))", "write (u64 -1) for the u64") ]; + accepts "the casts those refusals name compile" + "(defconst a u64 (u64 -1)) (defonce g u32 (u32 -5)) \ + (defstruct S [a u8]) (defn f [x u64] S \ + (let [a [(u64 -1) 18446744073709551615] b [x (u64 -1)] \ + c (the u64 (u64 -1))] \ + (S (u8 -3))))"; + (* The literal that does not fit is the one blamed, not one that does. *) + rejects_check "a negative literal among u64 elements is the one blamed" + "(defn f [] () (println [(u64 2) 1 -1]))" ~needle:"-1 does not fit in u64"; + rejects_check "a negative literal after a u64 element is the one blamed" + "(defn f [] () (println [1 (u64 2) -1]))" ~needle:"-1 does not fit in u64"; + (* In a generic body the cast would break the other instantiations. *) + (match + checked + "(defn add1 [x $t] $t {:where (numeric? $t)} (+ x -1)) \ + (defn main [] i32 (add1 3) (add1 (u64 5)) 0)" + with + | _ -> check "a negative literal at a u64 instantiation is refused" false + | exception Loc.Error d -> + check "the generic's refusal names a fix for every type and the call" + (contains d.Loc.dmsg "as in (- x 1) in place of (+ x -1)" + && not (contains d.Loc.dmsg "(u64 -1)") + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "add1 is instantiated at $t = u64 here") + d.Loc.notes)); + accepts "the generic's fix compiles at both types" + "(defn add1 [x $t] $t {:where (numeric? $t)} (- x 1)) \ + (defn main [] i32 (add1 3) (add1 (u64 5)) 0)"; + accepts "a doubly negated literal is positive at an unsigned type" + "(defn f [] u8 (- (- 1)))"; + rejects_check "a folded constant's conversion is still its type" + "(defconst a u8 (i32 5))" ~needle:"expected u8, found i32"; rejects_check "a wide decimal with nothing to say u64" ~needle:"18446744073709551615 does not fit in i32, the type an integer \ literal takes when nothing says otherwise — write (u64 \ @@ -6510,17 +6612,106 @@ let () = parse_rejects "the $ refusal names the bare spelling" "(defn $foo [x i32] i32 x)" ~needle:"Name it foo"; - (* ── An array literal's first element types the rest ───────────── *) - accepts "an f32 array literal from its first element" - "(defn main [] i32 (let [a [(f32 1.0) 2.5]] (i32 (length a))))"; - (match checked "(defn main [] i32 (let [a [(u8 1) 256]] 0))" with - | _ -> check "an element that does not fit the first element's type" false + (* ── An array literal with nothing outside it naming a type ────── *) + infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]"; + infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]"; + infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]"; + infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]"; + infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]"; + infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn"; + infers "nil beside a number is a dyn vector" "[nil 1]" "dyn"; + infers "two dyns are a typed array of dyn" "[nil nil]" "[2 dyn]"; + infers "the names the element type of a mixed literal" "(the [dyn] [1 2.5])" "[2 dyn]"; + infers "the with a slice type gives the literal's array type" + "(the [f32] [1 2.5])" "[2 f32]"; + (match checked "(defstruct P [x i32]) (defn main [] i32 (let [a [(P 1) 2]] 0))" with + | _ -> check "a struct beside a number is refused" false | exception Loc.Error d -> - check "the refusal says the first element set the type" - (List.exists - (fun (n : Loc.note) -> - contains n.Loc.nmsg "this array's first element is u8") - d.Loc.notes)); + check "elements that cannot become a dyn are refused against the first" + (contains d.Loc.dmsg "expected P, found the integer literal 2" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "this array's first element is P") + d.Loc.notes)); + (match checked "(defn g [x $t] i32 (let [a [x 1]] 0))" with + | _ -> check "a type variable beside a literal is refused" false + | exception Loc.Error d -> + check "a type variable beside a literal names the bound and spells $t" + (contains d.Loc.dmsg "{:where (numeric? $t)}" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "this array's first element is $t") + d.Loc.notes)); + rejects_check "numbers with no common type are refused and the fix named" + "(defn f [x i32 y f32] i32 (let [a [x y]] 0))" + ~needle:"elements are i32 and f32, and neither holds every value of the \ + other — convert one, as in (f32 x)"; + accepts "the conversion that refusal names compiles" + "(defn f [x i32 y f32] i32 (let [a [(f32 x) y]] 0))"; + rejects_check "two integer types with no common type are refused" + "(defn f [x i64 y u64] i32 (let [a [x y]] 0))" ~needle:"as in (i64 y)"; + accepts "the integer conversion that refusal names compiles" + "(defn f [x i64 y u64] i32 (let [a [x (i64 y)]] 0))"; + rejects_check "every element needing a type names the first's refusal" + "(defn main [] i32 (let [a [None None]] 0))" + ~needle:"what None is an Option of"; + + (* ── (max-value T) and (min-value T) ──────────────────────────────── *) + infers "max-value carries its type" "(max-value u16)" "u16"; + infers "min-value at a float" "(min-value f32)" "f32"; + (match checked "(defn f [x $t] $t (max-value $t))" with + | _ -> check "max-value at an unbounded type variable is refused" false + | exception Loc.Error d -> + check "max-value at an unbounded type variable names the bound and only it" + (contains d.Loc.dmsg "write {:where (numeric? $t)}" + && not (contains d.Loc.dmsg "Fn"))); + infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64"; + infers "two integer if arms stay i32" "(if true 1 2)" "i32"; + infers "two literal match arms meet at the wider" + "(match (Some 1) (Some v) 1 None 2.5)" "f64"; + accepts "max-value at a type variable the bound admits" + "(defn f [x $t] $t {:where (integer? $t)} (max-value t))"; + rejects_check "max-value at a type that is not a number names the bound" + "(defn f [] string (max-value string))" + ~needle:"max-value takes a numeric? type, and string is not one"; + rejects_check "max-value of a value says it takes a type" + "(defn f [x i32] i32 (max-value x))" ~needle:"max-value takes a type"; + accepts "max-of of a slice is the prelude's reduction" + "(defn f [xs [i32]] (Option i32) (max-of xs))"; + rejects_check "max-of of a type names max-value" + "(defn f [] u8 (max-of u8))" ~needle:"the largest value of a type is (max-value u8)"; + + (* ── (the T e) ─────────────────────────────────────────────────── *) + infers "the gives a literal its type" "(the u8 200)" "u8"; + infers "the widens as an annotation does" "(the i64 (the i32 1))" "i64"; + rejects_check "the does not narrow" + "(defn f [x i64] i32 (the i32 x))" ~needle:"expected i32, found i64"; + rejects_check "the refuses a dyn and names the cast" + "(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it"; + accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))"; + rejects_check "the refuses a dyn at a type a dyn does not become" + "(defn f [x dyn] string (the string x))" + ~needle:"dyn — string does not cross into a written type yet"; + rejects_check "the refuses a dyn at bool, which a dyn becomes where passed" + "(defn f [x dyn] bool (the bool x))" + ~needle:"a dyn becomes a bool where a bool is passed"; + accepts "the bool a dyn becomes where it is returned" "(defn f [x dyn] bool x)"; + accepts "the at an Option takes nil" "(defn f [] (Option i32) (the (Option i32) nil))"; + parse_rejects "the takes a type and a value" "(defn f [] i32 (the i32))" + ~needle:"the is (the TYPE value)"; + (* The refusals of a form with no type of its own name the as a way out, and + the spellings they name compile. *) + rejects_check "an empty array literal names the" + "(defn main [] i32 (let [a []] 0))" ~needle:"(the [0 i32] [])"; + accepts "the empty array that refusal names compiles" + "(defn main [] i32 (let [a (the [0 i32] [])] (length a)))"; + accepts "the None that refusal names compiles" + "(defn main [] i32 (let [a (the (Option i32) None)] 0))"; + accepts "the zeroed that refusal names compiles" + "(defn main [] i32 (let [a (the [4 i32] (zeroed))] (at a 0)))"; + accepts "the fills that refusal names compile" + "(defn main [] i32 (let [a (the [4 u32] (filled 0xFF)) \ + b (the [4 u32] (dead-beef))] 0))"; (* ── A wide literal's follow-ups ──────────────────────────────── *) parse_rejects "a wide enum member is refused for its range" @@ -6541,10 +6732,7 @@ let () = "(defmacro idm [x] x) \ (defn f [] u64 (idm 18446744073709551615))"; - rejects_check "a wide element after a narrow first names the u64 array" - "(defn main [] i32 (let [a [1 18446744073709551615]] 0))" - ~needle:"write the first element as (u64 1) for an array of u64"; - accepts "the u64 array that refusal names compiles" + accepts "a u64 array with a cast first element" "(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))"; (* ── Suggestions that compile ─────────────────────────────────── *) diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index cc0b2626..a4b13462 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -343,7 +343,7 @@ let dyn_sweep () = the old block, or a [len] that outlived the block it described, is a use-after-free here and nothing anywhere else. *) [ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing"; "park"; - "classes" ]; + "classes"; "hook" ]; (try Sys.remove exe with Sys_error _ -> ()) (* A third sweep, over a handful of the same programs built [--dev]. diff --git a/test/test_session.ml b/test/test_session.ml index c612c83d..604b92b5 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1591,6 +1591,39 @@ let () = (String.concat " " c.Session.fns) | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a class and its caller evaluated together: %s" m); + (* A method of update-instance-for-redefined-class, from the session. The + generic is written by [Classes.expand], not by the program, so this is + the case where the declaration being extended is nowhere in the + session's own list — and the method still has to install the generic's + dispatch, and the module has to hand the runtime the body it just + installed, or migrations go on calling the old one. *) + (let t, _ = Session.create ~file:"programs/dev-class.flan" () in + match + Session.eval t + "(defmethod update-instance-for-redefined-class point \ + [p added discarded] nil)" + with + | c -> + if not (List.mem Classes.migrate_generic c.Session.fns) then + fail "a migration method installed %s" (String.concat " " c.Session.fns); + if not (has c.Session.ir "call void @flan_dyn_class_hook") then + fail "a migration method did not re-register the hook" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a migration method was refused: %s" m); + (* A slot's type changed and nothing else. Every constructor parameter is + dyn whatever the slot says, so the signature is the one it was and a + compiled caller is no reason to refuse — the type is checked where a + value is stored, at run time. What has to reach the program is the new + definition, and the registration carries it with the type after the + name, which is what makes the runtime see a change and migrate. *) + (let t, _ = Session.create ~file:"programs/dev-class.flan" () in + ignore (Session.eval t "(defn origin [] dyn (point 0 0))"); + match Session.eval t "(defclass point [x i64 y])" with + | c -> + if not (has c.Session.ir "c\"x i64\\0Ay\"") then + fail "a slot's new type did not reach the registration" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a slot's type changed under a compiled caller was refused: %s" m); (* ── What a slot is shown as ────────────────────────────────────────── [strip_rebind] takes only a trailing ~N — [~] is the reader's delimiter diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 54c5d5a6..7945a954 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -337,6 +337,8 @@ extern int64_t flan_break_site_len; * shadow-stack frame's shape does: the struct is declared in one file. */ extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen); extern void flan_restart_pop_c(void *frame); +extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance, + uint64_t added, uint64_t discarded); /* -- How far down a transfer can actually land ----------------------- */ @@ -425,6 +427,44 @@ extern void flan_dev_frames_restore(void *head) __attribute__((weak)); extern int64_t flan_dyn_root_mark(void) __attribute__((weak)); extern void flan_dyn_root_restore(int64_t n) __attribute__((weak)); +/* -- update-instance-for-redefined-class ------------------------------ */ + +/* A class migration calls the method from inside [get], [put] or [set] — + * a C frame with no transfer channel of its own — so the call is made the + * way a thunk's is: behind a floor, with a channel of its own and a restart + * of its own above the floor. A break inside the method then offers + * [migrate-by-name] and nothing below the call, which it could not reach. + * Taking it leaves the instance as name-matching made it; flan_dyn.c's + * [class_hook] puts that back. + * + * [eval_boundary] is cleared for the call: an evaluation in progress + * underneath is below this floor, and offering to abandon it would be a + * choice nothing can carry out. Everything saved is restored, so a + * migration inside a thunk inside a break nests like the rest. */ +static const uint8_t migrate_name[] = "migrate-by-name"; + +typedef uint64_t (*migrate_fn_t)(uint64_t, uint64_t, uint64_t, void *); + +static int migrate_call(void *fn, uint64_t instance, uint64_t added, + uint64_t discarded) { + int32_t outer = restart_floor; + int32_t oframe = frame_floor; + void *obound = eval_boundary; + void *xfer = NULL; + void *mine; + restart_floor = flan_restart_count(); + frame_floor = flan_dev_frame_count(); + eval_boundary = NULL; + mine = flan_restart_push_c(migrate_name, sizeof migrate_name - 1); + ((migrate_fn_t)fn)(instance, added, discarded, &xfer); + flan_restart_pop_c(mine); + eval_boundary = obound; + restart_floor = outer; + frame_floor = oframe; + if (xfer == NULL) return 0; + return (mine != NULL && xfer == mine) ? 1 : 2; +} + /* The three of them, dropped between two runs of [main]. The counterpart of * flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's * [flan_dev_frames_reset], called from the same one place and for the same @@ -904,6 +944,9 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition, : !s->resumable ? " (cannot be taken from this trap)" : i == s->boundary ? " (stop running the expression; the program carries on)" + : strcmp(s->names + s->off[i], (const char *)migrate_name) == 0 + && s->reachable[i] + ? " (keep the instance as its slots matched by name)" : s->reachable[i] ? "" : " (below this break; cannot be taken)"); if (s->total > s->n) @@ -2200,6 +2243,7 @@ static int32_t start_on(const char *path) { * to do, and stopping forever is worse than the abort it replaces. */ flan_break_hook = break_loop; flan_trap_hook = trap_stop; + flan_dyn_migrate_hook = migrate_call; return 0; failed: diff --git a/web/examples/classes.flan b/web/examples/classes.flan index b79f5b5f..d036b73c 100644 --- a/web/examples/classes.flan +++ b/web/examples/classes.flan @@ -1,5 +1,5 @@ -;; A class is a named dyn map with a shape tag. Its slots are names and -;; carry no types, and its constructor is the class's own name, positional. +;; A class is a named dyn map with a shape tag. A slot with no type holds +;; any value, and its constructor is the class's own name, positional. (defclass point [x y]) (defclass circle [r]) diff --git a/web/index.html b/web/index.html index bee16947..1c311673 100644 --- a/web/index.html +++ b/web/index.html @@ -710,10 +710,17 @@ unit carries nothing for a dyn word to hold, and boxing it is refused — and

Classes and generic functions

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

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

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

-
;; A class is a named dyn map with a shape tag. Its slots are names and
-;; carry no types, and its constructor is the class's own name, positional.
+
;; A class is a named dyn map with a shape tag. A slot with no type holds
+;; any value, and its constructor is the class's own name, positional.
 (defclass point [x y])
 (defclass circle [r])
 
@@ -2214,9 +2221,18 @@ reason is the whole difference between the two: an instance carries a header nam
 its class and a flat struct does not. Redefining one re-registers the class and
 bumps a generation counter, which is O(1) and walks no heap; every live instance
 migrates at its next touch. Slots matched by name keep their values, a gained slot
-appears as nil, a dropped one goes, the object is the same object, and
+starts at its type's zero value — false, 0,
+0.0 or "", and nil for a slot with no type,
+an (Option T) or a class — a dropped one goes, the object is the same object, and
 class-of still answers the same tag, so every method still reaches it.
-That is CLHS 4.3.6's protocol without the user hook, which is not built.

+That is CLHS 4.3.6's protocol. Its user hook is
+update-instance-for-redefined-class: a method of it written for a
+class, from the running session, runs on each instance as it migrates, with a
+vec of the slots it gained and a map from each slot it lost to the value that slot
+held. A method that signals stops the program with migrate-by-name
+on offer, which keeps the instance as matching by name left it. A kept value that
+no longer fits its slot's new type is kept, with a warning, and the next write to
+the slot is checked.

 
 
C-c C-x rebuilds, relaunches and reconnects, and is the way out while the
 above is true. It costs the program's state, which is why it is a key you press rather than