diff --git a/lib/check.ml b/lib/check.ml index 42031e60..c429184f 100644 --- a/lib/check.ml +++ b/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 - buffer in the runtime, shared by every call in the process, and nothing - copied it: (print a) (print b) over two of them printed the second number - twice. No crash and nothing for a sanitizer to find, because the read was - 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 + The printer and the prelude's number appends render a number into a + buffer that is the caller's, one frame slot per call site, and write or + copy it out before the next; i64->bytes and f64->bytes elsewhere answer + text in the temp allocator instead. The slot 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 slice that i64->bytes / f64->bytes / u64->bytes answer is a view into - a frame slot belonging to *that call site* (see [to_bytes]), so two of - 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. *) + The text i64->bytes and f64->bytes answer lives in the temp allocator + until the next (free-temp); calling it a string does not copy it, so text + kept past the frame is cloned first. *) | "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 - and into the temp allocator, so the slice outlives the frame: a function - may return one and a Vec may hold one, until the next (free-temp). A - number drawn every frame is then reclaimed every frame rather than leaked - from the context allocator; text kept longer is cloned. + (* The number's text in the temp allocator: flan_i64_temp and flan_f64_temp + render it and bump-allocate the bytes there in one call, so the slice + outlives the frame — a function may return one and a Vec may hold one — + until the next (free-temp). A number drawn every frame is reclaimed every + 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, - append-f64, format-f64, gensym — each copy the bytes into a Vec before - the next conversion, and a copy per call there would be an allocation - per number appended that nothing ever frees. *) + The prelude's calls — append-i64, append-f64, format-f64, gensym — are + answered with a frame slot instead ([to_bytes]): each copies the bytes + into a Vec before the next conversion, so the temp copy would be work + thrown away. *) | "f64->bytes" | "i64->bytes" -> arity ctx loc name 1 args; - let slot = - if name = "f64->bytes" then - to_bytes ctx loc Tast.F64ToBytes - (check ctx ~want:(Types.Float Types.F64) (List.hd args)) - else - to_bytes ctx loc Tast.I64ToBytes - (check ctx ~want:(Types.Int Types.I64) (List.hd args)) - in + let f64 = name = "f64->bytes" in + let nty = if f64 then Types.Float Types.F64 else Types.Int Types.I64 in + let x = check ctx ~want:nty (List.hd args) in + let bslice = Types.Slice (Types.Int Types.U8) in expect ctx loc ~want - (if String.equal loc.Loc.file Prelude.file then slot - else dup_elems ctx loc (Types.Int Types.U8) slot - (rt loc raw_alloc "flan_context_temp" [])) + (if String.equal loc.Loc.file Prelude.file then + to_bytes ctx loc (if f64 then Tast.F64ToBytes else Tast.I64ToBytes) x + 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) ] diff --git a/lib/emit.ml b/lib/emit.ml index 007f450a..cc04ccbd 100644 --- a/lib/emit.ml +++ b/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() diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index a9a50c03..c3ac37a0 100644 --- a/runtime/flan_rt.c +++ b/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; } diff --git a/test/programs/temp-grow.flan b/test/programs/temp-grow.flan new file mode 100644 index 00000000..3f7c6d4a --- /dev/null +++ b/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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 1afb483a..92a2b3cb 100644 --- a/test/test_acceptance.ml +++ b/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. *) diff --git a/test/test_dev.ml b/test/test_dev.ml index 543fecb5..bad1346e 100644 --- a/test/test_dev.ml +++ b/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 diff --git a/test/test_session.ml b/test/test_session.ml index 1aaf209d..bb359320 100644 --- a/test/test_session.ml +++ b/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); diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 18bfb4aa..ad5ed290 100644 --- a/vendor/agent/flan_agent.c +++ b/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); } }