JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 18:08:41 +07:00
parent 488a6a3295
commit 7d2da19c0c
13 changed files with 395 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lib/ast.ml
View File

@ -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 }

22
lib/check.ml
View File

@ -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,

2
lib/cimport.ml
View File

@ -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)

4
lib/classes.ml
View File

@ -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

26
lib/dev.ml
View File

@ -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

43
lib/emit.ml
View File

@ -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));

66
lib/parse.ml
View File

@ -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 ]

70
lib/session.ml
View File

@ -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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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

20
lib/x86.ml
View File

@ -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

16
test/programs/dev-arities.fln Normal file
View File

@ -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

119
test/test_dev.ml
View File

@ -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,

17
test/test_flan.ml
View File

@ -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";

41
test/test_session.ml
View File

@ -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. *)