The park's root reset stops at the globals' watermark

# Conflicts:
#	test/test_dyn.ml

lib/dev.ml

@@ -3700,7 +3700,15 @@ extern void flan_dev_frames_reset(void) __attribute__((weak));
  * no frame, so every root the last run pushed still names an address the next
  * run is about to write over — and the next mark would follow whatever it put
  * there. Weak for the reason the frames reset is weak; runtime/flan_dyn.h
- * exports this for this one caller. */
+ * exports this for this one caller.
+ *
+ * The frames' roots and not the globals': this drops everything above the line
+ * the emitted main's global pushes left behind. The globals are the thing the
+ * banner below promises are still there, and a park is not quiet — it runs
+ * evaluated thunks, which allocate, which collect. Dropping their roots too
+ * meant a thunk of any size swept every dyn global the run had stored, and the
+ * read afterwards was a read of freed memory that happened to answer nil.
+ * runtime/flan_dyn.h's [flan_dyn_root_reset] holds the whole of it. */
 extern void flan_dyn_root_reset(void) __attribute__((weak));
 
 /* The agent's ring, drained on whatever thread calls this. Weak for the reason

lib/emit.ml

@@ -3402,6 +3402,8 @@ declare i64 @flan_dyn_view_flat(ptr, i64, i32)
 declare void @flan_dyn_root_push(ptr)
 declare void @flan_dyn_root_push_desc(ptr, ptr)
 declare void @flan_dyn_root_pop(i64)
+declare void @flan_dyn_root_globals_begin()
+declare void @flan_dyn_root_globals_end()
 declare void @flan_gc_init()
 declare void @flan_dev_reg_enable()
 declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64)
@@ -3531,7 +3533,22 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.
 
      Zero is what a global holds until its initialiser has run: BSS gives that
      for free, and runtime/flan_dyn.h says a rooted slot holding 0 is not a
-     value. *)
+     value.
+
+     Bracketed, and the bracket is what tells the collector which entries at
+     the bottom of its stack are these. It buys two things. A merged dev
+     build's [main] is re-entered — the dev daemon's [rerun] — and [begin]
+     empties the stack first, so the second entry re-roots these globals rather
+     than pushing a second copy of each. And a run that finishes parks with
+     every frame's roots dropped but these kept, which is what makes a global
+     still readable, and still collectable-through, in a park that runs
+     evaluated thunks. runtime/flan_dyn.h's [flan_dyn_root_reset] has the rest.
+
+     Nothing between the two may allocate: the globals are unrooted in that
+     window while still holding what a previous run left. Only the pushes are
+     in it. *)
+  if dyn_globals <> [] then
+    Buffer.add_string b "  call void @flan_dyn_root_globals_begin()\n";
   List.iter
     (fun (g, ty) ->
        match (if ty = Types.Dyn then None else desc_of m ty) with
@@ -3546,6 +3563,8 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.
               "  call void @flan_dyn_root_push_desc(ptr %s, ptr @\"%s\")\n"
               (gname g) sym))
     dyn_globals;
+  if dyn_globals <> [] then
+    Buffer.add_string b "  call void @flan_dyn_root_globals_end()\n";
   (* The program's own end of the transfer channel. Nothing can be transferring
      when [main] returns: a restart is found by name on the restart stack, and
      an [invoke-restart] that finds none fails at the invoke site rather than

lib/x86.ml

@@ -3893,7 +3893,18 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
      Zero is what a global holds until its initialiser has run: [.bss] gives
      that for free, and a zero word is not a pointer the collector will
      follow — see the entry-block roots in [emit_fn] for why that is a fact
-     about runtime/flan_dyn.c and not a convention. *)
+     about runtime/flan_dyn.c and not a convention.
+
+     Bracketed for the reasons [Emit.emit_main] gives at its own copy of this
+     push: [begin] empties the root stack, so a [main] the dev daemon re-enters
+     re-roots these globals instead of pushing a second copy of each, and [end]
+     records where the globals stop and the frames begin, which is the line a
+     park resets to. Nothing between the two may allocate, and only the pushes
+     are between them. *)
+  if dyn_globals <> [] then begin
+    xor_rr b ~dst:rax ~src:rax;
+    call_sym b "flan_dyn_root_globals_begin"
+  end;
   List.iter
     (fun (g, ty) ->
        (* Pc-relative and not through the GOT: [emit_main] is only ever a
@@ -3910,6 +3921,10 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
          xor_rr b ~dst:rax ~src:rax;
          call_sym b "flan_dyn_root_push_desc")
     dyn_globals;
+  if dyn_globals <> [] then begin
+    xor_rr b ~dst:rax ~src:rax;
+    call_sym b "flan_dyn_root_globals_end"
+  end;
   (* The computed globals, after the runtime is up and before a line of the
      program's own code — [emit.ml]'s [emit_startup] says why this is a call
      from here rather than a second constructor. It takes no channel: no caller

runtime/flan_dyn.c

@@ -303,6 +303,14 @@ typedef struct {
 static flan_root *roots;
 static int64_t    roots_n, roots_cap;
 
+/* How much of the bottom of that stack belongs to the globals rather than to
+ * any frame. The globals are pushed once, before the first frame runs, and
+ * never popped — so they are exactly the entries below this line, and every
+ * frame's roots are exactly the entries above it. Zero until a [main] says
+ * otherwise, which is also the right answer for a program that has no dyn
+ * globals to push. See [flan_dyn_root_globals_begin]. */
+static int64_t    roots_base;
+
 /* ── The temporaries ring ──────────────────────────────────────────────
  *
  * The hazard this exists for, plainly: mark-sweep frees what is unreachable,
@@ -926,17 +934,34 @@ void flan_dyn_root_push_desc(void *base, const flan_desc *d) {
   root_add(base, d == NULL ? &desc_empty : d);
 }
 
-/* Clamped at empty rather than refused. A pop that outruns its pushes means
+/* Clamped at the globals rather than refused. A pop that outruns its pushes
- * the frame machinery is already out of step, and the useful thing at that
+ * means the frame machinery is already out of step, and the useful thing at
- * point is a heap that still collects, not a second failure on top of the
+ * that point is a heap that still collects, not a second failure on top of the
  * first. flan_rt.c's [flan_handler_pop] takes the same line for the same
- * reason, by frame rather than by count. */
+ * reason, by frame rather than by count. The floor is [roots_base] and not
+ * zero because the globals under it were never any frame's to pop: an
+ * over-popping frame taking them with it is the one way this clamp could turn
+ * a miscount into a use-after-free. */
 void flan_dyn_root_pop(int64_t n) {
   if (n <= 0) return;
-  roots_n = n < roots_n ? roots_n - n : 0;
+  roots_n = roots_n - n > roots_base ? roots_n - n : roots_base;
 }
 
-void flan_dyn_root_reset(void) { roots_n = 0; }
+/* The two halves of "the globals are the bottom of this stack".
+ *
+ * [begin] empties it outright, because a re-entered [main] is about to push
+ * the same globals again and the entries the previous run left are the ones
+ * that would be duplicated. [end] records how many of them there are.
+ *
+ * Nothing between the two may allocate: between them the globals hold whatever
+ * the previous run left in them and are not rooted, so a collection there
+ * would sweep values the slots still point at. The emitted [main] calls
+ * [begin] immediately before the pushes and [end] immediately after, with only
+ * the pushes in between, which is what makes that hold. */
+void flan_dyn_root_globals_begin(void) { roots_n = 0; roots_base = 0; }
+void flan_dyn_root_globals_end(void) { roots_base = roots_n; }
+
+void flan_dyn_root_reset(void) { roots_n = roots_base; }
 
 /* ── Constructors ──────────────────────────────────────────────────────*/
 

runtime/flan_dyn.h

@@ -285,14 +285,34 @@ void flan_dyn_root_push_desc(void *base, const flan_desc *d);
  * They are here because something in this repository needs them; each says
  * what. */
 
-/* The root stack, emptied. The counterpart of flan_dev.c's
+/* The *frames*' roots, dropped. The counterpart of flan_dev.c's
  * [flan_dev_frames_reset] and there for its one caller: the merged dev build's
  * [main] is re-entered by longjmp, which pops no frame, so every root the
  * finished run pushed still points into stack the next run is about to write
  * over. Marking through those addresses would decode whatever the new run put
- * there. Called between runs, on the thread that runs them. */
+ * there. Called between runs, on the thread that runs them.
+ *
+ * The globals' roots are not dropped with them, and that is the whole of the
+ * distinction: a finished run's frames are gone but its globals are not — the
+ * dev daemon parks with them readable, and runs evaluated thunks against them
+ * that allocate and therefore collect. Emptying the stack outright unrooted
+ * every dyn global for the whole of the park. This resets to the line
+ * [flan_dyn_root_globals_end] recorded. */
 void flan_dyn_root_reset(void);
 
+/* Where that line comes from. The emitted [main] brackets its global pushes
+ * with these: [begin] immediately before the first, [end] immediately after
+ * the last, with nothing but the pushes in between — nothing there may
+ * allocate, because between the two the globals are unrooted and still hold
+ * whatever a previous run left in them. [begin] empties the stack rather than
+ * adding to it, so a [main] entered a second time re-roots the same globals
+ * instead of pushing a second copy of each.
+ *
+ * A program with no dyn globals need not call either: the line starts at zero,
+ * which is what an empty push list should leave it at. */
+void flan_dyn_root_globals_begin(void);
+void flan_dyn_root_globals_end(void);
+
 /* The tag of a value, as a number and as the word that number is printed as.
  * The numbers are FLAN_DYN_TAG_* below. The break loop and the inspector want
  * both — a value's tag is the first thing anyone asks a stopped dyn program —

test/dyn_ops.c

@@ -765,6 +765,68 @@ static void unrooted(void) {
          after <= before + 64 ? "yes" : "no");
 }
 
+/* The park, which is the one place a root stack is cut back without any frame
+ * having returned. The merged dev build's [main] is left by longjmp, so the
+ * finished run's frame roots name stack the next run will overwrite and have
+ * to go — and the globals, pushed once by [main] and never popped, have to
+ * stay, because the process parks with them readable and runs evaluated thunks
+ * against them. A thunk allocates, so a thunk collects.
+ *
+ * The bug this pins: [flan_dyn_root_reset] emptied the stack outright, which
+ * unrooted every dyn global for the whole of the park. The next collection
+ * swept what they held and the read afterwards answered whatever the freed
+ * words decoded as.
+ *
+ * So the shape here is a run and a park and another run, three times over,
+ * with a collection in every park. [config] stands in for a global in .bss;
+ * [frame] for a root the finished run left behind, holding enough objects to
+ * be measurable. The claims are both halves: the global's text is still its
+ * text, and the frame's objects are gone. */
+static void park(void) {
+  enum { CYCLES = 3, HELD = 500 };
+  flan_dyn config = flan_dyn_nil();
+  flan_dyn frame = flan_dyn_nil();
+  int cycle, i, kept = 1, dropped = 1;
+
+  flan_gc_init();
+  flan_gc_set_floor(16 * 1024);
+
+  for (cycle = 0; cycle < CYCLES; cycle++) {
+    int64_t before, after;
+
+    /* The run. [main]'s bracket first, then a frame pushing its own root on
+       top of it — which is the order the emitted code has and the order that
+       makes the globals the bottom of the stack. */
+    flan_dyn_root_globals_begin();
+    flan_dyn_root_push(&config);
+    flan_dyn_root_globals_end();
+    config = text("hello");
+    flan_dyn_root_push(&frame);
+    frame = flan_dyn_vec_new();
+    for (i = 0; i < HELD; i++) flan_dyn_push(frame, text("frame"));
+    flan_gc_collect();
+    before = flan_gc_count();
+
+    /* The park. Nothing popped [frame]'s root: the run was left by longjmp. */
+    flan_dyn_root_reset();
+
+    /* And a thunk that allocates, which is what makes the park not a quiet
+       state. Well past the floor, so this collects several times over. */
+    for (i = 0; i < 20000; i++) (void)text("thunk");
+    flan_gc_collect();
+    after = flan_gc_count();
+
+    if (!flan_dyn_need_bool(flan_dyn_eq(config, text("hello")))) kept = 0;
+    /* The frame's five hundred are gone, which is the half that says the reset
+       still does the job it was written for. The ring's sixty-four and the
+       globals are the only things allowed to have survived. */
+    if (after > before - HELD + 64) dropped = 0;
+  }
+
+  printf("a dyn global survives a parked thunk: %s\n", kept ? "yes" : "no");
+  printf("a finished run's frame roots go: %s\n", dropped ? "yes" : "no");
+}
+
 /* An aggregate root: a struct with dyn fields somewhere inside it, rooted by
  * its address and a descriptor rather than word by word. This is the runtime's
  * half of the per-type descriptors, exercised with the descriptor written out
@@ -947,6 +1009,7 @@ int main(int argc, char **argv) {
   if (strcmp(argv[1], "nested") == 0) { nested(); return 0; }
   if (strcmp(argv[1], "sharing") == 0) { sharing(); return 0; }
   if (strcmp(argv[1], "unrooted") == 0) { unrooted(); return 0; }
+  if (strcmp(argv[1], "park") == 0) { park(); return 0; }
   if (strcmp(argv[1], "desc") == 0) { desc(); return 0; }
   if (strcmp(argv[1], "view") == 0) {
     view();

test/programs/dev-dyn-global.flan

@@ -0,0 +1,24 @@
+;;;; A dyn global that outlives the run that filled it.
+;;;;
+;;;; The park is not a quiet state: the daemon services evaluated thunks on
+;;;; the parked thread, a thunk allocates, and an allocation collects. So the
+;;;; question this program is built to ask is whether the roots the emitted
+;;;; main pushed for its dyn globals are still on the collector's stack after
+;;;; the run that pushed them has finished — because the park cuts that stack
+;;;; back, and cutting it back to empty took the globals with the frames.
+;;;;
+;;;; [config] is a map rather than a number on purpose: a dyn number is an
+;;;; immediate word and survives an unrooted heap by not being on it, so it
+;;;; would answer the same whether or not the root was there. What is stored
+;;;; is a heap object, and reading it back is a read of heap memory.
+;;;;
+;;;; main returns immediately: the run has nothing to do but fill the global,
+;;;; and everything this fixture is for happens after it.
+(import agent "vendor:agent")
+
+(defvar config dyn)
+
+(defn main [] i32
+  (agent/start "/tmp/flan-dev-dyn-global-fallback.sock")
+  (set config {:s "kept" :n 1})
+  0)

test/test_dev.ml

@@ -4644,6 +4644,112 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ xsock2; xout2; msock; mout ];
 
+    (* ── The dyn globals a park holds ─────────────────────────────────── *)
+
+    (* The banner a finished run prints says the globals are as it left them,
+       and for a dyn global that was not true. The park cuts three stacks back
+       — the conditions, the frame chain, and the collector's roots — and the
+       third one was emptied outright. But the dyn globals' roots are on it
+       too: the emitted main pushes them once and nothing ever pops them,
+       which is the whole of what a global's extent means to the collector. So
+       the park unrooted every one of them, and the first evaluated thunk to
+       allocate past the heap's floor swept what they held. The read
+       afterwards answered [nil] — by luck of what the freed words decoded as,
+       which is to say it was a read of freed memory and could as easily have
+       been a crash.
+
+       Both backends, because the daemon's own default is [--x86] and the fix
+       is two emitters agreeing: the bracket around the global pushes is
+       emitted by [Emit.emit_main] and by [X86]'s, and a session on either one
+       has to come back with the string.
+
+       The cycle is run three times over. Once would pass on a fix that kept
+       the globals rooted for the first park only; a re-entered main pushing a
+       second copy of every global rather than re-rooting the same ones is the
+       other way to get this wrong, and it needs a second and third run to
+       show at all. *)
+    List.iter
+      (fun backend ->
+         let dsock = tmp ("dynglobal" ^ backend ^ ".sock")
+         and dout = tmp ("dynglobal" ^ backend ^ ".out") in
+         (try Sys.remove dsock with Sys_error _ -> ());
+         let dfd =
+           Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+         in
+         let dpid =
+           Unix.create_process flan
+             [| flan; "dev"; "programs/dev-dyn-global.flan"; "-s"; dsock;
+                "--" ^ backend |]
+             Unix.stdin dfd Unix.stderr
+         in
+         Unix.close dfd;
+         if not (listening ~pid:dpid dsock) then begin
+           fail "the dyn-global daemon (--%s) %s" backend !listen_why;
+           (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
+         end
+         else begin
+           let c = connect dsock in
+           let said r = Option.value ~default:(status r) (Wire.string_field r "message") in
+           let parked () =
+             match Wire.field (request c "(:op \"describe\")") "parked" with
+             | Some { Form.v = Form.Sym "t"; _ } -> true
+             | _ -> false
+           in
+           (* What the expression answered, wherever it came back: a dyn value
+              is rendered into the reply's output rather than into [:value],
+              and which of the two carries it is not what is under test. *)
+           let answer r =
+             Option.value ~default:"" (Wire.string_field r "value")
+             ^ Option.value ~default:"" (Wire.string_field r "output")
+           in
+           let read () =
+             answer
+               (request c
+                  "(:op \"eval-expr\" :code \"(get config :s)\" \
+                   :file \"programs/dev-dyn-global.flan\")")
+           in
+           (* A hundred thousand small maps: flan_dyn.c collects at a
+              one-megabyte floor, so this is several collections and not a
+              heap that merely grew. *)
+           let churn () =
+             request c
+               "(:op \"eval-expr\" :code \"(do (dotimes [i 100000] (let [m \
+                {:k i}] 0)) 1)\" :file \"programs/dev-dyn-global.flan\")"
+           in
+           if not (await ~ms:20000 parked) then
+             fail "the dyn-global program (--%s) never parked" backend
+           else begin
+             if not (contains_sub (read ()) "kept") then
+               fail "--%s: the global was not readable before any thunk ran: %S"
+                 backend (read ());
+             for cycle = 1 to 3 do
+               let r = churn () in
+               if status r <> "ok" then
+                 fail "--%s: the churning thunk (cycle %d): %s" backend cycle
+                   (said r)
+               else if not (contains_sub (read ()) "kept") then
+                 fail
+                   "--%s: after a thunk that allocates (cycle %d) the parked \
+                    program's dyn global reads %S"
+                   backend cycle (read ());
+               (* And round main again, which re-enters the very code that
+                  pushed those roots. *)
+               let r = request c "(:op \"rerun\")" in
+               if status r <> "ok" then
+                 fail "--%s: rerun (cycle %d): %s" backend cycle (said r);
+               if not (await ~ms:20000 parked) then
+                 fail "--%s: the program did not park again (cycle %d)" backend
+                   cycle
+             done
+           end;
+           ignore (request c "(:op \"close\")");
+           (try Unix.close c with Unix.Unix_error _ -> ());
+           (try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
+         end;
+         List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
+           [ dsock; dout ])
+      [ "llvm"; "x86" ];
+
     (* ── A daemon whose editor was killed ─────────────────────────────── *)
 
     (* The defect FIX.org recorded and PDEATHSIG does not reach: an editor that

test/test_dyn.ml

@@ -14,6 +14,9 @@
      gc        a million allocations against a hundred live, and the heap's
                high-water mark bounded
      unrooted  the positive control: an object nothing points at is reclaimed.
+     park      the root stack cut back to its globals with no frame having
+               returned, which is what the dev daemon's park does between one
+               run and the next: the globals stay rooted, the frames' go
      desc      an aggregate root: a struct whose dyn fields are named by a
                descriptor rather than pushed one at a time.
                Without it a collector that never freed would pass everything
@@ -38,7 +41,7 @@
                mismatched write on each of the three element kinds, and a
                push against a flat (slice or array) view
 
-   One binary, built once, run thirty-six times. The build is the expensive
+   One binary, built once, run thirty-eight times. The build is the expensive
    part and the runs are milliseconds, which is what keeps this inside
    `dune test` rather than behind an alias. *)
 
@@ -112,6 +115,20 @@ let () =
       fail "an unrooted object\n        got: %S (exit %d)\n     wanted: %S"
         out code want_un;
 
+    (* The park: a root stack cut back to its globals with no frame having
+       returned, which is what the merged dev build does between a run and the
+       next. Both halves are asserted, because each on its own is met by doing
+       nothing — a reset that dropped everything keeps no global, and a reset
+       that dropped nothing keeps every frame. *)
+    let code, out, _ = run "park" in
+    let want_park =
+      "a dyn global survives a parked thunk: yes\n\
+       a finished run's frame roots go: yes\n"
+    in
+    if code <> 0 || out <> want_park then
+      fail "the park's root reset\n        got: %S (exit %d)\n     wanted: %S"
+        out code want_park;
+
     (* The aggregate roots the per-type descriptors added: a struct with dyn
        fields at three offsets, one of them inside a nested struct, rooted by
        address and descriptor rather than word by word.
@@ -241,7 +258,7 @@ let () =
     (* A line on the way out, because a test that says nothing when it passes
        is a test nobody can tell from a test that did not run. *)
     if !failures = 0 then
-      Printf.printf "  ok   the dyn runtime: %d refusals and eight runs\n"
+      Printf.printf "  ok   the dyn runtime: %d refusals and nine runs\n"
         (List.length refusals + List.length view_refusals)
     else exit 1
   | _ -> print_endline "SKIP  test_dyn: no clang"

test/test_sanitize.ml

@@ -307,7 +307,7 @@ let dyn_sweep () =
          if reported text then fail "dyn %s: sanitizer report\n%s" mode text
          else if code <> 0 then
            fail "dyn %s: exit %d under the sanitizers\n%s" mode code text)
-      [ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing" ];
+      [ "ops"; "gc"; "unrooted"; "desc"; "nested"; "sharing"; "park" ];
     (try Sys.remove exe with Sys_error _ -> ())
 
 (* The positive controls, which are the only evidence that a clean sweep means