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