From 74c648902049480e3b413cb3fa2de78ea0063b37 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:55:18 +0700 Subject: [PATCH] Allocator is a builtin opaque type, so the arena needs nothing from milestone 5 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit spec-memory.md defines an allocator as a procedure plus an opaque data pointer, which reads as a function value, which check.ml refuses four ways. None of the four is anywhere near this: `Allocator` is a `Types.t` case with no user-writable constructor, the way `string` is a builtin ptr+len, its procedure is a C symbol the emitter names, and every operation is an ordinary named call that `check_call` already routes through `named_call`. The one thing that really does need milestone 5 is a *user-written* allocator — it wants a defn's name in value position — and that is refused by name with that reason rather than left to come back as an unknown function. An `Allocator` value is a pointer to the runtime's struct and 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 copy would give each its own epoch and the dev trap would never fire. Two decisions the spec left to be made here, both announced in BUILT.md: `free-all` is retain-capacity — offset = 0, the pages stay — and handing the pages back is `arena-destroy`, a separate operation. Zig's reset takes a mode; Odin's arena_free_all is already retain-capacity in effect. Taking the mode would have grown the operation table the spec froze at four. The epoch is bumped either way, because the pages being the same does not make a container made before the reset valid. `context/allocator` and `context/temp` are dynamic variables with save and restore, not extra parameters. The spec calls the allocator part of the calling convention; the literal reading touches every signature, the FFI shim, the dev trampolines and the reload ABI for the same observable behaviour. `with-allocator` is its own IR node rather than a let and two calls, because the restore has to happen on the transfer path too. A body that errors leaves through the landing pad, and a context allocator left pointing into a region nobody outside the body has heard of would be wrong in the break loop, which is exactly where something is about to allocate to render a condition. The acceptance program asserts that path by taking a restart out of a body. The backend grew one prim, `Rt of string`: a call into the runtime's C named by symbol, with argument and result types read off the expression nodes. The container runtime is type-erased and therefore *is* a list of C entry points, so one arm covers all of them rather than one arm each. --- lib/check.ml | 132 +++++++++++++ lib/emit.ml | 87 ++++++++ lib/parse.ml | 2 +- lib/reach.ml | 1 + lib/render.ml | 4 + lib/tast.ml | 15 ++ lib/types.ml | 13 +- runtime/flan_rt.c | 294 ++++++++++++++++++++++++++++ test/programs/allocators.flan | 68 +++++++ test/programs/free-all-refused.flan | 1 + test/programs/user-allocator.flan | 1 + test/test_acceptance.ml | 38 ++++ 12 files changed, 654 insertions(+), 2 deletions(-) create mode 100644 test/programs/allocators.flan create mode 100644 test/programs/free-all-refused.flan create mode 100644 test/programs/user-allocator.flan diff --git a/lib/check.ml b/lib/check.ml index e85f043..4c36d82 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -264,6 +264,10 @@ and resolve_name env ~seen loc n = | "string" -> Types.String | "Unit" -> Types.Unit | "Never" -> Types.Never + (* A builtin opaque type, the way [string] is a builtin ptr+len. There is + no user-writable constructor and no way to name its procedure: see + Types, and NEXT.md's "the escape is real". *) + | "Allocator" -> Types.Alloc | _ when Hashtbl.mem env.aliases n -> if List.mem n seen then fail loc "the type alias %s is defined in terms of itself" n @@ -321,6 +325,13 @@ let mk loc ty e : Tast.expr = { Tast.e; ty; loc } let unit_at loc = mk loc Types.Unit Tast.Unit +(* A source location as a value, for a runtime trap that has to name the site + rather than the runtime. The bounds and slice traps get theirs from [Emit], + which renders the [Loc.t] it is already carrying; a trap reached through a + plain runtime call has no such carrier, so the string is built here and + crosses as ptr+len like any other. *) +let here loc = mk loc Types.String (Tast.Str (Loc.to_string loc)) + (* Every integer index into an array or slice is i32 at milestone 2. *) let index_ty = Types.Int Types.I32 @@ -561,6 +572,17 @@ and var ctx loc ~want name = fail loc "nothing here says what None is an Option of — annotate the \ function's return type or the binding") + (* spec-memory.md puts the allocator in the calling convention as + [context/allocator] and [context/temp]. They read as names rather than + calls because that is how the spec writes them, and they are dynamic + variables at run time rather than extra parameters — see BUILT.md for why + the literal reading of "calling convention" is deferred. *) + | "context/allocator" -> + expect loc ~want + (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_allocator", []))) + | "context/temp" -> + expect loc ~want + (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_temp", []))) | _ -> match lookup ctx name with | Some b -> expect loc ~want (mk loc b.bty (Tast.Local b.slot)) @@ -1237,6 +1259,116 @@ and named_call ctx ~want loc name args = fail loc "destructure~nth is written by the compiler and cannot be called") + (* ── allocators, spec-memory.md ────────────────────────────────── *) + (* Every one of these is an ordinary named call, which is the whole of the + escape NEXT.md describes: [check_call] already routes a named call through + here, so none of the four function-value refusals is anywhere near it. *) + (* A *user-written* allocator is the one thing in this tier that does need + milestone 5, and it is refused by name rather than left as an unknown + one. "Here is my proc, make an Allocator from it" needs a defn's name in + value position, which is the refusal a few hundred lines below this. The + built-in set needs nothing from milestone 5 because its procedures are C + symbols the emitter names and no Flan type mentions them. *) + | "make-allocator" | "allocator-from" | "allocator" -> + fail loc + "a user-written allocator is not implemented yet — milestone 5. It needs \ + a defn's name in value position, which is a function value; the \ + built-in allocators (heap-allocator, arena-new) need none of that \ + because their procedures are runtime symbols and no Flan type names \ + them" + | "heap-allocator" -> + arity loc name 0 args; + expect loc ~want + (mk loc Types.Alloc (Tast.Prim (Tast.Rt "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 + reach on purpose. *) + | "arena-new" -> + arity loc name 1 args; + let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in + expect loc ~want + (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ]))) + (* Hands the pages back, which [free-all] deliberately does not — see + BUILT.md, "free-all is retain-capacity". *) + | "arena-destroy" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect 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 + as a string so that an allocator with no region to release names the site + rather than the runtime. *) + | "free-all" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect loc ~want + (mk loc Types.Unit + (Tast.Prim (Tast.Rt "flan_alloc_free_all", [ a; here loc ]))) + (* The capability set, read off the allocator value. Odin asks its procedure + (Query_Features returning an Allocator_Mode_Set); a field is the same + answer without the round trip, which is NEXT.md's call. *) + | "can-free?" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect loc ~want + (mk loc Types.Bool + (Tast.Prim (Tast.Ne, + [ mk loc (Types.Int Types.I8) + (Tast.Prim (Tast.Rt "flan_alloc_can_free", [ a ])); + mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) + | "can-free-all?" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect loc ~want + (mk loc Types.Bool + (Tast.Prim (Tast.Ne, + [ mk loc (Types.Int Types.I8) + (Tast.Prim (Tast.Rt "flan_alloc_can_free_all", [ a ])); + mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) + (* The counter [free-all] bumps. A container records it and traps if it + moved; this is the same number, readable, so a program can say what it + saw. *) + | "alloc-epoch" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect loc ~want + (mk loc (Types.Int Types.I64) + (Tast.Prim (Tast.Rt "flan_alloc_epoch", [ a ]))) + (* "Did you forget to free" is an allocator-tier question and this is the + tier answering it — spec-memory.md, "Leaking is defined behaviour". *) + | "alloc-live-blocks" -> + arity loc name 1 args; + let a = check ctx ~want:Types.Alloc (List.hd args) in + expect loc ~want + (mk loc (Types.Int Types.I64) + (Tast.Prim (Tast.Rt "flan_alloc_live_blocks", [ a ]))) + (* (with-allocator A BODY...). It rebinds and releases nothing: not at the + end of the body, not anywhere. spec-memory.md is explicit that this is not + a scope-end release point and that it is the point on which Odin's + [defer delete] and Carp's scope-end frees were both rejected. *) + | "with-allocator" -> + (match args with + | [] -> fail loc "with-allocator is (with-allocator allocator body ...)" + | a :: body -> + let a = check ctx ~want:Types.Alloc a in + let body, ty = + scoped ctx (fun () -> + match body with + | [] -> [ unit_at loc ], Types.Unit + | _ -> + let rec go = function + | [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty + | e :: rest -> + let e = check ctx e in + let rest, ty = go rest in + e :: rest, ty + | [] -> assert false + in + go body) + in + expect loc ~want (mk loc ty (Tast.WithAlloc (a, body)))) + (* ── containers ────────────────────────────────────────────────── *) | "len" -> arity loc name 1 args; diff --git a/lib/emit.ml b/lib/emit.ml index 44f2dd7..829869f 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -93,6 +93,9 @@ 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" | Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e) | Types.Map _ | Types.Fn _ | Types.Var _ -> (* The checker rejects each of these by name — nothing reaches here. *) @@ -229,6 +232,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 (* [n x T] adds no padding of its own: T's size already carries its tail. *) | Types.Array (n, e) -> let s, a = lay m e in Int64.to_int n * s, a | Types.Option e -> let s, a, _ = lay_fields m [ Types.Int Types.I8; e ] in s, a @@ -344,6 +348,12 @@ let rec dty m d (t : Types.t) : int = (List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty)) st.Tast.fields) | None -> failwith ("no debug type for struct " ^ 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. *) + | Types.Alloc -> + dnode d + "!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)" | Types.Map _ | Types.Fn _ | Types.Var _ -> failwith ("no debug type for " ^ Types.to_string t) in @@ -635,6 +645,7 @@ and value_at f (e : Tast.expr) : string = "zeroinitializer" | Tast.Handled (frames, body) -> emit_handled f frames body | Tast.RestartCase (clauses, body) -> emit_restart_case f e.Tast.ty clauses body + | Tast.WithAlloc (a, body) -> emit_with_alloc f e.Tast.ty a body (* §4's lookup, then the transfer itself: the frame that was found goes into the channel and this function leaves through its landing block. Type Never, so nothing follows. *) @@ -898,6 +909,45 @@ and emit_handled f frames body = if not reached then begin f.live <- false; "zeroinitializer" end else begin label f ld; "zeroinitializer" end +(* (with-allocator A BODY...) — spec-memory.md's "Allocators". + + Save, run, restore, and *restore again at the pad*. The second restore is + the whole reason this is a node rather than a let and two calls: a body that + errors, or one a handler transfers out of, leaves through [current_pad], and + a context allocator left pointing into a region nobody outside the body has + heard of would be wrong in the break loop, which is exactly where someone is + about to allocate to render a condition. + + It releases nothing, per the spec: the region this names is released, if + ever, by an explicit [free-all] somewhere else. *) +and emit_with_alloc f ty (a : Tast.expr) body = + let av = value f a in + let prev = fresh f in + ins f "%s = call ptr @flan_context_set(ptr %s)" prev av; + let result = if is_void ty then None else Some (alloca f ty) in + let ld = fresh_label f "endwith" in + let pad = fresh_label f "wxfer" and used = ref false in + let reached = ref false in + f.pads <- (pad, used) :: f.pads; + let v = block f body in + f.pads <- List.tl f.pads; + if f.live then begin + ins f "call void @flan_context_restore(ptr %s)" prev; + (match result with + | Some r -> ins f "store %s %s, ptr %s" (ll ty) v r + | None -> ()); + reached := true; + term f "br label %%%s" ld + end; + label f pad; + ins f "call void @flan_context_restore(ptr %s)" prev; + term f "br label %%%s" (current_pad f); + if not !reached then begin f.live <- false; "zeroinitializer" end + else begin + label f ld; + match result with Some r -> load f r ty | None -> "zeroinitializer" + end + (* (restart-case BODY (name [] BODY-1) ...) — §3, §4 and §6 together. One frame per clause, so that the frame a transfer names says which clause @@ -1247,6 +1297,31 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = let tmp = alloca f (Types.Slice Types.String) in ins f "call void @flan_argv(ptr %s)" tmp; load f tmp (Types.Slice Types.String) + (* 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. *) + | Tast.Rt sym, args -> + let vs = + List.concat + (map_lr + (fun (a : Tast.expr) -> + match a.Tast.ty with + | Types.String | Types.Slice _ -> + let p, n = explode f a in + [ "ptr " ^ p; "i64 " ^ n ] + | Types.Unit | Types.Never -> [] + | t -> [ ll t ^ " " ^ value f a ]) + args) + in + let args' = String.concat ", " vs in + if is_void e.Tast.ty then begin + ins f "call void @%s(%s)" sym args'; + "zeroinitializer" + end else begin + let t = fresh f in + ins f "%s = call %s @%s(%s)" t (ll e.Tast.ty) sym args'; + t + end | Tast.Cast target, [ x ] -> cast f x target | _ -> failwith "malformed primitive" @@ -1568,6 +1643,18 @@ declare void @flan_restart_fail(ptr, i64, ptr, i64) noreturn cold declare void @flan_transfer_fail(ptr, i64) noreturn cold declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold +declare ptr @flan_context_allocator() +declare ptr @flan_context_temp() +declare ptr @flan_heap_allocator() +declare ptr @flan_context_set(ptr) +declare void @flan_context_restore(ptr) +declare ptr @flan_arena_new(i64) +declare void @flan_arena_destroy(ptr) +declare void @flan_alloc_free_all(ptr, ptr, i64) +declare i8 @flan_alloc_can_free(ptr) +declare i8 @flan_alloc_can_free_all(ptr) +declare i64 @flan_alloc_epoch(ptr) +declare i64 @flan_alloc_live_blocks(ptr) |} (* C's main, adapting to whichever of the four shapes Flan's main has: argv and diff --git a/lib/parse.ml b/lib/parse.ml index ef25878..ecab736 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -332,7 +332,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = [find-restart] and [compute-restarts] are §4's two ways to look at the restart stack without committing to one. *) | "find-restart" | "compute-restarts" - | "errdefer" | "with-allocator" | "loop" | "recur" + | "errdefer" | "loop" | "recur" (* plan.org's loop story is settled as imperative while/for with these two and [return]. Neither exists, and both *alter control flow* — the first thing the house rule says must be recognised explicitly. diff --git a/lib/reach.ml b/lib/reach.ml index 8520616..03f9969 100644 --- a/lib/reach.ml +++ b/lib/reach.ml @@ -64,6 +64,7 @@ let rec expr_refs f (e : Tast.expr) = | Tast.RestartCase (cs, body) -> List.iter (fun (c : Tast.rclause) -> gos c.Tast.rbody) cs; go body + | Tast.WithAlloc (a, body) -> go a; gos body and place_refs f (p : Tast.place) = match p with diff --git a/lib/render.ml b/lib/render.ml index 034a64b..67793d0 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -110,6 +110,10 @@ let rec render c depth (e : Tast.expr) : Tast.expr list = thing that could make this walk cycle, and dereferencing one a REPL was handed is not a safe thing to do on someone's behalf. *) | Types.Ptr _ -> [ lit "" ] + (* Opaque on purpose, and for the same reason: its contents are the + runtime's, its address is not stable across runs, and printing either + would make an acceptance test's output depend on the heap. *) + | Types.Alloc -> [ lit "" ] | Types.Option t -> let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I8; loc } in let some = { Tast.e = Tast.Field (e, 1); ty = t; loc } in diff --git a/lib/tast.ml b/lib/tast.ml index 0e17f01..eec1597 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -36,6 +36,15 @@ type prim = string nested inside a printed structure. *) | U64ToBytes | EscapeBytes | WriteStdout | Exit | Argv + (* A call into the runtime's C, named by symbol. The argument and result + LLVM types come off the expression nodes themselves, so one constructor + covers every entry point the allocator and container runtime has and the + backend grows one arm rather than one per operation — which matters + because spec-memory.md's runtime is type-erased and therefore *is* a list + of C entry points. A string or slice argument crosses as ptr+len, the + same rule as every other shim here. No transfer guard follows one: a + transfer cannot cross a C frame. *) + | Rt of string | Cast of Types.t type expr = { e : expr_kind; ty : Types.t; loc : Loc.t } @@ -83,6 +92,12 @@ and expr_kind = frame it found into the transfer channel and leaves — it has type Never, so nothing follows it. *) | RestartCase of rclause list * expr + (* (with-allocator A BODY...) — spec-memory.md. It rebinds the current + allocator for its dynamic extent and releases nothing. Its own node + because the restore has to happen on the *transfer* path too: a body that + errors, or a restart taken from inside it, must not leave the context + allocator pointing at a region the handler knows nothing about. *) + | WithAlloc of expr * expr list | InvokeRestart of int * string * Loc.t (* name id, name, where *) (* [Serror] is §2's diverging variant: the same lookup, type Never, and with diff --git a/lib/types.ml b/lib/types.ml index ef1ef27..80fa637 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -30,6 +30,15 @@ type t = | Array of int64 * t (* [n T] inline, a value, copies *) | Map of t * t (* {K V} *) | Ptr of t (* (Ptr T) *) + (* [Allocator]: a builtin opaque type, the way [string] is a builtin + ptr+len. It is a [Types.t] case with no user-writable constructor, which + is what lets spec-memory.md's "procedure plus an opaque data pointer" be + expressed with none of milestone 5's function values — the procedure is a + C symbol the emitter names and no Flan type ever mentions it. At run time + it is a pointer to the runtime's [flan_allocator], never a copy of one: + the capability set and the epoch have to be shared by every container + made from it, and a copy would give each its own. *) + | Alloc | Option of t (* (Option T) *) | Fn of t list * t (* (Fn [T ...] R) *) | Var of string (* a type variable — milestone 5 *) @@ -55,7 +64,7 @@ let fkind_of_name = function near-miss can be reported as the typo it is. *) let primitive_names = [ "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "u64"; - "f32"; "f64"; "bool"; "string"; "Unit"; "Never" ] + "f32"; "f64"; "bool"; "string"; "Unit"; "Never"; "Allocator" ] let ikind_name k = (if signed k then "i" else "u") ^ string_of_int (bits k) @@ -75,6 +84,7 @@ let rec equal a b = | Array (n, x), Array (m, y) -> Int64.equal n m && equal x y | Map (k, v), Map (k', v') -> equal k k' && equal v v' | Ptr x, Ptr y -> equal x y + | Alloc, Alloc -> true | Option x, Option y -> equal x y | Fn (ps, r), Fn (ps', r') -> List.length ps = List.length ps' @@ -95,6 +105,7 @@ let rec to_string = function | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) | Map (k, v) -> Printf.sprintf "{%s %s}" (to_string k) (to_string v) | Ptr t -> "(Ptr " ^ to_string t ^ ")" + | Alloc -> "Allocator" | Option t -> "(Option " ^ to_string t ^ ")" | Fn (ps, r) -> Printf.sprintf "(Fn [%s] %s)" diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index c649104..d5e5d80 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -420,3 +420,297 @@ _Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen, (long long)len); rt_die(); } + +/* ── Allocators, spec-memory.md ──────────────────────────────────────── + * + * One type-erased procedure plus an opaque data pointer, which is Odin's + * shape (base/runtime/core.odin, Allocator_Proc), and every operation takes + * 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. + * 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 + * allocator has to observe. A copied-by-value allocator would give each copy + * its own epoch and the dev trap would never fire. + * + * Nothing here returns a struct by value, per the file header. + */ + +enum { + FLAN_ALLOC_ALLOC = 0, + FLAN_ALLOC_RESIZE = 1, + FLAN_ALLOC_FREE = 2, + FLAN_ALLOC_FREE_ALL = 3 +}; + +/* The capability set. Odin reads its own back through the procedure + * (Query_Features returning an Allocator_Mode_Set); a field is the same + * information without the round trip, and `can-free` is the one that is + * load-bearing — spec-memory.md refuses a drop-carrying container against an + * allocator that lacks it. */ +enum { + FLAN_CAN_ALLOC = 1u << 0, + FLAN_CAN_RESIZE = 1u << 1, + FLAN_CAN_FREE = 1u << 2, + FLAN_CAN_FREE_ALL = 1u << 3 +}; + +typedef struct flan_allocator flan_allocator; + +/* Returns NULL on failure and never reports failure any other way. The + * condition, the restart and the message are all the compiler's job; this + * layer says yes or no. */ +typedef void *(*flan_alloc_proc)(flan_allocator *a, int32_t mode, void *p, + int64_t old_size, int64_t size, int64_t align); + +struct flan_allocator { + flan_alloc_proc proc; + void *data; + uint32_t caps; + /* Bumped on every free-all. A container records it and traps if it moved: + * spec-memory.md, "Dev builds detect a released region". Separate from the + * per-Vec generation word, which answers a different question. */ + uint64_t epoch; + /* Dev accounting for the general-purpose tier: "did you forget to free" is + * an allocator-tier question and this is the allocator's answer. */ + int64_t live_blocks; + int64_t live_bytes; +}; + +/* -- The heap allocator: malloc, realloc, free. ---------------------- */ + +static void *flan_heap_proc(flan_allocator *a, int32_t mode, void *p, + int64_t old_size, int64_t size, int64_t align) { + switch (mode) { + case FLAN_ALLOC_ALLOC: { + void *q = NULL; + size_t al, sz; + if (size <= 0) return NULL; + al = (size_t)(align < (int64_t)sizeof(void *) ? (int64_t)sizeof(void *) : align); + sz = (size_t)size; + /* aligned_alloc requires a size that is a multiple of the alignment. */ + if (sz % al) sz += al - (sz % al); + q = aligned_alloc(al, sz); + if (q) { a->live_blocks++; a->live_bytes += size; } + return q; + } + case FLAN_ALLOC_RESIZE: { + /* aligned_alloc has no realloc, so growth is a new block and a copy. The + * caller passes old_size for exactly this reason, and it is the one + * number a wrong answer here would read off the end of. */ + void *q = flan_heap_proc(a, FLAN_ALLOC_ALLOC, NULL, 0, size, align); + if (!q) return NULL; + if (p && old_size > 0) + memcpy(q, p, (size_t)(old_size < size ? old_size : size)); + if (p) { free(p); a->live_blocks--; a->live_bytes -= old_size; } + return q; + } + case FLAN_ALLOC_FREE: + if (p) { free(p); a->live_blocks--; a->live_bytes -= old_size; } + return NULL; + case FLAN_ALLOC_FREE_ALL: + default: + return NULL; + } +} + +static flan_allocator flan_heap = { + flan_heap_proc, NULL, + FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE, + 0, 0, 0 +}; + +/* -- The arena: one fixed backing buffer and a bump offset. ---------- + * + * `free-all` is retain-capacity: offset = 0, the pages stay. That is an + * announced amendment to spec-memory.md's operation table (see BUILT.md) and + * it is what Odin's arena_free_all already does in effect. Handing the pages + * back is `arena-destroy`, a separate operation, because a frame arena reset + * every frame must not return memory only to ask for it again. + * + * The epoch is bumped either way: the pages are the same but every container + * made before the reset is invalid, which is the whole point of the trap. */ + +typedef struct flan_arena { + uint8_t *base; + int64_t cap; + int64_t offset; + int64_t peak; +} flan_arena; + +static int64_t flan_align_up(int64_t x, int64_t a) { + if (a <= 1) return x; + return (x + a - 1) / a * a; +} + +static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, + int64_t old_size, int64_t size, int64_t align) { + flan_arena *ar = (flan_arena *)a->data; + switch (mode) { + case FLAN_ALLOC_ALLOC: { + int64_t start, end; + if (size <= 0) return NULL; + if (align < 1) align = 1; + start = flan_align_up(ar->offset, align); + end = start + size; + if (end > ar->cap || end < start) return NULL; /* exhausted, or overflow */ + ar->offset = end; + if (end > ar->peak) ar->peak = end; + a->live_blocks++; + a->live_bytes += size; + return ar->base + start; + } + case FLAN_ALLOC_RESIZE: { + void *q; + /* Growing the most recent block in place is the one case worth special + * casing: a Vec that is the only thing pushing into a frame arena grows + * without copying, which is the common shape. */ + if (p && (uint8_t *)p + old_size == ar->base + ar->offset) { + int64_t end = (int64_t)((uint8_t *)p - ar->base) + size; + if (end > ar->cap || end < 0) return NULL; + ar->offset = end; + if (end > ar->peak) ar->peak = end; + a->live_bytes += size - old_size; + return p; + } + q = flan_arena_proc(a, FLAN_ALLOC_ALLOC, NULL, 0, size, align); + if (!q) return NULL; + if (p && old_size > 0) + memcpy(q, p, (size_t)(old_size < size ? old_size : size)); + return q; /* the old block is not reclaimable */ + } + case FLAN_ALLOC_FREE: + return NULL; /* refused by the capability set above */ + case FLAN_ALLOC_FREE_ALL: + ar->offset = 0; + a->live_blocks = 0; + a->live_bytes = 0; + return NULL; + default: + return NULL; + } +} + +/* -- The context, spec-memory.md's context/allocator and context/temp ---- + * + * A dynamic variable with save and restore, not an extra parameter on every + * signature. The spec calls it part of the calling convention; taking that + * literally would touch every function signature, the FFI shim, the dev + * trampolines and the reload ABI, for the same observable behaviour. The + * literal reading is deferred and BUILT.md says so. + * + * There are no threads in Flan, so a plain global is the whole of it. */ + +static flan_allocator *flan_ctx_alloc = &flan_heap; +static flan_allocator *flan_ctx_tmp = NULL; + +flan_allocator *flan_arena_new(int64_t cap); + +flan_allocator *flan_context_allocator(void) { return flan_ctx_alloc; } + +/* The default temp arena, made on first use. 1 MiB: big enough that the + * per-frame tier does not fail on a toy program, small enough that a program + * which never touches it has not paid for a heap. */ +#define FLAN_TEMP_DEFAULT (1 << 20) + +flan_allocator *flan_context_temp(void) { + if (!flan_ctx_tmp) flan_ctx_tmp = flan_arena_new(FLAN_TEMP_DEFAULT); + return flan_ctx_tmp; +} + +/* Returns the previous one, which is what with-allocator restores — on the + * normal path and on the transfer path both. */ +flan_allocator *flan_context_set(flan_allocator *a) { + flan_allocator *prev = flan_ctx_alloc; + if (a) flan_ctx_alloc = a; + return prev; +} + +void flan_context_restore(flan_allocator *a) { + if (a) flan_ctx_alloc = a; +} + +flan_allocator *flan_arena_new(int64_t cap) { + flan_allocator *a; + flan_arena *ar; + if (cap <= 0) cap = FLAN_TEMP_DEFAULT; + a = (flan_allocator *)calloc(1, sizeof *a); + ar = (flan_arena *)calloc(1, sizeof *ar); + if (!a || !ar) { free(a); free(ar); return NULL; } + ar->base = (uint8_t *)malloc((size_t)cap); + if (!ar->base) { free(a); free(ar); return NULL; } + ar->cap = cap; + a->proc = flan_arena_proc; + a->data = ar; + /* No FLAN_CAN_FREE: an arena cannot release one block, which is Odin's + * answer too (allocators.odin returns Mode_Not_Implemented for .Free). */ + a->caps = FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE_ALL; + return a; +} + +void flan_arena_destroy(flan_allocator *a) { + flan_arena *ar; + if (!a || a->proc != flan_arena_proc) return; + ar = (flan_arena *)a->data; + if (a == flan_ctx_alloc) flan_ctx_alloc = &flan_heap; + if (a == flan_ctx_tmp) flan_ctx_tmp = NULL; + a->epoch++; + free(ar->base); + free(ar); + free(a); +} + +flan_allocator *flan_heap_allocator(void) { return &flan_heap; } + +int8_t flan_alloc_can_free(flan_allocator *a) { + return (int8_t)(a && (a->caps & FLAN_CAN_FREE) ? 1 : 0); +} + +int8_t flan_alloc_can_free_all(flan_allocator *a) { + return (int8_t)(a && (a->caps & FLAN_CAN_FREE_ALL) ? 1 : 0); +} + +int64_t flan_alloc_epoch(flan_allocator *a) { + return a ? (int64_t)a->epoch : 0; +} + +int64_t flan_alloc_live_blocks(flan_allocator *a) { + return a ? a->live_blocks : 0; +} + +_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen); +_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen); + +/* free-all on an allocator that does not offer it is a trap, not a silent + * no-op: "I released the region" and "I leaked the region" must not be the + * same program text. */ +void flan_alloc_free_all(flan_allocator *a, const uint8_t *loc, int64_t loclen) { + /* A null allocator is a zeroed [defvar] nobody assigned yet. Silently doing + * nothing would make "I released the region" and "I never made one" the same + * program text, which is the thing this trap exists to prevent. */ + if (!a) flan_null_alloc_fail(loc, loclen); + if (!(a->caps & FLAN_CAN_FREE_ALL)) flan_free_all_fail(loc, loclen); + a->proc(a, FLAN_ALLOC_FREE_ALL, NULL, 0, 0, 0); + a->epoch++; +} + +_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) { + fflush(stdout); + fprintf(stderr, + "%.*s: this allocator is null — a zeroed Allocator was never given " + "one\n", + (int)loclen, (const char *)loc); + rt_die(); +} + +_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) { + fflush(stdout); + fprintf(stderr, + "%.*s: this allocator does not offer free-all — it has no region to " + "release, and releasing nothing is not the same as releasing " + "everything\n", + (int)loclen, (const char *)loc); + rt_die(); +} diff --git a/test/programs/allocators.flan b/test/programs/allocators.flan new file mode 100644 index 0000000..5ac0dc8 --- /dev/null +++ b/test/programs/allocators.flan @@ -0,0 +1,68 @@ +;;;; Allocators — spec-memory.md, "Allocators". No container here: this is the +;;;; tier on its own, so that a failure in it is not read as a Vec bug. +;;;; +;;;; What is asserted: the capability set is readable at run time and differs +;;;; per allocator; with-allocator rebinds for its dynamic extent and restores +;;;; afterwards, including out of a call and out of a transfer; free-all is +;;;; retain-capacity and bumps the epoch anyway; and nothing is released at +;;;; scope exit, which is the point the spec is most emphatic about. + +;; A zeroed Allocator. A global rather than a local because the arena has to +;; outlive the frame that makes it, and because a handler cannot see a local +;; (check.ml's `captured` says so by name). +(defvar frame Allocator) + +;;; The context is a dynamic variable, so a function called from inside a +;;; with-allocator body sees the rebinding without anything being passed. +(defn who-am-i [] bool + (can-free? context/allocator)) + +(defn main [] i32 + ;; The heap allocator frees one block; an arena does not. That is Odin's + ;; answer too — its arena returns Mode_Not_Implemented for .Free — and it is + ;; the capability spec-memory.md calls load-bearing. + (set frame (arena-new 1024)) + (println (can-free? (heap-allocator))) ; true + (println (can-free? frame)) ; false + (println (can-free-all? (heap-allocator))) ; false + (println (can-free-all? frame)) ; true + + ;; The default context is the heap allocator, and context/temp is its own + ;; arena — the per-frame tier, distinct from it. + (println (can-free? context/allocator)) ; true + (println (can-free? context/temp)) ; false + + ;; with-allocator rebinds for the dynamic extent, so a call made from inside + ;; the body sees the arena, and the binding is gone after the body. + (println (with-allocator frame (who-am-i))) ; false + (println (who-am-i)) ; true + + ;; ... and it is an expression: the body's last value is the form's value. + (println (with-allocator frame 41)) ; 41 + + ;; free-all is retain-capacity: the pages stay, the epoch moves. Both halves + ;; matter — the first is what makes a per-frame reset free, and the second is + ;; what a container's dev trap reads. + (println (alloc-epoch frame)) ; 0 + (free-all frame) + (println (alloc-epoch frame)) ; 1 + (free-all frame) + (println (alloc-epoch frame)) ; 2 + + ;; Nothing is released at scope exit — not at the end of a let, not at the + ;; end of a with-allocator body. The epoch is the observable proof: leaving + ;; the body did not release the region it named. + (let [before (alloc-epoch frame)] + (with-allocator frame (println (alloc-epoch frame))) ; 2 + (println (= before (alloc-epoch frame)))) ; true + + ;; And out of a transfer. The restart-case's clause runs after the body has + ;; left through the pad, so the context allocator here is the one the + ;; with-allocator displaced, not the arena. + (println + (restart-case + (with-allocator frame (invoke-restart 'resync)) + (resync [] (can-free? context/allocator)))) ; true + + (arena-destroy frame) + 0) diff --git a/test/programs/free-all-refused.flan b/test/programs/free-all-refused.flan new file mode 100644 index 0000000..873fcf9 --- /dev/null +++ b/test/programs/free-all-refused.flan @@ -0,0 +1 @@ +(defn main [] i32 (free-all (heap-allocator)) 0) diff --git a/test/programs/user-allocator.flan b/test/programs/user-allocator.flan new file mode 100644 index 0000000..2876d18 --- /dev/null +++ b/test/programs/user-allocator.flan @@ -0,0 +1 @@ +(defn main [] i32 (println (make-allocator 1)) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 05b46a2..eadcd5a 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -261,6 +261,38 @@ let () = outputs "restarts" "programs/restarts.flan" restarts_out; outputs ~opt:"-O0" "restarts, -O0" "programs/restarts.flan" restarts_out; outputs ~dev:true "restarts, dev" "programs/restarts.flan" restarts_out; + (* Allocators, spec-memory.md. The tier on its own, with no container + above it, so that a failure here is not read as a Vec bug. What is + asserted is the capability set differing per allocator, the context + rebinding for a dynamic extent and restoring — out of a call and out of + a *transfer* — and free-all moving the epoch while keeping the pages. + At -O0 as well, because with-allocator's restore on the transfer path is + control flow an optimiser would otherwise launder, and as a dev build, + because the call inside the body then goes through a cell. *) + let allocators_out = + "true\nfalse\nfalse\ntrue\ntrue\nfalse\nfalse\ntrue\n41\n0\n1\n2\n2\ntrue\ntrue\n" + in + outputs "allocators" "programs/allocators.flan" allocators_out; + outputs ~opt:"-O0" "allocators, -O0" "programs/allocators.flan" allocators_out; + outputs ~dev:true "allocators, dev" "programs/allocators.flan" allocators_out; + (* free-all on an allocator that does not offer it traps rather than doing + nothing, because "I released the region" and "I leaked the region" must + not be the same program text. Its own case for the same reason the + bounds traps are: a trap has no result, only an exit and a message. *) + let exe = compile "programs/free-all-refused.flan" in + let code, text = run exe None in + if code <> 134 + || not (contains text "programs/free-all-refused.flan:") + || not (contains text "does not offer free-all") + then begin + incr failures; + Printf.printf + "FAIL free-all on an allocator without it\n\ + \ got: %S (exit %d)\n wanted: exit 134, naming the site\n" + text code + end; + (try Sys.remove exe with Sys_error _ -> ()); + (* §2's other half, which cannot be an [outputs] case because it does not exit 0: a handler runs, returns normally, and has still not answered the error, so the program stops and names the condition. *) @@ -694,6 +726,12 @@ let () = and this row is what says so. *) refuses "nth is not a name" "programs/nth-gone.flan" "unknown function nth"; + (* The one thing in the allocator tier that really does need milestone 5, + refused by name and with the reason rather than as an unknown function. + NEXT.md's escape is that the *built-in* set needs nothing from milestone + 5; this row is the other half of that claim. *) + refuses "a user-written allocator" "programs/user-allocator.flan" + "a defn's name in value position"; (* ── wasm32 (NEXT.md, deferred item 6) ────────────────────────────── The second target, and the reason sand-headless imports no raylib. What