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

Four copies in the checker become four callers

Browse Source 
get and map-remove asked the runtime the same question through two
identical bodies; only the symbol differed, so map_lookup takes it and
both entry points keep their own preambles and their own prose.

invented_ctx existed and six sites still wrote the sixteen-field literal
out by hand. All six go through it now — three verbatim, three with the
two or three fields that make them a written body rather than an
invented one — so a field added to the record is one edit.

dyn_descriptors and dyn_sites each walked every place a value can live,
and the two walks had already drifted: an unnamed frame slot was "a
local of f" in one and "a local in f" in the other. One value_sites
walker now, with the callers' filters kept on their side; the surviving
text is "a local in f", because a named slot has always read "n in f"
and neither spelling was pinned by a test.

The duplicate-field scan appeared three times and the ZII fill twice —
check_case's own comment conceded the copy. given_once and zii_fill.
The union keeps its unknown-member pass ahead of the scan rather than
folding it in, because that ordering is what it reports today.
This commit is contained in:
Joseph Ferano 2026-09-20 11:50:19 +07:00
parent 7db5ec1885
commit 001f17b8bf
1 changed files with 198 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

364
lib/check.ml
View File

@ -1837,9 +1837,21 @@ let rec bytewise_key = function
let hash_ty = Types.Int Types.U64
(* A context for a function the checker is about to invent. Nothing is
reachable from it: no outer scope, no defers, and [defer_ok] false, because
none of these is a body anyone wrote. *)
(* The fresh context a frame starts from: no outer scope, no defers, no loops,
and [defer_ok] false. As written it is a function the checker invented —
nothing is reachable from it because none of it is a body anyone wrote — and
that is how the emitted hashers and the constant-inference pass take it.
A body someone *did* write starts here too and then reattaches the few
fields that make it theirs: [owner] is the function's name, and an fn or a
handler sets [outer] to the enclosing scope so that a reference to the
enclosing function's locals is refused for the reason it is really refused
for. Those are [with] clauses on this record rather than a literal of their
own, so that a field added here is added to all of them.
Each caller calls it again rather than sharing one value: [slots] and
[slot_tys] are counted up per frame, and two frames that shared a context
would share a slot counter. *)
let invented_ctx env ret =
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = [];
defers = []; defer_slot = None; outer = []; outer_what = None; in_frames = None; loops = []; tail = false;
@ -2103,6 +2115,67 @@ let deferred_key env loc what (k : Types.t) =
true
| _ -> false
(* The body shared by [get] and [map-remove]: both answer an (Option V), both
ask the runtime one question over (key address, out address, sizes, hash,
equality), and the only thing that differs between them is which symbol is
called. [sym] is therefore the whole of the difference, and the entry points
above keep their own preambles — the dyn case and the deferred-key case are
not the same on the two sides.
The key is checked and the out slot zeroed by the caller's [k] and by
[Tast.Zero] here; the Option is built here rather than in the runtime,
because the runtime answers 1/0 and fills [out] only when it answers 1. It
has no idea what an Option's layout is, and keeping it that way is what lets
one entry point serve every value type. *)
let map_lookup ctx ~want loc sym target kt vt k =
let hash, eq = key_fns ctx.env loc kt in
let ks = fresh_slot ctx kt in
let out = fresh_slot ctx vt in
let found =
rt loc (Types.Int Types.I8) sym
[ target; addr_of loc (mk loc kt (Tast.Local ks));
addr_of loc (mk loc vt (Tast.Local out));
size_of loc kt; size_of loc vt; hash; eq; here loc ]
in
let oty = Types.Option vt in
let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in
let none = mk loc oty Tast.None_ in
let cond =
mk loc Types.Bool
(Tast.Prim (Tast.Ne,
[ found;
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
in
expect ctx loc ~want
(mk loc oty
(Tast.Let ([ (ks, k);
(out, mk loc vt (Tast.Zero vt)) ],
[ mk loc oty (Tast.If (cond, some, none)) ])))
(* The braced-pairs scan a struct literal, a union value and a data case all
do: each key is refused if it has already been given, with a note at the
first mention, and the table of what was given comes back for the fill that
follows. [noun] is the word the message uses — a union's are members, the
other two have fields — and [~known] is the caller's own unknown-key
refusal, run after the duplicate check on the same pair so that a key given
twice is reported as the duplicate it is rather than as whatever the second
mention is. A caller that wants its unknown-key pass run over all the pairs
first, before any of this, passes no [~known] and keeps its own loop. *)
let given_once ~noun ?(known = fun _ _ -> ()) kvs =
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
(match Hashtbl.find_opt seen k with
| Some (first : Ast.expr) ->
Loc.failk "check/duplicate-field" v.Ast.loc
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
"%s %s is given twice" noun k
| None -> ());
known k v;
Hashtbl.add seen k v)
kvs;
seen
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
let loc = e.Ast.loc in
(* Read the permission this form was given and withdraw it in the same
@ -2671,11 +2744,8 @@ and check_fn ctx ~want loc (params : string list) body =
reference to the enclosing function's locals is refused for the reason it
is really refused for. *)
let fctx =
{ env = ctx.env; ret; slots = 0; slot_tys = []; slot_names = [];
scope = []; defers = []; defer_slot = None; outer = ctx.scope;
outer_what = Some "an fn"; in_frames = None; loops = []; tail = false;
in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = ctx.owner }
{ (invented_ctx ctx.env ret) with
outer = ctx.scope; outer_what = Some "an fn"; owner = ctx.owner }
in
List.iter2
(fun n t -> ignore (bind fctx n t ~assignable:false)) params pts;
@ -2753,8 +2823,8 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body =
(* Its own context: a fresh frame, an empty scope, and no way to reach
the enclosing one. *)
let hctx =
{ env = ctx.env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = [];
scope = []; defers = []; defer_slot = None; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
{ (invented_ctx ctx.env Types.Unit) with
outer = ctx.scope; outer_what = Some "a handler" }
in
(* The condition crosses as a pointer, because the handler runs while
the signalling frame is still alive and there is nothing to copy.
@ -3557,32 +3627,15 @@ and check_struct ctx ~want loc name kvs =
Loc.failk "check/unknown-struct" loc ~notes:(declared_note ctx.env name)
"unknown struct %s" name)
| Some s ->
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
(match Hashtbl.find_opt seen k with
| Some (first : Ast.expr) ->
Loc.failk "check/duplicate-field" v.Ast.loc
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
"field %s is given twice" k
| None -> ());
let seen =
given_once ~noun:"field" kvs
~known:(fun k (v : Ast.expr) ->
if Tast.field_index s k = None then
Loc.failk "check/unknown-field" v.Ast.loc
~notes:(declared_note ctx.env name)
"%s has no field %s" name k;
Hashtbl.add seen k v)
kvs;
(* Omitted fields are zeroed — ZII, the same rule as a declaration with no
initialiser (plan.org, Data model). Every field is present from here on,
in declaration order, so no backend has to know about omission. *)
let fields =
map_lr
(fun (f : Tast.field) ->
match Hashtbl.find_opt seen f.Tast.fname with
| Some v -> check ctx ~want:f.Tast.fty v
| None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty))
s.Tast.fields
"%s has no field %s" name k)
in
let fields = zii_fill ctx loc seen s.Tast.fields in
expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields)))
(* [(U {.member v})] — an untagged union value.
@ -3609,21 +3662,14 @@ and check_union ctx ~want loc name kvs =
~notes:(declared_note ctx.env name)
"%s has no member %s" name k)
kvs;
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
(* Before the two-member refusal below, so [(U {.i 1 .i 2})] is told it
named one member twice rather than that [i] and [i] are the same
bytes — which is true and useless. Same words and same note as the
struct path, because it is the same mistake. *)
(match Hashtbl.find_opt seen k with
| Some (first : Ast.expr) ->
Loc.failk "check/duplicate-field" v.Ast.loc
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
"member %s is given twice" k
| None -> ());
Hashtbl.add seen k v)
kvs;
(* Before the two-member refusal below, so [(U {.i 1 .i 2})] is told it named
one member twice rather than that [i] and [i] are the same bytes — which is
true and useless. Same helper, same note and the same [check/duplicate-
field] kind as the struct path, because it is the same mistake; only the
noun changes. The unknown-member refusal above stays its own full pass
rather than being handed to [~known], so that [(U {.i 1 .i 1 .bad 2})] is
still told about [.bad] first, as it is today. *)
ignore (given_once ~noun:"member" kvs : (string, Ast.expr) Hashtbl.t);
(match kvs with
| (a, _) :: (b, (second : Ast.expr)) :: _ ->
Loc.failk "check/union-two-members" second.Ast.loc
@ -3663,35 +3709,35 @@ and first_case_name env dname =
| _ -> "Case"
(* [(U.C {.f v ...})]. The fields are checked and filled in exactly as a
struct's are — same ZII, same duplicate and unknown-field refusals — and the
only difference is the node at the end and the type it carries. *)
struct's are — literally so: the same [given_once] and [zii_fill], with only
the index function and the name in the unknown-field message differing — and
the only other difference is the node at the end and the type it carries. *)
and check_case ctx ~want loc dname (c : Tast.variant) kvs =
let full = dname ^ "." ^ c.Tast.vname in
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
(match Hashtbl.find_opt seen k with
| Some (first : Ast.expr) ->
Loc.failk "check/duplicate-field" v.Ast.loc
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
"field %s is given twice" k
| None -> ());
let seen =
given_once ~noun:"field" kvs
~known:(fun k (v : Ast.expr) ->
if Tast.vfield_index c k = None then
Loc.failk "check/unknown-field" v.Ast.loc
~notes:(declared_note ctx.env dname)
"%s has no field %s" full k;
Hashtbl.add seen k v)
kvs;
let fields =
"%s has no field %s" full k)
in
let fields = zii_fill ctx loc seen c.Tast.vfields in
expect ctx loc ~want
(mk loc (Types.Named dname) (Tast.MakeCase (dname, c.Tast.vname, fields)))
(* Omitted fields are zeroed — ZII, the same rule as a declaration with no
initialiser (plan.org, Data model). Every field is present from here on, in
declaration order, so no backend has to know about omission. [seen] is what
[given_once] collected; [fields] is the declaration, and it is the
declaration that fixes the order. *)
and zii_fill ctx loc seen fields =
map_lr
(fun (f : Tast.field) ->
match Hashtbl.find_opt seen f.Tast.fname with
| Some v -> check ctx ~want:f.Tast.fty v
| None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty))
c.Tast.vfields
in
expect ctx loc ~want
(mk loc (Types.Named dname) (Tast.MakeCase (dname, c.Tast.vname, fields)))
fields
and check_arr ctx ~want loc items =
let elem_want =
@ -5198,33 +5244,7 @@ and named_call ctx ~want loc name args =
if deferred_key ctx.env loc "get" kt then
expect ctx loc ~want (mk loc (Types.Option vt) Tast.None_)
else
let hash, eq = key_fns ctx.env loc kt in
let ks = fresh_slot ctx kt in
let out = fresh_slot ctx vt in
let found =
rt loc (Types.Int Types.I8) "flan_map_get"
[ target; addr_of loc (mk loc kt (Tast.Local ks));
addr_of loc (mk loc vt (Tast.Local out));
size_of loc kt; size_of loc vt; hash; eq; here loc ]
in
let oty = Types.Option vt in
(* The runtime answers 1/0 and fills [out] only when it answers 1, so
the Option is built here rather than there: the runtime has no idea
what an Option's layout is, and keeping it that way is what lets one
entry point serve every value type. *)
let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in
let none = mk loc oty Tast.None_ in
let cond =
mk loc Types.Bool
(Tast.Prim (Tast.Ne,
[ found;
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
in
expect ctx loc ~want
(mk loc oty
(Tast.Let ([ (ks, k);
(out, mk loc vt (Tast.Zero vt)) ],
[ mk loc oty (Tast.If (cond, some, none)) ])))
map_lookup ctx ~want loc "flan_map_get" target kt vt k
end
| _ -> assert false)
@ -5270,31 +5290,7 @@ and named_call ctx ~want loc name args =
if deferred_key ctx.env loc "map-remove" kt then
expect ctx loc ~want (mk loc (Types.Option vt) Tast.None_)
else
let hash, eq = key_fns ctx.env loc kt in
let ks = fresh_slot ctx kt in
let out = fresh_slot ctx vt in
let found =
rt loc (Types.Int Types.I8) "flan_map_remove"
[ target; addr_of loc (mk loc kt (Tast.Local ks));
addr_of loc (mk loc vt (Tast.Local out));
size_of loc kt; size_of loc vt; hash; eq; here loc ]
in
let oty = Types.Option vt in
(* Built here and not there, as [get]'s is: the runtime fills [out] only
when it answers 1 and has no idea what an Option's layout is. *)
let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in
let none = mk loc oty Tast.None_ in
let cond =
mk loc Types.Bool
(Tast.Prim (Tast.Ne,
[ found;
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
in
expect ctx loc ~want
(mk loc oty
(Tast.Let ([ (ks, k);
(out, mk loc vt (Tast.Zero vt)) ],
[ mk loc oty (Tast.If (cond, some, none)) ])))
map_lookup ctx ~want loc "flan_map_remove" target kt vt k
| _ -> assert false)
(* (map-next m (addr cur) (addr k) (addr v)) -> bool, and the whole of map
@ -7054,10 +7050,7 @@ let collect env (decls : Ast.decl list) =
defined in terms of another declared after it. A constant that still does
not check once no progress is left has a real error, so the last round is
run without swallowing it. *)
let infer (_, v) =
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } v).Tast.ty
in
let infer (_, v) = (check (invented_ctx env Types.Unit) v).Tast.ty in
let pending = ref (List.rev !untyped) in
let rec settle () =
let left =
@ -7184,9 +7177,7 @@ let check_union_members env =
let rec check_fn env (fn : Ast.fn) : Tast.fn =
let params, ret = Hashtbl.find env.fns fn.Ast.name in
let ctx = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = fn.Ast.name } in
let ctx = { (invented_ctx env ret) with owner = fn.Ast.name } in
List.iter2
(fun (p : Ast.field) ty ->
if List.mem_assoc p.Ast.fname ctx.scope then begin
@ -7525,8 +7516,7 @@ let lift_ginit ctx loc n ty (v : Tast.expr) =
{ Tast.e = Tast.Call (fname, []); ty; loc }
let check_global env (d : Ast.decl) : Tast.global option =
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } in
let ctx () = invented_ctx env Types.Unit in
match d.Ast.d with
| Ast.Defvar (n, _, init) ->
let ty, _ = Hashtbl.find env.globals n in
@ -8034,10 +8024,57 @@ let rec hidden_dyn p seen (t : Types.t) : Types.t option =
| None -> None)
| _ -> None
(* Every place a value can live: a global, a parameter, a return, a frame slot.
Two passes want exactly this list — the descriptor refusal below and the
[--no-gc] site collection at the bottom of the file — and each walked it
itself until the phrase naming an unnamed slot drifted between the two. One
walk now; the callers keep their own filters, which is where they really
differ.
[visit] is handed the location, the phrase naming the place, and the type.
[~slot] says whether this is a frame slot: that is the one distinction a
caller filters on, and a caller cannot recover it from the type. [?after_fn]
runs at the end of each function, before the next is begun, so that a caller
which also walks the body emits its diagnostics in the order a single loop
over [p.Tast.fns] gave them. *)
let value_sites (p : Tast.program) ?(after_fn = fun (_ : Tast.fn) -> ())
(visit : slot:bool -> _) =
List.iter
(fun (g : Tast.global) ->
visit ~slot:false g.Tast.ginit.Tast.loc
(Printf.sprintf "the global %s" g.Tast.gname) g.Tast.gty)
p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iteri
(fun i t ->
visit ~slot:false fn.Tast.floc
(Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name) t)
fn.Tast.params;
visit ~slot:false fn.Tast.floc
(Printf.sprintf "the return type of %s" fn.Tast.name) fn.Tast.ret;
Array.iteri
(fun i t ->
(* A slot the program named is called by that name; one the checker
synthesised has none to give, and "a local" is the phrase both
passes now use for it. The preposition is [in] either way,
because a named slot has always read "%s in %s". *)
let named =
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None
in
visit ~slot:true fn.Tast.floc
(Printf.sprintf "%s in %s"
(match named with Some n -> n | None -> "a local")
fn.Tast.name)
t)
fn.Tast.slots;
after_fn fn)
p.Tast.fns
(* Over the whole program rather than at each declaration, because the type
that hides a dyn may be declared after the one that names it — and because
a struct nobody ever holds a value of costs nothing either way. Every place
a value can live is here: a global, a parameter, a return, a frame slot. *)
a struct nobody ever holds a value of costs nothing either way. *)
let dyn_descriptors (p : Tast.program) =
let check loc what (t : Types.t) =
(match hidden_dyn p [] t with
@ -8112,33 +8149,7 @@ let dyn_descriptors (p : Tast.program) =
refuse "the return type" e.Tast.eret
"What C hands back points at storage this compiler never rooted")
p.Tast.externs;
List.iter
(fun (g : Tast.global) ->
check g.Tast.ginit.Tast.loc
(Printf.sprintf "the global %s" g.Tast.gname) g.Tast.gty)
p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iteri
(fun i t ->
check fn.Tast.floc
(Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name) t)
fn.Tast.params;
check fn.Tast.floc
(Printf.sprintf "the return type of %s" fn.Tast.name) fn.Tast.ret;
Array.iteri
(fun i t ->
let what =
match
(if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None)
with
| Some n -> Printf.sprintf "%s in %s" n fn.Tast.name
| None -> Printf.sprintf "a local of %s" fn.Tast.name
in
check fn.Tast.floc what t)
fn.Tast.slots)
p.Tast.fns
value_sites p (fun ~slot:_ loc what t -> check loc what t)
let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
let env = new_env () in
@ -8327,10 +8338,7 @@ let instances_since env mark =
than a second sentence written here that would drift from it. *)
let expressions env (es : (Types.t option * Ast.expr) list) :
Tast.expr list * Types.t array * string option array =
let ctx =
{ env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None;
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
in
let ctx = invented_ctx env Types.Unit in
(* Folded rather than mapped, because [List.map]'s order is unspecified and
every one of these calls has a side effect on [ctx] — the slot counter it
shares. An order nobody chose is one that can differ between builds, and
@ -8382,32 +8390,13 @@ let dyn_sites (p : Tast.program) : Loc.diag list =
expression in it ever having the type [dyn] — a zeroed one, never filled,
whose dyn word the collector is still asked to mark. *)
let holds t = dyn_anywhere p [] t in
List.iter
(fun (g : Tast.global) ->
if holds g.Tast.gty then
add g.Tast.ginit.Tast.loc (Printf.sprintf "the global %s" g.Tast.gname))
p.Tast.globals;
List.iter
(fun (fn : Tast.fn) ->
List.iteri
(fun i t ->
if holds t then
add fn.Tast.floc
(Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name))
fn.Tast.params;
if holds fn.Tast.ret then
add fn.Tast.floc (Printf.sprintf "the return type of %s" fn.Tast.name);
Array.iteri
(fun i t ->
if holds t && not (t = Types.Dyn) then
add fn.Tast.floc
(Printf.sprintf "%s in %s"
(match
(if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None)
with Some n -> n | None -> "a local")
fn.Tast.name))
fn.Tast.slots;
value_sites p
(* The filter this pass has and the descriptor pass does not: a frame slot
whose type is bare [dyn] is passed over here. A parameter or a global of
that type is still named. *)
(fun ~slot loc what t ->
if holds t && not (slot && t = Types.Dyn) then add loc what)
~after_fn:(fun (fn : Tast.fn) ->
(* The body's own dyn values, which are the ones a signature does not
show: a let bound to a boxed literal, a (vec-new dyn) deep inside an
expression. Reported at the node, because that is the character to
@ -8422,8 +8411,7 @@ let dyn_sites (p : Tast.program) : Loc.diag list =
&& String.sub sym 0 8 = "flan_dyn" ->
add e.Tast.loc (Printf.sprintf "this value in %s" fn.Tast.name)
| _ -> ()))
fn.Tast.body)
p.Tast.fns;
fn.Tast.body);
List.rev_map
(fun (loc, what) ->
Loc.diag ~kind:"check/no-gc" loc