A handler for a parent reads the condition's own name and message or the condition printed with its values, kept in the handler-case's own frame across the unwind, and a frame re-entered through a signal or a C call names where it is

lib/check.ml

@@ -2429,22 +2429,6 @@ let condition_chain env name =
   in
   go [] name
 
-(* The sentence a handler for [Error] reads as the message, for the built-in
-   conditions the compiler itself signals. It has no values in it, because a
-   handler-case carries it past the frame that signalled; the fields carry
-   those. A program's own condition has none: its fields say what it is. The
-   runtime's own two, BoundsError and ArithError, are written in flan_rt.c. *)
-let condition_message = function
-  | "StorageExhausted" -> "an allocator could not provide the memory asked of it"
-  | "FileError" -> "a file operation failed"
-  | "NoMethod" -> "no method answers this call"
-  | _ -> ""
-
-let condition_desc env name =
-  { Tast.cname = name;
-    cchain = List.map type_id (condition_chain env name);
-    cmessage = condition_message name }
-
 (* How a restart's parameter list is spelled, and with it what the two ends of
    an [invoke-restart] compare — spec-conditions.md §3's run-time check. A
    restart is found by name on a dynamic stack, so neither end can see the
@@ -3172,6 +3156,70 @@ let invented_ctx env ret =
     in_defer = false; defer_ok = false; defer_block = "a nested form";
     owner = "<none>" }
 
+(* Whether a struct has exactly Error's two fields, which is what a parent must
+   have: a handler for a parent is handed a view of that shape. *)
+let error_shaped env n =
+  match Hashtbl.find_opt env.structs n with
+  | Some s ->
+    (match s.Tast.fields with
+     | [ { Tast.fname = "name"; fty = Types.String };
+         { Tast.fname = "message"; fty = Types.String } ] -> true
+     | _ -> false)
+  | None -> false
+
+(* What a signal site tells the runtime about its condition. A condition that
+   something could catch through a parent, and that is not Error-shaped itself,
+   gets a printer lifted out of the signalling function: the runtime calls it
+   only when a parent's handler is about to run, or nothing handled it, so a
+   signal nobody catches that way costs nothing. It prints what [println]
+   prints, fields and values, and that is the message such a handler reads. *)
+let condition_desc ctx loc name =
+  let chain = condition_chain ctx.env name in
+  let self = error_shaped ctx.env name in
+  let render =
+    if self || List.length chain < 2 then None
+    else begin
+      let ty = Types.Named name in
+      let hctx = { (invented_ctx ctx.env Types.Unit) with owner = ctx.owner } in
+      let pslot = fresh_slot hctx (Types.Ptr ty) in
+      let bslice = Types.Slice (Types.Int Types.U8) in
+      let emit x = mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_msg_emit", [ x ])) in
+      let emitter : Render.emitter =
+        { Render.ebytes = emit;
+          estr = (fun x -> emit (mk loc bslice (Tast.Prim (Tast.EscapeBytes, [ x ]))));
+          ei64 = (fun x -> emit (to_bytes hctx loc Tast.I64ToBytes x));
+          eu64 = (fun x -> emit (to_bytes hctx loc Tast.U64ToBytes x));
+          ef64 = (fun x -> emit (to_bytes hctx loc Tast.F64ToBytes x));
+          edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_emit_msg", [ x ]))) }
+      in
+      let value =
+        mk loc ty (Tast.Deref (mk loc (Types.Ptr ty) (Tast.Local pslot)))
+      in
+      let body = Render.render (render_ctx hctx emitter) 0 value in
+      let mine =
+        List.filter
+          (fun (l : Tast.fn) ->
+             l.Tast.fparent = Some ctx.owner
+             && String.length l.Tast.name >= 8
+             && String.sub l.Tast.name 0 8 = "message/")
+          ctx.env.lifted
+      in
+      let fname =
+        Printf.sprintf "message/%s/%d/%s" ctx.owner (List.length mine) name
+      in
+      ctx.env.lifted <-
+        { Tast.name = fname; params = [ Types.Ptr ty ];
+          slots = Array.of_list (List.rev hctx.slot_tys);
+          snames = Array.of_list (List.rev hctx.slot_names);
+          ret = Types.Unit; body; fdefers = [];
+          fenv = None; fparent = Some ctx.owner; floc = loc }
+        :: ctx.env.lifted;
+      Some fname
+    end
+  in
+  { Tast.cname = name; cchain = List.map type_id chain; cself = self;
+    crender = render }
+
 (* The address of field [i] of the struct the pointer in slot [p] points at. *)
 let field_addr_of loc sty fty p i =
   let target = mk loc sty (Tast.Deref (mk loc (Types.Ptr sty) (Tast.Local p))) in
@@ -3971,7 +4019,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
       | Ast.Serror -> (Types.Never, Tast.Serror)
     in
     expect ctx loc ~want
-      (mk loc ty (Tast.Signal (kind, condition_desc ctx.env name, c)))
+      (mk loc ty (Tast.Signal (kind, condition_desc ctx loc name, c)))
 
   | Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body
   | Ast.HandlerCase (body, clauses) -> check_handler_case ctx ?want loc body clauses
@@ -4719,7 +4767,12 @@ and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr)
            rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ];
            rloc = c.Ast.rloc;
            rreport = Option.value c.Ast.rreport ~default:"";
-           rhidden = hidden })
+           rhidden = hidden;
+           rkeep =
+             hidden
+             && (match params with
+                 | [ (_, Types.Named n) ] -> error_shaped ctx.env n
+                 | _ -> false) })
       clauses
   in
   let ty = match !ty with Some t -> t | None -> Types.Never in
@@ -6965,7 +7018,7 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
   in
   let signal =
     mk loc Types.Never
-      (Tast.Signal (Tast.Serror, condition_desc ctx.env "StorageExhausted",
+      (Tast.Signal (Tast.Serror, condition_desc ctx loc "StorageExhausted",
                     cond))
   in
   let attempt_then_signal =
@@ -6982,7 +7035,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
     let sg = restart_sig [] in
     { Tast.rname_id = type_id "retry"; rname = "retry"; rparams = [];
       rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ];
-      rloc = loc; rreport = "Try the allocation again"; rhidden = false }
+      rloc = loc; rreport = "Try the allocation again"; rhidden = false;
+      rkeep = false }
   in
   let body =
     mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal))
@@ -7036,7 +7090,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
   in
   let signal () =
     mk loc Types.Never
-      (Tast.Signal (Tast.Serror, condition_desc ctx.env "FileError", cond))
+      (Tast.Signal (Tast.Serror, condition_desc ctx loc "FileError", cond))
   in
   (* One step of the attempt: run the runtime call, record whether it worked,
      and signal if it did not. The last step a caller gives is what leaves [ok]
@@ -7053,7 +7107,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
     let sg = restart_sig (List.map snd params) in
     { Tast.rname_id = type_id name; rname = name; rparams = params;
       rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ];
-      rloc = loc; rreport = report; rhidden = false }
+      rloc = loc; rreport = report; rhidden = false; rkeep = false }
   in
   let body =
     mk loc Types.Unit
@@ -10832,29 +10886,37 @@ let rec defconst_type_shaped env gname (v : Ast.expr) =
    name and the sentence, so a parent shaped any other way would be read off
    bytes that are not its fields. *)
 let check_parents env =
-  let shaped n =
-    match Hashtbl.find_opt env.structs n with
-    | Some s ->
-      (match s.Tast.fields with
-       | [ { Tast.fname = "name"; fty = Types.String };
-           { Tast.fname = "message"; fty = Types.String } ] -> true
-       | _ -> false)
-    | None -> false
-  in
   Hashtbl.iter
     (fun child parent ->
        let loc =
          Option.value (Hashtbl.find_opt env.locs child) ~default:Loc.unknown
        in
-       if not (shaped parent) then
+       if not (error_shaped env parent) then begin
+         let has =
+           match Hashtbl.find_opt env.structs parent with
+           | Some { Tast.fields = []; _ } -> "none"
+           | Some s ->
+             String.concat " "
+               (List.map
+                  (fun (f : Tast.field) ->
+                     f.Tast.fname ^ " " ^ Types.to_string f.Tast.fty)
+                  s.Tast.fields)
+           | None -> "none"
+         in
+         let fix =
+           match Hashtbl.find_opt env.parents parent with
+           | Some _ -> Printf.sprintf "(defstruct %s :parent %s)" parent
+                         (Hashtbl.find env.parents parent)
+           | None -> Printf.sprintf "(defstruct %s :parent Error)" parent
+         in
          fail loc
-           "%s names %s as its parent, and %s has fields of its own. A \
+           "%s names %s as its parent, and a parent has exactly the fields \
-            handler for a parent is handed the name and the sentence of \
+            [name string message string], because a handler for a parent is \
-            whatever it caught, not that condition's fields, so a parent has \
+            handed the name and the message of whatever it caught. %s has \
-            exactly [name string message string]. Give %s its own category \
+            [%s]. Declare it with no field vector, %s, which gives it those \
-            with no field vector, (defstruct Category :parent Error), and \
+            two"
-            name that as the parent"
+           child parent parent has fix
-           child parent parent child;
+       end;
        (* A cycle is a chain with no root; the walk stops at the repeat. *)
        let chain = condition_chain env child in
        match Hashtbl.find_opt env.parents (List.nth chain (List.length chain - 1)) with

lib/emit.ml

@@ -176,6 +176,10 @@ let globalptr n = "@" ^ quoted (Mangle.globalptr n)
 let abi_marker = "flan.abi.llvm"
 let abi_marker_sym = "@" ^ quoted abi_marker
 
+(* The bytes a condition's message may take, flan_rt.c's FLAN_MESSAGE_MAX:
+   the buffer a handler-case landing owns for the message it is handed. *)
+let message_max = 512
+
 (* ── The runtime's own structs ───────────────────────────────────────── *)
 
 (* Four structs that are not Flan types: they are declared in C, in
@@ -223,7 +227,7 @@ module Rt = struct
           "args", Ptr; "arity", I32; "sig_id", I32; "armed", I32;
           "sig", Ptr; "siglen", I64;
           "loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
-          "flags", I32 ] }
+          "flags", I32; "keep", Ptr; "keepcap", I64 ] }
 
   (* What a signal site says about its condition — the runtime's
      [flan_condesc]. The first four fields are the prelude's [Error] laid out,
@@ -234,7 +238,8 @@ module Rt = struct
     { sname = "condesc";
       fields =
         [ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
-          "chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64 ] }
+          "chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64;
+          "render", Ptr; "flags", I32 ] }
 
   (* The static description of a function, and the shadow-stack frame that
      points at one. Dev builds only (runtime/flan_dev.c). *)
@@ -1741,7 +1746,8 @@ let fninfo m (fn : Tast.fn) ~nslots =
    site. *)
 let condesc m (d : Tast.condesc) loc =
   let nid, nlen = string_bytes m d.Tast.cname in
-  let mid, mlen = string_bytes m d.Tast.cmessage in
+  (* A compiled condition carries no sentence: the runtime asks [render]. *)
+  let mid, mlen = string_bytes m "" in
   let lid, llen = fi_bytes m (Loc.to_string loc) in
   let cid = Printf.sprintf "@\".cd.%d\"" m.nfi in
   m.nfi <- m.nfi + 1;
@@ -1757,7 +1763,9 @@ let condesc m (d : Tast.condesc) loc =
        (Rt.ll_init Rt.condesc
           [ nid; string_of_int nlen; mid; string_of_int mlen; cid;
             string_of_int (List.length d.Tast.cchain); lid;
-            string_of_int llen ]));
+            string_of_int llen;
+            (match d.Tast.crender with Some r -> fname r | None -> "null");
+            (if d.Tast.cself then "1" else "0") ]));
   id
 
 (* ── Bounds checks ───────────────────────────────────────────────────── *)
@@ -1798,10 +1806,30 @@ let fail_block f (loc : Loc.t) ok emit_call =
    **That is the answer to "does a trap run defers": an answered one does, an
    unanswered one still does not, because the unanswered one is still a die
    inside C.** *)
+(* A dev build's frame records where it is when it hands control to something
+   that can come back into Flan: a call, a signal, a C function, a runtime
+   check that signals. So a backtrace names the call each frame is in, and a
+   frame re-entered through a handler names the signal and not whatever it
+   called last. Stored before and cleared after, so a frame that has come back
+   names nothing rather than a call that has already returned. One store each
+   side; nothing in a release build. *)
+let mark_call f at =
+  match f.frame with
+  | None -> ()
+  | Some _ ->
+    let id = fi_cstring f.md (Loc.to_string at) in
+    ins f "store ptr %s, ptr %%frame.a" id
+
+let clear_call f =
+  match f.frame with
+  | None -> ()
+  | Some _ -> if f.live then ins f "store ptr null, ptr %%frame.a"
+
 let signal_block f (loc : Loc.t) ~guard ok emit_call =
   let good = fresh_label f "inb" and bad = fresh_label f "oob" in
   term f "br i1 %s, label %%%s, label %%%s" ok good bad;
   label f bad;
+  mark_call f loc;
   let id, n = string_bytes f.md (Loc.to_string loc) in
   emit_call id n;
   guard ();
@@ -2331,7 +2359,11 @@ and value_at f (e : Tast.expr) : string =
   | Tast.Prim (p, args) -> prim f e p args
   | Tast.Call (name, args) ->
     (match Hashtbl.find_opt f.md.externs name with
-     | Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
+     | Some sym ->
+       (* A C function may call back into Flan. *)
+       let r = extern_call ~at:e.Tast.loc f e.Tast.ty ("@" ^ sym) args in
+       clear_call f;
+       r
      | None -> call f ~loc:e.Tast.loc e.Tast.ty name args)
   | Tast.CallPtr (callee, args) -> call_ptr ~at:e.Tast.loc f e.Tast.ty callee args
   | Tast.Do body -> block f body
@@ -2401,8 +2433,10 @@ and value_at f (e : Tast.expr) : string =
   | Tast.Signal (Tast.Ssignal, d, c) ->
     let p = addr_rooted f c in
     let dp = condesc f.md d e.Tast.loc in
+    mark_call f e.Tast.loc;
     ins f "call void @flan_signal(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
     guard f;
+    clear_call f;
     "zeroinitializer"
   (* §2's diverging variant. [flan_error] does not return unless a handler
      transferred, so the guard is the only way out and the fall-through is
@@ -2411,6 +2445,7 @@ and value_at f (e : Tast.expr) : string =
   | Tast.Signal (Tast.Serror, d, c) ->
     let p = addr_rooted f c in
     let dp = condesc f.md d e.Tast.loc in
+    mark_call f e.Tast.loc;
     ins f "call void @flan_error(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
     guard f;
     term f "unreachable";
@@ -2730,18 +2765,6 @@ and body_of f ?loc flan =
     p
   end
 
-(* A dev build's frame records the call it is making, after the arguments —
-   which may make calls of their own — and before the call itself, so a
-   backtrace names the call each caller is in and two calls to one function
-   from one caller are two different lines. One store; nothing in a release
-   build. *)
-and mark_call f at =
-  match f.frame with
-  | None -> ()
-  | Some _ ->
-    let id = fi_cstring f.md (Loc.to_string at) in
-    ins f "store ptr %s, ptr %%frame.a" id
-
 (* The signature word, at a call site through a cell: the one the cell holds
    against the one this site was compiled with. Equal is the whole of the fast
    path — a load, a compare, a branch not taken.
@@ -2784,7 +2807,9 @@ and call f ?loc ret flan args =
      word is read beside it, for the same reason: an argument that polls can
      install a new body, and the word checked has to be the body's own. *)
   let callee = body_of f ?loc flan in
-  call_through f ret callee vs
+  let r = call_through f ret callee vs in
+  if loc <> None then clear_call f;
+  r
 
 (* A call through a function value. Identical to the direct case once the
    callee is in hand — a Flan function's signature is its parameters followed
@@ -2816,7 +2841,9 @@ and call_ptr ?at f ret callee args =
   let vs = map_lr (fun (a : Tast.expr) ->
     let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
   Option.iter (mark_call f) at;
-  call_through f ?env ret code vs
+  let r = call_through f ?env ret code vs in
+  if at <> None then clear_call f;
+  r
 
 (* The code address behind one of the three [fnref]s, which is the same string
    whether it is wanted as a bare [Alloc] pointer or as the first word of a
@@ -2902,7 +2929,7 @@ and current_pad f =
    argument type is a scalar, because [check.ml] rejects an extern signature
    that would need an aggregate — that is the shim's job, in C, where clang
    knows the target's calling convention. *)
-and extern_call f ret name args =
+and extern_call ?at f ret name args =
   let vs =
     List.concat_map
       (fun (a : Tast.expr) ->
@@ -2913,6 +2940,7 @@ and extern_call f ret name args =
          | ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
       args
   in
+  Option.iter (mark_call f) at;
   if is_void ret then begin
     ins f "call void %s(%s)" name (String.concat ", " vs);
     "zeroinitializer"
@@ -3100,6 +3128,16 @@ and emit_restart_case f ty clauses body =
          ins f "store i64 %d, ptr %s" rlen (restart_field f slot "reportlen");
          ins f "store i32 %d, ptr %s" (if c.Tast.rhidden then 1 else 0)
            (restart_field f slot "flags");
+         (* See [Tast.rclause.rkeep]; the size is flan_rt.c's
+            FLAN_MESSAGE_MAX. *)
+         if c.Tast.rkeep then begin
+           let kb = alloca_raw f (Printf.sprintf "[%d x i8]" message_max) in
+           ins f "store ptr %s, ptr %s" kb (restart_field f slot "keep");
+           ins f "store i64 %d, ptr %s" message_max (restart_field f slot "keepcap")
+         end else begin
+           ins f "store ptr null, ptr %s" (restart_field f slot "keep");
+           ins f "store i64 0, ptr %s" (restart_field f slot "keepcap")
+         end;
          let args =
            if c.Tast.rparams = [] then None
            else begin
@@ -4594,6 +4632,8 @@ declare void @flan_dyn_emit_watch(i64)
 ; into every build, so these resolve in a release build too.
 declare i32 @flan_dev_watch_begin_n(ptr, i64)
 declare void @flan_dev_watch_emit(ptr, i64)
+declare void @flan_msg_emit(ptr, i64)
+declare void @flan_dyn_emit_msg(i64)
 declare void @flan_dev_watch_emit_str(ptr, i64)
 declare void @flan_dev_watch_emit_i64(i64)
 declare void @flan_dev_watch_emit_u64(i64)

lib/parse.ml

@@ -1326,9 +1326,10 @@ let rec decl (f : Form.t) : Ast.decl =
     (match args with
      | [ n; { v = Vec fs; _ } ] ->
        mk (Ast.Defstruct (dname n, fields f fs, None))
-     | [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] ->
+     | [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] ->
        mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p)))
-     | [ n; { v = Kw "parent"; _ }; p ] ->
+     (* An empty field vector is the same category as none. *)
+     | [ n; { v = Kw "parent"; _ }; p ] | [ n; { v = Kw "parent"; _ }; p; { v = Vec []; _ } ] ->
        let str name =
          { Ast.fname = name; fty = { Ast.t = Ast.Tname "string"; tloc = f.loc };
            floc = f.loc }

lib/reach.ml

@@ -59,6 +59,8 @@ let expr_refs f (e : Tast.expr) =
        | Tast.Set (Tast.Pglobal n, _) | Tast.Addr (Tast.Pglobal n) -> f n
        | Tast.Handled (frames, _) ->
          List.iter (fun (h : Tast.hframe) -> f h.Tast.hfn) frames
+       (* The condition's printer, reached from the signal's descriptor. *)
+       | Tast.Signal (_, d, _) -> Option.iter f d.Tast.crender
        (* A [CallPtr] roots no name: whatever it calls was reached as a value,
           and the [FnAddr] that produced it is a node inside the callee. *)
        | _ -> ())

lib/session.ml

@@ -1177,6 +1177,23 @@ let eval ?(origin = "<eval>") ?pause ?(running = true) t src : change =
    path for anything that prints, and a dev-only feature must not put a branch
    in it. *)
 
+(* The functions checking an expression lifted out of it — a handler clause,
+   a condition's printer — which the checker hangs on a function it calls
+   [<none>], since an expression has no enclosing one. They belong to the
+   thunk the expression becomes, and a redefinition module brings a lifted
+   function along only with its parent, so each is handed to [thunk]. *)
+let lifted_mark t = List.length t.env.Check.lifted
+
+let claim_lifted t mark thunk =
+  let n = List.length t.env.Check.lifted - mark in
+  List.rev
+    (List.filter_map
+       (fun (f : Tast.fn) ->
+          if f.Tast.fparent = Some "<none>" then
+            Some { f with Tast.fparent = Some thunk }
+          else None)
+       (List.filteri (fun i _ -> i < n) t.env.Check.lifted))
+
 type emitter = { ename : string; ety : Types.t }
 
 let emit_bytes  = { ename = "flan/dev-emit";     ety = Types.Slice (Types.Int Types.U8) }
@@ -2043,6 +2060,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
                thunk would have the second one's [let] reading and writing the
                first one's storage. *)
             let mark = Check.instance_mark t.env in
+            let lmark = lifted_mark t in
             let wanted =
               List.map
                 (fun (at, _, tty, code) ->
@@ -2115,7 +2133,9 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
                in
                let program =
                  { t.program with
-                   Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
+                   Tast.fns =
+                     t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
+                     @ [ thunk ];
                    externs = t.program.Tast.externs @ externs }
                in
                let ir =
@@ -2164,6 +2184,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
   let md = X86.layout_ctx ~checks:false ~dev:true t.program in
   let _, _, offs = Emit.lay_fields md params in
   let mark = Check.instance_mark t.env in
+  let lmark = lifted_mark t in
   let wanted =
     List.map2
       (fun ty code ->
@@ -2242,7 +2263,8 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
     in
     let program =
       { t.program with
-        Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
+        Tast.fns =
+          t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
         externs = t.program.Tast.externs @ externs }
     in
     let ir =
@@ -2384,6 +2406,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
      below — without this the thunk calls a symbol the module never defines
      and the host has no cell for. *)
   let mark = Check.instance_mark t.env in
+  let lmark = lifted_mark t in
   let checked, base, bnames = Check.expression t.env parsed in
   let fresh = Check.instances_since t.env mark in
   (* The thunk's frame starts at whatever [Check.expression] needed and grows
@@ -2423,7 +2446,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
      for every expression ever typed. *)
   let program =
     { t.program with
-      Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
+      Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark name @ [ thunk ];
       externs = t.program.Tast.externs @ externs }
   in
   let ir =

lib/tast.ml

@@ -277,9 +277,17 @@ and sigkind = Ssignal | Serror
 
 (* What a signal site says about its condition, which the backends write out
    as a constant the runtime's [flan_condesc] reads: the type's name, the type
-   ids from its own to its root ([Check.condition_chain]), and the sentence a
+   ids from its own to its root ([Check.condition_chain]), and how a handler
-   handler for a parent reads as the message. *)
+   for a parent is told what it caught. *)
-and condesc = { cname : string; cchain : int list; cmessage : string }
+and condesc =
+  { cname : string; cchain : int list;
+    (* The type's own fields are Error's, so the condition is its own view:
+       a handler for a parent reads its [name] and [message] directly. *)
+    cself : bool;
+    (* The lifted function that prints the condition, with its values, into
+       the runtime's message sink — what a handler for a parent reads as the
+       message. [None] when nothing can catch it through a parent. *)
+    crender : string option }
 
 and place =
   | Plocal  of int
@@ -315,7 +323,10 @@ and hframe = { htype : int; hfn : string; henv : expr option }
 and rclause =
   { rname_id : int; rname : string; rparams : (int * Types.t) list;
     rsig : string; rsig_id : int; rbody : expr list;
-    rloc : Loc.t; rreport : string; rhidden : bool }
+    rloc : Loc.t; rreport : string; rhidden : bool;
+    (* A handler-case landing whose condition may arrive as a parent's view:
+       the frame owns a buffer the message is copied into before the unwind. *)
+    rkeep : bool }
 
 (* [binds] are the slots the pattern's fields are bound to, in field order. *)
 and arm = { acase : string option; binds : int list; abody : expr list }

lib/x86.ml

@@ -1073,7 +1073,7 @@ let fi_cstring f s =
    returns. In [.data.rel.ro] for [fninfo]'s reason: it holds addresses. *)
 let condesc f (d : Tast.condesc) loc =
   let nlbl = string_const f d.Tast.cname in
-  let mlbl = string_const f d.Tast.cmessage in
+  let mlbl = string_const f "" in
   let llbl, llen = fi_bytes f (Loc.to_string loc) in
   let clbl = rodata_label f in
   Buffer.add_string f.rodata
@@ -1087,9 +1087,11 @@ let condesc f (d : Tast.condesc) loc =
        l
        (Emit.Rt.asm_init Emit.Rt.condesc
           [ nlbl; string_of_int (String.length d.Tast.cname); mlbl;
-            string_of_int (String.length d.Tast.cmessage); clbl;
+            "0"; clbl;
             string_of_int (List.length d.Tast.cchain); llbl;
-            string_of_int llen ]));
+            string_of_int llen;
+            (match d.Tast.crender with Some r -> fsym r | None -> "0");
+            (if d.Tast.cself then "1" else "0") ]));
   l
 
 (* The store that says "this slot is bound now", and it is the address rather
@@ -1864,7 +1866,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
   | Tast.Prim (p, args) -> prim f e p args dst
   | Tast.Call (name, args) ->
     (match Hashtbl.find_opt f.externs name with
-     | Some sym -> call_c f ~sym ~args ~rty:t dst
+     | Some sym -> call_c ~at:e.Tast.loc f ~sym ~args ~rty:t dst
      | None ->
        (* A dev build calls through the cell so that a redefinition reaches
           every existing call site; a release build names the symbol. *)
@@ -2028,8 +2030,10 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
       addr_into f ~reg:rsi l;
       lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
       chan_into f ~reg:rdx;
+      mark_at f e.Tast.loc;
       xor_rr f.b ~dst:rax ~src:rax;
       call_sym f.b "flan_signal";
+      clear_at f;
       guard f)
   (* §2's diverging variant. [flan_error] does not return unless a handler
      transferred, so the guard is the only way out and the fall-through is
@@ -2040,6 +2044,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
       addr_into f ~reg:rsi l;
       lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
       chan_into f ~reg:rdx;
+      mark_at f e.Tast.loc;
       xor_rr f.b ~dst:rax ~src:rax;
       call_sym f.b "flan_error";
       guard f;
@@ -2197,8 +2202,15 @@ and emit_restart_case f clauses body dst t =
          (c, slot, args))
       clauses
   in
+  let keeps =
+    List.map
+      (fun ((c : Tast.rclause), slot, _) ->
+         slot, if c.Tast.rkeep then Some (alloc f Emit.message_max 8) else None)
+      frames
+  in
   List.iter
     (fun ((c : Tast.rclause), slot, args) ->
+       let keep = List.assoc slot keeps in
        imm_into f ~reg:rax (Int64.of_int c.Tast.rname_id);
        store_int f.b ~src:rax ~mm:(Frame (slot + r_name_id)) ~size:4;
        (* The name itself, beside the hash. A hash is all that matching needs,
@@ -2225,6 +2237,17 @@ and emit_restart_case f clauses body dst t =
        store_int f.b ~src:rcx ~mm:(Frame (slot + r_field "reportlen")) ~size:8;
        imm_into f ~reg:rax (if c.Tast.rhidden then 1L else 0L);
        store_int f.b ~src:rax ~mm:(Frame (slot + r_field "flags")) ~size:4;
+       (* [Tast.rclause.rkeep]: the landing's own message buffer. *)
+       (match keep with
+        | Some kb ->
+          lea f.b ~dst:rax ~mm:(Frame kb);
+          store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keep")) ~size:8;
+          imm_into f ~reg:rax (Int64.of_int Emit.message_max);
+          store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keepcap")) ~size:8
+        | None ->
+          xor_rr f.b ~dst:rax ~src:rax;
+          store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keep")) ~size:8;
+          store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keepcap")) ~size:8);
        (match args with
         | None -> ()
         | Some (buf, _) ->
@@ -2678,6 +2701,7 @@ and bounds_call f sym (loc : Loc.t) (extra : int list) =
        load_int f.b ~dst:regs.(k) ~mm:(Frame off) ~size:8 ~signed:true)
     extra;
   chan_into f ~reg:regs.(List.length extra);
+  mark_at f loc;
   xor_rr f.b ~dst:rax ~src:rax;
   call_sym f.b sym;
   guard f;
@@ -3016,14 +3040,8 @@ and call_flan f ?env ?at ~target ~args ~rty dst =
   let tail = match env with None -> [] | Some a -> [ a ] in
   ignore (emit_args f (head @ body @ chan @ tail));
   (* The call this frame is making, for a backtrace — [Emit.mark_call]. After
-     the arguments, which may make calls of their own, and through [r11],
+     the arguments, which may make calls of their own. *)
-     which no argument is in. *)
+  Option.iter (mark_at f) at;
-  (match f.dframe, at with
-   | Some fr, Some at ->
-     lea f.b ~dst:r11 ~mm:(Sym (fi_cstring f (Loc.to_string at), 0));
-     store_int f.b ~src:r11
-       ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at")) ~size:8
-   | _ -> ());
   (* The cell is loaded *after* the arguments, and [emit.ml] has the same as a
      load-bearing comment: a redefinition that lands between two calls still
      must not land in the middle of one. [r11] is scratch and no argument
@@ -3071,13 +3089,33 @@ and call_flan f ?env ?at ~target ~args ~rty dst =
   else if (not (is_void rty)) && Emit.dyn_offsets f.md rty <> [] then begin
     let o = agg_tmp f rty in
     copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty)
-  end
+  end;
+  if at <> None then clear_at f
 
 (* Flan calling C. SysV exactly, because this is the boundary where it has to
    be — and the only aggregates that get here are the ones the shim rules
    already flatten. *)
-and call_c f ~sym ~args ~rty dst =
+and call_c ?at f ~sym ~args ~rty dst =
-  call_native f ~sym:(asm_sym sym) ~args ~rty dst
+  call_native ?at f ~sym:(asm_sym sym) ~args ~rty dst
+
+(* [Emit.mark_call] and [Emit.clear_call]: where this frame is while control
+   is somewhere that can come back into Flan. Through [r11], which holds no
+   argument and no result. *)
+and mark_at f at =
+  match f.dframe with
+  | Some fr ->
+    lea f.b ~dst:r11 ~mm:(Sym (fi_cstring f (Loc.to_string at), 0));
+    store_int f.b ~src:r11
+      ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at")) ~size:8
+  | None -> ()
+
+and clear_at f =
+  match f.dframe with
+  | Some fr ->
+    xor_rr f.b ~dst:r11 ~src:r11;
+    store_int f.b ~src:r11
+      ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at")) ~size:8
+  | None -> ()
 
 (* The two runtime entry points whose bounds check signals. They are the only
    [Rt] symbols that can transfer, so they are the only ones that take the
@@ -3107,7 +3145,7 @@ and call_rt f ~sym ~args ~rty dst =
     store_int f.b ~src:rax ~mm:(Frame slot) ~size:8
   end
 
-and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
+and call_native ?at f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
   (* A Vec and a Map cross to the runtime as their
      *address*, which is what lets an operation mutate the caller's container
      in place. [eval] would hand over the address of a copy, and the runtime
@@ -3126,10 +3164,13 @@ and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
   let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in
   let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr Types.Unit) ] else flat in
   let nsse = emit_args f flat in
+  (* A C function may call back into Flan. *)
+  Option.iter (mark_at f) at;
   (* [al] is how many SSE registers were used, which a variadic callee reads.
      Harmless on a fixed one, and a [declare] does not say which it is. *)
   imm_into f ~reg:rax (Int64.of_int nsse);
   call_sym f.b sym;
+  if at <> None then clear_at f;
   if chan then guard f;
   if not (is_void rty) then begin
     (* Unreachable, and it is worth saying why rather than leaving it reading

runtime/flan_dyn.c

@@ -665,6 +665,10 @@ void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); }
 void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); }
 void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); }
 
+/* And into a condition's message, which flan_rt.c's sink bounds. */
+void flan_msg_emit(const uint8_t *p, int64_t n);
+void flan_dyn_emit_msg(flan_dyn v) { render(flan_msg_emit, v, 0, 1); }
+
 /* The same walk into a buffer, for a trap's sentence. Bounded and truncated
  * rather than allocating: a trap is the one moment when allocating would be a
  * second thing to go wrong, and the message's job is to name the value, not to

runtime/flan_rt.c

@@ -69,19 +69,15 @@ void flan_handler_pop(flan_handler *h) {
  * at a constant; the runtime's own conditions build one on the failing
  * frame's stack.
  *
- * The first four fields are laid out as the prelude's
+ * A handler that matched through a parent link is not handed the condition,
- * (defstruct Error [name string message string]), and that is the point of
+ * whose layout is its own type's, but a view laid out as the prelude's
- * their order: a handler that matched through a parent link is handed *this*
+ * (defstruct Error [name string message string]) — the parent's type is
- * rather than the condition, because the condition's layout is its own type's
+ * Error-shaped, which the checker requires. The view's message is the
- * and the handler's type is an ancestor's. A parent is a type with exactly
+ * condition with its values: [message] for the runtime's own conditions,
- * Error's fields — the checker refuses any other — so every such handler reads
+ * which format their sentence before signalling; what [render] prints for a
- * the name and the sentence and nothing it could misread.
+ * compiled one; and the condition's own fields when its type is Error-shaped
- *
+ * itself ([flags] & FLAN_CONDESC_SELF), since then it is its own view.
- * [message] is a sentence with no values in it, and static: a handler-case
+ * [chain] is the type ids from the condition's own type to its root. */
- * copies the view out before the signalling frame is unwound, so the bytes it
- * points at must outlive that frame. The sentence with the values in it is the
- * break loop's, below. [chain] is the type ids from the condition's own type
- * to its root, own first. */
 typedef struct flan_condesc {
   const uint8_t  *name;
   int64_t         namelen;
@@ -91,8 +87,72 @@ typedef struct flan_condesc {
   int64_t         chainlen;
   const uint8_t  *loc;
   int64_t         loclen;
+  void          (*render)(void *condition, void *xfer);
+  int32_t         flags;
 } flan_condesc;
 
+#define FLAN_CONDESC_SELF 1
+
+/* The view a parent's handler reads: Error's layout. */
+typedef struct {
+  const uint8_t *name;
+  int64_t        namelen;
+  const uint8_t *message;
+  int64_t        messagelen;
+} flan_view;
+
+/* The most a message takes, here and in the buffer a handler-case landing
+ * owns (Emit.message_max). A longer one is cut and ends in "…", which says it
+ * was cut rather than passing for the whole of it. */
+#define FLAN_MESSAGE_MAX 512
+
+/* Where [render] prints: the buffer of the signal asking, set around the one
+ * synchronous call. A printer only formats, so nothing nests inside it. */
+static char   *msg_out;
+static int64_t msg_len;
+static int     msg_cut;
+
+static void msg_append(const uint8_t *p, int64_t n) {
+  static const char ell[] = "\xe2\x80\xa6";
+  if (msg_out == NULL || msg_cut || n <= 0) return;
+  if (msg_len + n > FLAN_MESSAGE_MAX - 4) {
+    int64_t room = FLAN_MESSAGE_MAX - 4 - msg_len;
+    if (room > 0) { memcpy(msg_out + msg_len, p, (size_t)room); msg_len += room; }
+    memcpy(msg_out + msg_len, ell, 3);
+    msg_len += 3;
+    msg_cut = 1;
+    return;
+  }
+  memcpy(msg_out + msg_len, p, (size_t)n);
+  msg_len += n;
+}
+
+void flan_msg_emit(const uint8_t *p, int64_t n) { msg_append(p, n); }
+
+/* The view of [condition] for a parent's handler, its message in [buf],
+ * which the caller owns and which lives as long as the handler runs. */
+static void rt_view(const flan_condesc *d, void *condition, char *buf,
+                    flan_view *v) {
+  if (d->flags & FLAN_CONDESC_SELF) {
+    *v = *(const flan_view *)condition;
+    return;
+  }
+  v->name = d->name;
+  v->namelen = d->namelen;
+  v->message = (const uint8_t *)buf;
+  msg_out = buf;
+  msg_len = 0;
+  msg_cut = 0;
+  if (d->messagelen > 0)
+    msg_append(d->message, d->messagelen);
+  else if (d->render != NULL) {
+    void *x = NULL;
+    d->render(condition, &x);
+  }
+  v->messagelen = msg_len;
+  msg_out = NULL;
+}
+
 /* 1 when a handler for [type_id] answers the condition by its own type, 2
  * when it answers through a parent link, 0 when it does not answer. */
 static int flan_handles(uint32_t type_id, const flan_condesc *d) {
@@ -120,17 +180,28 @@ static int flan_handles(uint32_t type_id, const flan_condesc *d) {
  * back afterwards whether or not the clause transferred: a transfer's target
  * can be a restart-case inside the handler-bind's own body, whose frame does
  * not pop this handler on the way there. */
+static void rt_keep(void *target, const flan_view *v);
+
 void flan_signal(const flan_condesc *d, void *condition, void *xfer) {
   flan_handler *saved = handlers;
+  /* The parent's view, made the first time a parent's handler needs it and
+   * living in this frame for as long as the walk. Its own, so a signal nested
+   * inside a handler cannot write over the message the outer one is reading. */
+  char      buf[FLAN_MESSAGE_MAX];
+  flan_view v;
+  int       viewed = 0;
   for (flan_handler *h = saved; h != NULL; h = h->prev) {
     int how = flan_handles(h->type_id, d);
     if (how) {
+      if (how == 2 && !viewed) { rt_view(d, condition, buf, &v); viewed = 1; }
       handlers = h->prev;
-      /* A parent's handler reads the name and the sentence; see
+      h->fn(how == 1 ? condition : (void *)&v, xfer, h->env);
-       * flan_condesc. */
-      h->fn(how == 1 ? condition : (void *)d, xfer, h->env);
       handlers = saved;
-      if (*(void **)xfer != NULL) return;
+      if (*(void **)xfer != NULL) {
+        if (how == 2 && !(d->flags & FLAN_CONDESC_SELF))
+          rt_keep(*(void **)xfer, &v);
+        return;
+      }
     }
   }
 }
@@ -168,6 +239,10 @@ typedef struct flan_restart {
   const uint8_t       *report;
   int64_t              reportlen;
   int32_t              flags;
+  /* A handler-case landing's own buffer for the message of a condition that
+   * arrives as a parent's view, or NULL; see [rt_keep]. */
+  char                *keep;
+  int64_t              keepcap;
 } flan_restart;
 
 /* A clause the checker made up rather than one anybody wrote: a
@@ -191,6 +266,25 @@ void flan_restart_push(flan_restart *r) {
 
 void flan_restart_pop(flan_restart *r) { restarts = r->prev; }
 
+/* A parent's handler in a handler-case has just aimed the transfer at the
+ * form's landing, with the view copied into the landing's argument buffer —
+ * and the view's message is in [flan_signal]'s frame, which the unwind is
+ * about to take. So the bytes go into the landing's own buffer now, while
+ * both frames are alive, and the copy in the argument buffer is pointed at
+ * them. Anything else the transfer is aimed at owns no such buffer. */
+static void rt_keep(void *target, const flan_view *v) {
+  flan_restart *r = (flan_restart *)target;
+  flan_view    *arg;
+  int64_t       n = v->messagelen;
+  if (r->keep == NULL || r->args == NULL || !r->armed) return;
+  arg = (flan_view *)r->args;
+  if (arg->message != v->message) return;
+  if (n > r->keepcap) n = r->keepcap;
+  memcpy(r->keep, v->message, (size_t)n);
+  arg->message = (const uint8_t *)r->keep;
+  arg->messagelen = n;
+}
+
 /* What is on offer, innermost first — spec-conditions.md §4's walk, without
  * committing to anything. This is [compute-restarts]' data; today its only
  * caller is the break loop. */
@@ -808,6 +902,14 @@ static void rt_sentence(const char *fmt, ...) {
   va_end(ap);
 }
 
+/* The sentence just formatted, NUL-terminated into a caller's buffer. */
+static void rt_sentence_copy(char *out) {
+  int64_t n = flan_break_sentence_len;
+  if (n > FLAN_MESSAGE_MAX - 1) n = FLAN_MESSAGE_MAX - 1;
+  memcpy(out, flan_break_sentence, (size_t)n);
+  out[n] = 0;
+}
+
 static void rt_break_clear(void) {
   flan_break_site = NULL;
   flan_break_site_len = 0;
@@ -926,20 +1028,28 @@ void flan_error(const flan_condesc *d, void *condition, void *xfer) {
    * having. The site is the (error ...) itself, and the sentence is the
    * condition's static one, or none: a program's own condition says what it
    * is in its fields. */
-  if (flan_break_hook != NULL) {
+  {
-    flan_break_site = d->loclen > 0 ? d->loc : NULL;
+    /* What the condition is, as a parent's handler would read it: the
-    flan_break_site_len = d->loclen;
+     * sentence, the printed condition, or an Error-shaped condition's own
-    rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message);
+     * message. A condition with no parent and no sentence has none. */
-    flan_break_hook(d->name, d->namelen, condition, xfer);
+    char      buf[FLAN_MESSAGE_MAX];
-    rt_break_clear();
+    flan_view v;
-    if (*(void **)xfer != NULL) return;
+    rt_view(d, condition, buf, &v);
+    if (flan_break_hook != NULL) {
+      flan_break_site = d->loclen > 0 ? d->loc : NULL;
+      flan_break_site_len = d->loclen;
+      rt_sentence("%.*s", (int)v.messagelen, (const char *)v.message);
+      flan_break_hook(d->name, d->namelen, condition, xfer);
+      rt_break_clear();
+      if (*(void **)xfer != NULL) return;
+    }
+    if (v.messagelen > 0)
+      rt_sentence("unhandled %.*s: %.*s", (int)d->namelen,
+                  (const char *)d->name, (int)v.messagelen,
+                  (const char *)v.message);
+    else
+      rt_sentence("unhandled %.*s", (int)d->namelen, (const char *)d->name);
   }
-  if (d->messagelen > 0)
-    rt_sentence("unhandled %.*s: %.*s", (int)d->namelen,
-                (const char *)d->name, (int)d->messagelen,
-                (const char *)d->message);
-  else
-    rt_sentence("unhandled %.*s", (int)d->namelen, (const char *)d->name);
   rt_print_sentence(d->loc, d->loclen);
   rt_die();
 }
@@ -1058,10 +1168,16 @@ static const uint8_t flan_error_name[] = "Error";
 #define FLAN_ERROR_NAMELEN 5
 
 /* A descriptor for one of the runtime's own conditions, on the caller's
- * stack; [chain] is the caller's too, two entries long. */
+ * stack; [chain] is the caller's too, two entries long. [message] is the
+ * sentence with its values, which the caller has formatted into a buffer of
+ * its own frame before signalling: a parent's handler reads it, and so does
+ * the break loop after the walk, when a handler may have written over the
+ * shared one. */
 static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name,
                        int64_t namelen, const char *message,
                        const uint8_t *loc, int64_t loclen) {
+  d->render = NULL;
+  d->flags = 0;
   chain[0] = flan_name_id(name, namelen);
   chain[1] = flan_name_id(flan_error_name, FLAN_ERROR_NAMELEN);
   d->name = name;
@@ -1081,6 +1197,7 @@ static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name,
  * which case the caller returns and its caller's guard carries the transfer
  * out. */
 static int rt_error_break(const flan_condesc *d, void *condition, void *xfer) {
+  rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message);
   if (flan_break_hook != NULL) {
     flan_break_site = d->loc;
     flan_break_site_len = d->loclen;
@@ -1100,16 +1217,18 @@ static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer,
   flan_bounds_cond c;
   flan_condesc     d;
   uint32_t         chain[2];
+  char             said[FLAN_MESSAGE_MAX];
   c.low = low;
   c.high = high;
   c.length = len;
-  rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN,
-             "an index or a range is out of bounds", loc, loclen);
-  flan_signal(&d, &c, xfer);
-  if (*(void **)xfer != NULL) return 1;
   if (kind == BOUNDS_AT) bounds_sentence(low, len);
   else if (kind == BOUNDS_SLICE) slice_sentence(low, high, len);
   else promise_sentence(high);
+  rt_sentence_copy(said);
+  rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN, said, loc,
+             loclen);
+  flan_signal(&d, &c, xfer);
+  if (*(void **)xfer != NULL) return 1;
   return rt_error_break(&d, &c, xfer);
 }
 
@@ -1265,28 +1384,6 @@ static void arith_sentence(int32_t op, int64_t lhs, int64_t rhs) {
   }
 }
 
-/* The same, with no values in it: what a handler for Error reads as the
- * message. Static, because a handler-case carries it past the frame that
- * signalled. */
-static const char *arith_message(int32_t op) {
-  switch (op) {
-  case FLAN_ARITH_DIV_ZERO: return "divide by zero";
-  case FLAN_ARITH_REM_ZERO: return "remainder by zero";
-  case FLAN_ARITH_DIV_OVERFLOW:
-    return "a division overflows: the quotient is one past the largest value "
-           "the type holds";
-  case FLAN_ARITH_REM_OVERFLOW:
-    return "a remainder overflows: the quotient is one past the largest value "
-           "the type holds";
-  case FLAN_ARITH_CAST_NAN:
-    return "a NaN has no integer value to cast to";
-  case FLAN_ARITH_CAST_INF:
-    return "an infinity has no integer value to cast to";
-  default:
-    return "a value does not fit the integer type it is cast to";
-  }
-}
-
 void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op,
                       int64_t lhs, int64_t rhs, void *xfer) {
   flan_arith_cond c;
@@ -1295,11 +1392,13 @@ void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op,
   c.op = op;
   c.lhs = lhs;
   c.rhs = rhs;
-  rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, arith_message(op),
+  char            said[FLAN_MESSAGE_MAX];
-             loc, loclen);
+  arith_sentence(op, lhs, rhs);
+  rt_sentence_copy(said);
+  rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, said, loc,
+             loclen);
   flan_signal(&d, &c, xfer);
   if (*(void **)xfer != NULL) return;
-  arith_sentence(op, lhs, rhs);
   if (rt_error_break(&d, &c, xfer)) return;
   rt_print_sentence(loc, loclen);
   rt_die();
@@ -1361,17 +1460,18 @@ void flan_stale_call(const char *site, const char *callee, const char *want,
   flan_slice where = flan_stale_copy(site);
   flan_condesc d;
   uint32_t     chain[2];
-  rt_condesc(&d, chain, flan_stale_name, FLAN_STALE_NAMELEN,
+  char         said[FLAN_MESSAGE_MAX];
-             "a call was compiled for a signature its function no longer has",
-             where.ptr, where.len);
-  flan_signal(&d, &c, xfer);
-  if (*(void **)xfer != NULL) return;
   rt_sentence("this call to %s was compiled for %s, and %s is defined as %s. "
               "Evaluating the function this call is in again fixes its next "
               "call. A function that is still running, such as main's loop, "
               "is never called again: define %s with %s again, or run the "
               "program again.",
               callee, want, callee, now, callee, want);
+  rt_sentence_copy(said);
+  rt_condesc(&d, chain, flan_stale_name, FLAN_STALE_NAMELEN, said, where.ptr,
+             where.len);
+  flan_signal(&d, &c, xfer);
+  if (*(void **)xfer != NULL) return;
   if (rt_error_break(&d, &c, xfer)) return;
   rt_print_sentence(where.ptr, where.len);
   rt_die();

test/programs/condition-messages.flan

@@ -0,0 +1,34 @@
+;;;; What a handler for a parent reads as the message, and that it is still
+;;;; there after the unwind. The clause below runs after the signalling frames
+;;;; are gone, and [scribble] reuses their stack before the message is
+;;;; printed, so a message left pointing into them prints as garbage.
+
+(defstruct IoError :parent Error)
+(defstruct Empty :parent Error [])
+(defstruct MyErr :parent Error [code i32  why string])
+
+(defonce zero i64)
+
+;; Deep enough, and wide enough, to overwrite what the signal left below.
+(defn scribble [n i32] i64
+  (let [junk (array-fill [64] (i64 n))]
+    (if (= n 0) (at junk 3) (+ (at junk 5) (scribble (- n 1))))))
+
+(defn caught [thunk (Fn [] i32)] i32
+  (handler-case (thunk)
+    [(Error [e]
+       (scribble 40)
+       (println (.name e))
+       (println (.message e))
+       -1)]))
+
+(defn main [] i32
+  ;; A category the program filled in is its own name and message.
+  (caught (fn [] (do (error (IoError {.name "io" .message "disk gone"})) 0)))
+  ;; An empty field vector is the same category.
+  (caught (fn [] (do (error (Empty {.name "empty" .message "nothing"})) 0)))
+  ;; A program's own condition is printed with its values.
+  (caught (fn [] (do (error (MyErr {.code 3 .why "bad"})) 0)))
+  ;; A runtime condition carries the sentence with its values.
+  (caught (fn [] (i32 (/ 7 zero))))
+  0)

test/programs/dev-bt-handler.flan

@@ -0,0 +1,23 @@
+;;;; A frame re-entered through a handler names the signal it is in, not the
+;;;; last Flan call it made: [inner] calls [helper] on line 11 and stops on
+;;;; line 12, and the handler pauses, so the backtrace shows [inner] at 12.
+(import agent "vendor:agent")
+
+(defstruct Oops [n i32])
+
+(defn helper [] i32 1)
+
+(defn inner [] i32
+  (helper)
+  (error (Oops {.n 1}))
+  0)
+
+(defn go [] i32
+  (restart-case
+    (handler-bind [(Oops [_o] (pause))] (inner))
+    (skip [] 5)))
+
+(defn main [] i32
+  (agent/start "/tmp/flan-dev-bt-handler-fallback.sock")
+  (println (go))
+  0)

test/test_acceptance.ml

@@ -2905,14 +2905,13 @@ let () =
       "programs/arith-condition.flan" arith_cond_out;
 
     (* A handler for a parent answers every condition below it, and is handed
-       the name and the sentence rather than the fields. The empty line is
+       the name and the message — the condition with its values — rather than
-       DiskFull's sentence: a program's own condition says what it is in its
+       its fields. *)
-       fields. *)
     let parents_out =
-      "ArithError\ndivide by zero\n-1\n\
+      "ArithError\ndivide by zero: (/ 10 0)\n-1\n\
-       BoundsError\nan index or a range is out of bounds\n-1\n\
+       BoundsError\nindex 6 is out of bounds for length 4\n-1\n\
-       DiskFull\n\n-1\n3\nDiskFull\n-2\n7\n\
+       DiskFull\n(DiskFull {.free 7})\n-1\n3\nDiskFull\n-2\n7\n\
-       true\ndivide by zero\n-4\n1\n"
+       true\ndivide by zero: (/ 10 0)\n-4\n1\n"
     in
     outputs "conditions have a parent link" "programs/condition-parents.flan"
       parents_out;
@@ -2920,6 +2919,16 @@ let () =
       "programs/condition-parents.flan" parents_out;
     outputs ~dev:true "conditions have a parent link, dev"
       "programs/condition-parents.flan" parents_out;
+    (* And the message outlives the frames it was made in: the clause runs
+       after the unwind and writes over their stack before printing it. *)
+    let messages_out =
+      "io\ndisk gone\nempty\nnothing\nMyErr\n(MyErr {.code 3 .why \"bad\"})\n\
+       ArithError\ndivide by zero: (/ 7 0)\n"
+    in
+    outputs "a parent's message outlives the unwind"
+      "programs/condition-messages.flan" messages_out;
+    outputs ~x86:true "a parent's message outlives the unwind, --x86"
+      "programs/condition-messages.flan" messages_out;
 
     (* And the half that finishes that thought. bounds-condition.flan's last
        line is `10 99 12 13` — an abandoned frame's leftovers — and a restart

test/test_dev.ml

@@ -7687,6 +7687,68 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ lsock; lout ];
 
+    (* ── A frame re-entered through a handler names its signal ─────────
+       [inner] calls [helper] and then signals; a handler pauses. The pause
+       stands in the handler, so [inner] is an outer frame, and it must name
+       the (error ...) it is in — line 12 — and not its call to [helper] on
+       line 11, which has returned. On both backends. *)
+    List.iter
+      (fun backend ->
+         let bsock = tmp ("bt-" ^ backend ^ ".sock")
+         and bout = tmp ("bt-" ^ backend ^ ".out") in
+         (try Sys.remove bsock with Sys_error _ -> ());
+         let bfd =
+           Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+         in
+         let bpid =
+           Unix.create_process flan
+             [| flan; "dev"; "programs/dev-bt-handler.flan"; "-s"; bsock;
+                "--" ^ backend |]
+             Unix.stdin bfd Unix.stderr
+         in
+         Unix.close bfd;
+         if not (listening ~pid:bpid bsock) then begin
+           fail "the backtrace-handler daemon (--%s) %s" backend !listen_why;
+           (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
+         end
+         else begin
+           let c = connect bsock in
+           let stopped () =
+             match Wire.field (request c "(:op \"describe\")") "stopped" with
+             | Some { Form.v = Form.Sym "t"; _ } -> true
+             | _ -> false
+           in
+           if not (await stopped) then
+             fail "--%s: the handler's pause never stopped the program" backend
+           else begin
+             let r = request c "(:op \"backtrace\")" in
+             let frames =
+               match Wire.field r "frames" with
+               | Some { Form.v = Form.List l; _ } ->
+                 List.filter_map
+                   (fun (e : Form.t) ->
+                      match e.Form.v with
+                      | Form.List
+                          ({ Form.v = Form.Str n; _ }
+                           :: { Form.v = Form.Str loc; _ } :: _) -> Some (n, loc)
+                      | _ -> None)
+                   l
+               | _ -> []
+             in
+             match List.assoc_opt "inner" frames with
+             | Some loc when contains_sub loc "dev-bt-handler.flan:12:" -> ()
+             | Some loc -> fail "--%s: inner's frame is at %s, not line 12" backend loc
+             | None ->
+               fail "--%s: no inner frame: %s" backend
+                 (String.concat ", " (List.map fst frames))
+           end;
+           (try Unix.close c with Unix.Unix_error _ -> ());
+           (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ());
+           (try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ())
+         end;
+         List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ bsock; bout ])
+      [ "llvm"; "x86" ];
+
     (* ── The parked note, once per park ────────────────────────────────
        A finished program is parked, so re-evaluating while a run's output is
        still on the screen is the commonest thing there is — and it used to

test/test_flan.ml

@@ -3416,9 +3416,17 @@ let () =
      (defn f [e Io] string (.message e))";
   accepts "the suggested category spelling compiles"
     "(defstruct Category :parent Error)";
-  rejects_check "a parent with fields of its own is refused"
+  rejects_check "a parent with fields of its own is refused, fixed at the parent"
     "(defstruct Oops :parent Error [n i32]) (defstruct Worse :parent Oops [m i32])"
-    ~needle:"Worse names Oops as its parent, and Oops has fields of its own";
+    ~needle:"Oops has [n i32]. Declare it with no field vector, \
+             (defstruct Oops :parent Error)";
+  rejects_check "a parent with no fields at all is not said to have some"
+    "(defstruct E []) (defstruct Worse :parent E [m i32])"
+    ~needle:"E has [none]. Declare it with no field vector, \
+             (defstruct E :parent Error)";
+  accepts "an empty field vector under a parent is a category"
+    "(defstruct Io :parent Error []) (defstruct Full :parent Io [n i32]) \
+     (defn f [e Io] string (.message e))";
   rejects_check "a parent that is not a struct is refused"
     "(defstruct Oops :parent i32 [n i32])"
     ~needle:"a parent is a condition struct";