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

The note is emitted where the type is known, and dropped where it is not

Browse Source 
The checker builds one note after every operation that may have allocated,
because the checker is the only place the concrete element type exists — and it
builds them in every build, because a tree that differed by build flag would
make every pass between here and the backend ask which one it was looking at.
The backend drops them when [dev] is off, before walking the arguments: a note
takes the container's address, and emitting that only to discard the call would
leave an escaped alloca that mem2reg will not promote.

Armed by a global constructor rather than a line in main. A defvar initialiser
can allocate before main runs, and a note that arrived before the flag was set
would be a block the table never heard of.

A dev build reports the live block, answers 1 for a pointer into it, and 0 for
the same pointer after the free. A release build answers 0 to all of it.
This commit is contained in:
Joseph Ferano 2026-09-13 09:13:36 +07:00
parent ac31ebc211
commit 662b25ef5b
2 changed files with 110 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
lib/check.ml
View File

@ -589,6 +589,37 @@ let here loc = mk loc Types.String (Tast.Str (Loc.to_string loc))
(* A runtime call, with the result type spelled at the site. *)
let rt loc ty sym args = mk loc ty (Tast.Prim (Tast.Rt sym, args))
(* ── The allocation registry's note, NEXT.md ───────────────────────────
One after every operation that may have allocated — which is *here*, and
nowhere else, because here is the only place the concrete type is known. A
Flan struct is exactly its C layout with no header and no tag word, so
nothing at run time can say what is at an address; the allocator's caller
knew, and this is the caller writing it down.
The type is spelled with [Types.to_string], the same spelling a slot
fingerprint and a DWARF node already key on, so a name that appears in a
registry answer is a name the programmer wrote.
It is built unconditionally and dropped by the backend in a release build
(see [Emit]'s [Rt] arm). The checker does not know which kind of build this
is and must not learn: a note that existed only in a dev build would make
the two builds different *trees*, and every pass between here and the
backend would have to agree about which one it was looking at.
[target] is the container, passed by address like every other container
operation; the extent comes off its header in the runtime, because the
header is the only thing that knows where the storage landed. *)
let reg_note loc sym (target : Tast.expr) sizes ty =
rt loc Types.Unit sym
((target :: sizes) @ [ mk loc Types.String (Tast.Str (Types.to_string ty)) ])
(* [(do attempt note)] — the note runs only once the guard's retry loop has
stopped, so it describes the storage the program ended up with rather than
one of the attempts that failed. *)
let with_note loc (guarded : Tast.expr) (note : Tast.expr) =
mk loc Types.Unit (Tast.Do [ guarded; note ])
(* ── Reading a file at compile time, decision 1 ────────────────────────
The path is a *literal*, because the bytes have to be in hand before any
value exists — this is Odin's rule too (check_load_directive rejects
@ -2928,7 +2959,10 @@ and named_call ctx ~want loc name args =
expect loc ~want
(mk loc (Types.Vec elem)
(Tast.Let ([ (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_vec"
(mk loc (Types.Vec elem) (Tast.Local v))
[ size_of loc elem ] elem);
mk loc (Types.Vec elem) (Tast.Local v) ])))
(* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *)
| "push" ->
@ -2946,9 +2980,17 @@ and named_call ctx ~want loc name args =
[ target; addr_of loc (mk loc elem (Tast.Local e));
size_of loc elem; align_of loc elem; here loc ]
in
(* Re-noted after every push, not only the first: a push that grows the
Vec moves the storage, and the note is keyed on the base address, so
an unmoved block costs a probe and an overwrite with the same
numbers. This is the insert per allocation NEXT.md settles on, and
the settled answer to what it costs is "measure a real program". *)
expect loc ~want
(mk loc Types.Unit
(Tast.Let ([ (e, x) ], [ alloc_guard ctx loc attempt ])))
(Tast.Let ([ (e, x) ],
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_vec" target
[ size_of loc elem ] elem) ])))
| _ -> assert false)
| "reserve" ->
arity loc name 2 args;
@ -2959,7 +3001,7 @@ and named_call ctx ~want loc name args =
let n64 =
mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Cast (Types.Int Types.I64), [ n ]))
in
let attempt =
let attempt, note =
match target.Tast.ty with
(* For a map the number is entries, not slots: the runtime sizes the
block so that [n] still sits under the 75% load factor, which is
@ -2968,13 +3010,17 @@ and named_call ctx ~want loc name args =
| Types.Map (k, v) ->
let hash, _ = key_fns ctx.env loc k in
rt loc (Types.Int Types.I8) "flan_map_reserve"
[ target; n64; size_of loc k; size_of loc v; hash; here loc ]
[ target; n64; size_of loc k; size_of loc v; hash; here loc ],
reg_note loc "flan_dev_reg_note_map" target
[ size_of loc k; size_of loc v ] target.Tast.ty
| _ ->
let elem = vec_elem loc "reserve" target.Tast.ty in
rt loc (Types.Int Types.I8) "flan_vec_reserve"
[ target; n64; size_of loc elem; align_of loc elem; here loc ]
[ target; n64; size_of loc elem; align_of loc elem; here loc ],
reg_note loc "flan_dev_reg_note_vec" target
[ size_of loc elem ] elem
in
expect loc ~want (alloc_guard ctx loc attempt)
expect loc ~want (with_note loc (alloc_guard ctx loc attempt) note)
| _ -> assert false)
(* (as-slice v) and (as-slice v lo hi) — spec-memory.md, "Borrowing". The
result is a non-owning view: copying it copies ptr+len and never the
@ -3072,7 +3118,10 @@ and named_call ctx ~want loc name args =
expect loc ~want
(mk loc mty
(Tast.Let ([ (d, mk loc mty (Tast.Zero mty)) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_map"
(mk loc mty (Tast.Local d))
[ size_of loc k; size_of loc v ] mty);
mk loc mty (Tast.Local d) ])))
(* Refused by name rather than falling through to "clone takes a
(Vec T)". Copying a pool would duplicate every slot *and* every
@ -3098,7 +3147,10 @@ and named_call ctx ~want loc name args =
(mk loc (Types.Vec elem)
(Tast.Let ([ (d, mk loc (Types.Vec elem)
(Tast.Zero (Types.Vec elem))) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_vec"
(mk loc (Types.Vec elem) (Tast.Local d))
[ size_of loc elem ] elem);
mk loc (Types.Vec elem) (Tast.Local d) ]))))
| _ -> fail loc "clone is (clone v) or (clone v allocator)")
@ -3124,7 +3176,10 @@ and named_call ctx ~want loc name args =
expect loc ~want
(mk loc pty
(Tast.Let ([ (p, mk loc pty (Tast.Zero pty)) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_pool"
(mk loc pty (Tast.Local p))
[ size_of loc elem ] elem);
mk loc pty (Tast.Local p) ])))
(* (insert p x) -> (Handle T). The handle is the *only* way back to what was
@ -3152,7 +3207,9 @@ and named_call ctx ~want loc name args =
expect loc ~want
(mk loc hty
(Tast.Let ([ (e, x); (h, mk loc hty (Tast.Zero hty)) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_pool" target
[ size_of loc elem ] elem);
mk loc hty (Tast.Local h) ])))
| _ -> assert false)
@ -3333,7 +3390,10 @@ and named_call ctx ~want loc name args =
expect loc ~want
(mk loc mty
(Tast.Let ([ (m, mk loc mty (Tast.Zero mty)) ],
[ alloc_guard ctx loc attempt;
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_map"
(mk loc mty (Tast.Local m))
[ size_of loc k; size_of loc v ] mty);
mk loc mty (Tast.Local m) ])))
(* (put m k v) — the upsert. Unit, not a Result and not an ignorable error
@ -3360,7 +3420,11 @@ and named_call ctx ~want loc name args =
in
expect loc ~want
(mk loc Types.Unit
(Tast.Let ([ (ks, k); (vs, v) ], [ alloc_guard ctx loc attempt ])))
(Tast.Let ([ (ks, k); (vs, v) ],
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_map" target
[ size_of loc kt; size_of loc vt ]
target.Tast.ty) ])))
| _ -> assert false)
(* (get m k) -> (Option V). Absence is None, not an untyped nil, and the
@ -3597,9 +3661,13 @@ and named_call ctx ~want loc name args =
(* Previous turn's storage, if a retry brought us back here. *)
rt loc Types.Unit "flan_vec_free"
[ vv (); size_of loc u8; align_of loc u8; here loc ];
alloc_guard ctx loc
(rt loc (Types.Int Types.I8) "flan_vec_init"
[ vv (); a; nv (); size_of loc u8; align_of loc u8; here loc ]);
with_note loc
(alloc_guard ctx loc
(rt loc (Types.Int Types.I8) "flan_vec_init"
[ vv (); a; nv (); size_of loc u8; align_of loc u8;
here loc ]))
(reg_note loc "flan_dev_reg_note_vec" (vv ())
[ size_of loc u8 ] u8);
(* Fills the Vec the line above sized. A file that grew since the
measurement is truncated to the buffer; one that shrank leaves a
shorter Vec. Both are successful reads of what was there. *)

27
lib/emit.ml
View File

@ -1866,6 +1866,19 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
(* One arm for every runtime entry point the allocator and container runtime
has. The result type is the node's own and the argument types are the
arguments' own, so nothing here has to know which symbol it is calling. *)
(* The allocation registry's notes are the one family in here a release
build drops on the floor, and the drop has to happen before the arguments
are walked rather than after: a note takes the address of the container it
is describing, and emitting that address only to discard the call would
leave an escaped alloca behind for mem2reg to refuse. So this is a
[Types.t] the checker built and the backend declines to use, which is the
same arrangement the indirection cells and the shadow stack have — the
checker does not know whether this is a dev build and does not have to. *)
| Tast.Rt sym, _
when (not f.md.dev)
&& String.length sym > 17
&& String.equal (String.sub sym 0 17) "flan_dev_reg_note" ->
"zeroinitializer"
| Tast.Rt sym, args ->
let vs =
List.concat
@ -2394,6 +2407,10 @@ declare i64 @flan_alloc_fail_align()
declare i64 @flan_alloc_fail_id()
declare i64 @flan_alloc_budget(ptr)
declare void @flan_alloc_set_budget(ptr, i64)
declare void @flan_dev_reg_enable()
declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_pool(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64)
declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)
@ -2671,6 +2688,16 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
(Printf.sprintf "%s = global ptr %s\n" (cellname fn.Tast.name)
(fname fn.Tast.name)))
p.Tast.fns;
(* And the allocation registry is armed, which is the whole of what makes
it a dev-build feature at run time. A constructor rather than a line in
[main]: the notes are emitted into every function, a global that a
[defvar] initialiser allocates runs before main does, and a note that
arrived before the flag was set would be a block the table never heard
of. Priority 65535 is the default slot; nothing here needs to beat
another constructor, only to beat the program. *)
Buffer.add_string m.out
"@llvm.global_ctors = appending global [1 x { i32, ptr, ptr }] \
[{ i32, ptr, ptr } { i32 65535, ptr @flan_dev_reg_enable, ptr null }]\n";
Buffer.add_char m.out '\n'
end;
List.iter (emit_global m) p.Tast.globals;