An abandoned evaluation puts the context allocator back, and a fault's break loop runs on a guarded stack of its own so a runaway recursion evaluated there is another break rather than a dead session

runtime/flan_dev.c

@@ -2255,8 +2255,95 @@ void flan_dev_crash_enable(void) {}
 #include <pthread.h>
 #include <signal.h>
 #include <unistd.h>
+#if defined(__linux__) && (defined(__x86_64__) || defined(__aarch64__))
+#include <sys/mman.h>
+#include <ucontext.h>
+#define FLAN_PARK_STACKS 1
+#endif
 
 extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen);
+
+#ifdef FLAN_PARK_STACKS
+/* Where a fault's break loop runs. Not the signal stack: the loop evaluates
+ * whatever is typed at it, and a runaway recursion there ran off the end of a
+ * 1 MiB malloc'd block with nothing below it, into the heap. And a fault taken
+ * while already on the signal stack has no stack to be delivered on, so the
+ * kernel kills the process.
+ *
+ * So the handler moves to one of these before calling the hook: 8 MiB each,
+ * mapped on first use, with a guard page at the low end. An overflow on one
+ * faults on its guard, the fault is delivered on the signal stack (the
+ * interrupted code was not on it), and its break loop gets the next stack up.
+ * Which stack is next is read off the interrupted stack pointer: a fault in
+ * code running on stack k parks on k + 1, and every stack above k is free,
+ * because a break loop is only ever left by a jump down to its caller. */
+#define PARK_COUNT 10
+#define PARK_SIZE ((size_t)8 << 20)
+static char *park_lo[PARK_COUNT];
+static ucontext_t park_uc[PARK_COUNT];
+static const uint8_t *park_name;
+static int64_t park_namelen;
+
+/* The guard page counts as the stack's: an overflow's stack pointer is in it
+ * when the fault is taken, and reading it as some other stack's would park the
+ * overflow's break loop on the very stack it overflowed. */
+static int park_index_of(uintptr_t sp) {
+  uintptr_t pg = (uintptr_t)sysconf(_SC_PAGESIZE);
+  for (int i = 0; i < PARK_COUNT; i++)
+    if (park_lo[i] != NULL && sp >= (uintptr_t)park_lo[i] - pg
+        && sp <= (uintptr_t)park_lo[i] + PARK_SIZE)
+      return i;
+  return -1;
+}
+
+static char *park_stack(int i) {
+  if (park_lo[i] == NULL) {
+    size_t pg = (size_t)sysconf(_SC_PAGESIZE);
+    char *m = mmap(NULL, PARK_SIZE + pg, PROT_READ | PROT_WRITE,
+                   MAP_PRIVATE | MAP_ANONYMOUS | MAP_NORESERVE, -1, 0);
+    if (m == MAP_FAILED) return NULL;
+    if (mprotect(m, pg, PROT_NONE) != 0) {
+      munmap(m, PARK_SIZE + pg);
+      return NULL;
+    }
+    park_lo[i] = m + pg;
+  }
+  return park_lo[i];
+}
+
+static uintptr_t park_interrupted_sp(void *uc) {
+  const ucontext_t *u = (const ucontext_t *)uc;
+#if defined(__x86_64__)
+  return (uintptr_t)u->uc_mcontext.gregs[15];   /* REG_RSP */
+#else
+  return (uintptr_t)u->uc_mcontext.sp;
+#endif
+}
+
+static void park_run(void) {
+  flan_trap_hook(park_name, park_namelen);
+  /* The hook parks and is left only by a jump; reaching here is dying. */
+  signal(SIGSEGV, SIG_DFL);
+  raise(SIGSEGV);
+}
+
+/* Calls the hook on the next park stack, or returns 0 when there is none to
+ * be had and the caller should call it where it stands. */
+static int park_elsewhere(void *uc, const uint8_t *name, int64_t namelen) {
+  int k = park_index_of(park_interrupted_sp(uc)) + 1;
+  char *st = k < PARK_COUNT ? park_stack(k) : NULL;
+  if (st == NULL) return 0;
+  park_name = name;
+  park_namelen = namelen;
+  if (getcontext(&park_uc[k]) != 0) return 0;
+  park_uc[k].uc_stack.ss_sp = st;
+  park_uc[k].uc_stack.ss_size = PARK_SIZE;
+  park_uc[k].uc_link = NULL;
+  makecontext(&park_uc[k], park_run, 0);
+  setcontext(&park_uc[k]);
+  return 0;
+}
+#endif
 extern void __asan_init(void) __attribute__((weak));
 
 static volatile sig_atomic_t flan_crash_entered;
@@ -2347,6 +2434,12 @@ static void crash_handler(int sig, siginfo_t *si, void *uc) {
     /* Parks for good, exactly like NullAllocator and the other no-channel
      * traps: there is no address to resume *at* — the faulting instruction
      * would fault again — so this is a place to stand and read. */
+#ifdef FLAN_PARK_STACKS
+    if (sig == SIGBUS)
+      park_elsewhere(uc, (const uint8_t *)"BusError", 8);
+    else
+      park_elsewhere(uc, (const uint8_t *)"SegFault", 8);
+#endif
     if (sig == SIGBUS)
       flan_trap_hook((const uint8_t *)"BusError", 8);
     else

runtime/flan_rt.c

@@ -1561,6 +1561,20 @@ void flan_context_restore(flan_allocator *a) {
   if (a) flan_ctx_alloc = a;
 }
 
+/* The context as it stands, and putting it back: the agent's way out of an
+ * evaluation that trapped jumps past the [with-allocator] that would have
+ * restored it. Two words, which is room for whatever the context grows into;
+ * the agent only carries them. */
+void flan_context_save(uint64_t m[2]) {
+  m[0] = (uint64_t)(uintptr_t)flan_ctx_alloc;
+  m[1] = 0;
+}
+
+void flan_context_load(const uint64_t m[2]) {
+  flan_allocator *a = (flan_allocator *)(uintptr_t)m[0];
+  flan_ctx_alloc = a ? a : &flan_heap;
+}
+
 /* Allocator headers [flan_arena_destroy] retired, linked through [data]. See
  * there for why a header is never freed; this is why that does not grow. */
 static flan_allocator *flan_retired;

test/test_dev.ml

@@ -7785,6 +7785,7 @@ let () =
            let r =
              request tc
                "(:op \"eval\" :code \"(defonce nowhere Allocator)\n\
+                (defonce frame Allocator)\n\
                 (defn deep [n i64] i64 (+ 1 (deep (+ n 1))))\" \
                 :file \"programs/dev-nomain.flan\")"
            in
@@ -7820,6 +7821,55 @@ let () =
                        fail "aborting %s (%s) ended the session: %s" code shape
                          (Printexc.to_string e)))
              [ "(free-all nowhere)"; "(deep 0)" ];
+           let stopped () =
+             await (fun () ->
+                 match Wire.field (request tc "(:op \"describe\")") "stopped" with
+                 | Some { Form.v = Form.Sym "t"; _ } -> true
+                 | _ -> false)
+           in
+           let eval_expr code =
+             request tc
+               (Printf.sprintf "(:op \"eval-expr\" :code %S :file \"<test>\")" code)
+           in
+           let answers code want what =
+             match Wire.string_field (eval_expr code) "value" with
+             | Some v when v = want -> ()
+             | v ->
+               fail "%s (%s): %s" what shape (Option.value ~default:"no value" v)
+             | exception e ->
+               fail "%s (%s) ended the session: %s" what shape (Printexc.to_string e)
+           in
+           (* The context allocator a trapped [with-allocator] had bound is put
+              back: a push through the context afterwards goes to the heap, not
+              to the 4 KiB arena, which would run out. *)
+           ignore (eval_expr "(do (set frame (arena-new 4096)) 0)");
+           ignore (eval_expr "(with-allocator frame (deep 0))");
+           if not (stopped ()) then fail "a trap inside with-allocator (%s) did not stop" shape
+           else begin
+             ignore (request tc "(:op \"abort\")");
+             answers
+               "(let [v (vec-new i64)] (dotimes [i 100000] (push v i)) (length v))"
+               "100000" "the context allocator after a trap inside with-allocator"
+           end;
+           (* A runaway recursion evaluated in the break loop of a fault: the
+              loop runs on a stack of its own with a guard page, so the second
+              overflow is a second break, and both abort. *)
+           ignore (eval_expr "(deep 0)");
+           if not (stopped ()) then fail "the first overflow (%s) did not stop" shape
+           else begin
+             ignore (eval_expr "(deep 0)");
+             (match request tc "(:op \"abort\")" with
+              | r when status r = "ok" -> ()
+              | r -> fail "aborting a nested overflow (%s): %s" shape (said r)
+              | exception e ->
+                fail "a nested overflow (%s) ended the session: %s" shape
+                  (Printexc.to_string e));
+             (* The inner break unwinds on the program's thread; the second
+                abort is for the outer one, so it waits for that. *)
+             Unix.sleepf 0.5;
+             ignore (request tc "(:op \"abort\")");
+             answers "(helper)" "1" "the session after a nested overflow"
+           end;
            (try
               ignore (Wire.send tc "(:op \"close\")");
               ignore (Wire.recv tc)

vendor/agent/flan_agent.c

@@ -410,7 +410,8 @@ static const uint8_t abandon_name[] = "abandon-evaluation";
  * restart is a return that unwinds frame by frame, and a trap has nothing to
  * return through, so abandoning the evaluation from one is a jump straight
  * back to the poll that called it ([flan_agent_poll]), which puts the
- * condition, frame and root chains back where they stood. The defers of the
+ * condition, frame and root chains and the context allocator back where
+ * they stood. The defers of the
  * frames jumped over do not run. NULL when no evaluation is in progress;
  * saved and restored around the call like [eval_boundary]. */
 static sigjmp_buf *eval_escape;
@@ -426,6 +427,8 @@ extern void *flan_dev_frames_mark(void) __attribute__((weak));
 extern void flan_dev_frames_restore(void *head) __attribute__((weak));
 extern int64_t flan_dyn_root_mark(void) __attribute__((weak));
 extern void flan_dyn_root_restore(int64_t n) __attribute__((weak));
+extern void flan_context_save(uint64_t m[2]) __attribute__((weak));
+extern void flan_context_load(const uint64_t m[2]) __attribute__((weak));
 
 /* -- update-instance-for-redefined-class ------------------------------ */
 
@@ -1153,6 +1156,8 @@ int32_t flan_agent_poll(void) {
       if (flan_condition_stacks_mark) flan_condition_stacks_mark(&mh, &mr, &md);
       if (flan_dev_frames_mark) mf = flan_dev_frames_mark();
       if (flan_dyn_root_mark) mroots = flan_dyn_root_mark();
+      uint64_t    mctx[2] = { 0, 0 };
+      if (flan_context_save) flan_context_save(mctx);
       if (sigsetjmp(escape, 1) == 0) {
         eval_escape = &escape;
         j.call();
@@ -1160,6 +1165,7 @@ int32_t flan_agent_poll(void) {
         if (flan_condition_stacks_restore) flan_condition_stacks_restore(mh, mr, md);
         if (flan_dev_frames_restore) flan_dev_frames_restore(mf);
         if (flan_dyn_root_restore) flan_dyn_root_restore(mroots);
+        if (flan_context_load) flan_context_load(mctx);
       }
       eval_escape = oescape;
       /* Popped whichever way the thunk left — returning with a value, or