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

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,
+   literal's bytes, and here — the one place that knows the argument is a
-   and the wrapper hands a string whose last byte is NUL to C as it is
+   literal — it is passed with its length encoded as -(n+1) by
-   ([Shim.cstr_helpers]). The one reader of the argument is C, which stops at
+   [flan_c_literal]. No other Flan string has a negative length, so the
-   the NUL, so the longer length changes nothing it sees.
+   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
+   Flan wrapper. The encoded value passes through that wrapper untouched,
-   through that wrapper untouched, because its body only forwards it. *)
+   because its body only forwards it. *)
-let c_literals env name (params : Types.t list) (args : Tast.expr list) =
+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))))

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()

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
+   A literal is the one string that crosses uncopied. Both backends write a
-   to C as it is, uncopied, and C reads exactly the bytes before it. That is
+   NUL after a literal's bytes, and at a declare-c call whose argument is a
-   how a literal crosses without a copy — both backends write a NUL after a
+   literal the checker passes it with its length encoded as -(n+1)
-   literal's bytes, and the checker passes a literal argument of a declare-c
+   ([Check.c_literals]). No other Flan string has a negative length, so the
-   with its length counting that NUL ([Check.c_literals]). *)
+   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 (n < 0) {  /* a literal, NUL-terminated by the compiler */\n\
-  \  if (z != NULL) {\n\
+  \    len = (size_t)(-(n + 1));\n\
-  \    if (z == p + len - 1) return (char *)p;  /* already a C string */\n\
+  \    if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
-  \    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\

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
+/* with-allocator hands in two values in its own frame: [0] the one to install
- * normal path and on the transfer path both. */
+ * and [1] where the displaced one is kept. It gets the same pointer back and
-flan_allocator *flan_context_set(flan_allocator *a) {
+ * passes it to restore — on the normal path and on the transfer path both —
-  flan_allocator *prev = flan_ctx_alloc;
+ * so a displaced value is restored with its incarnation. A null record in [0]
-  if (a) flan_ctx_alloc = a;
+ * is a zeroed Allocator and leaves the context as it was. */
-  return prev;
+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) {
+void flan_context_restore(flan_alloc_value *v) {
-  if (a) flan_ctx_alloc = a;
+  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) {
+  if (a && a->incarnation != v->inc) flan_destroyed_fail(loc, 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);
-  }
   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);
 }

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)

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)

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";

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";