From d864818956bd53531bf06aed2f0945b4a8203484 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 13:16:35 +0700 Subject: [PATCH] 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 | 140 +++++++++++----- lib/emit.ml | 80 ++++++--- lib/parse.ml | 5 +- lib/reach.ml | 2 + lib/session.ml | 29 +++- lib/tast.ml | 19 ++- lib/x86.ml | 73 ++++++-- runtime/flan_dyn.c | 4 + runtime/flan_rt.c | 230 ++++++++++++++++++-------- test/programs/condition-messages.flan | 34 ++++ test/programs/dev-bt-handler.flan | 23 +++ test/test_acceptance.ml | 23 ++- test/test_dev.ml | 62 +++++++ test/test_flan.ml | 12 +- 14 files changed, 578 insertions(+), 158 deletions(-) create mode 100644 test/programs/condition-messages.flan create mode 100644 test/programs/dev-bt-handler.flan diff --git a/lib/check.ml b/lib/check.ml index ed7e9330..7e97ed32 100644 --- a/lib/check.ml +++ b/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 = "" } +(* 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 \ - handler for a parent is handed the name and the sentence of \ - whatever it caught, not that condition's fields, so a parent has \ - exactly [name string message string]. Give %s its own category \ - with no field vector, (defstruct Category :parent Error), and \ - name that as the parent" - child parent parent child; + "%s names %s as its parent, and a parent has exactly the fields \ + [name string message string], because a handler for a parent is \ + handed the name and the message of whatever it caught. %s has \ + [%s]. Declare it with no field vector, %s, which gives it those \ + two" + child parent parent has fix + 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 diff --git a/lib/emit.ml b/lib/emit.ml index 6acf3996..20d0a9d5 100644 --- a/lib/emit.ml +++ b/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) diff --git a/lib/parse.ml b/lib/parse.ml index 97387413..33d2151f 100644 --- a/lib/parse.ml +++ b/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 } diff --git a/lib/reach.ml b/lib/reach.ml index a3000a3b..e350b561 100644 --- a/lib/reach.ml +++ b/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. *) | _ -> ()) diff --git a/lib/session.ml b/lib/session.ml index d73af2b4..96a61ead 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1177,6 +1177,23 @@ let eval ?(origin = "") ?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 + [], 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 "" 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 = "") 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 = "") 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 = "") 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 = "") 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 = "") ?(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 = "") ?(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 = diff --git a/lib/tast.ml b/lib/tast.ml index 8bfec955..f4520ed8 100644 --- a/lib/tast.ml +++ b/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 - handler for a parent reads as the message. *) -and condesc = { cname : string; cchain : int list; cmessage : string } + ids from its own to its root ([Check.condition_chain]), and how a handler + for a parent is told what it caught. *) +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 } diff --git a/lib/x86.ml b/lib/x86.ml index 31aa3ff7..8aeed7f9 100644 --- a/lib/x86.ml +++ b/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], - which no argument is in. *) - (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 arguments, which may make calls of their own. *) + Option.iter (mark_at f) at; (* 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 = - call_native f ~sym:(asm_sym sym) ~args ~rty dst +and call_c ?at f ~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 diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 94a7f5b8..a349a784 100644 --- a/runtime/flan_dyn.c +++ b/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 diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 7e861b98..4d60a6c3 100644 --- a/runtime/flan_rt.c +++ b/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 - * (defstruct Error [name string message string]), and that is the point of - * their order: a handler that matched through a parent link is handed *this* - * rather than the condition, because the condition's layout is its own type's - * and the handler's type is an ancestor's. A parent is a type with exactly - * Error's fields — the checker refuses any other — so every such handler reads - * the name and the sentence and nothing it could misread. - * - * [message] is a sentence with no values in it, and static: a handler-case - * 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. */ + * A handler that matched through a parent link is not handed the condition, + * whose layout is its own type's, but a view laid out as the prelude's + * (defstruct Error [name string message string]) — the parent's type is + * Error-shaped, which the checker requires. The view's message is the + * condition with its values: [message] for the runtime's own conditions, + * which format their sentence before signalling; what [render] prints for a + * 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. + * [chain] is the type ids from the condition's own type to its root. */ 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 - * flan_condesc. */ - h->fn(how == 1 ? condition : (void *)d, xfer, h->env); + h->fn(how == 1 ? condition : (void *)&v, 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; - flan_break_site_len = d->loclen; - rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message); - flan_break_hook(d->name, d->namelen, condition, xfer); - rt_break_clear(); - if (*(void **)xfer != NULL) return; + { + /* What the condition is, as a parent's handler would read it: the + * sentence, the printed condition, or an Error-shaped condition's own + * message. A condition with no parent and no sentence has none. */ + char buf[FLAN_MESSAGE_MAX]; + flan_view v; + 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), - loc, loclen); + char said[FLAN_MESSAGE_MAX]; + 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, - "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; + char said[FLAN_MESSAGE_MAX]; 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(); diff --git a/test/programs/condition-messages.flan b/test/programs/condition-messages.flan new file mode 100644 index 00000000..fcb51192 --- /dev/null +++ b/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) diff --git a/test/programs/dev-bt-handler.flan b/test/programs/dev-bt-handler.flan new file mode 100644 index 00000000..a8b01638 --- /dev/null +++ b/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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 0b844959..1dcba481 100644 --- a/test/test_acceptance.ml +++ b/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 - DiskFull's sentence: a program's own condition says what it is in its - fields. *) + the name and the message — the condition with its values — rather than + its fields. *) let parents_out = - "ArithError\ndivide by zero\n-1\n\ - BoundsError\nan index or a range is out of bounds\n-1\n\ - DiskFull\n\n-1\n3\nDiskFull\n-2\n7\n\ - true\ndivide by zero\n-4\n1\n" + "ArithError\ndivide by zero: (/ 10 0)\n-1\n\ + BoundsError\nindex 6 is out of bounds for length 4\n-1\n\ + DiskFull\n(DiskFull {.free 7})\n-1\n3\nDiskFull\n-2\n7\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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 96e353ef..d82eecbb 100644 --- a/test/test_dev.ml +++ b/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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 51c6aeda..be125e5e 100644 --- a/test/test_flan.ml +++ b/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";