From c11623762150fe25ee61259b5c09b4cab5a50397 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 12:05:44 +0700 Subject: [PATCH] An Allocator value is its record and the incarnation it was made for, so one kept past its arena-destroy traps at every use even after arena-new reuses the record --- TODO.org | 15 +++---- docs/BUILT.md | 17 +++++--- lib/check.ml | 70 ++++++++++++++++++++++-------- lib/emit.ml | 33 ++++++++------ lib/x86.ml | 12 ++--- runtime/flan_rt.c | 54 ++++++++++++++++++++--- spec-memory.md | 5 +++ test/programs/destroy-region.flan | 21 +++++++++ test/programs/dev-alloc-param.flan | 20 +++++++++ test/test_acceptance.ml | 31 ++++++++++++- test/test_dev.ml | 64 +++++++++++++++++++++++++++ test/test_valgrind.ml | 3 ++ 12 files changed, 287 insertions(+), 58 deletions(-) create mode 100644 test/programs/dev-alloc-param.flan diff --git a/TODO.org b/TODO.org index 8a2bdaf4..ba356326 100644 --- a/TODO.org +++ b/TODO.org @@ -1315,10 +1315,8 @@ No ordering of the frees fixes it: the container holds a pointer to the header. allocator header — epoch bumped, procedure trapping as =DestroyedAllocator=, never freed — so the stale check reads live memory on every side that makes it. The next =arena-new= takes a retired header back, epoch kept, so a loop of them -stays flat and a container made before the destroy still traps. An =Allocator= -value kept past its destroy names the new arena once its header is reused. -Rules out freeing the header while any container may hold it. The -=DestroyedAllocator= trap prints no site: the allocator procedure is given none. See +stays flat and a container made before the destroy still traps. +Rules out freeing the header while any container may hold it. See docs/BUILT.md, "Three amendments to a frozen spec". ** DONE Map removal costs a backward-shift loop @@ -1501,11 +1499,10 @@ Deleted, in a sweep for dead code across the repository in which each removal was first shown unused. flan_dyn.c is the one implementation of the flan_dyn.h ABI; a stand-in beside it is not to come back. -** NEXT A destroyed arena always traps, even after its record is reused -Decided 2026-09-25: an Allocator value is two words, the record and the -incarnation it was made for; every use compares the incarnation, so a destroyed -arena traps whether or not a later arena-new reused its record. Rules out -static tracking of destroy, which is move semantics. +** DONE A destroyed arena always traps, even after its record is reused +CLOSED: [2026-09-25] +An Allocator value is the record and the incarnation it was made for, compared on every use. +Rules out static tracking of destroy, which is move semantics. docs/BUILT.md has the cost. ** NEXT A mixed array literal with no want is a dyn vector Decided 2026-09-25: with nothing expected of it, an array literal whose elements diff --git a/docs/BUILT.md b/docs/BUILT.md index a3999e5f..202fd434 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -2768,10 +2768,10 @@ What *does* need milestone 5 is a **user-written** allocator: "here is my proc, `defn`'s name in value position. `make-allocator`, `allocator-from` and `allocator` are refused by name with that reason, rather than coming back as unknown functions. -**An `Allocator` value is a pointer to the runtime's struct, never a copy of one.** That is forced, not chosen. The +**An `Allocator` value names the runtime's struct, never a copy of one.** That is forced, not chosen. The capability set has to be readable from wherever a container landed, and `free-all` bumps an epoch every container made from the allocator has to observe. A copied-by-value allocator gives each copy its own epoch and the dev trap never -fires. +fires. The value is two words: the struct's address and the incarnation of it the value was made for (see below). ### The surface @@ -2836,9 +2836,16 @@ turned the trap into a read of freed memory that happened to see the bumped valu retired instead — epoch bumped, procedure swapped for one that traps as `DestroyedAllocator`, never freed — and put on a list that the next `arena-new` takes from. The epoch is kept on reuse: it only ever rises on a header, so a container made before the destroy still records an older number and still traps. Keeping every retired header instead grew -without bound — ten million `arena-new`/`arena-destroy` rounds peaked at 626 MB against 1.7 MB. The cost of reuse is -an `Allocator` value kept past its destroy: while its header is on the list it traps, and once a later `arena-new` has -taken the header it names that new arena. A second `arena-destroy` of the same allocator, before reuse, does nothing. +without bound — ten million `arena-new`/`arena-destroy` rounds peaked at 626 MB against 1.7 MB. + +Reuse would let an `Allocator` value kept past its destroy name the next arena to take its header, so the value carries +the header's *incarnation*, which the retire bumps, and every use of a value (`flan_alloc_use`) compares the two. A +stale value traps as `DestroyedAllocator` at the site that used it, reused header or not, a second `arena-destroy` +included. The incarnation is its own counter rather than the epoch, because `free-all` keeps the arena and a value made +before one is still good. Containers need no change: they hold the header and already trap on its epoch. The cost is a +16-byte value and one call per use of a value — per `vec-new`, `with-allocator` or `free-all` naming one, not per push: +on a loop of `vec-new` + `with-allocator` + `free-all` against one arena, 50 more instructions an iteration out of 549 +under LLVM and 69 out of 827 under `--x86`, cycles within noise. `test/programs/destroy-region.flan`, arguments 4 to 6. **2. `context/allocator` and `context/temp` are dynamic variables with save and restore, not extra parameters.** The spec says the allocator is "part of the calling convention". The literal reading touches every function signature, the diff --git a/lib/check.ml b/lib/check.ml index a100f2d6..43794e68 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2237,6 +2237,35 @@ let to_bytes ctx loc pr (x : Tast.expr) = [ mk loc bslice (Tast.Prim (pr, [ x; addr_of loc (mk loc bty (Tast.Local s)) ])) ])) +(* ── An Allocator value, made and used ───────────────────────────────── + A value is two words, flan_rt.c's [flan_alloc_value]: the runtime's + allocator record and the incarnation of it the value was made for, which + arena-destroy bumps. Every runtime operation takes the bare record, typed + [raw_alloc] here; [seal_alloc] makes a value from one and [use_alloc] opens + one, trapping if the incarnation has moved. So a value kept past its arena's + destroy traps at its next use, including after arena-new has taken the + record back for another arena — which a one-word value could not tell from + the new arena's own. Both cross through the value's address, since nothing + the runtime answers or takes is a struct by value. *) +let raw_alloc = Types.Ptr Types.Unit + +let seal_alloc ctx loc (record : Tast.expr) = + let s = fresh_slot ctx Types.Alloc in + mk loc Types.Alloc + (Tast.Let + ([ (s, mk loc Types.Alloc (Tast.Zero Types.Alloc)) ], + [ rt loc Types.Unit "flan_alloc_seal" + [ record; addr_of loc (mk loc Types.Alloc (Tast.Local s)) ]; + mk loc Types.Alloc (Tast.Local s) ])) + +let use_alloc ctx loc (v : Tast.expr) = + let s = fresh_slot ctx Types.Alloc in + mk loc raw_alloc + (Tast.Let + ([ (s, v) ], + [ rt loc raw_alloc "flan_alloc_use" + [ addr_of loc (mk loc Types.Alloc (Tast.Local s)); here loc ] ])) + (* A string literal handed to a [declare-c] function goes to C without the copy the wrapper makes of any other string. Both backends write a NUL after a literal's bytes, so the literal is passed with its length counting that NUL, @@ -3267,11 +3296,10 @@ and struct_key_pair env loc n = end (* The pair as two expressions, ready to be passed. Their Flan type is - [Alloc]: an opaque pointer-width value with no user-writable constructor, - which is all the backend needs and all any Flan type ever says about it. *) + [(Ptr ())]: one opaque word, which is all the backend needs. *) let key_fns env loc k = let h, e = key_pair env loc k in - mk loc Types.Alloc (Tast.FnAddr h), mk loc Types.Alloc (Tast.FnAddr e) + mk loc raw_alloc (Tast.FnAddr h), mk loc raw_alloc (Tast.FnAddr e) (* ── The map operations, deferred to the instantiation ───────────────── True when the key is a type variable, which means the operation cannot be @@ -3942,10 +3970,10 @@ and var ctx ?(qualified = false) loc ~want name = the literal reading of "calling convention" is deferred. *) | "context/allocator" -> expect ctx loc ~want - (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_allocator", []))) + (seal_alloc ctx loc (rt loc raw_alloc "flan_context_allocator" [])) | "context/temp" -> expect ctx loc ~want - (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_temp", []))) + (seal_alloc ctx loc (rt loc raw_alloc "flan_context_temp" [])) | _ when qualified -> (* In [builtin_set] — the arm above checked — but not one of the four arms above this one, so it is a builtin that exists only as a call. @@ -6876,10 +6904,14 @@ and vec_elem loc what (t : Types.t) = implicit one. spec-memory.md: an operation never falls back to a hidden global allocator, and an explicit allocator can override the context. *) and allocator_arg ctx loc = function - | [] -> rt loc Types.Alloc "flan_context_allocator" [] - | [ a ] -> check ctx ~want:Types.Alloc a + | [] -> rt loc raw_alloc "flan_context_allocator" [] + | [ a ] -> alloc_value ctx loc a | _ -> fail loc "at most one allocator may be named here" +(* An Allocator value, checked and opened: the record every runtime call + takes, after [use_alloc] has compared the incarnation. *) +and alloc_value ctx loc e = use_alloc ctx loc (check ctx ~want:Types.Alloc e) + (* A copy of [src]'s elements — a string's bytes or a slice's elements — into a block from [a], answered as a slice over it: (bytes s), (clone xs) and the number conversions. The lowering mirrors [vec-new]: a hidden (Vec T) temp @@ -7466,7 +7498,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | "heap-allocator" -> arity ctx loc name 0 args; expect ctx loc ~want - (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", []))) + (seal_alloc ctx loc (rt loc raw_alloc "flan_heap_allocator" [])) (* The capacity is explicit and there is no growing backing store: an arena whose size is decided by the program is one a program can reason about, and it is the only shape under which "exhausted" is a state a test can @@ -7475,12 +7507,12 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 1 args; let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in expect ctx loc ~want - (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ]))) + (seal_alloc ctx loc (rt loc raw_alloc "flan_arena_new" [ cap ])) (* Hands the pages back, which [free-all] deliberately does not — see TODO.org, "Allocators, (Vec T) and StorageExhausted". *) | "arena-destroy" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ]))) (* One of spec-memory.md's two release points. It takes the source location @@ -7488,7 +7520,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = rather than the runtime. *) | "free-all" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_free_all", [ a; here loc ]))) @@ -7497,7 +7529,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = answer without the round trip, which is the call this made. *) | "can-free?" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Bool (Tast.Prim (Tast.Ne, @@ -7506,7 +7538,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) | "can-free-all?" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Bool (Tast.Prim (Tast.Ne, @@ -7518,7 +7550,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = saw. *) | "alloc-epoch" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_epoch", [ a ]))) @@ -7527,7 +7559,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = which one ran out. *) | "alloc-id" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ]))) (* A ceiling on live bytes, 0 for none. spec-memory.md's retry restart is @@ -7539,7 +7571,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = program exhausts an allocator on purpose. *) | "alloc-budget" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ]))) @@ -7547,7 +7579,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ a; n ] -> - let a = check ctx ~want:Types.Alloc a in + let a = alloc_value ctx loc a in let n = check ctx ~want:(Types.Int Types.I64) n in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_set_budget", [ a; n ]))) @@ -7556,7 +7588,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = tier answering it — spec-memory.md, "Leaking is defined behaviour". *) | "alloc-live-blocks" -> arity ctx loc name 1 args; - let a = check ctx ~want:Types.Alloc (List.hd args) in + let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_live_blocks", [ a ]))) @@ -7568,7 +7600,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = (match args with | [] -> fail loc "with-allocator is (with-allocator allocator body ...)" | a :: body -> - let a = check ctx ~want:Types.Alloc a in + let a = alloc_value ctx loc a in let body, ty = scoped ctx (fun () -> match body with diff --git a/lib/emit.ml b/lib/emit.ml index 3aa80f0d..f8313d3a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -271,9 +271,10 @@ let rec ll (t : Types.t) = | Types.Enum _ -> "i32" | Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e) | Types.Ptr _ -> "ptr" - (* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a - copy of one: see Types. Opaque here in the same sense [ptr] is. *) - | Types.Alloc -> "ptr" + (* An [Allocator] is the runtime's [flan_allocator] record and the + incarnation of it the value was made for — flan_rt.c's [flan_alloc_value]. + The runtime is handed its address; see [Check.use_alloc]. *) + | Types.Alloc -> "%alloc" (* A code address and the environment it is called with: two words, always, whether or not this particular value captured anything. See [%fnv]. *) | Types.Fn _ -> "%fnv" @@ -488,7 +489,7 @@ let rec lay m (t : Types.t) : int * int = | Types.Unit | Types.Never -> 0, 1 | Types.Enum _ -> 4, 4 | Types.Ptr _ -> 8, 8 - | Types.Alloc -> 8, 8 + | Types.Alloc -> 16, 8 | Types.Fn _ -> 16, 8 | Types.CFn _ -> 8, 8 | Types.Vec _ | Types.Map _ -> 40, 8 @@ -824,19 +825,20 @@ let rec dty m d (t : Types.t) : int = (List.map (fun i -> Printf.sprintf "!%d" i) ms))); id | None -> internal "no debug type for struct %s" sn) - (* An opaque pointer under lldb, which is the truth: the allocator's - fields are the runtime's C and lldb already has that type from - flan_rt.c's own debug info. *) + (* The record as an opaque pointer — its fields are the runtime's C and + lldb already has that type from flan_rt.c's own debug info — and the + incarnation beside it. *) | Types.Alloc -> - dnode d - "!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)" + composite "Allocator" + [ ("record", Types.Ptr Types.Unit); + ("incarnation", Types.Int Types.U64) ] (* Shown as what it is. The epoch word is in the layout and so it is here too: a debugger that showed four fields of a five-field struct would put the reader's offsets out by one. *) | Types.Vec e -> composite (Types.to_string t) [ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64); - ("cap", Types.Int Types.I64); ("allocator", Types.Alloc); + ("cap", Types.Int Types.I64); ("allocator", Types.Ptr Types.Unit); ("epoch", Types.Int Types.I64) ] (* Five fields again, and shown as five for the same reason: a debugger that showed fewer would put the reader's offsets out. [log2cap] is @@ -847,7 +849,7 @@ let rec dty m d (t : Types.t) : int = composite (Types.to_string t) [ ("data", Types.Ptr (Types.Int Types.U8)); ("len", Types.Int Types.I64); ("log2cap", Types.Int Types.I64); - ("allocator", Types.Alloc); ("epoch", Types.Int Types.I64) ] + ("allocator", Types.Ptr Types.Unit); ("epoch", Types.Int Types.I64) ] |> fun n -> ignore k; ignore v; n (* Two words, and shown as two, the same rule the Vec and the Map above follow: a debugger told a function value were one pointer would put @@ -2192,7 +2194,7 @@ and value_at f (e : Tast.expr) : string = it there. See [%fnv]. Only a [Fn]-typed one. The same three [fnref] constructors are also asked - for as bare addresses — carrying [CFn], and carrying [Alloc] for the + for as bare addresses — carrying [CFn], and carrying [(Ptr ())] for the map's hash and equality pair and a handler frame's clause, which are fields of structs the runtime declares — and those stay one word. The node's type is what says which is being asked for. *) @@ -2660,7 +2662,7 @@ and call_ptr f ret callee args = call_through f ?env ret code vs (* The code address behind one of the three [fnref]s, which is the same string - whether it is wanted as a bare [Alloc] pointer or as the first word of a + whether it is wanted as a bare [(Ptr ())] or as the first word of a function value. [Flanfn] and [Rtfn] are the symbol itself, not a load from it: a function's @@ -4284,6 +4286,9 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher ; A value that captures nothing carries a null there and every call passes it ; on regardless; see [env_param]. %fnv = type { ptr, ptr } +; An Allocator value: the runtime's record, and the incarnation of it the value +; was made for, so a value kept past its arena's destroy is caught on use. +%alloc = type { ptr, i64 } ; (Vec T), spec-memory.md. The element type is nowhere in it: the runtime is ; type-erased and every operation is handed size and align at its call site. %vec = type { ptr, i64, i64, ptr, i64 } @@ -4347,6 +4352,8 @@ declare void @flan_slice_promise_error(ptr, i64, i64, ptr) cold ; operands, or the destination's range for a cast. declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold declare ptr @flan_context_allocator() +declare void @flan_alloc_seal(ptr, ptr) +declare ptr @flan_alloc_use(ptr, ptr, i64) declare ptr @flan_context_temp() declare ptr @flan_heap_allocator() declare ptr @flan_context_set(ptr) diff --git a/lib/x86.ml b/lib/x86.ml index 9d6f15a3..28819b4b 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -510,7 +510,9 @@ let is_agg (t : Types.t) = (* A [(CFn ...)] is one word and crosses exactly as a pointer does, which is the whole of its reason for existing. *) | Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _ - | Types.Alloc | Types.CFn _ -> false + | Types.CFn _ -> false + (* The record and its incarnation — see [Emit]'s %alloc. *) + | Types.Alloc -> true | Types.Unit | Types.Never -> false (* A [(Fn ...)] is two words — the code address and the environment beside it — so it crosses the way a slice does. [Emit.lay] is the one place that @@ -1171,7 +1173,7 @@ let load_sym f ~dst s = else load_int f.b ~dst ~mm:(Sym (s, 0)) ~size:8 ~signed:false (* The code address behind one of the three [fnref]s, which is the same - sequence whether it is wanted as a bare [Alloc] pointer or as the first + sequence whether it is wanted as a bare [(Ptr ())] or as the first word of a function value. [Flanfn] and [Rtfn] are the symbol itself, not a load from it: a function's @@ -1735,7 +1737,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit = (* A [(Fn ...)] value: the code address, then the environment beside it. Two words — see [Emit]'s %fnv. Only a [Fn]-typed node; the same three constructors are also asked for as bare addresses, carrying [CFn] or - [Alloc], and those stay one word. The node's type says which. *) + [(Ptr ())], and those stay one word. The node's type says which. *) | (Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _) when (match t with Types.Fn _ -> true | _ -> false) -> let env = @@ -3023,8 +3025,8 @@ and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst = [Unit] or a scalar. [flan_vec_as_slice] is the one that looks like a counter-example and is not: [check.ml] builds it as [rt loc Types.Unit] and [flan_rt.c] writes the two words through [void *out]. - Every other [rt] builder in the file answers [Unit], an [Int], a - [Ptr] or an [Alloc]. + Every other [rt] builder in the file answers [Unit], an [Int] + or a [Ptr]. - [crossable], which admits [String] and [Slice _] only as "a parameter" and refuses an aggregate return from a [declare] outright. diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 0b0b1ba3..dd58fcd6 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1065,7 +1065,8 @@ void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op, * size and align as parameters because the only place the concrete type is * known is the call site. * - * A Flan `Allocator` value is a *pointer* to one of these, not a copy of it. + * A Flan `Allocator` value names one of these — its address and the + * [incarnation] it was made for, see flan_alloc_value — and is never a copy. * That is forced by two things in the spec and is not a convenience: the * capability set has to be readable at run time from wherever a container * landed, and `free-all` bumps an epoch that every container made from the @@ -1122,8 +1123,22 @@ struct flan_allocator { * the spec names as the handler that works, needs a ceiling to raise. It * doubles as the knob a test exhausts an allocator with on purpose. */ int64_t budget; + /* Bumped when arena-destroy retires this record. A Flan Allocator value is + * this record's address and the incarnation it was made for, and every use + * of one compares the two (flan_alloc_use), so a value kept past its + * arena's destroy traps even after arena-new has taken the record back for + * another arena. Separate from [epoch]: free-all keeps the arena, and a + * value made before a free-all is still good. */ + uint64_t incarnation; }; +/* A Flan Allocator value, two words. The compiler lays it out as { ptr, i64 } + * and hands the runtime its address. */ +typedef struct flan_alloc_value { + flan_allocator *rec; + uint64_t inc; +} flan_alloc_value; + /* ── Byte counts that cannot wrap ────────────────────────────────────── * * Every size this file computes is a signed 64-bit count of bytes, and every @@ -1245,7 +1260,7 @@ static void *flan_heap_proc(flan_allocator *a, int32_t mode, void *p, static flan_allocator flan_heap = { flan_heap_proc, NULL, FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE, - 0, 0, 0, 0 + 0, 0, 0, 0, 0 }; /* -- Telling memcheck an arena reset happened. ----------------------- @@ -1508,9 +1523,10 @@ static void *flan_destroyed_proc(flan_allocator *a, int32_t mode, void *p, * makes and destroys arenas in a loop holds as many headers as it ever had * arenas alive at once. * - * A second destroy finds the retired procedure and does nothing — while the - * header is still on the list. Once a later arena-new has taken it back, the - * old Allocator value names the new arena. */ + * The Allocator value that named the arena carries the incarnation it was made + * for, which the retire bumps, so every later use of that value — a second + * destroy included — traps in flan_alloc_use before it reaches here, whether + * or not a later arena-new has taken the record back. */ void flan_arena_destroy(flan_allocator *a) { flan_arena *ar; if (!a || a->proc != flan_arena_proc) return; @@ -1525,6 +1541,7 @@ void flan_arena_destroy(flan_allocator *a) { } static void flan_header_retire(flan_allocator *a) { + a->incarnation++; a->proc = flan_destroyed_proc; a->live_blocks = 0; a->live_bytes = 0; @@ -1534,6 +1551,33 @@ static void flan_header_retire(flan_allocator *a) { flan_allocator *flan_heap_allocator(void) { return &flan_heap; } +/* An Allocator value made from a record: the record and its incarnation now. + * Through an out-pointer, since nothing here returns a struct by value. */ +void flan_alloc_seal(flan_allocator *a, flan_alloc_value *out) { + out->rec = a; + out->inc = a ? a->incarnation : 0; +} + +/* Every use of an Allocator value comes through here: the record, if the + * value's incarnation is still the record's. A mismatch is a value kept past + * its arena's destroy, and it traps whether the record is still retired or + * serves a newer arena — reaching the newer arena would be allocating from a + * region the program never named. A null record passes through to the + * operation's own null check, which names the site the same way. */ +flan_allocator *flan_alloc_use(const flan_alloc_value *v, const uint8_t *loc, + int64_t loclen) { + flan_allocator *a = v->rec; + if (a && a->incarnation != v->inc) { + rt_flush_out(); + fprintf(stderr, + "%.*s: this allocator was destroyed by arena-destroy, so nothing " + "can be allocated from it or released through it\n", + (int)loclen, (const char *)loc); + rt_trap((const uint8_t *)"DestroyedAllocator", 18); + } + return a; +} + int8_t flan_alloc_can_free(flan_allocator *a) { return (int8_t)(a && (a->caps & FLAN_CAN_FREE) ? 1 : 0); } diff --git a/spec-memory.md b/spec-memory.md index 86574e44..651c4e77 100644 --- a/spec-memory.md +++ b/spec-memory.md @@ -615,6 +615,11 @@ operation. It works because an `Allocator` is a **pointer** to the allocator and not a copy of one — a copied-by-value allocator would give each copy its own epoch, and a copy taken before the bump would never notice it. +An `Allocator` value is two words: that pointer, and the incarnation of the +allocator it was made for, which `arena-destroy` bumps. Every use of the value +compares the two, so a value kept past its arena's destroy traps at its next +use, even after a later `arena-new` has taken the allocator's record back. + ### `drop` — owning something that is not memory A type may name one hook: diff --git a/test/programs/destroy-region.flan b/test/programs/destroy-region.flan index 680be7eb..7bc972de 100644 --- a/test/programs/destroy-region.flan +++ b/test/programs/destroy-region.flan @@ -13,6 +13,11 @@ ;;;; container made before the destroy still traps, because the epoch on a ;;;; header only ever rises. ;;;; +;;;; Arguments 4, 5 and 6 use the destroyed Allocator value itself after the +;;;; next arena-new took its record back — for a new container, through +;;;; with-allocator, and in a second destroy. The value carries the incarnation +;;;; it was made for, so each traps instead of reaching the new arena. +;;;; ;;;; Argument 3 makes and destroys arenas in a loop, as many times as the ;;;; second argument says. A retired allocator is reused rather than kept, so ;;;; the loop's memory stays flat however long it runs. @@ -35,6 +40,22 @@ (push w 5) (println (at w 0)) (println (at v 0)))) + ;; The Allocator value itself, kept past its destroy, after arena-new + ;; took its record back: b works, and a traps rather than naming b's + ;; arena. Argument 5 is the same through with-allocator, and 6 through + ;; a second arena-destroy. + (>= which 4) + (do + (arena-destroy a) + (let [b (arena-new 4096) + w (vec-new i32 b)] + (push w 5) + (println (at w 0)) + (cond + (= which 4) (let [x (vec-new i32 a)] (push x 1)) + (= which 5) (with-allocator a (let [x (vec-new i32)] (push x 1))) + :else (arena-destroy a)) + (println "unreachable"))) (= which 3) (let [n (bytes->i64 (bytes-view (at args 2)))] (arena-destroy a) diff --git a/test/programs/dev-alloc-param.flan b/test/programs/dev-alloc-param.flan new file mode 100644 index 00000000..6f858b87 --- /dev/null +++ b/test/programs/dev-alloc-param.flan @@ -0,0 +1,20 @@ +;;;; A function taking an Allocator, redefined while the program runs. The value +;;;; is two words, the record and its incarnation, and the redefined body is +;;;; compiled by the reload emitter and called through the host's cell, so the +;;;; two have to agree on how those words cross. test_dev.ml runs it on both +;;;; backends. +(import agent "vendor:agent") + +(defonce region Allocator) + +(defn fill [a Allocator n i32] i64 + (let [v (vec-new i64 a)] + (dotimes [i n] (push v (i64 i))) + (i64 (length v)))) + +(defn main [] i32 + (agent/start) + (set region (arena-new 4096)) + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 888c0370..0cb52082 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -1968,13 +1968,13 @@ let () = traps, because the epoch on a header only rises. *) let code, text = run exe (Some "2") in if code <> 134 || not (contains text "5\n") - || not (contains text "programs/destroy-region.flan:37:") + || not (contains text "programs/destroy-region.flan:42:") || not (contains text "allocator was released") then begin incr failures; Printf.printf "FAIL a container whose destroyed allocator was reused\n\ - \ got: %S (exit %d)\n wanted: 5, then the trap at 37 (exit 134)\n" + \ got: %S (exit %d)\n wanted: 5, then the trap at 42 (exit 134)\n" text code end; (* And the reuse is what keeps a make-and-destroy loop flat: two million @@ -2010,6 +2010,33 @@ let () = end end; (try Sys.remove exe with Sys_error _ -> ()); + (* The destroyed Allocator value itself, used after the next arena-new + took its record back: a new container, a with-allocator and a second + destroy each trap at the use rather than reaching the new arena. All + three backends, since the value's two words are laid out by each. *) + List.iter + (fun (x86, opt, tag) -> + let exe = compile ~x86 ~opt "programs/destroy-region.flan" in + List.iter + (fun (arg, line) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text "5\n") + || not (contains text + (Printf.sprintf "programs/destroy-region.flan:%d:" line)) + || not (contains text "destroyed by arena-destroy") + || contains text "unreachable" + then begin + incr failures; + Printf.printf + "FAIL a destroyed Allocator value whose record was reused, \ + argument %s%s\n\ + \ got: %S (exit %d)\n wanted: 5, then the trap at \ + %d (exit 134)\n" + arg tag text code line + end) + [ ("4", 55); ("5", 56); ("6", 57) ]; + (try Sys.remove exe with Sys_error _ -> ())) + [ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ]; (try Sys.remove exe with Sys_error _ -> ()); diff --git a/test/test_dev.ml b/test/test_dev.ml index 169a2eee..66891803 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7002,6 +7002,70 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ csock; cout ]; + (* ── A function taking an Allocator, redefined ───────────────── + An Allocator value is two words, the record and its incarnation. The + redefined body is built by the reload emitter and reached through the + host's cell, so the host and the module have to agree on how the two + words cross; each backend is its own pair of emitters. *) + List.iter + (fun mode -> + let asock = tmp ("alloc" ^ mode ^ ".sock") + and aout = tmp ("alloc" ^ mode ^ ".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-alloc-param.flan"; "-s"; asock; mode |] + Unix.stdin afd Unix.stderr + in + Unix.close afd; + if not (listening ~pid:apid asock) then begin + fail "the %s allocator daemon %s" mode !listen_why; + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect asock in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + let ask code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %S :file \"programs/dev-alloc-param.flan\")" + code) + in + let answered = ref "" in + let asked () = + let r = ask "(fill region 3)" in + status r = "ok" && (answered := value r; true) + in + if not (await asked) then + fail "the %s allocator daemon never reached a frame boundary" mode + else begin + if !answered <> "3" then + fail "%s: fill as built answered %S" mode !answered; + let r = + request c + "(:op \"eval\" :code \"(defn fill [a Allocator n i32] i64 (let \ + [v (vec-new i64 a)] (dotimes [i (* n 10)] (push v (i64 i))) \ + (+ 1000 (i64 (length v)))))\" :file \ + \"programs/dev-alloc-param.flan\")" + in + if status r <> "ok" then fail "%s: redefining fill: %s" mode (status r) + else begin + let r = ask "(fill region 3)" in + if value r <> "1030" then + fail "%s: the redefined fill answered %S" mode (value r) + end + 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 ]) + [ "--llvm"; "--x86" ]; + (* ══ The agent socket is not the editor protocol ══════════════════ Two daemons of their own, both about what a session owes an editor diff --git a/test/test_valgrind.ml b/test/test_valgrind.ml index 9b8c4419..3a1dcec5 100644 --- a/test/test_valgrind.ml +++ b/test/test_valgrind.ml @@ -252,6 +252,9 @@ let corpus = "programs/destroy-region.flan", [ "1" ]; "programs/destroy-region.flan", [ "2" ]; "programs/destroy-region.flan", [ "3"; "1000" ]; + "programs/destroy-region.flan", [ "4" ]; + "programs/destroy-region.flan", [ "5" ]; + "programs/destroy-region.flan", [ "6" ]; "programs/string-of-bytes.flan", []; "programs/text.flan", []; "programs/time.flan", [];