diff --git a/lib/check.ml b/lib/check.ml index 4509a319..154861e2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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)))) diff --git a/lib/emit.ml b/lib/emit.ml index 71ebb48e..9678f4f6 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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() diff --git a/lib/shim.ml b/lib/shim.ml index 9ad96ca5..d6086d75 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -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\ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 6b91f76c..d9fc7584 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -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); } diff --git a/test/programs/context-destroyed.flan b/test/programs/context-destroyed.flan new file mode 100644 index 00000000..65de8c53 --- /dev/null +++ b/test/programs/context-destroyed.flan @@ -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) diff --git a/test/programs/shim-nul-end.flan b/test/programs/shim-nul-end.flan new file mode 100644 index 00000000..621e82d0 --- /dev/null +++ b/test/programs/shim-nul-end.flan @@ -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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 0ba5a81b..7a9d66a7 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -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"; diff --git a/test/test_flan.ml b/test/test_flan.ml index ae8b871c..43215913 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -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";