Aborting an expression that trapped in the park abandons it by a jump back to the poll that called it, and the session stays

lib/dev.ml

@@ -3450,12 +3450,12 @@ let abort t =
   (* A thunk stopped in the break loop on the parked thread. Aborting it is
      abandoning the expression, not ending the process: the program had
      already finished, and the break loop offers the thunk's own boundary as a
-     restart, so that is what is taken and the session stays parked. A trap
+     restart, so that is what is taken and the session stays parked. At a
-     offers nothing that can be taken, and there abort still ends the
+     trap the boundary is left by a jump rather than a transfer (the agent's
-     process. *)
+     [eval_escape]), and it is offered the same way. *)
   | Parked
     when match restarts t with
-         | Ok (rs, false) -> List.exists (fun (_, f, _) -> f = Boundary) rs
+         | Ok (rs, _) -> List.exists (fun (_, f, _) -> f = Boundary) rs
          | _ -> false ->
     (match restarts t with
      | Ok (rs, _) ->
@@ -3465,7 +3465,9 @@ let abort t =
           ok
             [ ":note "
               ^ Wire.quote
-                  "the evaluation is abandoned; the program is still parked,                    and anything the expression changed before it stopped                    stays changed" ]
+                  "the evaluation is abandoned; the program is still parked, \
+                   and anything the expression changed before it stopped \
+                   stays changed" ]
         | reply -> error (String.trim reply)
         | exception Unix.Unix_error (e, _, _) -> error (unreachable t e))
      | Error m -> error m)

runtime/flan_dev.c

@@ -1064,6 +1064,11 @@ flan_frame *flan_frame_head;
  * which is the failure this whole file exists to avoid. */
 void flan_dev_frames_reset(void) { flan_frame_head = NULL; }
 
+/* Where the chain stood, and putting it back there: the agent's way out of a
+ * trapped evaluation jumps past the frames the evaluation pushed. */
+void *flan_dev_frames_mark(void) { return flan_frame_head; }
+void flan_dev_frames_restore(void *head) { flan_frame_head = (flan_frame *)head; }
+
 /* [i] counts from the innermost. NULL past the end, which is how a caller
  * learns the depth without a second walk. */
 void *flan_dev_frame_at(int32_t i) {

runtime/flan_dyn.c

@@ -1406,6 +1406,11 @@ void flan_dyn_root_globals_end(void) { roots_base = roots_n; }
 
 void flan_dyn_root_reset(void) { roots_n = roots_base; }
 
+/* The same for one evaluation that trapped: the roots its frames pushed are
+ * dropped, and the ones below it kept. */
+int64_t flan_dyn_root_mark(void) { return roots_n; }
+void flan_dyn_root_restore(int64_t n) { if (n <= roots_n) roots_n = n; }
+
 /* ── Constructors ──────────────────────────────────────────────────────*/
 
 flan_dyn flan_dyn_nil(void) { return dyn_make(BOX_NIL, 0); }

runtime/flan_dyn.h

@@ -416,6 +416,8 @@ void flan_dyn_track_vecs(void);
  * 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);
+int64_t flan_dyn_root_mark(void);
+void flan_dyn_root_restore(int64_t n);
 
 /* Where that line comes from. The emitted [main] brackets its global pushes
  * with these: [begin] immediately before the first, [end] immediately after

runtime/flan_rt.c

@@ -278,6 +278,21 @@ void flan_condition_stacks_reset(void) {
   c_restart_depth = 0;
 }
 
+/* The same three, marked and put back rather than emptied: an evaluation that
+ * trapped is left by a jump past every frame it pushed, so the chains are
+ * returned to where they stood when it was called (see the agent's poll). */
+void flan_condition_stacks_mark(void **h, void **r, int32_t *d) {
+  *h = handlers;
+  *r = restarts;
+  *d = c_restart_depth;
+}
+
+void flan_condition_stacks_restore(void *h, void *r, int32_t d) {
+  handlers = (flan_handler *)h;
+  restarts = (flan_restart *)r;
+  c_restart_depth = d;
+}
+
 /* The conversions are *text*: bytes->f64 parses "12.5", f64->bytes renders it.
  * calc-me's tokenizer needs the first, the prelude's printers the second. */
 

test/test_dev.ml

@@ -1937,16 +1937,10 @@ let () =
                  is only as good as SA_NODEFER: %s"
                 what (status r)
           end;
-          (* The one case where "just ignore that whole call" cannot hold, and
+          (* An evaluation that traps stops with no transfer channel anywhere
-             it is the same reason every other refusal at a trap has: an
+             in the call, so no restart can be unwound to — but the evaluation's
-             evaluation that *traps* stops with no transfer channel anywhere in
+             own boundary is left by the agent's jump back to the poll that
-             the call, so there is nothing for the boundary restart to unwind
+             called it, so it is listed as takeable and [:abandon] names it. *)
-             through either. It is listed — it is a live frame, and hiding it
-             would make the one break where it does not work the one break that
-             never mentions it — and it is listed as untakeable, with
-             [:abandon] saying there is no position to offer. Fix the
-             expression and evaluate it again; that is the whole of the way
-             out. *)
           if trapping <> "" then begin
             let r =
               ask
@@ -1970,15 +1964,16 @@ let () =
                    (String.concat ", " names)
              | _ -> fail "break at a trap inside an evaluation listed nothing");
             (match Wire.field r "unreachable" with
-             | Some { Form.v = Form.List [ { Form.v = Form.Int 0L; _ } ]; _ } -> ()
+             | None | Some { Form.v = Form.Sym "nil"; _ }
+             | Some { Form.v = Form.List []; _ } -> ()
              | _ ->
-               fail "the boundary restart was offered at a trap, where nothing \
+               fail "the boundary restart was refused at a trap inside an \
-                     can be taken");
+                     evaluation");
             (match Wire.field r "abandon" with
-             | Some { Form.v = Form.Sym "nil"; _ } -> ()
+             | Some { Form.v = Form.Int 0L; _ } -> ()
              | _ ->
-               fail "a trap inside an evaluation named a position that abandons \
+               fail "a trap inside an evaluation did not name the position \
-                     it");
+                     that abandons it");
             (* And the reason those positions are refused, which is the half an
                editor puts in front of somebody. [:abandon] being nil cannot
                carry it: a break the program took on its own has a nil there
@@ -7761,6 +7756,82 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ msock; mout ];
 
+    (* ── A trap in an expression evaluated in the park ──────────────────
+       A trap has no transfer channel, so no restart can be taken from it —
+       but the evaluation's own boundary can, by the agent's jump back to the
+       poll that called it. Abort takes it, and the session answers after.
+       A null allocator and a stack overflow, on both backends. *)
+    List.iter
+      (fun backend ->
+         let tsock = tmp "trap.sock" and tout = tmp "trap.out" in
+         (try Sys.remove tsock with Sys_error _ -> ());
+         let tfd =
+           Unix.openfile tout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+         in
+         let tpid =
+           Unix.create_process flan
+             (Array.append
+                [| flan; "dev"; "programs/dev-nomain.flan"; "-s"; tsock |]
+                backend)
+             Unix.stdin tfd tfd
+         in
+         Unix.close tfd;
+         let shape = if backend = [||] then "x86" else "llvm" in
+         if not (listening ~pid:tpid tsock) then
+           fail "a trap daemon (%s) %s" shape !listen_why
+         else begin
+           let tc = connect tsock in
+           let said r = Option.value ~default:"" (Wire.string_field r "message") in
+           let r =
+             request tc
+               "(:op \"eval\" :code \"(defonce nowhere Allocator)\n\
+                (defn deep [n i64] i64 (+ 1 (deep (+ n 1))))\" \
+                :file \"programs/dev-nomain.flan\")"
+           in
+           if status r <> "ok" then fail "trap definitions (%s): %s" shape (said r);
+           List.iter
+             (fun code ->
+                ignore
+                  (request tc
+                     (Printf.sprintf "(:op \"eval-expr\" :code %S :file \"<test>\")"
+                        code));
+                if not
+                    (await (fun () ->
+                         match Wire.field (request tc "(:op \"describe\")") "stopped" with
+                         | Some { Form.v = Form.Sym "t"; _ } -> true
+                         | _ -> false))
+                then fail "%s (%s) did not stop" code shape
+                else
+                  match request tc "(:op \"abort\")" with
+                  | r when status r <> "ok" ->
+                    fail "aborting %s (%s): %s" code shape (said r)
+                  | _ ->
+                    (match
+                       Wire.string_field
+                         (request tc
+                            "(:op \"eval-expr\" :code \"(helper)\" :file \"<test>\")")
+                         "value"
+                     with
+                     | Some "1" -> ()
+                     | v ->
+                       fail "the session after aborting %s (%s): %s" code shape
+                         (Option.value ~default:"no value" v)
+                     | exception e ->
+                       fail "aborting %s (%s) ended the session: %s" code shape
+                         (Printexc.to_string e)))
+             [ "(free-all nowhere)"; "(deep 0)" ];
+           (try
+              ignore (Wire.send tc "(:op \"close\")");
+              ignore (Wire.recv tc)
+            with _ -> ());
+           (try Unix.close tc with Unix.Unix_error _ -> ())
+         end;
+         (try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ());
+         (try ignore (Unix.waitpid [] tpid) with Unix.Unix_error _ -> ());
+         List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
+           [ tsock; tout ])
+      [ [||]; [| "--llvm" |] ];
+
     (* ── A class redefined under its own instances ──────────────────
        CLHS 4.3.6's update protocol, end to end, with a real editor at one
        end and the running program's own heap at the other. "A method added

vendor/agent/flan_agent.c

@@ -41,6 +41,7 @@
 #include <errno.h>
 #include <stdlib.h>
 #include <pthread.h>
+#include <setjmp.h>
 #include <signal.h>
 #include <stdatomic.h>
 #include <stdint.h>
@@ -402,6 +403,28 @@ static int32_t frame_floor = -1;
 static void *eval_boundary;
 static const uint8_t abandon_name[] = "abandon-evaluation";
 
+/* The way out of the innermost evaluation for a break that has no transfer
+ * channel — a trap: a fault, a failed bounds check, a null allocator. A
+ * 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
+ * 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;
+
+/* What the chains looked like when the evaluation was called, weak for the
+ * reason the frame walk below is: the runtime is linked into every program
+ * that links this, but not every build carries the dev and dyn halves. */
+extern void flan_condition_stacks_mark(void **h, void **r, int32_t *d)
+    __attribute__((weak));
+extern void flan_condition_stacks_restore(void *h, void *r, int32_t d)
+    __attribute__((weak));
+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));
+
 /* The three of them, dropped between two runs of [main]. The counterpart of
  * flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's
  * [flan_dev_frames_reset], called from the same one place and for the same
@@ -417,6 +440,7 @@ static const uint8_t abandon_name[] = "abandon-evaluation";
  * would be strange to empty two thirds of it. */
 void flan_agent_run_reset(void) {
   eval_boundary = NULL;
+  eval_escape = NULL;
   restart_floor = 0;
   frame_floor = -1;
 }
@@ -503,6 +527,9 @@ typedef struct {
    * client that matched on the name would offer the program's restart as the
    * way out of an evaluation. The address is what makes it this one. */
   int32_t boundary;
+  /* A trap inside an evaluation: nothing on the list can be taken, except the
+   * boundary, which is left by [eval_escape] rather than by a transfer. */
+  int32_t escapable;
   int32_t used;
   char    names[SNAP_NAMES];
   /* Where the stopped thread is, taken at the same moment and for the same
@@ -592,6 +619,12 @@ static snapshot *snap_top(void) {
  * to nest, which the caller reports rather than serving a stale one. */
 static int32_t snap_gen;                   /* monotone; 0 is "no snapshot" */
 
+/* Whether entry [i] can be taken: any reachable one at a break that can
+ * resume, and the evaluation's boundary at a trap inside an evaluation. */
+static int can_take(const snapshot *s, int32_t i) {
+  return (s->resumable && s->reachable[i]) || (s->escapable && i == s->boundary);
+}
+
 static int snap_push(int resumable, void *cond) {
   int d = atomic_load(&snap_depth);
   if (d >= BREAK_MAX) return 0;
@@ -677,6 +710,7 @@ static int snap_push(int resumable, void *cond) {
     s->names[s->used++] = 0;
     s->n++;
   }
+  s->escapable = !s->resumable && eval_escape != NULL && s->boundary >= 0;
   /* And the frames, from the same held-still stack. A deep recursion is
    * truncated rather than followed: the innermost frames are the ones the
    * question is about, and the count says how many were left out. */
@@ -849,7 +883,11 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
      * when none of it can be taken — and because the same names come back
      * from a `restarts' query, and the terminal and the socket must not be
      * describing two different programs. */
-    if (!s->resumable)
+    if (s->escapable)
+      fprintf(stderr,
+              "  nothing here can be resumed into; abandon the expression, "
+              "or read the frame, then fix and reload\n");
+    else if (!s->resumable)
       fprintf(stderr,
               "  nothing here can be resumed into; read the frame, then fix "
               "and reload, or abort\n");
@@ -861,7 +899,9 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
        * than hidden, since "why can I not have that one" is a fair question
        * and silence is how this went wrong the first time. */
       fprintf(stderr, "  %2d. restart: %s%s\n", i, s->names + s->off[i],
-              !s->resumable   ? "   (cannot be taken from this trap)"
+              i == s->boundary && can_take(s, i)
+                ? "   (stop running the expression; the program carries on)"
+              : !s->resumable   ? "   (cannot be taken from this trap)"
               : i == s->boundary
                 ? "   (stop running the expression; the program carries on)"
               : s->reachable[i] ? ""
@@ -914,7 +954,23 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
       atomic_store(&chosen_ready, 0);
       snapshot *s  = snap_top();
       int       ok = s != NULL && s->gen == my_gen && take >= 0 && take < s->n
-                     && s->resumable && s->reachable[take];
+                     && can_take(s, take);
+      if (ok && !s->resumable) {
+        /* The boundary, at a trap: nothing to return through, so the way out
+         * is [eval_escape]. The break is unwound here, as a resume unwinds
+         * it below, and the poll that called the evaluation puts the chains
+         * back. */
+        fprintf(stderr,
+                "flan: the evaluation is abandoned; the program carries on "
+                "from where it was called. Anything it changed before it "
+                "stopped stays changed.\n");
+        fflush(stderr);
+        memcpy(condition_name, outer_name, sizeof condition_name);
+        atomic_store(&aborting, 0);
+        snap_pop();
+        atomic_fetch_sub(&depth, 1);
+        siglongjmp(*eval_escape, 1);
+      }
       if (ok) {
         /* Which of the two things a take is, decided here because this is the
          * only place that holds both the choice and the boundary. The transfer
@@ -1042,7 +1098,27 @@ int32_t flan_agent_poll(void) {
        * that were there when the thunk started, and this one is the thunk's.
        * Pushed first it would be below its own boundary and refused. */
       eval_boundary = flan_restart_push_c(abandon_name, sizeof abandon_name - 1);
-      j.call();
+      /* The marks are taken after the boundary is pushed, so a jump back
+       * here leaves it on the chain for the pop below, as a return does.
+       * [sigsetjmp] with the mask saved: a fault's break loop runs inside the
+       * signal handler, and the jump leaves the handler. */
+      sigjmp_buf  escape;
+      sigjmp_buf *oescape = eval_escape;
+      void       *mh = NULL, *mr = NULL, *mf = NULL;
+      int32_t     md = 0;
+      int64_t     mroots = 0;
+      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();
+      if (sigsetjmp(escape, 1) == 0) {
+        eval_escape = &escape;
+        j.call();
+      } else {
+        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);
+      }
+      eval_escape = oescape;
       /* Popped whichever way the thunk left — returning with a value, or
        * unwinding past this frame because someone abandoned it. */
       flan_restart_pop_c(eval_boundary);
@@ -1278,7 +1354,7 @@ static void handle_line(char *line, sink *o) {
        * reads a takeable restart as takeable, and only misses that this one
        * is the way out. */
       int  k = snprintf(hdr, sizeof hdr, "%d %c ", i,
-                        !(s->resumable && s->reachable[i]) ? '-'
+                        !can_take(s, i)                    ? '-'
                         : i == s->boundary                 ? '*'
                                                            : '+');
       if (k > 0) emit(o, hdr, (size_t)k);
@@ -1400,13 +1476,13 @@ static void handle_line(char *line, sink *o) {
      * with the better sentence: at a trap every restart is unreachable, and
      * answering with the thunk-boundary reason would send the reader looking
      * for an evaluation that is not there. */
-    if (!s->resumable) {
+    if (!s->resumable && !can_take(s, idx)) {
       reply(o, "err this break was taken by a trap with no transfer channel, "
-               "so no restart can be taken from it; read the frame, then fix "
+               "so no restart can be taken from it but the evaluation's own; "
-               "and reload, or abort\n");
+               "read the frame, then fix and reload, or abort\n");
       return;
     }
-    if (!s->reachable[idx]) {
+    if (!can_take(s, idx)) {
       /* Refused, with the reason, rather than accepted and dropped. The
        * transfer would unwind to the thunk this break is inside and stop
        * there, and the program would carry on as if nothing had been
@@ -1452,13 +1528,13 @@ static void handle_line(char *line, sink *o) {
       reply(o, " is active\n");
       return;
     }
-    if (!s->resumable) {
+    if (!s->resumable && !can_take(s, at)) {
       reply(o, "err this break was taken by a trap with no transfer channel, "
-               "so no restart can be taken from it; read the frame, then fix "
+               "so no restart can be taken from it but the evaluation's own; "
-               "and reload, or abort\n");
+               "read the frame, then fix and reload, or abort\n");
       return;
     }
-    if (!s->reachable[at]) {
+    if (!can_take(s, at)) {
       reply(o, "err restart ");
       reply(o, line + 8);
       reply(o, " is below the evaluation this break is inside, so a "