The temp allocator grows a block that outgrows its chunk, answers a formatted number with one bump allocation, poisons what a dev wipe releases, and is wiped after each expression run while parked

lib/check.ml

@@ -2477,16 +2477,12 @@ let align_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.AlignOf t, []
 let addr_of loc (e : Tast.expr) =
   mk loc (Types.Ptr e.Tast.ty) (Tast.Prim (Tast.AddrOf, [ e ]))
 
-(* ── Where a rendered number's bytes live ──────────────────────────────
+(* ── A frame slot for a rendered number ────────────────────────────────
 
-   The three number-to-text conversions used to answer a slice into one static
+   The printer and the prelude's number appends render a number into a
-   buffer in the runtime, shared by every call in the process, and nothing
+   buffer that is the caller's, one frame slot per call site, and write or
-   copied it: (print a) (print b) over two of them printed the second number
+   copy it out before the next; i64->bytes and f64->bytes elsewhere answer
-   twice. No crash and nothing for a sanitizer to find, because the read was
+   text in the temp allocator instead. The slot is allocated here rather than in either backend on purpose: a slot is a
-   inside a buffer that was perfectly alive — the wrong bytes, alive.
-
-   The buffer is now the caller's, one frame slot per call site, and it is
-   allocated here rather than in either backend on purpose: a slot is a
    function-lifetime frame location in both of them — an entry-block alloca in
    [Emit], a prologue-allocated offset in [X86] — where a backend temporary in
    [X86] is bump-allocated and reclaimed at the end of the expression that made
@@ -9767,13 +9763,9 @@ and named_call ?(qualified = false) ctx ~want loc name args =
         is read-only everywhere — so the result of (string b) can reach
         strictly fewer stores than b could.
 
-     The sharp edge left here is one of lifetime and no longer one of sharing:
+     The text i64->bytes and f64->bytes answer lives in the temp allocator
-     the slice that i64->bytes / f64->bytes / u64->bytes answer is a view into
+     until the next (free-temp); calling it a string does not copy it, so text
-     a frame slot belonging to *that call site* (see [to_bytes]), so two of
+     kept past the frame is cloned first. *)
-     them can be held at once and the text of one survives the making of the
-     next. What it does not survive is its frame — calling it a string does not
-     copy it, so storing one in a container or returning it hands back a view
-     of storage that has been reused. Copy the bytes for that. *)
   | "string" ->
     arity ctx loc name 1 args;
     prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ]
@@ -9783,30 +9775,51 @@ and named_call ?(qualified = false) ctx ~want loc name args =
   | "bytes->i64" ->
     arity ctx loc name 1 args;
     prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ]
-  (* The rendered text is copied out of the frame slot [to_bytes] renders into
+  (* The number's text in the temp allocator: flan_i64_temp and flan_f64_temp
-     and into the temp allocator, so the slice outlives the frame: a function
+     render it and bump-allocate the bytes there in one call, so the slice
-     may return one and a Vec may hold one, until the next (free-temp). A
+     outlives the frame — a function may return one and a Vec may hold one —
-     number drawn every frame is then reclaimed every frame rather than leaked
+     until the next (free-temp). A number drawn every frame is reclaimed every
-     from the context allocator; text kept longer is cloned.
+     frame; text kept longer is cloned. The number is bound before the guard's
+     loop, so a retry does not evaluate it twice.
 
-     The prelude is answered with the slot itself. Its callers — append-i64,
+     The prelude's calls — append-i64, append-f64, format-f64, gensym — are
-     append-f64, format-f64, gensym — each copy the bytes into a Vec before
+     answered with a frame slot instead ([to_bytes]): each copies the bytes
-     the next conversion, and a copy per call there would be an allocation
+     into a Vec before the next conversion, so the temp copy would be work
-     per number appended that nothing ever frees. *)
+     thrown away. *)
   | "f64->bytes" | "i64->bytes" ->
     arity ctx loc name 1 args;
-    let slot =
+    let f64 = name = "f64->bytes" in
-      if name = "f64->bytes" then
+    let nty = if f64 then Types.Float Types.F64 else Types.Int Types.I64 in
-        to_bytes ctx loc Tast.F64ToBytes
+    let x = check ctx ~want:nty (List.hd args) in
-          (check ctx ~want:(Types.Float Types.F64) (List.hd args))
+    let bslice = Types.Slice (Types.Int Types.U8) in
-      else
-        to_bytes ctx loc Tast.I64ToBytes
-          (check ctx ~want:(Types.Int Types.I64) (List.hd args))
-    in
     expect ctx loc ~want
-      (if String.equal loc.Loc.file Prelude.file then slot
+      (if String.equal loc.Loc.file Prelude.file then
-       else dup_elems ctx loc (Types.Int Types.U8) slot
+         to_bytes ctx loc (if f64 then Tast.F64ToBytes else Tast.I64ToBytes) x
-              (rt loc raw_alloc "flan_context_temp" []))
+       else
+         let xs = fresh_slot ctx nty and out = fresh_slot ctx bslice in
+         let attempt () =
+           rt loc (Types.Int Types.I8)
+             (if f64 then "flan_f64_temp" else "flan_i64_temp")
+             [ mk loc nty (Tast.Local xs);
+               addr_of loc (mk loc bslice (Tast.Local out)) ]
+         in
+         (* The guard — a retry restart around the attempt — is entered only
+            once a first attempt has failed, so the common case pays one call
+            and a compare. A failure then re-attempts under the guard exactly
+            as it would have. *)
+         let failed =
+           mk loc Types.Bool
+             (Tast.Prim (Tast.Eq,
+                         [ attempt ();
+                           mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
+         in
+         mk loc bslice
+           (Tast.Let
+              ([ (xs, x); (out, mk loc bslice (Tast.Zero bslice)) ],
+               [ mk loc Types.Unit
+                   (Tast.If (failed, alloc_guard ctx loc (attempt ()),
+                             unit_at loc));
+                 mk loc bslice (Tast.Local out) ])))
   | "write-stdout" ->
     arity ctx loc name 1 args;
     prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]

lib/emit.ml

@@ -4766,6 +4766,8 @@ declare ptr @flan_context_allocator()
 declare ptr @flan_context_use(ptr, i64)
 declare void @flan_context_value(ptr)
 declare void @flan_free_temp()
+declare i8 @flan_i64_temp(i64, ptr)
+declare i8 @flan_f64_temp(double, ptr)
 declare void @flan_alloc_seal(ptr, ptr)
 declare ptr @flan_alloc_use(ptr, ptr, i64)
 declare ptr @flan_context_temp()

runtime/flan_rt.c

@@ -1507,6 +1507,7 @@ static void flan_arena_drop_old(flan_arena *ar) {
     flan_chunk *c = ar->old;
     ar->old = c->next;
     flan_dev_reg_dead_range(c->base, c->cap);
+    flan_dev_poison(c->base, c->cap);
     free(c->base);
     free(c);
   }
@@ -1545,7 +1546,10 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p,
     /* 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) {
+    /* A growing arena whose block cannot hold the new size falls through to
+     * the copy below, whose allocation starts a bigger block. */
+    if (p && (uint8_t *)p + old_size == ar->base + ar->offset
+        && !(ar->grow && (int64_t)((uint8_t *)p - ar->base) + size > ar->cap)) {
       int64_t end = (int64_t)((uint8_t *)p - ar->base) + size;
       /* The budget is checked here as on every other path; a block grown in
        * place is still more live bytes. */
@@ -1585,6 +1589,10 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p,
        cheaper if the second could be skipped. */
     flan_arena_drop_old(ar);
     flan_dev_reg_dead_range(ar->base, ar->cap);
+    /* The temp arena's wipe, in a dev build, fills what was handed out with
+       the pattern a moved Vec's old buffer gets, so text kept past its frame
+       without a clone reads as garbage rather than as last frame's value. */
+    if (ar->grow) flan_dev_poison(ar->base, ar->offset);
     FLAN_VG_MAKE_MEM_UNDEFINED(ar->base, ar->cap);
     ar->offset = 0;
     a->live_blocks = 0;
@@ -1992,6 +2000,68 @@ int64_t flan_alloc_fail_bytes(void) { return flan_fail_bytes; }
 int64_t flan_alloc_fail_align(void) { return flan_fail_align; }
 int64_t flan_alloc_fail_id(void) { return flan_fail_id; }
 
+/* i64->bytes and f64->bytes: the number's text in the temp arena, answered
+ * through [out]. When the current block has FLAN_NUM_BYTES to spare and no
+ * budget is set, the number is rendered straight into it and the offset moved
+ * past what was written — no copy, no call through the arena procedure.
+ * Otherwise it is rendered on the stack and allocated through the procedure,
+ * which grows the block. 0 is a failed allocation, reported like any other for
+ * the compiler's StorageExhausted guard; the temp arena grows, so that is
+ * malloc itself failing. */
+typedef int (*flan_render)(const void *x, char *buf, size_t cap);
+
+static int render_i64(const void *x, char *buf, size_t cap) {
+  return snprintf(buf, cap, "%lld", (long long)*(const int64_t *)x);
+}
+
+static int render_f64(const void *x, char *buf, size_t cap) {
+  return flan_f64_format(*(const double *)x, buf, cap);
+}
+
+static int8_t flan_temp_text(flan_render render, const void *x,
+                             flan_slice *out) {
+  flan_allocator *a = flan_context_temp();
+  flan_arena *ar;
+  uint8_t *q;
+  int64_t len;
+  if (!a) {
+    flan_fail_bytes = FLAN_NUM_BYTES;
+    flan_fail_align = 1;
+    flan_fail_id = 0;
+    return 0;
+  }
+  ar = (flan_arena *)a->data;
+  if (a->budget <= 0 && ar->cap - ar->offset >= FLAN_NUM_BYTES) {
+    q = ar->base + ar->offset;
+    len = fit(render(x, (char *)q, FLAN_NUM_BYTES));
+    ar->offset += len;
+    if (ar->offset > ar->peak) ar->peak = ar->offset;
+    a->live_blocks++;
+    a->live_bytes += len;
+  } else {
+    char buf[FLAN_NUM_BYTES];
+    len = fit(render(x, buf, sizeof buf));
+    flan_fail_bytes = len;
+    flan_fail_align = 1;
+    flan_fail_id = (int64_t)(intptr_t)a;
+    q = (uint8_t *)a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, len, 1);
+    if (!q) return 0;
+    memcpy(q, buf, (size_t)len);
+  }
+  flan_dev_reg_note(q, len, 1, "u8", 2);
+  out->ptr = q;
+  out->len = len;
+  return 1;
+}
+
+int8_t flan_i64_temp(int64_t x, flan_slice *out) {
+  return flan_temp_text(render_i64, &x, out);
+}
+
+int8_t flan_f64_temp(double x, flan_slice *out) {
+  return flan_temp_text(render_f64, &x, out);
+}
+
 /* The allocator's identity, for the condition's :allocator field. The pointer
  * is the identity — the same thing the epoch hangs off. */
 int64_t flan_alloc_id(flan_allocator *a) { return (int64_t)(intptr_t)a; }

test/programs/temp-grow.flan

@@ -0,0 +1,20 @@
+;;;; The temp allocator grows instead of failing. A Vec in it that is the
+;;;; newest block and outgrows the current chunk is moved to a bigger one rather
+;;;; than refused, whether it was made under with-allocator or named directly.
+;;;;
+;;;; Then text kept past a (free-temp) without a clone: a dev build has filled
+;;;; the wiped bytes with 0xDEADBEEF, so its first byte reads 239 (0xEF); a
+;;;; release build leaves the old text, whose first byte is the digit 4 (52).
+(defn main [] i32
+  (with-allocator context/temp
+    (let [v (vec-new u8)]
+      (dotimes [i 3000000] (push v (u8 1)))
+      (println (length v))))
+  (let [w (vec-new u8 context/temp)]
+    (dotimes [i 3000000] (push w (u8 1)))
+    (println (length w)))
+  (free-temp)
+  (let [s (i64->bytes 42)]
+    (free-temp)
+    (println (at s 0)))
+  0)

test/test_acceptance.ml

@@ -1004,6 +1004,19 @@ let () =
       [ (false, "-O2", false, ""); (false, "-O0", false, ", -O0");
         (true, "-O2", false, ", --x86"); (false, "-O2", true, ", dev");
         (true, "-O2", true, ", dev --x86") ];
+    (* The temp arena's newest block outgrowing its chunk moves to a bigger
+       one, and a dev wipe poisons what it released. It reads stale memory on
+       purpose, so it stays out of the valgrind list. *)
+    let tg = "programs/temp-grow.flan" in
+    let tg_out d = "3000000\n3000000\n" ^ d ^ "\n" in
+    outputs "the temp allocator grows a Vec past its chunk" tg (tg_out "52");
+    outputs ~opt:"-O0" "the temp allocator grows a Vec past its chunk, -O0" tg
+      (tg_out "52");
+    outputs ~x86:true "the temp allocator grows a Vec past its chunk, --x86" tg
+      (tg_out "52");
+    outputs ~dev:true "a dev free-temp poisons the wiped text" tg (tg_out "239");
+    outputs ~dev:true ~x86:true "a dev free-temp poisons the wiped text, --x86"
+      tg (tg_out "239");
     (* A dev build's agent poll is a frame boundary and wipes the temp
        allocator itself: a loop that polls and never calls free-temp does not
        fill the registry. *)

test/test_dev.ml

@@ -979,6 +979,19 @@ let () =
         if Wire.string_field r "value" <> Some "23" then
           fail "C-x C-e while stopped: %s"
             (Option.value ~default:(status r) (Wire.string_field r "message"));
+        (* A parked expression's temp text is wiped when it finishes: the
+           second expression finds nothing live in context/temp, although the
+           first formatted a number into it. *)
+        ignore
+          (ask "(:op \"eval-expr\" :code \"(length (i64->bytes 12345))\" :file \"/tmp/buf.flan\")");
+        let r =
+          ask "(:op \"eval-expr\" :code \"(alloc-live-blocks context/temp)\" :file \"/tmp/buf.flan\")"
+        in
+        if Wire.string_field r "value" <> Some "0" then
+          fail "a parked expression's temp text was not wiped: %s"
+            (Option.value ~default:(status r)
+               (match Wire.string_field r "value" with
+                | Some v -> Some v | None -> Wire.string_field r "message"));
 
         (* And installing, which the break loop deliberately allows: there is
            no frame in progress, so the rule about swapping a body that is on

test/test_session.ml

@@ -1620,7 +1620,7 @@ let () =
    ignore (Session.eval t "(defn origin [] dyn (point 0 0))");
    match Session.eval t "(defclass point [x i64 y])" with
    | c ->
-     if not (has c.Session.ir "c\"x i64\\0Ay\"") then
+     if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then
        fail "a slot's new type did not reach the registration"
    | exception Loc.Error { Loc.dmsg = m; _ } ->
      fail "a slot's type changed under a compiled caller was refused: %s" m);

vendor/agent/flan_agent.c

@@ -1099,6 +1099,10 @@ int32_t flan_agent_poll(void) {
       eval_boundary = obound;
       restart_floor = outer;
       frame_floor = oframe;
+      /* An expression run while the program is parked has no frame boundary
+       * after it until the program resumes, so a dev build wipes the temp
+       * allocator when it finishes, as the top of the next poll would. */
+      if (atomic_load(&depth) > 0 && flan_dev_reg_enabled()) flan_free_temp();
     }
     if (j.handle != NULL) { dlclose(j.handle); }
   }