From 2c8bd61a204f605778525c0baaa197caacfe3d59 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:48:09 +0700 Subject: [PATCH] (free s) hands a slice (bytes s) or (clone xs) made back to the context allocator or a named one, a dev build traps on the wrong allocator, and a sliced array literal lives for its whole function on x86 --- docs/BUILT.md | 2 +- lib/check.ml | 87 +++++++++++++++++++++++++++-------- lib/emit.ml | 1 + runtime/flan_dev.c | 34 ++++++++++++++ runtime/flan_rt.c | 41 ++++++++++++++++- test/programs/bytes-copy.flan | 14 +++++- test/programs/free-slice.flan | 26 +++++++++++ test/test_acceptance.ml | 31 ++++++++++++- test/test_flan.ml | 10 ++-- web/index.html | 6 ++- 10 files changed, 221 insertions(+), 31 deletions(-) create mode 100644 test/programs/free-slice.flan diff --git a/docs/BUILT.md b/docs/BUILT.md index 3ded16d5..3ae6cf4c 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3000,7 +3000,7 @@ fires. The value is two words: the struct's address and the incarnation of it th | `(slice v)` / `(slice v lo)` / `(slice v lo hi)` | a non-owning `[T]` view — the array names again, extended | | `(clone v)` / `(clone v a)` | the only copy; assignment moves | | `(free v)` | consumes its argument | -| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block, so nothing can `free` it through the slice; it lives until its allocator's `free-all` or destroy | +| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block; `(free b)` hands it back to the context allocator, or `(free b a)` to the one named, and a dev build's registry traps on a mismatch | | `(bytes-view s)` | the string's own storage as a `[const u8]`, costing nothing — the old `(bytes s)` reinterpret, renamed. A store through it is a compile error, because a literal's view points into `.rodata` | ### A view of a `Vec` goes stale at the `push`, and nothing checks it diff --git a/lib/check.ml b/lib/check.ml index 9ca97cf7..2dcb4981 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -8286,8 +8286,9 @@ and alloc_value ctx loc e = use_alloc ctx loc (check ctx ~want:Types.Alloc e) holds the block so the allocation registry can read its extent, the attempt sits under [alloc_guard] so a failure signals StorageExhausted with retry, and the answer is the [slice] of the whole of it. The slice carries no - allocator, so nothing can [free] the block through it — it lives until its - allocator's free-all or destroy. + allocator: (free s) hands the block back to the context allocator or the + one named, and a dev build's registry — which the note gives the Vec's + allocator — refuses the wrong one. The source is bound before the guard's loop, so a retry re-attempts the same copy rather than re-evaluating the expression that produced it. Same @@ -9232,9 +9233,18 @@ and named_call ?(qualified = false) ctx ~want loc name args = traps a read through a released region. That is the Odin contract: free is a thing you write, and writing it twice is yours to not do. *) | "free" -> - arity ctx loc name 1 args; + (match args with + | [ _ ] | [ _; _ ] -> () + | _ -> fail loc "free is (free v), or (free s allocator) for a slice"); let target = check_target ctx (List.hd args) in refuse_const_change ctx loc target; + (match target.Tast.ty, args with + | (Types.Vec _ | Types.Map _), [ _; _ ] -> + fail loc + "a %s knows the allocator it came from, so free takes only the \ + container. Write (free %s)" + (Types.to_string target.Tast.ty) (spell_arg "v" (List.hd args)) + | _ -> ()); (* A container of owning elements is refused here, and a reader will assume the opposite — that [free] recurses — so this says why it does not and what does. @@ -9274,11 +9284,41 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (rt loc Types.Unit "flan_map_free" [ target; size_of loc k; size_of loc v; here loc ]) + (* A slice (bytes s) or (clone xs) answered: its block goes back to the + allocator it came from, which a slice does not carry — so it is the + context allocator, as Odin's delete defaults to, or the one named. A + dev build checks the block against the allocation registry and traps + on a slice that is not the start of a block, or on the wrong + allocator, instead of handing one allocator another's block. *) + | Types.Slice (Types.Const, _) -> + fail loc + "%s can only be read, so it cannot be freed. Free the [%s] it was \ + copied into" + (Types.to_string target.Tast.ty) + (match target.Tast.ty with + | Types.Slice (_, e) -> Types.to_string e + | t -> Types.to_string t) + (* A view written right here — (slice ...) or (slice-from-ptr ...) — + is storage something else owns, known without running anything. *) + | Types.Slice (Types.Mut, _) + when (match (List.hd args).Ast.e with + | Ast.Call ({ Ast.e = Ast.Var ("slice" | "slice-from-ptr"); _ }, _) -> + true + | _ -> false) -> + fail loc + "this is a view of storage something else owns, so it cannot be \ + freed. Only a slice (bytes s) or (clone xs) made can be" + | Types.Slice (Types.Mut, elem) -> + let a = allocator_arg ctx loc (List.tl args) in + expect ctx loc ~want + (rt loc Types.Unit "flan_slice_free" + [ target; size_of loc elem; align_of loc elem; a; here loc ]) | other -> (* A field is never freed on its own: it would leave its owner partly dead with no way to say so. *) fail loc - "free takes an owning container — a Vec or a Map — found %s" + "free takes a Vec, a Map, or a slice (bytes s) or (clone xs) made — \ + found %s" (Types.to_string other)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) @@ -10070,12 +10110,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = let int k = mk loc index_ty (Tast.Int (k, Types.I32)) in (* [hi] is wanted twice only when it is the implicit length of something whose length is not static. *) + (* An array literal is also given a slot, so that what the slice views + lives for the whole function in both backends: the x86 backend + otherwise holds it in an expression temporary, reclaimed as soon as + the slice has been made, and a later temporary — (clone ...)'s own, + say — was written over it. *) let needs_slot = - List.length bounds < 2 - && (match ty with Types.Array _ -> false | _ -> true) - && (match target.Tast.e with - | Tast.Local _ | Tast.Global _ -> false - | _ -> true) + (match ty, target.Tast.e with + | Types.Array _, Tast.Arr _ -> true + | _ -> false) + || List.length bounds < 2 + && (match ty with Types.Array _ -> false | _ -> true) + && (match target.Tast.e with + | Tast.Local _ | Tast.Global _ -> false + | _ -> true) in let slot = if needs_slot then Some (fresh_slot ctx ty) else None in let src () = match slot with @@ -10146,10 +10194,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = and a reader who sees it has already been told where the promise comes from. - **It owns nothing.** The result is a [Types.Slice], which carries no - allocator and is the same non-owning view (slice v) answers — so - [free] refuses it by the rule it already had ("free takes an owning - container"). *) + **It owns nothing.** The result is a [Types.Slice], the same non-owning + view (slice v) answers; (free s) on it is the program's error, which a + dev build's registry traps as a slice no allocator handed out. *) | "slice-from-ptr" -> arity ctx loc name 2 args; (match args with @@ -11867,14 +11914,16 @@ let builtins : (string * string * string) list = "Makes room for n more. For a map the number is entries rather than \ slots — the block is sized so that n still sits under the load \ factor."); - ("free", "free [(Vec T)|(Map K V)] ()", + ("free", "free [(Vec T)|(Map K V)|[T] Allocator?] ()", "Releases the container's block. It does not recurse into elements that \ own storage — such a container is refused here, and releasing its \ - region with free-all is the answer."); + region with free-all is the answer. A slice (bytes s) or (clone xs) \ + made goes back to the current allocator, or the one named; a dev build \ + traps on a slice from another allocator or not from one at all."); ("clone", "clone [(Vec T)|(Map K V)|[T] Allocator?] (Vec T)|(Map K V)|[T]", "A deep, independent copy, from the current allocator or one named. \ - A slice's copy is a slice over a new block, which lives until its \ - allocator's free-all or destroy. Refused for elements that own \ + A slice's copy is a slice over a new block, released by (free s) or by \ + its allocator's free-all. Refused for elements that own \ storage: a bytewise copy would alias the original's blocks under a \ name promising otherwise."); @@ -11982,8 +12031,8 @@ let builtins : (string * string * string) list = ("bytes", "bytes [string Allocator?] [u8]", "A writable copy of the string's bytes, from the current allocator or \ one named. It allocates like vec-new does — a failure signals \ - StorageExhausted with retry — and the block lives until its \ - allocator's free-all or destroy. For reading without a copy, \ + StorageExhausted with retry — and (free b) releases it, through the \ + current allocator or (free b a) through the one it came from. For reading without a copy, \ bytes-view."); ("bytes-view", "bytes-view [string] [const u8]", "The string's own storage seen as a read-only byte slice. It costs \ diff --git a/lib/emit.ml b/lib/emit.ml index edd3773a..afb5de69 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4913,6 +4913,7 @@ declare ptr @flan_context_allocator() declare ptr @flan_context_use(ptr, i64) declare void @flan_context_value(ptr) declare void @flan_free_temp() +declare void @flan_slice_free(ptr, i64, i64, i64, ptr, ptr, i64) declare i8 @flan_i64_temp(i64, ptr) declare i8 @flan_f64_temp(double, ptr) declare void @flan_alloc_seal(ptr, ptr) diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..39769663 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1213,6 +1213,10 @@ typedef struct { int64_t seq; /* when it was made */ int64_t died; /* when it was released, or 0 while it is live */ uint64_t gen; /* this slot's own seqlock; odd while it is written */ + /* The allocator the block came from, where the note knew it — a Vec's, or + * the temp arena's — and NULL where it did not. (free s) on a slice asks + * it, so a block is never handed to an allocator it did not come from. */ + const void *owner; } flan_reg_entry; /* ── Why this table has a seqlock and the watch table's is the model ─── @@ -1505,6 +1509,7 @@ static void flan_reg_compact(void) { e->type = old[i].type; e->typelen = old[i].typelen; e->base = old[i].base; e->bytes = old[i].bytes; e->elem = old[i].elem; e->seq = old[i].seq; e->died = old[i].died; + e->owner = old[i].owner; flan_reg_end(e); flan_reg_used++; break; @@ -1518,8 +1523,18 @@ static void flan_reg_compact(void) { /* One note per allocation. [base] replaces whatever was recorded there, live * or dead: the allocator handing out an address is the event that makes any * older answer about it wrong. */ +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner); + void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen) { + flan_dev_reg_note_owned(base, bytes, elem, type, typelen, NULL); +} + +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner) { uintptr_t a = (uintptr_t)base; size_t s; int64_t probe; @@ -1549,6 +1564,7 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, flan_reg[j].elem = elem; flan_reg[j].seq = ++flan_reg_seq; flan_reg[j].died = 0; + flan_reg[j].owner = owner; flan_reg_end(&flan_reg[j]); return; } @@ -1575,6 +1591,24 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, int flan_dev_reg_overflowed(void) { return flan_reg_full; } +/* (free s) on a slice, asked before the block is handed back: 0 when it may + * go to [owner] — or when the registry cannot say, because this is not a dev + * build, the table is full, or the note did not know the allocator — 1 when + * [p] is not the start of a block any allocator handed out, 2 when the block + * came from another allocator, 3 when it was already released. */ +static flan_reg_entry *flan_reg_find(uintptr_t a); + +int32_t flan_dev_reg_owner_check(const void *p, const void *owner) { + flan_reg_entry *e; + if (!flan_reg_on) return 0; + e = flan_reg_find((uintptr_t)p); + if (e == NULL) return flan_reg_full ? 0 : 1; + if (e->base != (uintptr_t)p) return 1; + if (e->died != 0) return 3; + if (e->owner != NULL && e->owner != owner) return 2; + return 0; +} + /* The block containing [a], live or dead, or NULL. A linear scan, because the * reader is a person pressing a key and the writer is a game loop: the cost * belongs on this side of the table. */ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index a02103e8..df531bde 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1677,6 +1677,10 @@ static int flan_over_budget(flan_allocator *a, int64_t size) { */ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen); +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner); +int32_t flan_dev_reg_owner_check(const void *p, const void *owner); void flan_dev_reg_dead(void *base); void flan_dev_reg_dead_range(void *base, int64_t bytes); /* flan_dev.c: a dev build fills a block a resize moved away from, so that a @@ -2481,7 +2485,7 @@ static int8_t flan_temp_text(flan_render render, const void *x, if (!q) return 0; memcpy(q, buf, (size_t)len); } - flan_dev_reg_note(q, len, 1, "u8", 2); + flan_dev_reg_note_owned(q, len, 1, "u8", 2, a); out->ptr = q; out->len = len; return 1; @@ -2733,6 +2737,38 @@ int8_t flan_bytes_dup(flan_vec *v, flan_allocator *a, const uint8_t *p, return 1; } +/* (free s) on a slice (bytes s) or (clone xs) made: the block goes back to + * [a], the allocator the compiler passes — the context's, or the one named. + * The slice carries no allocator, so a dev build checks the registry first and + * traps on a slice that is not the start of a live block, or on a block from + * another allocator; a release build trusts the program, as Odin's delete + * does. An allocator that cannot free one block keeps it, as flan_vec_free + * does: free-all is how its region is released. */ +_Noreturn static void flan_slice_free_fail(const uint8_t *loc, int64_t loclen, + int32_t why) { + rt_flush_out(); + fprintf(stderr, "%.*s: %s\n", (int)loclen, (const char *)loc, + why == 2 ? "this slice's block came from another allocator — free it " + "through the allocator it was made with, (free s a)" + : why == 3 ? "this slice's block was already freed" + : "this slice is not a block an allocator handed out — " + "only a slice (bytes s) or (clone xs) made can be freed"); + rt_trap((const uint8_t *)"BadFree", 7); +} + +void flan_slice_free(const void *p, int64_t n, int64_t size, int64_t align, + flan_allocator *a, const uint8_t *loc, int64_t loclen) { + int32_t why; + int64_t bytes; + if (p == NULL || n <= 0) return; + if (!a) flan_null_alloc_fail(loc, loclen); + why = flan_dev_reg_owner_check(p, a); + if (why != 0) flan_slice_free_fail(loc, loclen, why); + if (!(a->caps & FLAN_CAN_FREE)) return; + if (!flan_mul_bytes(n, size, &bytes)) return; + a->proc(a, FLAN_ALLOC_FREE, (void *)p, bytes, 0, align); +} + int8_t flan_vec_clone(flan_vec *dst, flan_vec *src, flan_allocator *a, int64_t size, int64_t align, const uint8_t *loc, int64_t loclen) { @@ -3662,7 +3698,8 @@ int8_t flan_map_clone(flan_map *dst, flan_map *src, flan_allocator *a, void flan_dev_reg_note_vec(flan_vec *v, int64_t size, const char *type, int64_t typelen) { - if (v) flan_dev_reg_note(v->ptr, v->cap * size, size, type, typelen); + if (v) flan_dev_reg_note_owned(v->ptr, v->cap * size, size, type, typelen, + v->alloc); } void flan_dev_reg_note_map(flan_map *m, int64_t ksize, int64_t vsize, diff --git a/test/programs/bytes-copy.flan b/test/programs/bytes-copy.flan index 8084f2a5..d198c27b 100644 --- a/test/programs/bytes-copy.flan +++ b/test/programs/bytes-copy.flan @@ -14,13 +14,17 @@ b (bytes s)] (set (at b 0) \Z) (println (string b)) ; ZNSERTIONSORT - (println s)) ; INSERTIONSORT + (println s) ; INSERTIONSORT + ;; The copy's block came from the context allocator, and free hands it + ;; back there — which is what keeps this program leak-free. + (free b)) ;; 2. A literal's copy is writable — the exact form that used to segfault ;; at -O0 and silently do nothing at -O2. (let [b (bytes "hi")] (set (at b 0) \H) - (println (string b))) ; Hi + (println (string b)) ; Hi + (free b)) ;; 3. The view still costs nothing and reads the string's own storage. (let [v (bytes-view "abc")] @@ -35,4 +39,10 @@ (println (string b))) ; arenA (free-all frame) (arena-destroy frame) + + ;; 5. (clone xs) with no allocator is the context's too, and free releases + ;; it the same way. + (let [c (clone (slice [1 2 3]))] + (println (at c 2)) ; 3 + (free c)) 0) diff --git a/test/programs/free-slice.flan b/test/programs/free-slice.flan new file mode 100644 index 00000000..580e0fa1 --- /dev/null +++ b/test/programs/free-slice.flan @@ -0,0 +1,26 @@ +;;;; (free s) on a slice hands its block back to the context allocator, or to +;;;; the one named. A slice does not carry its allocator, so a dev build checks +;;;; the block against the allocation registry and traps rather than hand one +;;;; allocator another's block. Argument 0 frees correctly both ways; 1 frees +;;;; an arena's copy through the context allocator; 2 frees one copy twice; +;;;; 3 frees a view of an array, which no allocator handed out. +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0) + a (arena-new 4096)] + (cond + (= which 1) (let [b (bytes "arena" a)] (free b)) + (= which 2) (let [b (bytes "twice")] (free b) (free b)) + (= which 3) (let [arr [1 2 3] + s (slice arr)] + (free s)) + :else + (let [b (bytes "heap") + c (bytes "arena" a) + d (clone (slice [1.5 2.5]) (heap-allocator))] + (println (string b) (string c) (at d 1)) + (free b) + (free c a) + (free d (heap-allocator)))) + (println "done") + (arena-destroy a)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 19a2ae4a..468381ca 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -881,7 +881,7 @@ let () = *by* build shape (trap at -O0, silent no-op at -O2) and the copy must not. *) let bytes_copy_out = - "ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n" + "ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n3\n" in outputs "bytes copies, bytes-view aliases" "programs/bytes-copy.flan" bytes_copy_out; @@ -889,6 +889,35 @@ let () = "programs/bytes-copy.flan" bytes_copy_out; outputs ~x86:true "bytes copies, bytes-view aliases, --x86" "programs/bytes-copy.flan" bytes_copy_out; + (* (free s) on a slice: through the context allocator and through a named + one, every backend; and in a dev build, the registry's three refusals — + another allocator's block, a block freed twice, a view no allocator + handed out. *) + let fs = "programs/free-slice.flan" in + outputs "free on a slice" fs "heap arena 2.5\ndone\n"; + outputs ~opt:"-O0" "free on a slice, -O0" fs "heap arena 2.5\ndone\n"; + outputs ~x86:true "free on a slice, --x86" fs "heap arena 2.5\ndone\n"; + List.iter + (fun (x86, tag) -> + let exe = compile ~x86 ~dev:true fs in + List.iter + (fun (arg, line, want) -> + let code, text = run exe (Some arg) in + if code <> 134 + || not (contains text + (Printf.sprintf "programs/free-slice.flan:%d:" line)) + || not (contains text want) || contains text "done" + then begin + incr failures; + Printf.printf + "FAIL a dev build refuses a bad free of a slice, argument \ + %s%s\n got: %S (exit %d)\n" arg tag text code + end) + [ ("1", 11, "came from another allocator"); + ("2", 12, "was already freed"); + ("3", 15, "not a block an allocator handed out") ]; + (try Sys.remove exe with Sys_error _ -> ())) + [ (false, ", dev"); (true, ", dev --x86") ]; (* The other half of the same ruling: a store through a bytes-view is refused before anything is built, because bytes-view answers a [const u8]. It used to compile and trap at -O0 on both backends, and be diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..b7599ca7 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2508,12 +2508,14 @@ let () = rejects_check "slice-from-ptr with a negative literal length" "(defn f [p (Ptr i32)] i32 (length (slice-from-ptr p -1)))" ~needle:"is negative"; - (* The storage stays C's. A slice carries no allocator, so free refuses one - by the rule it already had — this pins that the new form did not become - a thing anybody could hand to free. *) + (* The storage stays C's, and a view made in place is refused at free + without running anything. *) rejects_check "free of a slice made from a pointer" "(defn f [p (Ptr i32)] () (free (slice-from-ptr p 3)))" - ~needle:"free takes an owning container"; + ~needle:"is a view of storage something else owns"; + rejects_check "free of a slice written in place" + "(defn f [v (Vec i32)] () (free (slice v)))" + ~needle:"is a view of storage something else owns"; (* ── Structs, fields and auto-deref ────────────────────────────── *) let cursor = "(defstruct Cursor [src [u8] pos i32]) " in diff --git a/web/index.html b/web/index.html index 7d1df1ee..862104c5 100644 --- a/web/index.html +++ b/web/index.html @@ -842,8 +842,10 @@ is allocated. (bytes-view s) is the string's own storage seen as a [const u8] and costs nothing; it aliases the string, and a store through it is a compile error. (bytes s) and (bytes s allocator) make a writable copy through the allocator — never a -hidden malloc, which is the rule every allocating operation follows. The -example above wants a view and takes one.

+hidden malloc, which is the rule every allocating operation follows. +(free b) hands the copy back to the current allocator and +(free b allocator) to the one named. The example above wants a view and +takes one.

An enum is an i32 at run time and its own type in the checker. A keyword at a call site resolves against the parameter's enum type at compile time, so a