JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Only a string the checker marks as a literal reaches C uncopied, a slice of dyn is refused at its clone, and the context allocator holds an incarnation so a restored context whose arena was destroyed traps

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 12:55:18 +07:00
parent acec25f8a1
commit 59a0fc80de
8 changed files with 244 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
lib/check.ml
View File

@ -950,6 +950,33 @@ let rec owning env ?(seen = []) (t : Types.t) =
(owning_fields env n)
| _ -> false
(* Does a value of this type hold a dyn anywhere — through a field, a case, an
element or a view? Asked where the program is still being checked, so it
reads the environment's tables rather than a finished program. *)
let rec holds_dyn env ?(seen = []) (t : Types.t) =
match t with
| Types.Dyn -> true
| Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Slice e
| Types.Ptr e -> holds_dyn env ~seen e
| Types.Map (k, v) -> holds_dyn env ~seen k || holds_dyn env ~seen v
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
let fields (fs : Tast.field list) =
List.exists (fun (f : Tast.field) -> holds_dyn env ~seen f.Tast.fty) fs
in
(match Hashtbl.find_opt env.structs n with
| Some s -> fields s.Tast.fields
| None ->
match Hashtbl.find_opt env.unions n with
| Some u -> fields u.Tast.fields
| None ->
match Hashtbl.find_opt env.datas n with
| Some d ->
List.exists (fun (c : Tast.variant) -> fields c.Tast.vfields)
d.Tast.cases
| None -> false)
| _ -> false
(* Does a container of this type have to be built against an allocator that
cannot free one block? Only the half a release would have to walk is asked:
a map's key cannot own anything — [map_type] refuses one, because a key that
@ -2366,24 +2393,33 @@ let use_alloc ctx loc (v : Tast.expr) =
(* 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,
and the wrapper hands a string whose last byte is NUL to C as it is
([Shim.cstr_helpers]). The one reader of the argument is C, which stops at
the NUL, so the longer length changes nothing it sees.
literal's bytes, and here — the one place that knows the argument is a
literal — it is passed with its length encoded as -(n+1) by
[flan_c_literal]. No other Flan string has a negative length, so the
wrapper can tell ([Shim.cstr_helpers]); a string that merely ends in a NUL
is still copied and refused.
The callee is a declare-c when it binds the shim's symbol for its own name —
directly, or through the flattened [-c] declaration the shim puts under a
Flan wrapper when the signature has a struct in it. The literal passes
through that wrapper untouched, because its body only forwards it. *)
let c_literals env name (params : Types.t list) (args : Tast.expr list) =
Flan wrapper. The encoded value passes through that wrapper untouched,
because its body only forwards it. *)
let c_literals ctx name (params : Types.t list) (args : Tast.expr list) =
let sym = Shim.shim_symbol name in
let bound n = Hashtbl.find_opt env.externs n = Some sym in
let bound n = Hashtbl.find_opt ctx.env.externs n = Some sym in
if not (bound name || bound (Shim.raw_name name)) then args
else
List.map2
(fun (p : Types.t) (a : Tast.expr) ->
match p, a.Tast.e with
| Types.String, Tast.Str s -> { a with Tast.e = Tast.Str (s ^ "\000") }
| Types.String, Tast.Str _ ->
let loc = a.Tast.loc in
let s = fresh_slot ctx Types.String in
mk loc Types.String
(Tast.Let
([ (s, mk loc Types.String (Tast.Zero Types.String)) ],
[ rt loc Types.Unit "flan_c_literal"
[ a; addr_of loc (mk loc Types.String (Tast.Local s)) ];
mk loc Types.String (Tast.Local s) ]))
| _ -> a)
params args
@ -4204,7 +4240,13 @@ and var ctx ?(qualified = false) loc ~want name =
the literal reading of "calling convention" is deferred. *)
| "context/allocator" ->
expect ctx loc ~want
(seal_alloc ctx loc (rt loc raw_alloc "flan_context_allocator" []))
(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_context_value"
[ addr_of loc (mk loc Types.Alloc (Tast.Local s)) ];
mk loc Types.Alloc (Tast.Local s) ])))
| "context/temp" ->
expect ctx loc ~want
(seal_alloc ctx loc (rt loc raw_alloc "flan_context_temp" []))
@ -7212,7 +7254,7 @@ 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 raw_alloc "flan_context_allocator" []
| [] -> rt loc raw_alloc "flan_context_use" [ here loc ]
| [ a ] -> alloc_value ctx loc a
| _ -> fail loc "at most one allocator may be named here"
@ -7908,7 +7950,22 @@ 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 = alloc_value ctx loc a in
(* Two values in this frame, handed to the runtime by address: the one
to install, checked here so a stale one traps at this site, and the
room for the one it displaces, so the restore puts that back with
its incarnation (flan_rt.c, flan_context_set). *)
let a =
let pair = Types.Array (2L, Types.Alloc) in
let s = fresh_slot ctx pair in
let first = addr_of loc (mk loc pair (Tast.Local s)) in
mk loc raw_alloc
(Tast.Let
([ (s, mk loc pair
(Tast.Arr [ check ctx ~want:Types.Alloc a;
mk loc Types.Alloc (Tast.Zero Types.Alloc) ])) ],
[ rt loc raw_alloc "flan_alloc_use" [ first; here loc ];
addr_of loc (mk loc pair (Tast.Local s)) ]))
in
let body, ty =
scoped ctx (fun () ->
match body with
@ -8159,6 +8216,14 @@ and named_call ?(qualified = false) ctx ~want loc name args =
can walk one to copy what it owns. Build a container and insert \
into it"
(Types.to_string target.Tast.ty)
(* The copy is a block from an allocator, which the collector does not
walk, so a dyn in it would be a root nothing marks. *)
| Types.Slice elem when holds_dyn ctx.env elem ->
fail loc
"%s cannot be cloned — its elements hold a dyn, and the copy would \
live in allocator storage the collector does not look in. Build \
a dyn vector from the elements instead"
(Types.to_string target.Tast.ty)
| Types.Slice elem ->
expect ctx loc ~want (dup_elems ctx loc elem target a)
(* A map's clone reinserts rather than copying the block, because the
@ -9528,7 +9593,7 @@ and ordinary_call ctx ~want loc name args =
let args =
map2_lr (fun p a -> incr i; check_arg ctx name !i p a) params args
in
let args = c_literals ctx.env name params args in
let args = c_literals ctx name params args in
(match Hashtbl.find_opt ctx.env.tracks name with
| Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args)
| None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args))))

3
lib/emit.ml
View File

@ -4429,6 +4429,7 @@ declare void @flan_f64_to_bytes(double, ptr, ptr)
declare void @flan_i64_to_bytes(i64, ptr, ptr)
declare void @flan_u64_to_bytes(i64, ptr, ptr)
declare void @flan_escape_bytes(ptr, i64, ptr)
declare void @flan_c_literal(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(i32, ptr, ptr)
@ -4455,6 +4456,8 @@ declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold
; something answered.
declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_use(ptr, i64)
declare void @flan_context_value(ptr)
declare void @flan_alloc_seal(ptr, ptr)
declare ptr @flan_alloc_use(ptr, ptr, i64)
declare ptr @flan_context_temp()

23
lib/shim.ml
View File

@ -314,22 +314,25 @@ let header =
act on a value nobody wrote. The refusal is the runtime's — the shim has no
condition channel — and it names the declare-c it came from.
The one NUL that is not refused is a last byte: a string ending in one goes
to C as it is, uncopied, and C reads exactly the bytes before it. That is
how a literal crosses without a copy — both backends write a NUL after a
literal's bytes, and the checker passes a literal argument of a declare-c
with its length counting that NUL ([Check.c_literals]). *)
A literal is the one string that crosses uncopied. Both backends write a
NUL after a literal's bytes, and at a declare-c call whose argument is a
literal the checker passes it with its length encoded as -(n+1)
([Check.c_literals]). No other Flan string has a negative length, so the
wrapper hands such a pointer to C as it is, after the same embedded-NUL
refusal. Every other string is copied, whatever its last byte is. *)
let cstr_helpers =
"_Noreturn void flan_shim_nul_fail(const char *site);\n\n\
static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap,\n\
\ const char *site) {\n\
\ size_t len = n <= 0 ? 0 : (size_t)n;\n\
\ size_t len;\n\
\ char *d = buf;\n\
\ const char *z = len != 0 ? (const char *)memchr(p, '\\0', len) : NULL;\n\
\ if (z != NULL) {\n\
\ if (z == p + len - 1) return (char *)p; /* already a C string */\n\
\ flan_shim_nul_fail(site);\n\
\ if (n < 0) { /* a literal, NUL-terminated by the compiler */\n\
\ len = (size_t)(-(n + 1));\n\
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
\ return (char *)p;\n\
\ }\n\
\ len = (size_t)n;\n\
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
\ if (len + 1 > cap) {\n\
\ d = (char *)malloc(len + 1);\n\
\ if (d == NULL) { d = buf; len = cap - 1; } /* out of memory: truncate */\n\

78
runtime/flan_rt.c
View File

@ -407,6 +407,15 @@ void flan_u64_to_bytes(uint64_t x, uint8_t *buf, flan_slice *out) {
out->len = fit(n);
}
/* A string literal on its way to a declare-c wrapper: the same pointer, with
* the length encoded as -(n+1). No other Flan string has a negative length, so
* the wrapper knows the bytes are the compiler's NUL-terminated constant and
* hands them to C uncopied (lib/shim.ml, flan_shim_cstr). */
void flan_c_literal(const uint8_t *p, int64_t n, flan_slice *out) {
out->ptr = p;
out->len = -(n + 1);
}
/* The escape table itself: what one byte reads as inside a quoted string,
* written into [out] and returning how many bytes that took. Never more than
* four, which is what every caller's headroom is sized from.
@ -1516,14 +1525,38 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p,
* trampolines and the reload ABI, for the same observable behaviour. The
* literal reading is deferred and docs/BUILT.md says so.
*
* There are no threads in Flan, so a plain global is the whole of it. */
* There are no threads in Flan, so a plain global is the whole of it.
*
* It holds an Allocator *value*, the record and its incarnation, and not the
* bare record: with-allocator restores what it displaced, and what it displaced
* may be an arena destroyed in the meantime whose record a later arena-new
* took. Holding the incarnation is what lets the next use of the context trap
* rather than allocate from that other arena. */
static flan_allocator *flan_ctx_alloc = &flan_heap;
static flan_alloc_value flan_ctx = { &flan_heap, 0 };
static flan_allocator *flan_ctx_tmp = NULL;
flan_allocator *flan_arena_new(int64_t cap);
_Noreturn static void flan_destroyed_fail(const uint8_t *loc, int64_t loclen);
flan_allocator *flan_context_allocator(void) { return flan_ctx_alloc; }
/* The context's record, for the runtime's own callers: a zeroed container
* adopting the context on its first operation. Checked like any use. */
flan_allocator *flan_context_allocator(void) {
if (flan_ctx.rec && flan_ctx.rec->incarnation != flan_ctx.inc)
flan_destroyed_fail((const uint8_t *)"context/allocator", 17);
return flan_ctx.rec;
}
/* The same, for an operation the compiler emitted, which names its site. */
flan_allocator *flan_context_use(const uint8_t *loc, int64_t loclen) {
if (flan_ctx.rec && flan_ctx.rec->incarnation != flan_ctx.inc)
flan_destroyed_fail(loc, loclen);
return flan_ctx.rec;
}
/* context/allocator as a value: the one the context holds, incarnation and
* all, so a value read from the context goes stale with it. */
void flan_context_value(flan_alloc_value *out) { *out = flan_ctx; }
/* 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
@ -1535,16 +1568,19 @@ flan_allocator *flan_context_temp(void) {
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;
/* with-allocator hands in two values in its own frame: [0] the one to install
* and [1] where the displaced one is kept. It gets the same pointer back and
* passes it to restore — on the normal path and on the transfer path both —
* so a displaced value is restored with its incarnation. A null record in [0]
* is a zeroed Allocator and leaves the context as it was. */
flan_alloc_value *flan_context_set(flan_alloc_value *v) {
v[1] = flan_ctx;
if (v[0].rec) flan_ctx = v[0];
return v;
}
void flan_context_restore(flan_allocator *a) {
if (a) flan_ctx_alloc = a;
void flan_context_restore(flan_alloc_value *v) {
if (v) flan_ctx = v[1];
}
/* Allocator headers [flan_arena_destroy] retired, linked through [data]. See
@ -1621,7 +1657,7 @@ 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.rec) { flan_ctx.rec = &flan_heap; flan_ctx.inc = 0; }
if (a == flan_ctx_tmp) flan_ctx_tmp = NULL;
a->epoch++;
flan_dev_reg_dead_range(ar->base, ar->cap);
@ -1657,17 +1693,19 @@ void flan_alloc_seal(flan_allocator *a, flan_alloc_value *out) {
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);
}
if (a && a->incarnation != v->inc) flan_destroyed_fail(loc, loclen);
return a;
}
_Noreturn static void flan_destroyed_fail(const uint8_t *loc, int64_t loclen) {
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);
}
int8_t flan_alloc_can_free(flan_allocator *a) {
return (int8_t)(a && (a->caps & FLAN_CAN_FREE) ? 1 : 0);
}

22
test/programs/context-destroyed.flan Normal file
View File

@ -0,0 +1,22 @@
;;;; The context allocator holds an Allocator value, incarnation and all. Here
;;;; the inner with-allocator destroys the arena the outer one installed, and
;;;; on the way out the outer one is put back; the next arena-new takes the
;;;; destroyed arena's record. Allocating from the context must then trap,
;;;; not quietly allocate from the new arena. Argument 1 reads context/allocator
;;;; as a value first and uses that instead, which traps the same way.
(defn main [args [string]] i32
(let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)
a (arena-new 4096)]
(with-allocator a
(let [held context/allocator]
(with-allocator (heap-allocator)
(arena-destroy a))
(let [b (arena-new 4096)
w (vec-new i32 b)]
(push w 5)
(println (at w 0))
(if (= which 1)
(let [v (vec-new i32 held)] (push v 1))
(let [v (vec-new i32)] (push v 1)))
(println "unreachable")))))
0)

17
test/programs/shim-nul-end.flan Normal file
View File

@ -0,0 +1,17 @@
;;;; A NUL as a string's last byte, handed to C. Only a literal crosses
;;;; uncopied, and only because the checker marks it at the call; a string that
;;;; merely ends in a NUL is copied like any other, and the NUL inside it is
;;;; refused. Each argument is one way to spell such a string, and each is
;;;; refused naming the call.
(declare-c c-puts [s string] i32 "puts")
(defn main [args [string]] i32
(let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)]
(println "before")
(cond
(= which 1) (let [s "ab\0"] (c-puts s))
(= which 2) (c-puts (string (slice (bytes-view "ab\0c") 0 3)))
(= which 3) (c-puts (string (bytes "q\0")))
:else (c-puts "ab\0"))
(println "unreachable"))
0)

48
test/test_acceptance.ml
View File

@ -908,6 +908,52 @@ let () =
clone_slice_out;
outputs ~x86:true "clone of a slice, --x86" "programs/clone-slice.flan"
clone_slice_out;
(* The context restored by with-allocator after its arena was destroyed and
its record reused: the next use of the context, or of a value read
from it, traps at its site. *)
List.iter
(fun (x86, opt, tag) ->
let exe = compile ~x86 ~opt "programs/context-destroyed.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/context-destroyed.flan:%d:" line))
|| not (contains text "destroyed by arena-destroy")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a restored context whose arena was destroyed, \
argument %s%s\n got: %S (exit %d)\n"
arg tag text code
end)
[ ("0", 20); ("1", 19) ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ];
(* A string ending in a NUL is refused however it is spelled — only a
literal the checker marked skips the copy, and its embedded NUL is
refused too. *)
List.iter
(fun (x86, opt, tag) ->
let exe = compile ~x86 ~opt "programs/shim-nul-end.flan" in
List.iter
(fun arg ->
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text "before")
|| not (contains text "c-puts: a string passed to C contains a NUL byte")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a string ending in NUL is refused at the C boundary, \
argument %s%s\n got: %S (exit %d)\n"
arg tag text code
end)
[ "0"; "1"; "2"; "3" ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ];
(* A slice taken before a push moved its Vec reads 0xDEADBEEF in a dev
build and the old value in a release one. *)
let poison = "programs/stale-slice-poison.flan" in
@ -4059,7 +4105,7 @@ level "1"
shim_case "declare-c: a returned string outlives the argument copies"
"(declare-c base [p string] string \"Base\")"
[ "const char *r = flan_shim_ret_keep(Base(a0), out_n);\n\
\ flan_shim_cstr_free(a0, a0_b);\n return r;\n" ];
\ flan_shim_cstr_free(a0, a0_b, a0_p);\n return r;\n" ];
shim_refuses "declare-c: a callback"
"(declare-c each [f (Fn [i32] ())] \"Each\")"
"a C callback is not implemented";

6
test/test_flan.ml
View File

@ -2895,6 +2895,12 @@ let () =
"(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (let [c (clone v)] (free c)))"
~needle:"cannot be cloned";
rejects_check "clone on a slice of dyn, at the clone"
"(defonce pair [2 dyn])\n(defn make [] [dyn] (clone (slice pair)))"
~needle:"[dyn] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of structs holding a dyn"
"(defstruct B [d dyn])\n(defn make [xs [B]] [B] (clone xs))"
~needle:"[B] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of owning elements"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"[(Vec i32)] cannot be cloned";