From 662b25ef5b88b93e743bf71c35189a4998c6781a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 09:13:36 +0700 Subject: [PATCH] The note is emitted where the type is known, and dropped where it is not MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- lib/check.ml | 98 ++++++++++++++++++++++++++++++++++++++++++++-------- lib/emit.ml | 27 +++++++++++++++ 2 files changed, 110 insertions(+), 15 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 2061a37..d451d26 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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. *) diff --git a/lib/emit.ml b/lib/emit.ml index 4d5c285..3b08308 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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;