From 7d2da19c0c375dd75b1e648ecc7451c4b959c7f9 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 18:08:41 +0700 Subject: [PATCH] A fn form's arities are one definition by an id the form is given, and a caller of a removed arity stops on StaleCall and is compiled again whenever its call checks. --- lib/ast.ml | 5 ++ lib/check.ml | 22 ++++--- lib/cimport.ml | 2 +- lib/classes.ml | 4 +- lib/dev.ml | 26 ++++++-- lib/emit.ml | 43 +++++++++++- lib/parse.ml | 66 +++++++++++++++---- lib/session.ml | 70 ++++++++++++++------ lib/x86.ml | 20 +++++- test/programs/dev-arities.fln | 16 +++++ test/test_dev.ml | 119 ++++++++++++++++++++++++++++++++++ test/test_flan.ml | 17 +++++ test/test_session.ml | 41 ++++++++++++ 13 files changed, 395 insertions(+), 56 deletions(-) create mode 100644 test/programs/dev-arities.fln diff --git a/lib/ast.ml b/lib/ast.ml index 2d85db01..9cdf4cfd 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -278,6 +278,11 @@ type fn = { fbody : expr list; nloc : Loc.t; fprivate : privacy; + (* The fn form this is one arity of, when the form has several — an id + [Parse.splice] mints per form, so two arities are one definition exactly + when they carry the same one (decision 139). [None] is a fn written on + its own, which shares its name with nothing. *) + fgroup : int option; } type decl = { d : decl_kind; dloc : Loc.t } diff --git a/lib/check.ml b/lib/check.ml index 4c02681b..f57afbff 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -17814,7 +17814,9 @@ let shadowed_builtins (decls : Ast.decl list) : Loc.diag list = && not (String.contains fn.Ast.name '/') && not (String.equal fn.Ast.nloc.Loc.file Prelude.file) -> Some - (Loc.diag ~kind:"check/shadows-builtin" fn.Ast.nloc + (Loc.diag ~kind:"check/shadows-builtin" + (* A fn with several arities is warned about at its fn line. *) + (if fn.Ast.fgroup <> None then d.Ast.dloc else fn.Ast.nloc) (Printf.sprintf "%s shadows the builtin %s — every call in this program now \ reaches your definition — the builtin stays reachable as %s%s" @@ -17979,10 +17981,11 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list = let n = fn.Ast.name and k = List.length fn.Ast.params in let seen = Option.value ~default:[] (Hashtbl.find_opt arities n) in (match seen with - | (_, _, group) :: _ when group <> d.Ast.dloc -> + | (_, _, group, gloc) :: _ + when fn.Ast.fgroup = None || group <> fn.Ast.fgroup -> let fln = fln_source d.Ast.dloc in Loc.failk "check/defined-twice" d.Ast.dloc - ~notes:[ Loc.note group (n ^ " is already defined here") ] + ~notes:[ Loc.note gloc (n ^ " is already defined here") ] "%s is defined twice. A function with several arities is one \ definition, each arity under it:\n\n%s" n @@ -17994,21 +17997,22 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list = Printf.sprintf " (defn %s ([a T] R ...) ([a T b T] R ...))" n) (* [main] is called by the startup code, by its own name, so it has one arity. *) - | (_, first, _) :: _ when String.equal n "main" -> + | (_, first, _, _) :: _ when String.equal n "main" -> Loc.failk "check/defined-twice" fn.Ast.nloc ~notes:[ Loc.note first "main's other arity is here" ] "main has one arity: the program's startup calls it by its \ name" | _ -> ()); - (match List.find_opt (fun (j, _, _) -> j = k) seen with - | Some (_, first, _) -> + (match List.find_opt (fun (j, _, _, _) -> j = k) seen with + | Some (_, first, _, _) -> Loc.failk "check/defined-twice" fn.Ast.nloc ~notes:[ Loc.note first "the other one is here" ] "%s has two arities with %d parameter%s. Each arity takes a \ different number of arguments, which is how a call picks one" n k (if k = 1 then "" else "s") | None -> ()); - Hashtbl.replace arities n (seen @ [ (k, fn.Ast.nloc, d.Ast.dloc) ]) + Hashtbl.replace arities n + (seen @ [ (k, fn.Ast.nloc, fn.Ast.fgroup, d.Ast.dloc) ]) | _ -> ()) decls; Hashtbl.iter @@ -18016,7 +18020,7 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list = if List.length seen > 1 then Hashtbl.replace env.versions n (List.sort compare - (List.map (fun (k, _, _) -> (k, version_name n k)) seen))) + (List.map (fun (k, _, _, _) -> (k, version_name n k)) seen))) arities; if Hashtbl.length env.versions = 0 then decls else @@ -18817,7 +18821,7 @@ let rec check_fn ?sign env (fn : Ast.fn) : Tast.fn = match fn.Ast.fbody with | [] -> if Types.equal ret Types.Unit || ret == infer_ret then [] - else fail fn.Ast.nloc "%s returns %s but has no body" fn.Ast.name + else fail fn.Ast.nloc "%s returns %s but has no body" (written_name fn.Ast.name) (tyname fn.Ast.nloc ret) | body -> (* The last form is the return value, unless the function returns Unit, diff --git a/lib/cimport.ml b/lib/cimport.ml index 3258b74a..add617fb 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -856,7 +856,7 @@ let of_dump ~env ~taken ~bound_syms ~config (d : dump) : imported = decls := { Ast.d = Ast.DeclareC - ({ Ast.name = flan; params; praw = None; ret; fwhere = []; fbody = []; nloc = f.cloc; fprivate = Ast.Exported }, + ({ Ast.name = flan; params; praw = None; ret; fwhere = []; fbody = []; nloc = f.cloc; fprivate = Ast.Exported; fgroup = None }, f.csym); dloc = f.cloc } :: !decls) diff --git a/lib/classes.ml b/lib/classes.ml index 2f3685aa..9d75fa62 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -80,7 +80,7 @@ let migrate_decls loc : Ast.decl list = { 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 } + fprivate = Ast.Exported; fgroup = None } in [ { Ast.d = Ast.Defgeneric (fn []); dloc = loc }; { Ast.d = @@ -224,7 +224,7 @@ let constructor n (slots : Ast.field list) loc : Ast.decl = Ast.Defn { Ast.name = n; params; praw = None; ret = Some (dyn_at loc); fwhere = []; fbody = [ ex loc (Ast.MapLit (Some n, pairs)) ]; - nloc = loc; fprivate = Ast.Exported }; + nloc = loc; fprivate = Ast.Exported; fgroup = None }; dloc = loc } (* The dispatch value a method answers for, as an expression to compare diff --git a/lib/dev.ml b/lib/dev.ml index d8e663e5..3e1718d7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1817,12 +1817,23 @@ let defs t = && String.equal (Check.written_name g.Tast.name) base) p.Tast.fns in + (* Where the fn form starts, which is where M-. should land: the + arities' own locations are their lines under it. *) + let form_loc = + List.find_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defn fn when String.equal fn.Ast.name base -> Some d.Ast.dloc + | _ -> None) + t.session.Session.decls + in (match versions with | first :: _ when first == f -> Some (entry ~name:base ~kind:"fn" ~sign:(String.concat " | " (List.map signature_of_fn versions)) - ~loc:(Loc.to_string f.Tast.floc) ()) + ~loc:(Loc.to_string (Option.value ~default:f.Tast.floc form_loc)) + ()) | _ -> None) | None -> Some @@ -2625,13 +2636,13 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = | Some (name, _, mine, nslots, sig_, _rsig) -> if not mine then Error - (name + (Check.shown_name name ^ " is a frame of the expression this break is inside, not of the program, so there is no record of what its slots are called") else match frame_fn t name with | None -> Error - (name + (Check.shown_name name ^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from") | Some fn -> (* The two body checks come first, including for a frame @@ -2643,7 +2654,8 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = Error (Printf.sprintf "%s on the stack has %d slots and the %s this session holds has %d — the frame is running a body that has been redefined since" - name nslots name (Emit.recorded_slots fn)) + (Check.shown_name name) nslots (Check.shown_name name) + (Emit.recorded_slots fn)) else if sig_ <> Emit.slot_fingerprint fn then (* The count matching is not the same as the body matching. A redefinition that renames a local, or changes its type @@ -2656,7 +2668,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = Error (Printf.sprintf "%s on the stack was compiled from a different body than the %s this session holds — it was redefined after this frame was entered, so its names no longer describe its values" - name name) + (Check.shown_name name) (Check.shown_name name)) else Ok (name, fn))) (* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees @@ -3494,7 +3506,9 @@ let globals_op t = List.iteri (fun i (name, _, mine, nslots, sig_, rsig) -> let skip why = - skipped := (Printf.sprintf "%d: %s" i name, why) :: !skipped + skipped := + (Printf.sprintf "%d: %s" i (Check.shown_name name), why) + :: !skipped in if not mine then skip diff --git a/lib/emit.ml b/lib/emit.ml index 1a855c4a..a6ea74ec 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -106,6 +106,10 @@ let sig_text (params : Types.t list) (ret : Types.t) = (String.concat " " (List.map Types.to_string params)) (Types.to_string ret) +(* The word a retired body's cell holds, which no call site's compare + matches: a signature hashing to zero is a one in 2^64 chance. *) +let retired_word = 0L + let sig_word params ret = let s = sig_text params ret in let h = ref 0xcbf29ce484222325L in @@ -5966,7 +5970,8 @@ let thunk_makes_fn_values (p : Tast.program) name = let redefinition ?(checks = true) ?(dev = false) ?(debug = false) ?(known = fun _ -> true) ?(retains = true) - ?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns + ?call ?(consts = []) ?(retire = []) ?(annotate = false) + (p : Tast.program) ~fns : string = (* A dev build places closures under the dev rule: a named callee can be replaced by a redefinition that keeps what it was handed. See @@ -6085,7 +6090,16 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) Printf.sprintf "%s = internal global ptr null\n" (cellptr f.Tast.name))) lifted_targets; - if new_fns <> [] || new_globals <> [] then + (* A retired body's cell: the host's, or the registry's for a name the + host never had. *) + List.iter + (fun (n, _) -> + if known n then + Buffer.add_string m.out + (Printf.sprintf "%s = external global %s\n" (cellname n) cell_ty)) + retire; + if new_fns <> [] || new_globals <> [] + || List.exists (fun (n, _) -> not (known n)) retire then Buffer.add_string m.out "\ndeclare ptr @flan_dev_cell(ptr)\n\ declare ptr @flan_dev_global(ptr, i64, ptr)\n"; @@ -6198,6 +6212,31 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) publish t f end) targets; + (* A body the program no longer has, which a caller not compiled again + may still reach: its cell keeps the body and takes a word no signature + hashes to, so every call site's compare fails and the call stops on + StaleCall, with the text of what the name is now. *) + List.iter + (fun (n, now) -> + let cell = + if known n then cellname n + else begin + let t = fresh () in + Buffer.add_string b + (Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n" t + (fi_cstring m (Mangle.sym n))); + t + end + in + let wp = fresh () and tp = fresh () in + Buffer.add_string b + (Printf.sprintf + " %s = getelementptr inbounds i8, ptr %s, i64 8\n \ + store i64 %Ld, ptr %s\n \ + %s = getelementptr inbounds i8, ptr %s, i64 16\n \ + store ptr %s, ptr %s\n" + wp cell retired_word wp tp cell (cstring m now) tp)) + retire; Buffer.add_string m.out (Printf.sprintf "\ndefine void @flan_reload_install() {\nentry:\n%s ret void\n}\n" (Buffer.contents b)); diff --git a/lib/parse.ml b/lib/parse.ml index 94753910..277c5b27 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1645,9 +1645,21 @@ let rec decl (f : Form.t) : Ast.decl = way for a signature to change with nothing redefined. *) (* [defn-] is a [defn] in every respect but one: [Check.private_ref] refuses a use of it from outside the package that declares it. *) - | List ({ v = Sym ("defn" | "defn-" as head); _ } :: args) -> + | List ({ v = Sym ("defn" | "defn-" | "defn~arity" | "defn-~arity" as head); _ } + :: args) -> let fprivate = - if String.equal head "defn-" then Ast.Private_to_package else Ast.Exported + if String.equal head "defn-" || String.equal head "defn-~arity" then + Ast.Private_to_package + else Ast.Exported + in + (* One arity of a fn with several, as [splice] wrote it: the form's id + comes first. No reader can spell the head, since [~] ends a symbol. *) + let head, fgroup, args = + match head, args with + | ("defn~arity" | "defn-~arity"), { v = Int id; _ } :: rest -> + ((if head = "defn~arity" then "defn" else "defn-"), + Some (Int64.to_int id), rest) + | _ -> (head, None, args) in (match args with | n :: { v = Vec ps; _ } :: ret :: body -> @@ -1684,7 +1696,7 @@ let rec decl (f : Form.t) : Ast.decl = let fwhere, body = constraints body in mk (Ast.Defn { Ast.name = dname n; params = []; praw = Some (pitems ps); ret = Some rty; fwhere; fbody = body_of body; - nloc = n.loc; fprivate }) + nloc = n.loc; fprivate; fgroup }) | _ -> fail f "%s is (%s name [param Type ...] ReturnType body ...). The return \ @@ -1760,7 +1772,7 @@ let rec decl (f : Form.t) : Ast.decl = else fun fn -> Ast.Defmulti fn) { Ast.name = dname n; params = dyn_params which ps; praw = None; ret = Some (texpr ret); fwhere = []; fbody = body_of body; - nloc = n.loc; fprivate = Ast.Exported }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None }) | _ -> fail f "%s" usage) | List ({ v = Sym "defmethod"; _ } :: args) -> @@ -1774,7 +1786,7 @@ let rec decl (f : Form.t) : Ast.decl = mfn = { Ast.name = gen ^ "@" ^ Ast.dispatch_text k; params = dyn_params "defmethod" ps; praw = None; ret = None; fwhere = []; fbody = body_of body; - nloc = n.loc; fprivate = Ast.Exported } }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None } }) | _ -> fail f "defmethod is (defmethod generic dispatch [param ...] body ...). \ @@ -1806,11 +1818,11 @@ let rec decl (f : Form.t) : Ast.decl = | [ n; { v = Form.Vec ps; _ } ] -> mk (mkd { Ast.name = dname n; params = fields f ps; praw = None; ret = None; fwhere = []; fbody = []; nloc = n.loc; - fprivate = Ast.Exported } csym) + fprivate = Ast.Exported; fgroup = None } csym) | [ n; { v = Form.Vec ps; _ }; r ] -> mk (mkd { Ast.name = dname n; params = fields f ps; praw = None; ret = Some (texpr r); fwhere = []; fbody = []; - nloc = n.loc; fprivate = Ast.Exported } csym) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None } csym) | _ -> fail f "%s" usage) | _ -> fail f "%s" usage) @@ -2083,7 +2095,7 @@ let rec decl (f : Form.t) : Ast.decl = leave off. *) praw = None; ret = Some form_t; fwhere = []; fbody = macro_body sg body; - nloc = n.loc; fprivate = Ast.Exported }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None }) | _ -> fail f "defmacro is (defmacro name [param ...] body ...)") @@ -2273,15 +2285,22 @@ let with_imported ?(decls = []) ?(fns = []) (ms : Form.t list) It is spliced *after* expansion and before the declaration walk, so what is spliced is already fully expanded — a [do] holding a call to another macro settled before it got here. *) +(* Mints the id each fn form with several arities gives its arities. Never + reset: a session holds declarations from many parses, and two forms must + never share one. *) +let groups = ref 0 + let rec splice (f : Form.t) : Form.t list = match f.Form.v with | Form.List ({ Form.v = Form.Sym "do"; _ } :: items) -> List.concat_map splice items (* A defn with several arities, Clojure's [(defn f ([a] ...) ([a b] ...))] - (decision 139), is one [defn] per arity from here on. They keep the - whole form's location as theirs, which is what tells [Check] they were - written as one definition and not as two of one name; each name carries - its own arity's location, where a message about that arity points. *) + (decision 139), is one [defn] per arity from here on, each carrying the + id this form is given, which is what tells [Check] they were written as + one definition and not as two of one name. An id and not a location: a + macro's expansion puts the call's location on every form it writes. The + arities keep the whole form's location, which a message about the fn as + a whole points at, and each name carries its own arity's. *) | Form.List ({ Form.v = Form.Sym ("defn" | "defn-"); _ } as head :: ({ Form.v = Form.Sym _; _ } as n) :: (_ :: _ as clauses)) @@ -2291,11 +2310,30 @@ let rec splice (f : Form.t) : Form.t list = | Form.List ({ Form.v = Form.Vec _; _ } :: _) -> true | _ -> false) clauses -> + incr groups; + let id = { f with Form.v = Form.Int (Int64.of_int !groups) } in + let head = + match head.Form.v with + | Form.Sym h -> { head with Form.v = Form.Sym (h ^ "~arity") } + | _ -> head + in List.map (fun (c : Form.t) -> match c.Form.v with - | Form.List items -> - { f with Form.v = Form.List (head :: { n with Form.loc = c.Form.loc } :: items) } + | Form.List ({ Form.v = Form.Vec ps; _ } :: _ as items) -> + (* A rest parameter would take every count from its own up, and + an arity is one count. *) + List.iter + (fun (q : Form.t) -> + if q.Form.v = Form.Sym "&" then + Loc.failk "parse/arity-rest" q.Form.loc + "an arity takes a fixed number of parameters, and & would \ + take any number from here up. Take the rest as one \ + parameter, a slice") + ps; + { f with Form.v = + Form.List (head :: id :: { n with Form.loc = c.Form.loc } + :: items) } | _ -> assert false) clauses | _ -> [ f ] diff --git a/lib/session.ml b/lib/session.ml index 2822a673..11ef8df8 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -711,14 +711,15 @@ type change = { which is the crossed pair [flan.abi.x86] exists to refuse at [dlopen]. A refusal a user can read is the right answer; a segfault three frames later is not. *) -let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns = +let redefinition (t : t) ?retains ?call ?(consts = []) ?(retire = []) program + ~fns = if not t.x86 then Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ?retains - ~consts ?call ~annotate:true program ~fns + ~consts ~retire ?call ~annotate:true program ~fns else match X86.redefinition ~checks:true ~dev:true ~known:(known t) ?retains ~consts - ?call ~annotate:true program ~fns + ~retire ?call ~annotate:true program ~fns with | asm -> asm (* The dev backend covers a subset of the IR and refuses the rest by name, @@ -996,6 +997,9 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr (fun (d : Ast.decl) -> match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None) incoming + (* Once each: the arities of one fn are one declaration apiece. *) + |> List.fold_left (fun acc n -> if List.mem n acc then acc else n :: acc) [] + |> List.rev in let incoming_named n = List.filter (fun (d : Ast.decl) -> Ast.declared_name d = Some n) incoming @@ -1302,24 +1306,21 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr name. The caller is compiled again when its source still checks — it then calls whichever arity its arguments pick — and is a stale caller, tolerated above and listed by [stale_sites], when it does not. *) + (* Asked of every compiled body and not only of the names this form + touched: a caller left stale when an arity went away is still compiled + against it forms later, when the name has a body its call checks against + again — and it is then that it has to be compiled again. Hash lookups, + because a session's program can hold thousands of bodies. *) + let written = Hashtbl.create 256 in + List.iter + (fun (f : Tast.fn) -> + Hashtbl.replace written (Check.written_name f.Tast.name) ()) + program.Tast.fns; + let still_named n = + (not (Check.internal_name n)) && Hashtbl.mem written (Check.written_name n) + in let versions_moved = - (* Only a form that gives a name several arities, or had one that had - them, renames anything, so only then is there anything to look for. *) - let touched = - List.exists - (fun n -> - Hashtbl.mem env.Check.versions n || Hashtbl.mem t.env.Check.versions n) - names - in - if not touched then [] - else let has n = Hashtbl.mem in_program n in - let written = Hashtbl.create 256 in - List.iter - (fun (f : Tast.fn) -> - Hashtbl.replace written (Check.written_name f.Tast.name) ()) - program.Tast.fns; - let still_named n = Hashtbl.mem written (Check.written_name n) in SM.fold (fun fname (b : built) acc -> if has fname @@ -1342,6 +1343,33 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr (declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved @ versions_moved) in + (* The bodies an arity was compiled under that the program no longer has — + the arity was removed, or the name's arities were renamed around it. A + caller compiled against one and not compiled again (its source no longer + checks) must stop at the call rather than run the old body, so its cell + is given a signature word no body has, and the text of what the name is + now, which the StaleCall reads out. *) + let retire = + List.filter_map + (fun (f : Tast.fn) -> + let n = f.Tast.name in + if f.Tast.fparent = None && not (Hashtbl.mem in_program n) + && still_named n + then + let w = Check.written_name n in + let now = + List.filter_map + (fun (g : Tast.fn) -> + if g.Tast.fparent = None + && String.equal (Check.written_name g.Tast.name) w + then Some (Emit.sig_text g.Tast.params g.Tast.ret) + else None) + program.Tast.fns + in + Some (n, String.concat " or " now) + else None) + t.program.Tast.fns + in (* A constant that changed and can be published: known to the host, not consumed by the checker. The module stores its new value at the frame boundary, exactly as it stores a new function body. *) @@ -1457,9 +1485,9 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr in let ir = match run_thunk with - | None -> redefinition t ~consts program ~fns + | None -> redefinition t ~consts ~retire program ~fns | Some th -> - redefinition t ~consts ~call:th.Tast.name + redefinition t ~consts ~retire ~call:th.Tast.name { program with Tast.fns = program.Tast.fns @ [ th ] } ~fns:(fns @ [ th.Tast.name ]) in diff --git a/lib/x86.ml b/lib/x86.ml index c3bb4e57..157931d5 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -5386,7 +5386,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) class-registration thunk a redefined [defclass] carries go through it, and [flan dev] takes this backend unasked. *) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) - ?(retains = true) ?(consts = []) ?call ?(annotate = false) + ?(retains = true) ?(consts = []) ?(retire = []) ?call ?(annotate = false) (p : Tast.program) ~fns : string = (* A dev build places closures under the dev rule: a named callee can be replaced by a redefinition that keeps what it was handed. See @@ -5614,6 +5614,24 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) store_int f.b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8 end) targets; + (* A body the program no longer has: its cell takes a word no signature + hashes to, so a caller not compiled again stops on StaleCall, as + [Emit.redefinition] has it. *) + List.iter + (fun (n, now) -> + if known n then + load_int f.b ~dst:rax ~mm:(Got (csym n)) ~size:8 ~signed:false + else begin + cstr (Mangle.sym n); + xor_rr f.b ~dst:rax ~src:rax; + call_sym f.b "flan_dev_cell" + end; + movabs f.b ~dst:r11 Emit.retired_word; + store_int f.b ~src:r11 ~mm:(Reg (rax, 8)) ~size:8; + let tl = string_const f now in + lea f.b ~dst:r11 ~mm:(Sym (tl, 0)); + store_int f.b ~src:r11 ~mm:(Reg (rax, 16)) ~size:8) + retire; (* Nothing a constant initialiser can do transfers, so this exit is unreachable and is emitted only when something claims to aim at it. *) if f.unwound then begin diff --git a/test/programs/dev-arities.fln b/test/programs/dev-arities.fln new file mode 100644 index 00000000..b9fd89bf --- /dev/null +++ b/test/programs/dev-arities.fln @@ -0,0 +1,16 @@ +;; Arities taken away and given back in a running program: a caller of a +;; removed arity stops on StaleCall, and one compiled against it is compiled +;; again once the name has an arity its call checks against. +import agent "vendor:agent" + +fn helper(a: i32) -> i32 = a + 1 + +let n: i32 = helper(4) + +fn use1() -> i32 = helper(2) + +fn main() -> i32 + agent/start("/tmp/flan-dev-arities-fallback.sock") + for i in range(4000) + agent/wait(5) + 0 diff --git a/test/test_dev.ml b/test/test_dev.ml index c36e4ee3..5cb8b509 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7619,6 +7619,125 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ vsock; vout ]) [ "x86"; "llvm" ]; + (* ── Arities taken away and given back ─────────────────────────────── + [use1] and [n] call [helper] with one argument. Taking that arity away + leaves them stale, and a call to [use1] stops on StaleCall rather than + running the removed body; giving [helper] a one-argument body again, + by any road, compiles them again, and nothing is stale after. *) + List.iter + (fun backend -> + let asock = tmp ("arities" ^ backend ^ ".sock") + and aout = tmp ("arities" ^ backend ^ ".out") in + (try Sys.remove asock with Sys_error _ -> ()); + let afd = + Unix.openfile aout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let apid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-arities.fln"; "-s"; asock; + "--" ^ backend |] + Unix.stdin afd Unix.stderr + in + Unix.close afd; + if not (listening ~pid:apid asock) then begin + fail "the arities daemon (--%s) %s" backend !listen_why; + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect asock in + let file = "programs/dev-arities.fln" in + let ask code = + request c + (Printf.sprintf "(:op \"eval-expr\" :code %s :file %s)" + (Wire.quote code) (Wire.quote file)) + in + let answer r = + match Wire.string_field r "value" with + | Some v -> v + | None -> Option.value ~default:(status r) (Wire.string_field r "message") + in + let is what code want = + let a = answer (ask code) in + if a <> want then fail "--%s: %s answered %S, not %S" backend what a want + in + let stale_callers r = + match Wire.field r "stale" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map (fun (e : Form.t) -> Wire.string_field e "caller") l + |> List.sort_uniq compare + | _ -> [] + in + let eval what code = + let r = + request c + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote code) (Wire.quote file)) + in + if status r <> "ok" then + fail "--%s: %s: %s" backend what + (Option.value ~default:(status r) (Wire.string_field r "message")); + r + in + let stopped () = + match Wire.field (request c "(:op \"describe\")") "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let three = + "fn helper\n (a: i32) -> i32 = a + 100\n \ + (a: i32, b: i32) -> i32 = a + b\n \ + (a: i32, b: i32, c: i32) -> i32 = a + b + c" + and two = + "fn helper\n (a: i32, b: i32) -> i32 = a * b\n \ + (a: i32, b: i32, c: i32) -> i32 = a + b + c" + in + if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then + fail "--%s: the arities program never took an expression" backend + else begin + ignore (eval "three arities" three); + is "use1 over three arities" "use1()" "102"; + let r = eval "the one-argument arity taken away" two in + if stale_callers r <> [ "n"; "use1" ] then + fail "--%s: a removed arity's stale callers were %s" backend + (String.concat ", " (stale_callers r)); + let r = ask "use1()" in + if status r <> "error" then + fail "--%s: a caller of a removed arity answered %s" backend + (answer r) + else if not (await ~ms:20000 stopped) then + fail "--%s: a caller of a removed arity never stopped" backend + else begin + (match + Wire.string_field (request c "(:op \"describe\")") "condition" + with + | Some "StaleCall" -> () + | k -> + fail "--%s: a caller of a removed arity stopped on %S" backend + (Option.value ~default:"" k)); + ignore (request c "(:op \"restart\" :name \"abandon-evaluation\")"); + if not (await ~ms:20000 (fun () -> not (stopped ()))) then + fail "--%s: the abandoned evaluation never let go" backend + end; + ignore (eval "a plain two-argument helper" + "fn helper(a: i32, b: i32) -> i32 = a * b"); + let r = eval "a plain one-argument helper again" + "fn helper(a: i32) -> i32 = a + 1000" in + if stale_callers r <> [] then + fail "--%s: once helper takes one argument again, %s stayed stale" + backend (String.concat ", " (stale_callers r)); + is "use1 compiled again" "use1()" "1002"; + let r = eval "an unrelated fn" "fn other() -> i32 = 1" in + if stale_callers r <> [] then + fail "--%s: a later evaluation still listed %s as stale" backend + (String.concat ", " (stale_callers r)) + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] apid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ asock; aout ]) + [ "x86"; "llvm" ]; + (* ── The dyn globals a park holds ─────────────────────────────────── *) (* The banner a finished run prints says the globals are as it left them, diff --git a/test/test_flan.ml b/test/test_flan.ml index 2b50ad7a..f0ecec7d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1543,6 +1543,23 @@ let () = refuses_all ~fln:true "an argument's refusal names the function as written" (two ^ "fn h() -> i32\n f(true)\n") "this is the 1st argument of f"; + (* A macro's expansion puts its call's location on every form it writes, + so what makes two defns one fn has to be the form they came from and + not where they appear to be. *) + refuses_all ~fln:true "a macro that defines one name twice" + "macro two-fs()\n quote\n fn f(a: i32) -> i32 = a * 2\n \ + fn f(a: i32, b: i32) -> i32 = a + b\n\ntwo-fs()\n" + "f is defined twice"; + refuses_all ~fln:true "a macro that writes two fns of one name, each with arities" + "macro two-gs()\n quote\n fn g\n (a: i32) -> i32 = a\n \ + (a: i32, b: i32) -> i32 = b\n fn g\n (a: i32, b: i32, c: i32) -> i32 = c\n\n\ + two-gs()\n" + "g is defined twice"; + refuses_all "a rest parameter beside a fixed arity" + "(defn g ([a i32] i32 a) ([a i32 & r] i32 a))" + "an arity takes a fixed number of parameters"; + refuses_all ~fln:true "an arity with no body names the fn as written" + "fn f\n () -> i32\n (a: i32) -> i32 = a\n" "f returns i32 but has no body"; refuses_all ~fln:true "an arity takes no rest parameter" "fn f\n (a: i32) -> i32 = a\n (a: i32, & xs) -> i32 = a\n" "& (a rest parameter) is not one"; diff --git a/test/test_session.ml b/test/test_session.ml index 64e0a995..9fabc9dc 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -152,6 +152,47 @@ let () = (eval "a same-arity helper over a type the form declares" "(defstruct Fresh [a i64]) (defn helper [x Fresh] i64 (.a x))")); + (* An arity taken away and, forms later, given back by another road: the + caller left stale is compiled again then, and nothing stays stale. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let eval what src = + match Session.eval t src with + | c -> Some c + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" what m; None + in + let callers (c : Session.change) = + List.sort_uniq compare + (List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale) + in + ignore + (eval "three arities" + "(defn helper ([x i64] i64 (+ x 100)) ([x i64 y i64] i64 (+ x y)) \ + ([x i64 y i64 z i64] i64 z))"); + (match eval "the one-argument arity taken away" + "(defn helper ([x i64 y i64] i64 (* x y)) ([x i64 y i64 z i64] i64 z))" with + | Some c -> + if callers c <> [ "bump" ] then + fail "a removed arity left %s stale" (String.concat ", " (callers c)) + | None -> ()); + ignore (eval "a plain two-argument helper" "(defn helper [x i64 y i64] i64 (* x y))"); + (match eval "a plain one-argument helper again" "(defn helper [x i64] i64 (+ x 1000))" with + | Some c -> + if not (List.mem "bump" c.Session.fns) then + fail "the stale caller was not compiled again: %s" + (String.concat " " c.Session.fns); + if c.Session.stale <> [] then + fail "once helper takes one argument again, %s stayed stale" + (String.concat ", " (callers c)); + if List.length (List.filter (String.equal "helper") c.Session.names) <> 1 then + fail "the reply named helper %d times" + (List.length (List.filter (String.equal "helper") c.Session.names)) + | None -> ()); + match eval "a later form" "(defn lonely-too [] i64 1)" with + | Some c -> + if c.Session.stale <> [] then + fail "a later form still listed %s as stale" (String.concat ", " (callers c)) + | None -> ()); + (* [bump] calls [helper] with one argument. Giving [helper] a second arity compiles [bump] again, to call the arity its argument picks; taking the one-argument arity away leaves [bump] a stale caller. *)